From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- plugins/btauto/Algebra.v | 591 ++++++ plugins/btauto/Btauto.v | 3 + plugins/btauto/Reflect.v | 398 +++++ plugins/btauto/btauto_plugin.mllib | 3 + plugins/btauto/g_btauto.ml4 | 16 + plugins/btauto/refl_btauto.ml | 260 +++ plugins/btauto/vo.itarget | 3 + plugins/cc/README | 2 +- plugins/cc/ccalgo.ml | 517 +++--- plugins/cc/ccalgo.mli | 132 +- plugins/cc/ccproof.ml | 123 +- plugins/cc/ccproof.mli | 38 +- plugins/cc/cctac.ml | 463 ++--- plugins/cc/cctac.mli | 11 +- plugins/cc/g_congruence.ml4 | 8 +- plugins/decl_mode/decl_expr.mli | 25 +- plugins/decl_mode/decl_interp.ml | 212 +-- plugins/decl_mode/decl_interp.mli | 7 +- plugins/decl_mode/decl_mode.ml | 51 +- plugins/decl_mode/decl_mode.mli | 23 +- plugins/decl_mode/decl_proof_instr.ml | 450 +++-- plugins/decl_mode/decl_proof_instr.mli | 53 +- plugins/decl_mode/g_decl_mode.ml4 | 100 +- plugins/decl_mode/ppdecl_proof.ml | 12 +- plugins/derive/Derive.v | 1 + plugins/derive/derive.ml | 104 ++ plugins/derive/derive.mli | 13 + plugins/derive/derive_plugin.mllib | 2 + plugins/derive/g_derive.ml4 | 16 + plugins/derive/vo.itarget | 1 + plugins/extraction/ExtrOcamlBasic.v | 2 +- plugins/extraction/ExtrOcamlBigIntConv.v | 6 +- plugins/extraction/ExtrOcamlIntConv.v | 2 +- plugins/extraction/ExtrOcamlNatBigInt.v | 4 +- plugins/extraction/ExtrOcamlNatInt.v | 2 +- plugins/extraction/ExtrOcamlString.v | 2 +- plugins/extraction/ExtrOcamlZBigInt.v | 4 +- plugins/extraction/ExtrOcamlZInt.v | 4 +- plugins/extraction/README | 8 +- plugins/extraction/big.ml | 2 +- plugins/extraction/common.ml | 203 ++- plugins/extraction/common.mli | 24 +- plugins/extraction/extract_env.ml | 419 +++-- plugins/extraction/extract_env.mli | 13 +- plugins/extraction/extraction.ml | 326 ++-- plugins/extraction/extraction.mli | 11 +- plugins/extraction/g_extraction.ml4 | 44 +- plugins/extraction/haskell.ml | 68 +- plugins/extraction/haskell.mli | 2 +- plugins/extraction/miniml.mli | 47 +- plugins/extraction/mlutil.ml | 291 +-- plugins/extraction/mlutil.mli | 15 +- plugins/extraction/modutil.ml | 61 +- plugins/extraction/modutil.mli | 10 +- plugins/extraction/ocaml.ml | 110 +- plugins/extraction/ocaml.mli | 2 +- plugins/extraction/scheme.ml | 40 +- plugins/extraction/scheme.mli | 2 +- plugins/extraction/table.ml | 227 ++- plugins/extraction/table.mli | 41 +- plugins/field/LegacyField.v | 14 - plugins/field/LegacyField_Compl.v | 36 - plugins/field/LegacyField_Tactic.v | 431 ----- plugins/field/LegacyField_Theory.v | 648 ------- plugins/field/field.ml4 | 191 -- plugins/field/field_plugin.mllib | 2 - plugins/field/vo.itarget | 4 - plugins/firstorder/formula.ml | 72 +- plugins/firstorder/formula.mli | 25 +- plugins/firstorder/g_ground.ml4 | 56 +- plugins/firstorder/ground.ml | 16 +- plugins/firstorder/ground.mli | 4 +- plugins/firstorder/instances.ml | 82 +- plugins/firstorder/instances.mli | 7 +- plugins/firstorder/rules.ml | 102 +- plugins/firstorder/rules.mli | 14 +- plugins/firstorder/sequent.ml | 62 +- plugins/firstorder/sequent.mli | 14 +- plugins/firstorder/unify.ml | 28 +- plugins/firstorder/unify.mli | 2 +- plugins/fourier/Fourier.v | 5 +- plugins/fourier/Fourier_util.v | 6 +- plugins/fourier/fourier.ml | 87 +- plugins/fourier/fourierR.ml | 321 ++-- plugins/fourier/g_fourier.ml4 | 8 +- plugins/funind/Recdef.v | 38 +- plugins/funind/functional_principles_proofs.ml | 474 +++-- plugins/funind/functional_principles_types.ml | 228 +-- plugins/funind/functional_principles_types.mli | 10 +- plugins/funind/g_indfun.ml4 | 167 +- plugins/funind/glob_term_to_relation.ml | 399 ++--- plugins/funind/glob_term_to_relation.mli | 10 +- plugins/funind/glob_termops.ml | 168 +- plugins/funind/glob_termops.mli | 58 +- plugins/funind/indfun.ml | 470 +++-- plugins/funind/indfun.mli | 15 +- plugins/funind/indfun_common.ml | 212 +-- plugins/funind/indfun_common.mli | 52 +- plugins/funind/invfun.ml | 706 +++++--- plugins/funind/merge.ml | 195 +- plugins/funind/recdef.ml | 2077 ++++++++++----------- plugins/funind/recdef.mli | 20 + plugins/micromega/CheckerMaker.v | 132 -- plugins/micromega/Env.v | 2 +- plugins/micromega/EnvRing.v | 2 +- plugins/micromega/Lia.v | 44 + plugins/micromega/MExtraction.v | 2 +- plugins/micromega/OrderedRing.v | 8 +- plugins/micromega/Psatz.v | 63 +- plugins/micromega/QMicromega.v | 6 +- plugins/micromega/RMicromega.v | 7 +- plugins/micromega/Refl.v | 2 +- plugins/micromega/RingMicromega.v | 31 +- plugins/micromega/Tauto.v | 20 +- plugins/micromega/VarMap.v | 2 +- plugins/micromega/ZCoeff.v | 9 +- plugins/micromega/ZMicromega.v | 16 +- plugins/micromega/certificate.ml | 96 +- plugins/micromega/coq_micromega.ml | 170 +- plugins/micromega/csdpcert.ml | 21 +- plugins/micromega/g_micromega.ml4 | 58 +- plugins/micromega/mfourier.ml | 57 +- plugins/micromega/micromega.ml | 6 +- plugins/micromega/mutils.ml | 76 +- plugins/micromega/persistent_cache.ml | 130 +- plugins/micromega/polynomial.ml | 29 +- plugins/micromega/sos.ml | 193 +- plugins/micromega/sos.mli | 2 +- plugins/micromega/sos_lib.ml | 37 +- plugins/micromega/sos_types.ml | 2 +- plugins/micromega/vo.itarget | 2 +- plugins/nsatz/Nsatz.v | 8 +- plugins/nsatz/ideal.ml | 134 +- plugins/nsatz/nsatz.ml4 | 60 +- plugins/nsatz/polynom.ml | 94 +- plugins/nsatz/polynom.mli | 2 +- plugins/nsatz/utile.ml | 16 +- plugins/nsatz/utile.mli | 4 - plugins/omega/Omega.v | 4 +- plugins/omega/OmegaPlugin.v | 2 +- plugins/omega/PreOmega.v | 5 +- plugins/omega/coq_omega.ml | 777 ++++---- plugins/omega/g_omega.ml4 | 21 +- plugins/omega/omega.ml | 106 +- plugins/pluginsbyte.itarget | 6 +- plugins/pluginsdyn.itarget | 3 +- plugins/pluginsopt.itarget | 6 +- plugins/pluginsvo.itarget | 4 +- plugins/quote/Quote.v | 2 +- plugins/quote/g_quote.ml4 | 25 +- plugins/quote/quote.ml | 113 +- plugins/ring/LegacyArithRing.v | 88 - plugins/ring/LegacyNArithRing.v | 43 - plugins/ring/LegacyRing.v | 35 - plugins/ring/LegacyRing_theory.v | 374 ---- plugins/ring/LegacyZArithRing.v | 35 - plugins/ring/Ring_abstract.v | 700 -------- plugins/ring/Ring_normalize.v | 897 ---------- plugins/ring/Setoid_ring.v | 12 - plugins/ring/Setoid_ring_normalize.v | 1160 ------------ plugins/ring/Setoid_ring_theory.v | 425 ----- plugins/ring/g_ring.ml4 | 134 -- plugins/ring/ring.ml | 928 ---------- plugins/ring/ring_plugin.mllib | 3 - plugins/ring/vo.itarget | 10 - plugins/romega/ReflOmegaCore.v | 14 +- plugins/romega/const_omega.ml | 65 +- plugins/romega/const_omega.mli | 3 +- plugins/romega/g_romega.ml4 | 23 +- plugins/romega/refl_omega.ml | 299 ++-- plugins/rtauto/Bintree.v | 16 +- plugins/rtauto/Rtauto.v | 2 +- plugins/rtauto/g_rtauto.ml4 | 8 +- plugins/rtauto/proof_search.ml | 127 +- plugins/rtauto/proof_search.mli | 4 +- plugins/rtauto/refl_tauto.ml | 59 +- plugins/rtauto/refl_tauto.mli | 6 +- plugins/setoid_ring/ArithRing.v | 2 +- plugins/setoid_ring/BinList.v | 2 +- plugins/setoid_ring/Cring.v | 7 +- plugins/setoid_ring/Field.v | 2 +- plugins/setoid_ring/Field_tac.v | 89 +- plugins/setoid_ring/Field_theory.v | 2278 +++++++++++------------- plugins/setoid_ring/InitialRing.v | 8 +- plugins/setoid_ring/NArithRing.v | 2 +- plugins/setoid_ring/Ncring.v | 2 +- plugins/setoid_ring/Ncring_initial.v | 3 +- plugins/setoid_ring/Ncring_polynom.v | 63 +- plugins/setoid_ring/Ncring_tac.v | 8 +- plugins/setoid_ring/Ring.v | 2 +- plugins/setoid_ring/Ring_base.v | 2 +- plugins/setoid_ring/Ring_equiv.v | 74 - plugins/setoid_ring/Ring_polynom.v | 166 +- plugins/setoid_ring/Ring_tac.v | 58 +- plugins/setoid_ring/Ring_theory.v | 7 +- plugins/setoid_ring/Rings_Z.v | 1 + plugins/setoid_ring/ZArithRing.v | 6 +- plugins/setoid_ring/newring.ml4 | 684 ++++--- plugins/setoid_ring/vo.itarget | 1 - plugins/subtac/eterm.ml | 259 --- plugins/subtac/eterm.mli | 33 - plugins/subtac/g_subtac.ml4 | 167 -- plugins/subtac/subtac.ml | 226 --- plugins/subtac/subtac.mli | 2 - plugins/subtac/subtac_cases.ml | 2023 --------------------- plugins/subtac/subtac_cases.mli | 21 - plugins/subtac/subtac_classes.ml | 190 -- plugins/subtac/subtac_classes.mli | 39 - plugins/subtac/subtac_coercion.ml | 510 ------ plugins/subtac/subtac_coercion.mli | 4 - plugins/subtac/subtac_command.ml | 544 ------ plugins/subtac/subtac_command.mli | 60 - plugins/subtac/subtac_errors.ml | 24 - plugins/subtac/subtac_errors.mli | 15 - plugins/subtac/subtac_obligations.ml | 699 -------- plugins/subtac/subtac_obligations.mli | 72 - plugins/subtac/subtac_plugin.mllib | 13 - plugins/subtac/subtac_pretyping.ml | 138 -- plugins/subtac/subtac_pretyping.mli | 23 - plugins/subtac/subtac_pretyping_F.ml | 662 ------- plugins/subtac/subtac_utils.ml | 476 ----- plugins/subtac/subtac_utils.mli | 131 -- 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 | 34 +- plugins/syntax/nat_syntax.ml | 26 +- plugins/syntax/numbers_syntax.ml | 69 +- plugins/syntax/r_syntax.ml | 67 +- plugins/syntax/string_syntax.ml | 19 +- plugins/syntax/z_syntax.ml | 72 +- plugins/xml/COPYRIGHT | 25 - plugins/xml/README | 269 +-- 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 | 273 --- plugins/xml/doubleTypeInference.mli | 24 - plugins/xml/dumptree.ml4 | 136 -- plugins/xml/proof2aproof.ml | 78 - plugins/xml/proofTree2Xml.ml4 | 205 --- plugins/xml/theoryobject.dtd | 62 - plugins/xml/unshare.ml | 52 - plugins/xml/unshare.mli | 21 - plugins/xml/xml.ml4 | 78 - plugins/xml/xml.mli | 38 - plugins/xml/xml_plugin.mllib | 13 - plugins/xml/xmlcommand.ml | 691 ------- plugins/xml/xmlcommand.mli | 39 - plugins/xml/xmlentries.ml4 | 38 - 259 files changed, 10303 insertions(+), 25187 deletions(-) create mode 100644 plugins/btauto/Algebra.v create mode 100644 plugins/btauto/Btauto.v create mode 100644 plugins/btauto/Reflect.v create mode 100644 plugins/btauto/btauto_plugin.mllib create mode 100644 plugins/btauto/g_btauto.ml4 create mode 100644 plugins/btauto/refl_btauto.ml create mode 100644 plugins/btauto/vo.itarget create mode 100644 plugins/derive/Derive.v create mode 100644 plugins/derive/derive.ml create mode 100644 plugins/derive/derive.mli create mode 100644 plugins/derive/derive_plugin.mllib create mode 100644 plugins/derive/g_derive.ml4 create mode 100644 plugins/derive/vo.itarget delete mode 100644 plugins/field/LegacyField.v delete mode 100644 plugins/field/LegacyField_Compl.v delete mode 100644 plugins/field/LegacyField_Tactic.v delete mode 100644 plugins/field/LegacyField_Theory.v delete mode 100644 plugins/field/field.ml4 delete mode 100644 plugins/field/field_plugin.mllib delete mode 100644 plugins/field/vo.itarget create mode 100644 plugins/funind/recdef.mli delete mode 100644 plugins/micromega/CheckerMaker.v create mode 100644 plugins/micromega/Lia.v delete mode 100644 plugins/ring/LegacyArithRing.v delete mode 100644 plugins/ring/LegacyNArithRing.v delete mode 100644 plugins/ring/LegacyRing.v delete mode 100644 plugins/ring/LegacyRing_theory.v delete mode 100644 plugins/ring/LegacyZArithRing.v delete mode 100644 plugins/ring/Ring_abstract.v delete mode 100644 plugins/ring/Ring_normalize.v delete mode 100644 plugins/ring/Setoid_ring.v delete mode 100644 plugins/ring/Setoid_ring_normalize.v delete mode 100644 plugins/ring/Setoid_ring_theory.v delete mode 100644 plugins/ring/g_ring.ml4 delete mode 100644 plugins/ring/ring.ml delete mode 100644 plugins/ring/ring_plugin.mllib delete mode 100644 plugins/ring/vo.itarget delete mode 100644 plugins/setoid_ring/Ring_equiv.v delete mode 100644 plugins/subtac/eterm.ml delete mode 100644 plugins/subtac/eterm.mli delete mode 100644 plugins/subtac/g_subtac.ml4 delete mode 100644 plugins/subtac/subtac.ml delete mode 100644 plugins/subtac/subtac.mli delete mode 100644 plugins/subtac/subtac_cases.ml delete mode 100644 plugins/subtac/subtac_cases.mli delete mode 100644 plugins/subtac/subtac_classes.ml delete mode 100644 plugins/subtac/subtac_classes.mli delete mode 100644 plugins/subtac/subtac_coercion.ml delete mode 100644 plugins/subtac/subtac_coercion.mli delete mode 100644 plugins/subtac/subtac_command.ml delete mode 100644 plugins/subtac/subtac_command.mli delete mode 100644 plugins/subtac/subtac_errors.ml delete mode 100644 plugins/subtac/subtac_errors.mli delete mode 100644 plugins/subtac/subtac_obligations.ml delete mode 100644 plugins/subtac/subtac_obligations.mli delete mode 100644 plugins/subtac/subtac_plugin.mllib delete mode 100644 plugins/subtac/subtac_pretyping.ml delete mode 100644 plugins/subtac/subtac_pretyping.mli delete mode 100644 plugins/subtac/subtac_pretyping_F.ml delete mode 100644 plugins/subtac/subtac_utils.ml delete mode 100644 plugins/subtac/subtac_utils.mli delete mode 100644 plugins/subtac/test/ListDep.v delete mode 100644 plugins/subtac/test/ListsTest.v delete mode 100644 plugins/subtac/test/Mutind.v delete mode 100644 plugins/subtac/test/Test1.v delete mode 100644 plugins/subtac/test/euclid.v delete mode 100644 plugins/subtac/test/id.v delete mode 100644 plugins/subtac/test/measure.v delete mode 100644 plugins/subtac/test/rec.v delete mode 100644 plugins/subtac/test/take.v delete mode 100644 plugins/subtac/test/wf.v delete mode 100644 plugins/xml/COPYRIGHT delete mode 100644 plugins/xml/acic.ml delete mode 100644 plugins/xml/acic2Xml.ml4 delete mode 100644 plugins/xml/cic.dtd delete mode 100644 plugins/xml/cic2Xml.ml delete mode 100644 plugins/xml/cic2acic.ml delete mode 100644 plugins/xml/doubleTypeInference.ml delete mode 100644 plugins/xml/doubleTypeInference.mli delete mode 100644 plugins/xml/dumptree.ml4 delete mode 100644 plugins/xml/proof2aproof.ml delete mode 100644 plugins/xml/proofTree2Xml.ml4 delete mode 100644 plugins/xml/theoryobject.dtd delete mode 100644 plugins/xml/unshare.ml delete mode 100644 plugins/xml/unshare.mli delete mode 100644 plugins/xml/xml.ml4 delete mode 100644 plugins/xml/xml.mli delete mode 100644 plugins/xml/xml_plugin.mllib delete mode 100644 plugins/xml/xmlcommand.ml delete mode 100644 plugins/xml/xmlcommand.mli delete mode 100644 plugins/xml/xmlentries.ml4 (limited to 'plugins') diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v new file mode 100644 index 00000000..bc5a3900 --- /dev/null +++ b/plugins/btauto/Algebra.v @@ -0,0 +1,591 @@ +Require Import Bool PArith DecidableClass Omega ROmega. + +Ltac bool := +repeat match goal with +| [ H : ?P && ?Q = true |- _ ] => + apply andb_true_iff in H; destruct H +| |- ?P && ?Q = true => + apply <- andb_true_iff; split +end. + +Arguments decide P /H. + +Hint Extern 5 => progress bool. + +Ltac define t x H := +set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. + +Lemma Decidable_sound : forall P (H : Decidable P), + decide P = true -> P. +Proof. +intros P H Hp; apply -> Decidable_spec; assumption. +Qed. + +Lemma Decidable_complete : forall P (H : Decidable P), + P -> decide P = true. +Proof. +intros P H Hp; apply <- Decidable_spec; assumption. +Qed. + +Lemma Decidable_sound_alt : forall P (H : Decidable P), + ~ P -> decide P = false. +Proof. +intros P [wit spec] Hd; destruct wit; simpl; tauto. +Qed. + +Lemma Decidable_complete_alt : forall P (H : Decidable P), + decide P = false -> ~ P. +Proof. + intros P [wit spec] Hd Hc; simpl in *; intuition congruence. +Qed. + +Ltac try_rewrite := +repeat match goal with +| [ H : ?P |- _ ] => rewrite H +end. + +(* We opacify here decide for proofs, and will make it transparent for + reflexive tactics later on. *) + +Global Opaque decide. + +Ltac tac_decide := +match goal with +| [ H : @decide ?P ?D = true |- _ ] => apply (@Decidable_sound P D) in H +| [ H : @decide ?P ?D = false |- _ ] => apply (@Decidable_complete_alt P D) in H +| [ |- @decide ?P ?D = true ] => apply (@Decidable_complete P D) +| [ |- @decide ?P ?D = false ] => apply (@Decidable_sound_alt P D) +| [ |- negb ?b = true ] => apply negb_true_iff +| [ |- negb ?b = false ] => apply negb_false_iff +| [ H : negb ?b = true |- _ ] => apply negb_true_iff in H +| [ H : negb ?b = false |- _ ] => apply negb_false_iff in H +end. + +Ltac try_decide := repeat tac_decide. + +Ltac make_decide P := match goal with +| [ |- context [@decide P ?D] ] => + let b := fresh "b" in + let H := fresh "H" in + define (@decide P D) b H; destruct b; try_decide +| [ X : context [@decide P ?D] |- _ ] => + let b := fresh "b" in + let H := fresh "H" in + define (@decide P D) b H; destruct b; try_decide +end. + +Ltac case_decide := match goal with +| [ |- context [@decide ?P ?D] ] => + let b := fresh "b" in + let H := fresh "H" in + define (@decide P D) b H; destruct b; try_decide +| [ X : context [@decide ?P ?D] |- _ ] => + let b := fresh "b" in + let H := fresh "H" in + define (@decide P D) b H; destruct b; try_decide +| [ |- context [Pos.compare ?x ?y] ] => + destruct (Pos.compare_spec x y); try (exfalso; zify; romega) +| [ X : context [Pos.compare ?x ?y] |- _ ] => + destruct (Pos.compare_spec x y); try (exfalso; zify; romega) +end. + +Section Definitions. + +(** * Global, inductive definitions. *) + +(** A Horner polynomial is either a constant, or a product P × (i + Q), where i + is a variable. *) + +Inductive poly := +| Cst : bool -> poly +| Poly : poly -> positive -> poly -> poly. + +(* TODO: We should use [positive] instead of [nat] to encode variables, for + efficiency purpose. *) + +Inductive null : poly -> Prop := +| null_intro : null (Cst false). + +(** Polynomials satisfy a uniqueness condition whenever they are valid. A + polynomial [p] satisfies [valid n p] whenever it is well-formed and each of + its variable indices is < [n]. *) + +Inductive valid : positive -> poly -> Prop := +| valid_cst : forall k c, valid k (Cst c) +| valid_poly : forall k p i q, + Pos.lt i k -> ~ null q -> valid i p -> valid (Pos.succ i) q -> valid k (Poly p i q). + +(** Linear polynomials are valid polynomials in which every variable appears at + most once. *) + +Inductive linear : positive -> poly -> Prop := +| linear_cst : forall k c, linear k (Cst c) +| linear_poly : forall k p i q, Pos.lt i k -> ~ null q -> + linear i p -> linear i q -> linear k (Poly p i q). + +End Definitions. + +Section Computational. + +Program Instance Decidable_PosEq : forall (p q : positive), Decidable (p = q) := + { Decidable_witness := Pos.eqb p q }. +Next Obligation. +apply Pos.eqb_eq. +Qed. + +Program Instance Decidable_PosLt : forall p q, Decidable (Pos.lt p q) := + { Decidable_witness := Pos.ltb p q }. +Next Obligation. +apply Pos.ltb_lt. +Qed. + +Program Instance Decidable_PosLe : forall p q, Decidable (Pos.le p q) := + { Decidable_witness := Pos.leb p q }. +Next Obligation. +apply Pos.leb_le. +Qed. + +(** * The core reflexive part. *) + +Hint Constructors valid. + +Fixpoint beq_poly pl pr := +match pl with +| Cst cl => + match pr with + | Cst cr => decide (cl = cr) + | Poly _ _ _ => false + end +| Poly pl il ql => + match pr with + | Cst _ => false + | Poly pr ir qr => + decide (il = ir) && beq_poly pl pr && beq_poly ql qr + end +end. + +(* We could do that with [decide equality] but dependency in proofs is heavy *) +Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := { + Decidable_witness := beq_poly p q +}. + +Next Obligation. +split. +revert q; induction p; intros [] ?; simpl in *; bool; try_decide; + f_equal; first [intuition congruence|auto]. +revert q; induction p; intros [] Heq; simpl in *; bool; try_decide; intuition; + try injection Heq; first[congruence|intuition]. +Qed. + +Program Instance Decidable_null : forall p, Decidable (null p) := { + Decidable_witness := match p with Cst false => true | _ => false end +}. +Next Obligation. +split. + destruct p as [[]|]; first [discriminate|constructor]. + inversion 1; trivial. +Qed. + +Definition list_nth {A} p (l : list A) def := + Pos.peano_rect (fun _ => list A -> A) + (fun l => match l with nil => def | cons t l => t end) + (fun _ F l => match l with nil => def | cons t l => F l end) p l. + +Fixpoint eval var (p : poly) := +match p with +| Cst c => c +| Poly p i q => + let vi := list_nth i var false in + xorb (eval var p) (andb vi (eval var q)) +end. + +Fixpoint valid_dec k p := +match p with +| Cst c => true +| Poly p i q => + negb (decide (null q)) && decide (i < k)%positive && + valid_dec i p && valid_dec (Pos.succ i) q +end. + +Program Instance Decidable_valid : forall n p, Decidable (valid n p) := { + Decidable_witness := valid_dec n p +}. +Next Obligation. +split. + revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto. + intros H; induction H; unfold valid_dec in *; bool; try_decide; auto. +Qed. + +(** Basic algebra *) + +(* Addition of polynomials *) + +Fixpoint poly_add pl {struct pl} := +match pl with +| Cst cl => + fix F pr := match pr with + | Cst cr => Cst (xorb cl cr) + | Poly pr ir qr => Poly (F pr) ir qr + end +| Poly pl il ql => + fix F pr {struct pr} := match pr with + | Cst cr => Poly (poly_add pl pr) il ql + | Poly pr ir qr => + match Pos.compare il ir with + | Eq => + let qs := poly_add ql qr in + (* Ensure validity *) + if decide (null qs) then poly_add pl pr + else Poly (poly_add pl pr) il qs + | Gt => Poly (poly_add pl (Poly pr ir qr)) il ql + | Lt => Poly (F pr) ir qr + end + end +end. + +(* Multiply a polynomial by a constant *) + +Fixpoint poly_mul_cst v p := +match p with +| Cst c => Cst (andb c v) +| Poly p i q => + let r := poly_mul_cst v q in + (* Ensure validity *) + if decide (null r) then poly_mul_cst v p + else Poly (poly_mul_cst v p) i r +end. + +(* Multiply a polynomial by a monomial *) + +Fixpoint poly_mul_mon k p := +match p with +| Cst c => + if decide (null p) then p + else Poly (Cst false) k p +| Poly p i q => + if decide (i <= k)%positive then Poly (Cst false) k (Poly p i q) + else Poly (poly_mul_mon k p) i (poly_mul_mon k q) +end. + +(* Multiplication of polynomials *) + +Fixpoint poly_mul pl {struct pl} := +match pl with +| Cst cl => poly_mul_cst cl +| Poly pl il ql => + fun pr => + (* Multiply by a factor *) + let qs := poly_mul ql pr in + (* Ensure validity *) + if decide (null qs) then poly_mul pl pr + else poly_add (poly_mul pl pr) (poly_mul_mon il qs) +end. + +(** Quotienting a polynomial by the relation X_i^2 ~ X_i *) + +(* Remove the multiple occurences of monomials x_k *) + +Fixpoint reduce_aux k p := +match p with +| Cst c => Cst c +| Poly p i q => + if decide (i = k) then poly_add (reduce_aux k p) (reduce_aux k q) + else + let qs := reduce_aux i q in + (* Ensure validity *) + if decide (null qs) then (reduce_aux k p) + else Poly (reduce_aux k p) i qs +end. + +(* Rewrite any x_k ^ {n + 1} to x_k *) + +Fixpoint reduce p := +match p with +| Cst c => Cst c +| Poly p i q => + let qs := reduce_aux i q in + (* Ensure validity *) + if decide (null qs) then reduce p + else Poly (reduce p) i qs +end. + +End Computational. + +Section Validity. + +(* Decision procedure of validity *) + +Hint Constructors valid linear. + +Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. +Proof. +intros k l p H Hl; induction H; constructor; eauto. +now eapply Pos.lt_le_trans; eassumption. +Qed. + +Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p. +Proof. +intros k l p H; revert l; induction H; constructor; eauto; zify; romega. +Qed. + +Lemma linear_valid_incl : forall k p, linear k p -> valid k p. +Proof. +intros k p H; induction H; constructor; auto. +eapply valid_le_compat; eauto; zify; romega. +Qed. + +End Validity. + +Section Evaluation. + +(* Useful simple properties *) + +Lemma eval_null_zero : forall p var, null p -> eval var p = false. +Proof. +intros p var []; reflexivity. +Qed. + +Lemma eval_extensional_eq_compat : forall p var1 var2, + (forall x, list_nth x var1 false = list_nth x var2 false) -> eval var1 p = eval var2 p. +Proof. +intros p var1 var2 H; induction p; simpl; try_rewrite; auto. +Qed. + +Lemma eval_suffix_compat : forall k p var1 var2, + (forall i, (i < k)%positive -> list_nth i var1 false = list_nth i var2 false) -> valid k p -> + eval var1 p = eval var2 p. +Proof. +intros k p var1 var2 Hvar Hv; revert var1 var2 Hvar. +induction Hv; intros var1 var2 Hvar; simpl; [now auto|]. +rewrite Hvar; [|now auto]; erewrite (IHHv1 var1 var2). + + erewrite (IHHv2 var1 var2); [ring|]. + intros; apply Hvar; zify; omega. + + intros; apply Hvar; zify; omega. +Qed. + +End Evaluation. + +Section Algebra. + +(* Compatibility with evaluation *) + +Lemma poly_add_compat : forall pl pr var, eval var (poly_add pl pr) = xorb (eval var pl) (eval var pr). +Proof. +intros pl; induction pl; intros pr var; simpl. ++ induction pr; simpl; auto; solve [try_rewrite; ring]. ++ induction pr; simpl; auto; try solve [try_rewrite; simpl; ring]. + destruct (Pos.compare_spec p p0); repeat case_decide; simpl; first [try_rewrite; ring|idtac]. + try_rewrite; ring_simplify; repeat rewrite xorb_assoc. + match goal with [ |- context [xorb (andb ?b1 ?b2) (andb ?b1 ?b3)] ] => + replace (xorb (andb b1 b2) (andb b1 b3)) with (andb b1 (xorb b2 b3)) by ring + end. + rewrite <- IHpl2. + match goal with [ H : null ?p |- _ ] => rewrite (eval_null_zero _ _ H) end; ring. + simpl; rewrite IHpl1; simpl; ring. +Qed. + +Lemma poly_mul_cst_compat : forall v p var, + eval var (poly_mul_cst v p) = andb v (eval var p). +Proof. +intros v p; induction p; intros var; simpl; [ring|]. +case_decide; simpl; try_rewrite; [ring_simplify|ring]. +replace (v && list_nth p2 var false && eval var p3) with (list_nth p2 var false && (v && eval var p3)) by ring. +rewrite <- IHp2; inversion H; simpl; ring. +Qed. + +Lemma poly_mul_mon_compat : forall i p var, + eval var (poly_mul_mon i p) = (list_nth i var false && eval var p). +Proof. +intros i p var; induction p; simpl; case_decide; simpl; try_rewrite; try ring. +inversion H; ring. +match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end. +match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end. +Qed. + +Lemma poly_mul_compat : forall pl pr var, eval var (poly_mul pl pr) = andb (eval var pl) (eval var pr). +Proof. +intros pl; induction pl; intros pr var; simpl. + apply poly_mul_cst_compat. + case_decide; simpl. + rewrite IHpl1; ring_simplify. + replace (eval var pr && list_nth p var false && eval var pl2) + with (list_nth p var false && (eval var pl2 && eval var pr)) by ring. + now rewrite <- IHpl2; inversion H; simpl; ring. + rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring. +Qed. + +Hint Extern 5 => +match goal with +| [ |- (Pos.max ?x ?y <= ?z)%positive ] => + apply Pos.max_case_strong; intros; zify; romega +| [ |- (?z <= Pos.max ?x ?y)%positive ] => + apply Pos.max_case_strong; intros; zify; romega +| [ |- (Pos.max ?x ?y < ?z)%positive ] => + apply Pos.max_case_strong; intros; zify; romega +| [ |- (?z < Pos.max ?x ?y)%positive ] => + apply Pos.max_case_strong; intros; zify; romega +| _ => zify; omega +end. +Hint Resolve Pos.le_max_r Pos.le_max_l. + +Hint Constructors valid linear. + +(* Compatibility of validity w.r.t algebraic operations *) + +Lemma poly_add_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> + valid (Pos.max kl kr) (poly_add pl pr). +Proof. +intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl. +{ eapply valid_le_compat; [clear k|apply Pos.le_max_r]. + now induction Hr; auto. } +{ assert (Hle : (Pos.max (Pos.succ i) kr <= Pos.max k kr)%positive) by auto. + apply (valid_le_compat (Pos.max (Pos.succ i) kr)); [|assumption]. + clear - IHHl1 IHHl2 Hl2 Hr H0; induction Hr. + constructor; auto. + now rewrite <- (Pos.max_id i); intuition. + destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). + + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. + + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; zify; romega. + + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; zify; romega. + + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition. + + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition. +} +Qed. + +Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_cst v p). +Proof. +intros k v p H; induction H; simpl; [now auto|]. +case_decide; [|now auto]. +eapply (valid_le_compat i); [now auto|zify; romega]. +Qed. + +Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p. +Proof. +intros i p; induction p; simpl; case_decide; simpl; inversion 1; intuition. +Qed. + +Lemma poly_mul_mon_valid_compat : forall k i p, + valid k p -> valid (Pos.max (Pos.succ i) k) (poly_mul_mon i p). +Proof. +intros k i p H; induction H; simpl poly_mul_mon; case_decide; intuition. ++ apply (valid_le_compat (Pos.succ i)); auto; constructor; intuition. + - match goal with [ H : null ?p |- _ ] => solve[inversion H] end. ++ apply (valid_le_compat k); auto; constructor; intuition. + - assert (X := poly_mul_mon_null_compat); intuition eauto. + - cutrewrite <- (Pos.max (Pos.succ i) i0 = i0); intuition. + - cutrewrite <- (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0); intuition. +Qed. + +Lemma poly_mul_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> + valid (Pos.max kl kr) (poly_mul pl pr). +Proof. +intros kl kr pl pr Hl Hr; revert kr pr Hr. +induction Hl; intros kr pr Hr; simpl. ++ apply poly_mul_cst_valid_compat; auto. + apply (valid_le_compat kr); now auto. ++ apply (valid_le_compat (Pos.max (Pos.max i kr) (Pos.max (Pos.succ i) (Pos.max (Pos.succ i) kr)))). + - case_decide. + { apply (valid_le_compat (Pos.max i kr)); auto. } + { apply poly_add_valid_compat; auto. + now apply poly_mul_mon_valid_compat; intuition. } + - repeat apply Pos.max_case_strong; zify; omega. +Qed. + +(* Compatibility of linearity wrt to linear operations *) + +Lemma poly_add_linear_compat : forall kl kr pl pr, linear kl pl -> linear kr pr -> + linear (Pos.max kl kr) (poly_add pl pr). +Proof. +intros kl kr pl pr Hl; revert kr pr; induction Hl; intros kr pr Hr; simpl. ++ apply (linear_le_compat kr); [|apply Pos.max_case_strong; zify; omega]. + now induction Hr; constructor; auto. ++ apply (linear_le_compat (Pos.max kr (Pos.succ i))); [|now auto]. + induction Hr; simpl. + - constructor; auto. + replace i with (Pos.max i i) by (apply Pos.max_id); intuition. + - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). + { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } + { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } + { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } + { apply (linear_le_compat (Pos.max i0 (Pos.succ i))); intuition. } + { apply (linear_le_compat (Pos.max i (Pos.succ i0))); intuition. } +Qed. + +End Algebra. + +Section Reduce. + +(* A stronger version of the next lemma *) + +Lemma reduce_aux_eval_compat : forall k p var, valid (Pos.succ k) p -> + (list_nth k var false && eval var (reduce_aux k p) = list_nth k var false && eval var p). +Proof. +intros k p var; revert k; induction p; intros k Hv; simpl; auto. +inversion Hv; case_decide; subst. ++ rewrite poly_add_compat; ring_simplify. + specialize (IHp1 k); specialize (IHp2 k). + destruct (list_nth k var false); ring_simplify; [|now auto]. + rewrite <- (andb_true_l (eval var p1)), <- (andb_true_l (eval var p3)). + rewrite <- IHp2; auto; rewrite <- IHp1; [ring|]. + apply (valid_le_compat k); [now auto|zify; omega]. ++ remember (list_nth k var false) as b; destruct b; ring_simplify; [|now auto]. + case_decide; simpl. + - rewrite <- (IHp2 p2); [inversion H|now auto]; simpl. + replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring); rewrite <- (IHp1 k). + { rewrite <- Heqb; ring. } + { apply (valid_le_compat p2); [auto|zify; omega]. } + - rewrite (IHp2 p2); [|now auto]. + replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring). + rewrite <- (IHp1 k); [rewrite <- Heqb; ring|]. + apply (valid_le_compat p2); [auto|zify; omega]. +Qed. + +(* Reduction preserves evaluation by boolean assignations *) + +Lemma reduce_eval_compat : forall k p var, valid k p -> + eval var (reduce p) = eval var p. +Proof. +intros k p var H; induction H; simpl; auto. +case_decide; try_rewrite; simpl. ++ rewrite <- reduce_aux_eval_compat; auto; inversion H3; simpl; ring. ++ repeat rewrite reduce_aux_eval_compat; try_rewrite; now auto. +Qed. + +Lemma reduce_aux_le_compat : forall k l p, valid k p -> (k <= l)%positive -> + reduce_aux l p = reduce_aux k p. +Proof. +intros k l p; revert k l; induction p; intros k l H Hle; simpl; auto. +inversion H; subst; repeat case_decide; subst; try (exfalso; zify; omega). ++ apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|zify; omega]. ++ f_equal; apply IHp1; auto. + now eapply valid_le_compat; [eauto|zify; omega]. +Qed. + +(* Reduce projects valid polynomials into linear ones *) + +Lemma linear_reduce_aux : forall i p, valid (Pos.succ i) p -> linear i (reduce_aux i p). +Proof. +intros i p; revert i; induction p; intros i Hp; simpl. ++ constructor. ++ inversion Hp; subst; case_decide; subst. + - rewrite <- (Pos.max_id i) at 1; apply poly_add_linear_compat. + { apply IHp1; eapply valid_le_compat; [eassumption|zify; omega]. } + { intuition. } + - case_decide. + { apply IHp1; eapply valid_le_compat; [eauto|zify; omega]. } + { constructor; try (zify; omega); auto. + erewrite (reduce_aux_le_compat p2); [|assumption|zify; omega]. + apply IHp1; eapply valid_le_compat; [eauto|]; zify; omega. } +Qed. + +Lemma linear_reduce : forall k p, valid k p -> linear k (reduce p). +Proof. +intros k p H; induction H; simpl. ++ now constructor. ++ case_decide. + - eapply linear_le_compat; [eauto|zify; omega]. + - constructor; auto. + apply linear_reduce_aux; auto. +Qed. + +End Reduce. diff --git a/plugins/btauto/Btauto.v b/plugins/btauto/Btauto.v new file mode 100644 index 00000000..d3331ccf --- /dev/null +++ b/plugins/btauto/Btauto.v @@ -0,0 +1,3 @@ +Require Import Algebra Reflect. + +Declare ML Module "btauto_plugin". diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v new file mode 100644 index 00000000..3bd7cd62 --- /dev/null +++ b/plugins/btauto/Reflect.v @@ -0,0 +1,398 @@ +Require Import Bool DecidableClass Algebra Ring PArith ROmega Omega. + +Section Bool. + +(* Boolean formulas and their evaluations *) + +Inductive formula := +| formula_var : positive -> formula +| formula_btm : formula +| formula_top : formula +| formula_cnj : formula -> formula -> formula +| formula_dsj : formula -> formula -> formula +| formula_neg : formula -> formula +| formula_xor : formula -> formula -> formula +| formula_ifb : formula -> formula -> formula -> formula. + +Fixpoint formula_eval var f := match f with +| formula_var x => list_nth x var false +| formula_btm => false +| formula_top => true +| formula_cnj fl fr => (formula_eval var fl) && (formula_eval var fr) +| formula_dsj fl fr => (formula_eval var fl) || (formula_eval var fr) +| formula_neg f => negb (formula_eval var f) +| formula_xor fl fr => xorb (formula_eval var fl) (formula_eval var fr) +| formula_ifb fc fl fr => + if formula_eval var fc then formula_eval var fl else formula_eval var fr +end. + +End Bool. + +(* Translation of formulas into polynomials *) + +Section Translation. + +(* This is straightforward. *) + +Fixpoint poly_of_formula f := match f with +| formula_var x => Poly (Cst false) x (Cst true) +| formula_btm => Cst false +| formula_top => Cst true +| formula_cnj fl fr => + let pl := poly_of_formula fl in + let pr := poly_of_formula fr in + poly_mul pl pr +| formula_dsj fl fr => + let pl := poly_of_formula fl in + let pr := poly_of_formula fr in + poly_add (poly_add pl pr) (poly_mul pl pr) +| formula_neg f => poly_add (Cst true) (poly_of_formula f) +| formula_xor fl fr => poly_add (poly_of_formula fl) (poly_of_formula fr) +| formula_ifb fc fl fr => + let pc := poly_of_formula fc in + let pl := poly_of_formula fl in + let pr := poly_of_formula fr in + poly_add pr (poly_add (poly_mul pc pl) (poly_mul pc pr)) +end. + +Opaque poly_add. + +(* Compatibility of translation wrt evaluation *) + +Lemma poly_of_formula_eval_compat : forall var f, + eval var (poly_of_formula f) = formula_eval var f. +Proof. +intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. + now simpl; match goal with [ |- ?t = ?u ] => destruct u; reflexivity end. + rewrite poly_mul_compat, IHf1, IHf2; ring. + repeat rewrite poly_add_compat. + rewrite poly_mul_compat; try_rewrite. + now match goal with [ |- ?t = ?x || ?y ] => destruct x; destruct y; reflexivity end. + rewrite poly_add_compat; try_rewrite. + now match goal with [ |- ?t = negb ?x ] => destruct x; reflexivity end. + rewrite poly_add_compat; congruence. + rewrite ?poly_add_compat, ?poly_mul_compat; try_rewrite. + match goal with + [ |- ?t = if ?b1 then ?b2 else ?b3 ] => destruct b1; destruct b2; destruct b3; reflexivity + end. +Qed. + +Hint Extern 5 => change 0 with (min 0 0). +Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat. +Local Hint Constructors valid. +Hint Extern 5 => zify; omega. + +(* Compatibility with validity *) + +Lemma poly_of_formula_valid_compat : forall f, exists n, valid n (poly_of_formula f). +Proof. +intros f; induction f; simpl. ++ exists (Pos.succ p); constructor; intuition; inversion H. ++ exists 1%positive; auto. ++ exists 1%positive; auto. ++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. ++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max (Pos.max n1 n2) (Pos.max n1 n2)); auto. ++ destruct IHf as [n Hn]; exists (Pos.max 1 n); auto. ++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. ++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; destruct IHf3 as [n3 Hn3]; eexists; eauto. +Qed. + +(* The soundness lemma ; alas not complete! *) + +Lemma poly_of_formula_sound : forall fl fr var, + poly_of_formula fl = poly_of_formula fr -> formula_eval var fl = formula_eval var fr. +Proof. +intros fl fr var Heq. +repeat rewrite <- poly_of_formula_eval_compat. +rewrite Heq; reflexivity. +Qed. + +End Translation. + +Section Completeness. + +(* Lemma reduce_poly_of_formula_simpl : forall fl fr var, + simpl_eval (var_of_list var) (reduce (poly_of_formula fl)) = simpl_eval (var_of_list var) (reduce (poly_of_formula fr)) -> + formula_eval var fl = formula_eval var fr. +Proof. +intros fl fr var Hrw. +do 2 rewrite <- poly_of_formula_eval_compat. +destruct (poly_of_formula_valid_compat fl) as [nl Hl]. +destruct (poly_of_formula_valid_compat fr) as [nr Hr]. +rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); [|assumption]. +rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); [|assumption]. +do 2 rewrite <- eval_simpl_eval_compat; assumption. +Qed. *) + +(* Soundness of the method ; immediate *) + +Lemma reduce_poly_of_formula_sound : forall fl fr var, + reduce (poly_of_formula fl) = reduce (poly_of_formula fr) -> + formula_eval var fl = formula_eval var fr. +Proof. +intros fl fr var Heq. +repeat rewrite <- poly_of_formula_eval_compat. +destruct (poly_of_formula_valid_compat fl) as [nl Hl]. +destruct (poly_of_formula_valid_compat fr) as [nr Hr]. +rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. +rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. +rewrite Heq; reflexivity. +Qed. + +Definition make_last {A} n (x def : A) := + Pos.peano_rect (fun _ => list A) + (cons x nil) + (fun _ F => cons def F) n. + +(* Replace the nth element of a list *) + +Fixpoint list_replace l n b := +match l with +| nil => make_last n b false +| cons a l => + Pos.peano_rect _ + (cons b l) (fun n _ => cons a (list_replace l n b)) n +end. + +(** Extract a non-null witness from a polynomial *) + +Existing Instance Decidable_null. + +Fixpoint boolean_witness p := +match p with +| Cst c => nil +| Poly p i q => + if decide (null p) then + let var := boolean_witness q in + list_replace var i true + else + let var := boolean_witness p in + list_replace var i false +end. + +Lemma list_nth_base : forall A (def : A) l, + list_nth 1 l def = match l with nil => def | cons x _ => x end. +Proof. +intros A def l; unfold list_nth. +rewrite Pos.peano_rect_base; reflexivity. +Qed. + +Lemma list_nth_succ : forall A n (def : A) l, + list_nth (Pos.succ n) l def = + match l with nil => def | cons _ l => list_nth n l def end. +Proof. +intros A def l; unfold list_nth. +rewrite Pos.peano_rect_succ; reflexivity. +Qed. + +Lemma list_nth_nil : forall A n (def : A), + list_nth n nil def = def. +Proof. +intros A n def; induction n using Pos.peano_rect. ++ rewrite list_nth_base; reflexivity. ++ rewrite list_nth_succ; reflexivity. +Qed. + +Lemma make_last_nth_1 : forall A n i x def, i <> n -> + list_nth i (@make_last A n x def) def = def. +Proof. +intros A n; induction n using Pos.peano_rect; intros i x def Hd; + unfold make_last; simpl. ++ induction i using Pos.peano_case; [elim Hd; reflexivity|]. + rewrite list_nth_succ, list_nth_nil; reflexivity. ++ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). + induction i using Pos.peano_case. + - rewrite list_nth_base; reflexivity. + - rewrite list_nth_succ; apply IHn; zify; omega. +Qed. + +Lemma make_last_nth_2 : forall A n x def, list_nth n (@make_last A n x def) def = x. +Proof. +intros A n; induction n using Pos.peano_rect; intros x def; simpl. ++ reflexivity. ++ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). + rewrite list_nth_succ; auto. +Qed. + +Lemma list_replace_nth_1 : forall var i j x, i <> j -> + list_nth i (list_replace var j x) false = list_nth i var false. +Proof. +intros var; induction var; intros i j x Hd; simpl. ++ rewrite make_last_nth_1, list_nth_nil; auto. ++ induction j using Pos.peano_rect. + - rewrite Pos.peano_rect_base. + induction i using Pos.peano_rect; [now elim Hd; auto|]. + rewrite 2list_nth_succ; reflexivity. + - rewrite Pos.peano_rect_succ. + induction i using Pos.peano_rect. + { rewrite 2list_nth_base; reflexivity. } + { rewrite 2list_nth_succ; apply IHvar; zify; omega. } +Qed. + +Lemma list_replace_nth_2 : forall var i x, list_nth i (list_replace var i x) false = x. +Proof. +intros var; induction var; intros i x; simpl. ++ now apply make_last_nth_2. ++ induction i using Pos.peano_rect. + - rewrite Pos.peano_rect_base, list_nth_base; reflexivity. + - rewrite Pos.peano_rect_succ, list_nth_succ; auto. +Qed. + +(* The witness is correct only if the polynomial is linear *) + +Lemma boolean_witness_nonzero : forall k p, linear k p -> ~ null p -> + eval (boolean_witness p) p = true. +Proof. +intros k p Hl Hp; induction Hl; simpl. + destruct c; [reflexivity|elim Hp; now constructor]. + case_decide. + rewrite eval_null_zero; [|assumption]; rewrite list_replace_nth_2; simpl. + match goal with [ |- (if ?b then true else false) = true ] => + assert (Hrw : b = true); [|rewrite Hrw; reflexivity] + end. + erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. + now intros j Hd; apply list_replace_nth_1; zify; omega. + rewrite list_replace_nth_2, xorb_false_r. + erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. + now intros j Hd; apply list_replace_nth_1; zify; omega. +Qed. + +(* This should be better when using the [vm_compute] tactic instead of plain reflexivity. *) + +Lemma reduce_poly_of_formula_sound_alt : forall var fl fr, + reduce (poly_add (poly_of_formula fl) (poly_of_formula fr)) = Cst false -> + formula_eval var fl = formula_eval var fr. +Proof. +intros var fl fr Heq. +repeat rewrite <- poly_of_formula_eval_compat. +destruct (poly_of_formula_valid_compat fl) as [nl Hl]. +destruct (poly_of_formula_valid_compat fr) as [nr Hr]. +rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. +rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. +rewrite <- xorb_false_l; change false with (eval var (Cst false)). +rewrite <- poly_add_compat, <- Heq. +repeat rewrite poly_add_compat. +rewrite (reduce_eval_compat nl); [|assumption]. +rewrite (reduce_eval_compat (Pos.max nl nr)); [|apply poly_add_valid_compat; assumption]. +rewrite (reduce_eval_compat nr); [|assumption]. +rewrite poly_add_compat; ring. +Qed. + +(* The completeness lemma *) + +(* Lemma reduce_poly_of_formula_complete : forall fl fr, + reduce (poly_of_formula fl) <> reduce (poly_of_formula fr) -> + {var | formula_eval var fl <> formula_eval var fr}. +Proof. +intros fl fr H. +pose (p := poly_add (reduce (poly_of_formula fl)) (poly_opp (reduce (poly_of_formula fr)))). +pose (var := boolean_witness p). +exists var. + intros Hc; apply (f_equal Z_of_bool) in Hc. + assert (Hfl : linear 0 (reduce (poly_of_formula fl))). + now destruct (poly_of_formula_valid_compat fl) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. + assert (Hfr : linear 0 (reduce (poly_of_formula fr))). + now destruct (poly_of_formula_valid_compat fr) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. + repeat rewrite <- poly_of_formula_eval_compat in Hc. + define (decide (null p)) b Hb; destruct b; tac_decide. + now elim H; apply (null_sub_implies_eq 0 0); fold p; auto; + apply linear_valid_incl; auto. + elim (boolean_witness_nonzero 0 p); auto. + unfold p; rewrite <- (min_id 0); apply poly_add_linear_compat; try apply poly_opp_linear_compat; now auto. + unfold p at 2; rewrite poly_add_compat, poly_opp_compat. + destruct (poly_of_formula_valid_compat fl) as [nl Hnl]. + destruct (poly_of_formula_valid_compat fr) as [nr Hnr]. + repeat erewrite reduce_eval_compat; eauto. + fold var; rewrite Hc; ring. +Defined. *) + +End Completeness. + +(* Reification tactics *) + +(* For reflexivity purposes, that would better be transparent *) + +Global Transparent decide poly_add. + +(* Ltac append_var x l k := +match l with +| nil => constr: (k, cons x l) +| cons x _ => constr: (k, l) +| cons ?y ?l => + let ans := append_var x l (S k) in + match ans with (?k, ?l) => constr: (k, cons y l) end +end. + +Ltac build_formula t l := +match t with +| true => constr: (formula_top, l) +| false => constr: (formula_btm, l) +| ?fl && ?fr => + match build_formula fl l with (?tl, ?l) => + match build_formula fr l with (?tr, ?l) => + constr: (formula_cnj tl tr, l) + end + end +| ?fl || ?fr => + match build_formula fl l with (?tl, ?l) => + match build_formula fr l with (?tr, ?l) => + constr: (formula_dsj tl tr, l) + end + end +| negb ?f => + match build_formula f l with (?t, ?l) => + constr: (formula_neg t, l) + end +| _ => + let ans := append_var t l 0 in + match ans with (?k, ?l) => constr: (formula_var k, l) end +end. + +(* Extract a counterexample from a polynomial and display it *) + +Ltac counterexample p l := + let var := constr: (boolean_witness p) in + let var := eval vm_compute in var in + let rec print l vl := + match l with + | nil => idtac + | cons ?x ?l => + match vl with + | nil => + idtac x ":=" "false"; print l (@nil bool) + | cons ?v ?vl => + idtac x ":=" v; print l vl + end + end + in + idtac "Counter-example:"; print l var. + +Ltac btauto_reify := +lazymatch goal with +| [ |- @eq bool ?t ?u ] => + lazymatch build_formula t (@nil bool) with + | (?fl, ?l) => + lazymatch build_formula u l with + | (?fr, ?l) => + change (formula_eval l fl = formula_eval l fr) + end + end +| _ => fail "Cannot recognize a boolean equality" +end. + +(* The long-awaited tactic *) + +Ltac btauto := +lazymatch goal with +| [ |- @eq bool ?t ?u ] => + lazymatch build_formula t (@nil bool) with + | (?fl, ?l) => + lazymatch build_formula u l with + | (?fr, ?l) => + change (formula_eval l fl = formula_eval l fr); + apply reduce_poly_of_formula_sound_alt; + vm_compute; (reflexivity || fail "Not a tautology") + end + end +| _ => fail "Cannot recognize a boolean equality" +end. *) diff --git a/plugins/btauto/btauto_plugin.mllib b/plugins/btauto/btauto_plugin.mllib new file mode 100644 index 00000000..319a9c30 --- /dev/null +++ b/plugins/btauto/btauto_plugin.mllib @@ -0,0 +1,3 @@ +Refl_btauto +G_btauto +Btauto_plugin_mod diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 new file mode 100644 index 00000000..8e00b1c1 --- /dev/null +++ b/plugins/btauto/g_btauto.ml4 @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Refl_btauto.Btauto.tac ] +END + diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml new file mode 100644 index 00000000..57268a9c --- /dev/null +++ b/plugins/btauto/refl_btauto.ml @@ -0,0 +1,260 @@ + +let contrib_name = "btauto" + +let init_constant dir s = + let find_constant contrib dir s = + Universes.constr_of_global (Coqlib.find_reference contrib dir s) + in + find_constant contrib_name dir s + +let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s) + +let get_inductive dir s = + let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in + Lazy.lazy_from_fun (fun () -> Globnames.destIndRef (glob_ref ())) + +let decomp_term (c : Term.constr) = + Term.kind_of_term (Term.strip_outer_cast c) + +let lapp c v = Term.mkApp (Lazy.force c, v) + +let (===) = Term.eq_constr + +module CoqList = struct + let path = ["Init"; "Datatypes"] + let typ = get_constant path "list" + let _nil = get_constant path "nil" + let _cons = get_constant path "cons" + + let cons ty h t = lapp _cons [|ty; h ; t|] + let nil ty = lapp _nil [|ty|] + let rec of_list ty = function + | [] -> nil ty + | t::q -> cons ty t (of_list ty q) + let type_of_list ty = lapp typ [|ty|] + +end + +module CoqPositive = struct + let path = ["Numbers"; "BinNums"] + let typ = get_constant path "positive" + let _xH = get_constant path "xH" + let _xO = get_constant path "xO" + let _xI = get_constant path "xI" + + (* A coq nat from an int *) + let rec of_int n = + if n <= 1 then Lazy.force _xH + else + let ans = of_int (n / 2) in + if n mod 2 = 0 then lapp _xO [|ans|] + else lapp _xI [|ans|] + +end + +module Env = struct + + module ConstrHashed = struct + type t = Term.constr + let equal = Term.eq_constr + let hash = Term.hash_constr + end + + module ConstrHashtbl = Hashtbl.Make (ConstrHashed) + + type t = (int ConstrHashtbl.t * int ref) + + let add (tbl, off) (t : Term.constr) = + try ConstrHashtbl.find tbl t + with + | Not_found -> + let i = !off in + let () = ConstrHashtbl.add tbl t i in + let () = incr off in + i + + let empty () = (ConstrHashtbl.create 16, ref 1) + + let to_list (env, _) = + (* we need to get an ordered list *) + let fold constr key accu = (key, constr) :: accu in + let l = ConstrHashtbl.fold fold env [] in + let sorted_l = List.sort (fun p1 p2 -> Int.compare (fst p1) (fst p2)) l in + List.map snd sorted_l + +end + +module Bool = struct + + let typ = get_constant ["Init"; "Datatypes"] "bool" + let ind = get_inductive ["Init"; "Datatypes"] "bool" + let trueb = get_constant ["Init"; "Datatypes"] "true" + let falseb = get_constant ["Init"; "Datatypes"] "false" + let andb = get_constant ["Init"; "Datatypes"] "andb" + let orb = get_constant ["Init"; "Datatypes"] "orb" + let xorb = get_constant ["Init"; "Datatypes"] "xorb" + let negb = get_constant ["Init"; "Datatypes"] "negb" + + type t = + | Var of int + | Const of bool + | Andb of t * t + | Orb of t * t + | Xorb of t * t + | Negb of t + | Ifb of t * t * t + + let quote (env : Env.t) (c : Term.constr) : t = + let trueb = Lazy.force trueb in + let falseb = Lazy.force falseb in + let andb = Lazy.force andb in + let orb = Lazy.force orb in + let xorb = Lazy.force xorb in + let negb = Lazy.force negb in + + let rec aux c = match decomp_term c with + | Term.App (head, args) -> + if head === andb && Array.length args = 2 then + Andb (aux args.(0), aux args.(1)) + else if head === orb && Array.length args = 2 then + Orb (aux args.(0), aux args.(1)) + else if head === xorb && Array.length args = 2 then + Xorb (aux args.(0), aux args.(1)) + else if head === negb && Array.length args = 1 then + Negb (aux args.(0)) + else Var (Env.add env c) + | Term.Case (info, r, arg, pats) -> + let is_bool = + let i = info.Term.ci_ind in + Names.eq_ind i (Lazy.force ind) + in + if is_bool then + Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) + else + Var (Env.add env c) + | _ -> + if c === falseb then Const false + else if c === trueb then Const true + else Var (Env.add env c) + in + aux c + +end + +module Btauto = struct + + open Pp + + let eq = get_constant ["Init"; "Logic"] "eq" + + let f_var = get_constant ["btauto"; "Reflect"] "formula_var" + let f_btm = get_constant ["btauto"; "Reflect"] "formula_btm" + let f_top = get_constant ["btauto"; "Reflect"] "formula_top" + let f_cnj = get_constant ["btauto"; "Reflect"] "formula_cnj" + let f_dsj = get_constant ["btauto"; "Reflect"] "formula_dsj" + let f_neg = get_constant ["btauto"; "Reflect"] "formula_neg" + let f_xor = get_constant ["btauto"; "Reflect"] "formula_xor" + let f_ifb = get_constant ["btauto"; "Reflect"] "formula_ifb" + + let eval = get_constant ["btauto"; "Reflect"] "formula_eval" + let witness = get_constant ["btauto"; "Reflect"] "boolean_witness" + + let soundness = get_constant ["btauto"; "Reflect"] "reduce_poly_of_formula_sound_alt" + + let rec convert = function + | Bool.Var n -> lapp f_var [|CoqPositive.of_int n|] + | Bool.Const true -> Lazy.force f_top + | Bool.Const false -> Lazy.force f_btm + | Bool.Andb (b1, b2) -> lapp f_cnj [|convert b1; convert b2|] + | Bool.Orb (b1, b2) -> lapp f_dsj [|convert b1; convert b2|] + | Bool.Negb b -> lapp f_neg [|convert b|] + | Bool.Xorb (b1, b2) -> lapp f_xor [|convert b1; convert b2|] + | Bool.Ifb (b1, b2, b3) -> lapp f_ifb [|convert b1; convert b2; convert b3|] + + let convert_env env : Term.constr = + CoqList.of_list (Lazy.force Bool.typ) env + + let reify env t = lapp eval [|convert_env env; convert t|] + + let print_counterexample p env gl = + let var = lapp witness [|p|] in + (* Compute an assignment that dissatisfies the goal *) + let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in + let rec to_list l = match decomp_term l with + | Term.App (c, _) + when c === (Lazy.force CoqList._nil) -> [] + | Term.App (c, [|_; h; t|]) + when c === (Lazy.force CoqList._cons) -> + if h === (Lazy.force Bool.trueb) then (true :: to_list t) + else if h === (Lazy.force Bool.falseb) then (false :: to_list t) + else invalid_arg "to_list" + | _ -> invalid_arg "to_list" + in + let concat sep = function + | [] -> mt () + | h :: t -> + let rec aux = function + | [] -> mt () + | x :: t -> (sep ++ x ++ aux t) + in + h ++ aux t + in + let msg = + try + let var = to_list var in + let assign = List.combine env var in + let map_msg (key, v) = + let b = if v then str "true" else str "false" in + let term = Printer.pr_constr key in + term ++ spc () ++ str ":=" ++ spc () ++ b + in + let assign = List.map map_msg assign in + let l = str "[" ++ (concat (str ";" ++ spc ()) assign) ++ str "]" in + str "Not a tautology:" ++ spc () ++ l + with e when Errors.noncritical e -> (str "Not a tautology") + in + Tacticals.tclFAIL 0 msg gl + + let try_unification env = + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let eq = Lazy.force eq in + let t = decomp_term concl in + match t with + | Term.App (c, [|typ; p; _|]) when c === eq -> + (* should be an equality [@eq poly ?p (Cst false)] *) + let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in + tac + | _ -> + let msg = str "Btauto: Internal error" in + Tacticals.New.tclFAIL 0 msg + end + + let tac = + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let eq = Lazy.force eq in + let bool = Lazy.force Bool.typ in + let t = decomp_term concl in + match t with + | Term.App (c, [|typ; tl; tr|]) + when typ === bool && c === eq -> + let env = Env.empty () in + let fl = Bool.quote env tl in + let fr = Bool.quote env tr in + let env = Env.to_list env in + let fl = reify env fl in + let fr = reify env fr in + let changed_gl = Term.mkApp (c, [|typ; fl; fr|]) in + Tacticals.New.tclTHENLIST [ + Tactics.change_concl changed_gl; + Tactics.apply (Lazy.force soundness); + Proofview.V82.tactic (Tactics.normalise_vm_in_concl); + try_unification env + ] + | _ -> + let msg = str "Cannot recognize a boolean equality" in + Tacticals.New.tclFAIL 0 msg + end + +end diff --git a/plugins/btauto/vo.itarget b/plugins/btauto/vo.itarget new file mode 100644 index 00000000..1f72d3ef --- /dev/null +++ b/plugins/btauto/vo.itarget @@ -0,0 +1,3 @@ +Algebra.vo +Reflect.vo +Btauto.vo diff --git a/plugins/cc/README b/plugins/cc/README index 073b140e..c616b5da 100644 --- a/plugins/cc/README +++ b/plugins/cc/README @@ -3,7 +3,7 @@ cctac: congruence-closure for coq author: Pierre Corbineau, Stage de DEA au LSV, ENS Cachan - Thèse au LRI, Université Paris Sud XI + Thèse au LRI, Université Paris Sud XI Files : diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 056ae3a9..29bca862 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* term r: term -> sign *) - type t = {toterm:(int*int,int) Hashtbl.t; - tosign:(int,int*int) Hashtbl.t} + module IntTable = Hashtbl.Make(Int) + module IntPair = + struct + type t = int * int + let equal (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 + let hash (i, j) = Hashset.Combine.combine (Int.hash i) (Int.hash j) + end + module IntPairTable = Hashtbl.Make(IntPair) + + type t = {toterm: int IntPairTable.t; + tosign: (int * int) IntTable.t} let empty ()= - {toterm=Hashtbl.create init_size; - tosign=Hashtbl.create init_size} + {toterm=IntPairTable.create init_size; + tosign=IntTable.create init_size} let enter t sign st= - if Hashtbl.mem st.toterm sign then - anomaly "enter: signature already entered" + if IntPairTable.mem st.toterm sign then + anomaly ~label:"enter" (Pp.str "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 + IntPairTable.replace st.toterm sign t; + IntTable.replace st.tosign t sign - let rev_query term st=Hashtbl.find st.tosign term + let query sign st=IntPairTable.find st.toterm sign let delete st t= - try let sign=Hashtbl.find st.tosign t in - Hashtbl.remove st.toterm sign; - Hashtbl.remove st.tosign t + try let sign=IntTable.find st.tosign t in + IntPairTable.remove st.toterm sign; + IntTable.remove st.tosign t with Not_found -> () - let rec delete_set st s = Intset.iter (delete st) s + let delete_set st s = Int.Set.iter (delete st) s end @@ -84,45 +93,78 @@ 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 PacOrd = +struct + type t = pa_constructor + let compare { cnode = cnode0; arity = arity0; args = args0 } + { cnode = cnode1; arity = arity1; args = args1 } = + let cmp = Int.compare cnode0 cnode1 in + if cmp = 0 then + let cmp' = Int.compare arity0 arity1 in + if cmp' = 0 then + List.compare Int.compare args0 args1 + else + cmp' + else + cmp +end + +module PafOrd = +struct + type t = pa_fun + let compare { fsym = fsym0; fnargs = fnargs0 } { fsym = fsym1; fnargs = fnargs1 } = + let cmp = Int.compare fsym0 fsym1 in + if cmp = 0 then + Int.compare fnargs0 fnargs1 + else + cmp +end -module PafMap=Map.Make(struct - type t=pa_fun - let compare=Pervasives.compare end) +module PacMap=Map.Make(PacOrd) +module PafMap=Map.Make(PafOrd) type cinfo= - {ci_constr: constructor; (* inductive type *) + {ci_constr: pconstructor; (* inductive type *) ci_arity: int; (* # args *) ci_nhyps: int} (* # projectable args *) +let family_eq f1 f2 = match f1, f2 with +| InProp, InProp +| InSet, InSet +| InType, InType -> true +| _ -> false + type term= Symb of constr | Product of sorts_family * sorts_family - | Eps of identifier + | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) let rec term_equal t1 t2 = match t1, t2 with - | Symb c1, Symb c2 -> eq_constr c1 c2 - | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2 - | Eps i1, Eps i2 -> id_ord i1 i2 = 0 + | Symb c1, Symb c2 -> eq_constr_nounivs c1 c2 + | Product (s1, t1), Product (s2, t2) -> family_eq s1 s2 && family_eq t1 t2 + | Eps i1, Eps i2 -> Id.equal i1 i2 | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 - | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1}, - Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} -> - i1 = i2 && j1 = j2 && eq_constructor c1 c2 - | _ -> t1 = t2 + | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1}, + Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} -> + Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *) + | _ -> false + +open Hashset.Combine -open Hashtbl_alt.Combine +let hash_sorts_family = function +| InProp -> 0 +| InSet -> 1 +| InType -> 2 let rec hash_term = function | Symb c -> combine 1 (hash_constr c) - | Product (s1, s2) -> combine3 2 (Hashtbl.hash s1) (Hashtbl.hash s2) - | Eps i -> combine 3 (Hashtbl.hash i) + | Product (s1, s2) -> combine3 2 (hash_sorts_family s1) (hash_sorts_family s2) + | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) - | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (Hashtbl.hash c) i j + | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) @@ -151,14 +193,16 @@ type patt_kind = | 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} - + { + qe_hyp_id: Id.t; + 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 @@ -174,12 +218,11 @@ type inductive_status = type representative= {mutable weight:int; - mutable lfathers:Intset.t; - mutable fathers:Intset.t; + mutable lfathers:Int.Set.t; + mutable fathers:Int.Set.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) *) + mutable functions: Int.Set.t PafMap.t} (*pac -> term = app(constr,t) *) type cl = Rep of representative| Eqto of int*equality @@ -188,12 +231,13 @@ type vertex = Leaf| Node of (int*int) type node = {mutable clas:cl; mutable cpath: int; + mutable constructors: int PacMap.t; vertex:vertex; term:term} module Constrhash = Hashtbl.Make (struct type t = constr - let equal = eq_constr + let equal = eq_constr_nounivs let hash = hash_constr end) module Typehash = Constrhash @@ -205,9 +249,9 @@ module Termhash = Hashtbl.Make end) module Identhash = Hashtbl.Make - (struct type t = identifier - let equal = Pervasives.(=) - let hash = Hashtbl.hash + (struct type t = Id.t + let equal = Id.equal + let hash = Id.hash end) type forest= @@ -221,45 +265,54 @@ type forest= type state = {uf: forest; sigtable:ST.t; - mutable terms: Intset.t; + mutable terms: Int.Set.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; + mutable pa_classes: Int.Set.t; q_history: (int array) Identhash.t; mutable rew_depth:int; mutable changed:bool; - by_type: Intset.t Typehash.t; + by_type: Int.Set.t Typehash.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)} - + { + clas=Eqto (min_int,{lhs=min_int;rhs=min_int;rule=Congruence}); + cpath=min_int; + constructors=PacMap.empty; + vertex=Leaf; + term=Symb (mkRel min_int) + } + +let empty_forest() = + { + max_size=init_size; + size=0; + map=Array.make init_size dummy_node; + epsilons=[]; + axioms=Constrhash.create init_size; + syms=Termhash.create init_size + } + let empty depth gls:state = - {uf= - {max_size=init_size; - size=0; - map=Array.create init_size dummy_node; - epsilons=[]; - axioms=Constrhash.create init_size; - syms=Termhash.create init_size}; - terms=Intset.empty; - combine=Queue.create (); - marks=Queue.create (); - sigtable=ST.empty (); - diseq=[]; - quant=[]; - pa_classes=Intset.empty; - q_history=Identhash.create init_size; - rew_depth=depth; - by_type=Constrhash.create init_size; - changed=false; - gls=gls} - + { + uf= empty_forest (); + terms=Int.Set.empty; + combine=Queue.create (); + marks=Queue.create (); + sigtable=ST.empty (); + diseq=[]; + quant=[]; + pa_classes=Int.Set.empty; + q_history=Identhash.create init_size; + rew_depth=depth; + by_type=Constrhash.create init_size; + changed=false; + gls=gls + } + let forest state = state.uf let compress_path uf i j = uf.map.(j).cpath<-i @@ -274,15 +327,25 @@ 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" + | _ -> anomaly ~label:"get_representative" (Pp.str "not a representative") + +let get_constructors uf i= uf.map.(i).constructors let find_pac uf i pac = - PacMap.find pac (get_representative uf i).constructors + PacMap.find pac (get_constructors uf i) + +let rec find_oldest_pac uf i pac= + try PacMap.find pac (get_constructors uf i) with + Not_found -> + match uf.map.(i).clas with + Eqto (j,_) -> find_oldest_pac uf j pac + | Rep _ -> raise Not_found + let get_constructor_info uf i= match uf.map.(i).term with Constructor cinfo->cinfo - | _ -> anomaly "get_constructor: not a constructor" + | _ -> anomaly ~label:"get_constructor" (Pp.str "not a constructor") let size uf i= (get_representative uf i).weight @@ -294,13 +357,13 @@ 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 + r.lfathers<-Int.Set.add t r.lfathers; + r.fathers <-Int.Set.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 + r.fathers <-Int.Set.add t r.fathers exception Discriminable of int * pa_constructor * int * pa_constructor @@ -313,21 +376,21 @@ let tail_pac p= 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_pac node pac t = + if not (PacMap.mem pac node.constructors) then + node.constructors<-PacMap.add pac t node.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 + try PafMap.find paf rep.functions with Not_found -> Int.Set.empty in + rep.functions<- PafMap.add paf (Int.Set.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" + | _ -> anomaly ~label:"subterms" (Pp.str "not a node") let signature uf i= let j,k=subterms uf i in (find uf j,find uf k) @@ -335,9 +398,9 @@ let signature uf i= let next uf= let size=uf.size in let nsize= succ size in - if nsize=uf.max_size then + if Int.equal nsize uf.max_size then let newmax=uf.max_size * 3 / 2 + 1 in - let newmap=Array.create newmax dummy_node in + let newmap=Array.make newmax dummy_node in begin uf.max_size<-newmax; Array.blit uf.map 0 newmap 0 size; @@ -349,46 +412,63 @@ let next uf= let new_representative typ = {weight=0; - lfathers=Intset.empty; - fathers=Intset.empty; + lfathers=Int.Set.empty; + fathers=Int.Set.empty; inductive_status=Unknown; class_type=typ; - functions=PafMap.empty; - constructors=PacMap.empty} + functions=PafMap.empty} (* rebuild a constr from an applicative term *) -let _A_ = Name (id_of_string "A") -let _B_ = Name (id_of_string "A") +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_)) + mkLambda(_A_,mkSort(Universes.new_sort_in_family s1), + mkLambda(_B_,mkSort(Universes.new_sort_in_family s2),_body_)) let rec constr_of_term = function - Symb s->s + Symb s-> applist_projection s [] | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id - | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Constructor cinfo -> mkConstructU 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 + | other -> + applist_proj other l +and applist_proj c l = + match c with + | Symb s -> applist_projection s l + | _ -> applistc (constr_of_term c) l +and applist_projection c l = + match kind_of_term c with + | Const c when Environ.is_projection (fst c) (Global.env()) -> + let p = Projection.make (fst c) false in + (match l with + | [] -> (* Expand the projection *) + let ty,_ = Typeops.type_of_constant (Global.env ()) c in + let pb = Environ.lookup_projection p (Global.env()) in + let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in + it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx + | hd :: tl -> + applistc (mkProj (p, hd)) tl) + | _ -> applistc c l let rec canonize_name c = let func = canonize_name in match kind_of_term c with - | Const kn -> + | Const (kn,u) -> let canon_const = constant_of_kn (canonical_con kn) in - (mkConst canon_const) - | Ind (kn,i) -> + (mkConstU (canon_const,u)) + | Ind ((kn,i),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in - (mkInd (canon_mind,i)) - | Construct ((kn,i),j) -> + (mkIndU ((canon_mind,i),u)) + | Construct (((kn,i),j),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in - mkConstruct ((canon_mind,i),j) + mkConstructU (((canon_mind,i),j),u) | Prod (na,t,ct) -> mkProd (na,func t, func ct) | Lambda (na,t,ct) -> @@ -396,16 +476,22 @@ let rec canonize_name c = | LetIn (na,b,t,ct) -> mkLetIn (na, func b,func t,func ct) | App (ct,l) -> - mkApp (func ct,array_smartmap func l) + mkApp (func ct,Array.smartmap func l) + | Proj(p,c) -> + let p' = Projection.map (fun kn -> + constant_of_kn (canonical_con kn)) p in + (mkProj (p', func c)) | _ -> c (* rebuild a term from a pattern and a substitution *) let build_subst uf subst = - Array.map (fun i -> - try term uf i - with e when Errors.noncritical e -> - anomaly "incomplete matching") subst + Array.map + (fun i -> + try term uf i + with e when Errors.noncritical e -> + anomaly (Pp.str "incomplete matching")) + subst let rec inst_pattern subst = function PVar i -> @@ -415,8 +501,8 @@ let rec inst_pattern subst = function (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_idx_term uf i = str "[" ++ int i ++ str ":=" ++ + Termops.print_constr (constr_of_term (term uf i)) ++ str "]" let pr_term t = str "[" ++ Termops.print_constr (constr_of_term t) ++ str "]" @@ -426,7 +512,8 @@ let rec add_term state t= try Termhash.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 trm = constr_of_term t in + let typ = pf_type_of state.gls trm in let typ = canonize_name typ in let new_node= match t with @@ -437,20 +524,23 @@ let rec add_term state t= Queue.add (b,Fmark paf) state.marks; {clas= Rep (new_representative typ); cpath= -1; + constructors=PacMap.empty; vertex= Leaf; term= t} | Eps id -> {clas= Rep (new_representative typ); cpath= -1; + constructors=PacMap.empty; 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; + state.terms<-Int.Set.add b state.terms; {clas= Rep (new_representative typ); cpath= -1; + constructors=PacMap.empty; vertex= Node(i1,i2); term= t} | Constructor cinfo -> @@ -465,15 +555,16 @@ let rec add_term state t= Queue.add (b,Cmark pac) state.marks; {clas=Rep (new_representative typ); cpath= -1; + constructors=PacMap.empty; vertex=Leaf; term=t} in uf.map.(b)<-new_node; Termhash.add uf.syms t b; Typehash.replace state.by_type typ - (Intset.add b + (Int.Set.add b (try Typehash.find state.by_type typ with - Not_found -> Intset.empty)); + Not_found -> Int.Set.empty)); b let add_equality state c s t= @@ -503,23 +594,23 @@ let is_redundant state id args = let prev_args = Identhash.find_all state.q_history id in List.exists (fun old_args -> - Util.array_for_all2 (fun i j -> i = find state.uf j) + Util.Array.for_all2 (fun i j -> Int.equal 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 (); + Control.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") + debug (str "discarding redundant (dis)equality") else begin Identhash.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 _ = 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 @@ -527,20 +618,18 @@ let add_inst state (inst,int_subst) = 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 "]")) (); + debug ( + (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ + (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 "]")) (); + debug ( + (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ + (str " [" ++ Termops.print_constr prf ++ str " : " ++ + pr_term s ++ str " <> " ++ pr_term t ++ str "]")); add_disequality state (Hyp prf) s t end end @@ -552,75 +641,77 @@ let link uf i j eq = (* links i -> 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) + Eqto (j,eq) ->down_path uf j (((i,j),eq)::l) | Rep _ ->l +let eq_pair (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 + let rec min_path=function ([],l2)->([],l2) | (l1,[])->(l1,[]) - | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) + | (((c1,t1)::q1),((c2,t2)::q2)) when eq_pair c1 c2 -> min_path (q1,q2) | cpl -> cpl let join_path uf i j= - assert (find uf i=find uf j); + assert (Int.equal (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 ".")) (); + debug (str "Linking " ++ pr_idx_term state.uf i1 ++ + str " and " ++ pr_idx_term state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; Constrhash.replace state.by_type r1.class_type - (Intset.remove i1 + (Int.Set.remove i1 (try Constrhash.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; + Not_found -> Int.Set.empty)); + let f= Int.Set.union r1.fathers r2.fathers in + r2.weight<-Int.Set.cardinal f; r2.fathers<-f; - r2.lfathers<-Intset.union r1.lfathers r2.lfathers; + r2.lfathers<-Int.Set.union r1.lfathers r2.lfathers; ST.delete_set state.sigtable r1.fathers; - state.terms<-Intset.union state.terms r1.fathers; + state.terms<-Int.Set.union state.terms r1.fathers; PacMap.iter (fun pac b -> Queue.add (b,Cmark pac) state.marks) - r1.constructors; + state.uf.map.(i1).constructors; PafMap.iter - (fun paf -> Intset.iter + (fun paf -> Int.Set.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 + state.pa_classes<-Int.Set.remove i1 state.pa_classes; + state.pa_classes<-Int.Set.add i2 state.pa_classes | Partial _ ,(Partial _ |Partial_applied) -> - state.pa_classes<-Intset.remove i1 state.pa_classes + state.pa_classes<-Int.Set.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; + state.pa_classes<-Int.Set.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 ".")) (); + debug + (str "Merging " ++ pr_idx_term state.uf eq.lhs ++ + str " and " ++ pr_idx_term state.uf 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 not (Int.equal 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 ".")) (); + debug + (str "Updating term " ++ pr_idx_term state.uf 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 @@ -628,12 +719,12 @@ let update t state = (* update 1 and 2 *) match rep.inductive_status with Partial _ -> rep.inductive_status <- Partial_applied; - state.pa_classes <- Intset.remove i state.pa_classes + state.pa_classes <- Int.Set.remove i state.pa_classes | _ -> () end; PacMap.iter (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) - rep.constructors; + (get_constructors state.uf i); PafMap.iter (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) rep.functions; @@ -645,12 +736,13 @@ let update t state = (* update 1 and 2 *) let process_function_mark t rep paf state = add_paf rep paf t; - state.terms<-Intset.union rep.lfathers state.terms + state.terms<-Int.Set.union rep.lfathers state.terms let process_constructor_mark t i rep pac state = - match rep.inductive_status with + add_pac state.uf.map.(i) pac t; + match rep.inductive_status with Total (s,opac) -> - if pac.cnode <> opac.cnode then (* Conflict *) + if not (Int.equal pac.cnode opac.cnode) then (* Conflict *) raise (Discriminable (s,opac,t,pac)) else (* Match *) let cinfo = get_constructor_info state.uf pac.cnode in @@ -662,26 +754,26 @@ let process_constructor_mark t i rep pac state = {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" + | _-> anomaly ~label:"add_pacs" + (Pp.str "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 +(* add_pac state.uf.map.(i) pac t; *) + state.terms<-Int.Set.union rep.lfathers state.terms | Unknown -> - if pac.arity = 0 then + if Int.equal 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; + (* add_pac state.uf.map.(i) pac t; *) + state.terms<-Int.Set.union rep.lfathers state.terms; rep.inductive_status <- Partial pac; - state.pa_classes<- Intset.add i state.pa_classes + state.pa_classes<- Int.Set.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 ".")) (); + debug + (str "Processing mark for term " ++ pr_idx_term state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in match m with @@ -696,14 +788,15 @@ type explanation = 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 + | dis::q -> + let (info, ans) = + if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis) + else (str "No", check_aux q) + in + let _ = debug + (str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++ + pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in + ans | [] -> None in check_aux state.diseq @@ -720,13 +813,13 @@ let one_step state = true with Queue.Empty -> try - let t = Intset.choose state.terms in - state.terms<-Intset.remove t state.terms; + let t = Int.Set.choose state.terms in + state.terms<-Int.Set.remove t state.terms; update t state; true with Not_found -> false -let __eps__ = id_of_string "_eps_" +let __eps__ = Id.of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in @@ -752,10 +845,10 @@ let complete_one_class state i= 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" + | _ -> anomaly (Pp.str "wrong incomplete class") let complete state = - Intset.iter (complete_one_class state) state.pa_classes + Int.Set.iter (complete_one_class state) state.pa_classes type matching_problem = {mp_subst : int array; @@ -773,14 +866,14 @@ let make_fun_table state = (fun paf _ -> let elem = try PafMap.find paf !funtab - with Not_found -> Intset.empty in - funtab:= PafMap.add paf (Intset.add i elem) !funtab) + with Not_found -> Int.Set.empty in + funtab:= PafMap.add paf (Int.Set.add i elem) !funtab) rep.functions | _ -> ()) state.uf.map; !funtab -let rec do_match state res pb_stack = +let do_match state res pb_stack = let mp=Stack.pop pb_stack in match mp.mp_stack with [] -> @@ -795,13 +888,13 @@ let rec do_match state res pb_stack = Stack.push {mp with mp_stack=remains} pb_stack end else - if mp.mp_subst.(pred i) = cl then + if Int.equal 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=Termhash.find uf.syms f in - if find uf j =cl then + if Int.equal (find uf j) cl then Stack.push {mp with mp_stack=remains} pb_stack with Not_found -> () end @@ -819,7 +912,7 @@ let rec do_match state res pb_stack = mp_stack= (PApp(f,rem_args),s) :: (last_arg,t) :: remains} pb_stack in - Intset.iter aux good_terms + Int.Set.iter aux good_terms with Not_found -> () let paf_of_patt syms = function @@ -836,21 +929,21 @@ let init_pb_stack state = begin let good_classes = match inst.qe_lhs_valid with - Creates_variables -> Intset.empty + Creates_variables -> Int.Set.empty | Normal -> begin try let paf= paf_of_patt syms inst.qe_lhs in PafMap.find paf funtab - with Not_found -> Intset.empty + with Not_found -> Int.Set.empty end | Trivial typ -> begin try Typehash.find state.by_type typ - with Not_found -> Intset.empty + with Not_found -> Int.Set.empty end in - Intset.iter (fun i -> + Int.Set.iter (fun i -> Stack.push {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; @@ -859,21 +952,21 @@ let init_pb_stack state = begin let good_classes = match inst.qe_rhs_valid with - Creates_variables -> Intset.empty + Creates_variables -> Int.Set.empty | Normal -> begin try let paf= paf_of_patt syms inst.qe_rhs in PafMap.find paf funtab - with Not_found -> Intset.empty + with Not_found -> Int.Set.empty end | Trivial typ -> begin try Typehash.find state.by_type typ - with Not_found -> Intset.empty + with Not_found -> Int.Set.empty end in - Intset.iter (fun i -> + Int.Set.iter (fun i -> Stack.push {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; @@ -886,28 +979,28 @@ let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = - debug msgnl (str "Running E-matching algorithm ... "); + debug (str "Running E-matching algorithm ... "); try while true do - check_for_interrupt (); + Control.check_for_interrupt (); do_match state res pb_stack done; - anomaly "get out of here !" + anomaly (Pp.str "get out of here !") with Stack.Empty -> () in !res let rec execute first_run state = - debug msgnl (str "Executing ... "); + debug (str "Executing ... "); try while - check_for_interrupt (); + Control.check_for_interrupt (); one_step state do () done; match check_disequalities state with None -> - if not(Intset.is_empty state.pa_classes) then + if not(Int.Set.is_empty state.pa_classes) then begin - debug msgnl (str "First run was incomplete, completing ... "); + debug (str "First run was incomplete, completing ... "); complete state; execute false state end @@ -922,12 +1015,12 @@ let rec execute first_run state = end else begin - debug msgnl (str "Out of instances ... "); + debug (str "Out of instances ... "); None end else begin - debug msgnl (str "Out of depth ... "); + debug (str "Out of depth ... "); None end | Some dis -> Some diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index e4713728..c72843d5 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* term -> bool +module Constrhash : Hashtbl.S with type key = constr +module Termhash : Hashtbl.S with type key = term -type patt_kind = - Normal - | Trivial of types - | Creates_variables type ccpattern = PApp of term * ccpattern list | PVar of int -type pa_constructor = - { cnode : int; - arity : int; - args : int list} - -module PacMap : Map.S with type key = pa_constructor - -type forest - -type state - type rule= Congruence | Axiom of constr * bool @@ -61,17 +60,67 @@ type equality = rule eq type disequality = from eq +type patt_kind = + Normal + | Trivial of types + | Creates_variables + +type quant_eq= + {qe_hyp_id: Id.t; + qe_pol: bool; + qe_nvars:int; + qe_lhs: ccpattern; + qe_lhs_valid:patt_kind; + qe_rhs: ccpattern; + qe_rhs_valid:patt_kind} + +type inductive_status = + Unknown + | Partial of pa_constructor + | Partial_applied + | Total of (int * pa_constructor) + +type representative= + {mutable weight:int; + mutable lfathers:Int.Set.t; + mutable fathers:Int.Set.t; + mutable inductive_status: inductive_status; + class_type : Term.types; + mutable functions: Int.Set.t PafMap.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; + mutable constructors: int PacMap.t; + vertex:vertex; + term:term} + +type forest= + {mutable max_size:int; + mutable size:int; + mutable map: node array; + axioms: (term*term) Constrhash.t; + mutable epsilons: pa_constructor list; + syms: int Termhash.t} + +type state + type explanation = Discrimination of (int*pa_constructor*int*pa_constructor) | Contradiction of disequality | Incomplete -module Constrhash : Hashtbl.S with type key = constr -module Termhash : Hashtbl.S with type key = term +type matching_problem + +val term_equal : term -> term -> bool val constr_of_term : term -> constr -val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit +val debug : Pp.std_ppcmds -> unit val forest : state -> forest @@ -87,7 +136,7 @@ val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit -val add_quant : state -> identifier -> bool -> +val add_quant : state -> Id.t -> bool -> int * patt_kind * ccpattern * patt_kind * ccpattern -> unit val tail_pac : pa_constructor -> pa_constructor @@ -96,6 +145,8 @@ val find : forest -> int -> int val find_pac : forest -> int -> pa_constructor -> int +val find_oldest_pac : forest -> int -> pa_constructor -> int + val term : forest -> int -> term val get_constructor_info : forest -> int -> cinfo @@ -105,25 +156,7 @@ 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 make_fun_table : state -> Int.Set.t PafMap.t val do_match : state -> (quant_eq * int array) list ref -> matching_problem Stack.t -> unit @@ -136,8 +169,9 @@ val find_instances : state -> (quant_eq * int array) list val execute : bool -> state -> explanation option +val pr_idx_term : forest -> int -> Pp.std_ppcmds - +val empty_forest: unit -> forest @@ -161,7 +195,7 @@ type term = type rule = Congruence - | Axiom of Names.identifier + | Axiom of Names.Id.t | Injection of int*int*int*int type equality = @@ -207,19 +241,19 @@ val process_rec : UF.t -> equality list -> int list val cc : UF.t -> unit val make_uf : - (Names.identifier * (term * term)) list -> UF.t + (Names.Id.t * (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 + UF.t -> (Names.Id.t * (term * term)) list -> + (Names.Id.t * (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)) + (Names.Id.t * (int * int)) list -> + (Names.Id.t * (int * int)) *) diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 037e9f66..42c03234 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 then nth_arg t1 (n-1) else t2 - | _ -> anomaly "nth_arg: not enough args" + | _ -> anomaly ~label:"nth_arg" (Pp.str "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 rec equal_proof uf i j= + debug (str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + if i=j then prefl (term uf i) else + let (li,lj)=join_path uf i j in + ptrans (path_proof uf i li) (psym (path_proof uf j lj)) + +and edge_proof uf ((i,j),eq)= + debug (str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + let pi=equal_proof uf i eq.lhs in + let pj=psym (equal_proof uf j eq.rhs) in + let pij= + match eq.rule with + Axiom (s,reversed)-> + if reversed then psymax (axioms uf) s + else pax (axioms uf) s + | Congruence ->congr_proof uf eq.lhs eq.rhs + | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) + let p=ind_proof uf 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 uf i ipac= + debug (str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20)); + let t=find_oldest_pac uf i ipac in + let eq_it=equal_proof uf i t in + if ipac.args=[] then + eq_it + else + let fipac=tail_pac ipac in + let (fi,arg)=subterms uf t in + let targ=term uf arg in + let p=constr_proof uf fi fipac in + ptrans eq_it (pcongr p (prefl targ)) + +and path_proof uf i l= + debug (str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++ + (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); + match l with + | [] -> prefl (term uf i) + | x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x) + +and congr_proof uf i j= + debug (str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + let (i1,i2) = subterms uf i + and (j1,j2) = subterms uf j in + pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2) + +and ind_proof uf i ipac j jpac= + debug (str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + let p=equal_proof uf i j + and p1=constr_proof uf i ipac + and p2=constr_proof uf j jpac in + ptrans (psym p1) (ptrans p p2) - 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 +let build_proof uf= + function + | `Prove (i,j) -> equal_proof uf i j + | `Discr (i,ci,j,cj)-> ind_proof uf i ci j cj diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index d55d3ef7..0e0eb6d2 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* proof + +val pcongr: proof -> proof -> proof + +val ptrans: proof -> proof -> proof + +val psym: proof -> proof + +val pax : (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t -> + Ccalgo.Constrhash.key -> proof + +val psymax : (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t -> + Ccalgo.Constrhash.key -> proof + +val pinject : proof -> pconstructor -> int -> int -> proof + +(** Proof building functions *) + +val equal_proof : forest -> int -> int -> proof + +val edge_proof : forest -> (int*int)*equality -> proof + +val path_proof : forest -> int -> ((int*int)*equality) list -> proof + +val congr_proof : forest -> int -> int -> proof + +val ind_proof : forest -> int -> pa_constructor -> int -> pa_constructor -> proof + +(** Main proof building function *) + val build_proof : forest -> [ `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 index 60d42916..7110e5b2 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -1,49 +1,39 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let (mind,i_ind),i_con = c in + | Construct c -> + let (((mind,i_ind),i_con),u)= c in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in - let nargs=mis_constructor_nargs_env env (canon_ind,i_con) in - Constructor {ci_constr= (canon_ind,i_con); + let nargs=constructor_nallargs_env env (canon_ind,i_con) in + Constructor {ci_constr= ((canon_ind,i_con),u); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} | Ind c -> - let mind,i_ind = c in + let (mind,i_ind),u = c in let canon_mind = mind_of_kn (canonical_mind mind) in - let canon_ind = canon_mind,i_ind in (Symb (mkInd canon_ind)) - | Const c -> + let canon_ind = canon_mind,i_ind in (Symb (mkIndU (canon_ind,u))) + | Const (c,u) -> let canon_const = constant_of_kn (canonical_con c) in - (Symb (mkConst canon_const)) + (Symb (mkConstU (canon_const,u))) + | Proj (p, c) -> + let canon_const kn = constant_of_kn (canonical_con kn) in + let p' = Projection.map canon_const p in + (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) | _ ->if closed0 t then (Symb t) else raise Not_found (* decompose equality in members and type *) +open Globnames 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 + if is_global _eq f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -107,9 +103,9 @@ let rec pattern_of_constr env sigma c = 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 + (Array.map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), - List.fold_left Intset.union Intset.empty lrels + List.fold_left Int.Set.union Int.Set.empty lrels | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> let b = Termops.pop _b in let pa,sa = pattern_of_constr env sigma a in @@ -117,11 +113,11 @@ let rec pattern_of_constr env sigma c = 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 + [pa;pb]),(Int.Set.union sa sb) + | Rel i -> PVar i,Int.Set.singleton i | _ -> let pf = decompose_term env sigma c in - PApp (pf,[]),Intset.empty + PApp (pf,[]),Int.Set.empty let non_trivial = function PVar _ -> false @@ -129,23 +125,21 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= - try destApp (whd_delta env term) - with e when Errors.noncritical e -> raise Not_found - in - if eq_constr f (Lazy.force _eq) && (Array.length args)=3 + try destApp (whd_delta env term) with DestKO -> raise Not_found in + if is_global _eq f && Int.equal (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 + if not (Int.equal (Int.Set.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 + if not (Int.equal (Int.Set.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 + if valid1 != Creates_variables + || valid2 != Creates_variables then nrels,valid1,patt1,valid2,patt2 else raise Not_found else raise Not_found @@ -153,7 +147,7 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with Prod (id,atom,ff) -> - if eq_constr ff (Lazy.force _False) then + if is_global _False ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else @@ -165,7 +159,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with | Prod (id,atom,ff) -> - if eq_constr ff (Lazy.force _False) then + if is_global _False ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) @@ -182,7 +176,7 @@ let litteral_of_constr env sigma term= (* store all equalities from the context *) -let rec make_prb gls depth additionnal_terms = +let make_prb gls depth additionnal_terms = let env=pf_env gls in let sigma=sig_sig gls in let state = empty depth gls in @@ -213,9 +207,9 @@ let rec make_prb gls depth additionnal_terms = 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 (Goal.V82.hyps gls.sigma gls.it)); + end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it)); begin - match atom_of_constr env sigma (pf_concl gls) with + match atom_of_constr env sigma (Evarutil.nf_evar sigma (pf_concl gls)) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter @@ -226,226 +220,256 @@ let rec make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) -let build_projection intype outtype (cstr:constructor) special default gls= +let build_projection intype outtype (cstr:pconstructor) 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 (h,argv) = try destApp intype with DestKO -> (intype,[||]) in + let ind,u=destInd h in + let types=Inductiveops.arities_of_constructors env (ind,u) in let lp=Array.length types in - let ci=pred (snd cstr) in + let ci=pred (snd(fst cstr)) in let branch i= - let ti=Term.prod_appvect types.(i) argv in + let ti= prod_appvect types.(i) argv in let rc=fst (decompose_prod_assum ti) in let head= - if i=ci then special else default in + if Int.equal 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 + 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 = +let app_global f args k = + Tacticals.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + +let new_app_global f args k = + Tacticals.New.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + +let new_refine c = Proofview.V82.tactic (refine c) + +let rec proof_tac p : unit Proofview.tactic = + Proofview.Goal.nf_enter begin fun gl -> + let type_of t = Tacmach.New.pf_type_of gl t in + try (* type_of can raise exceptions *) match p.p_rule with - Ax c -> exact_check c gls + Ax c -> exact_check c | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - let typ = Termops.refresh_universes (pf_type_of gls l) in - exact_check - (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls + let typ = (* Termops.refresh_universes *) type_of l in + new_app_global _sym_eq [|typ;r;l;c|] exact_check | Refl t -> let lr = constr_of_term t in - let typ = Termops.refresh_universes (pf_type_of gls lr) in - exact_check - (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls + let typ = (* Termops.refresh_universes *) type_of lr in + new_app_global _refl_equal [|typ;constr_of_term t|] exact_check | 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 = Termops.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 + let typ = (* Termops.refresh_universes *) (type_of t2) in + let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in + Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)] | 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 = Termops.refresh_universes (pf_type_of gls tf1) in - let typx = Termops.refresh_universes (pf_type_of gls tx1) in - let typfx = Termops.refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in - let id = pf_get_new_id (id_of_string "f") gls in + let typf = (* Termops.refresh_universes *)(type_of tf1) in + let typx = (* Termops.refresh_universes *) (type_of tx1) in + let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in + let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl 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 + app_global _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 + app_global _f_equal + [|typx;typfx;tf2;tx1;tx2;_M 1|] in let prf = - mkApp(Lazy.force _trans_eq, + app_global _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); + mkApp(tf2,[|tx2|]);_M 2;_M 3|] in + Tacticals.New.tclTHENS (Proofview.V82.tactic (prf refine)) + [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma1 refine)) (proof_tac p1); + Tacticals.New.tclFIRST + [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2); reflexivity; - fun gls -> - errorlabstrm "Congruence" + Proofview.tclZERO (UserError ("Congruence" , (Pp.str - "I don't know how to handle dependent equality")]] gls + "I don't know how to handle dependent equality")))]] | 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 = Termops.refresh_universes (pf_type_of gls ti) in - let outtype = Termops.refresh_universes (pf_type_of gls default) in + let intype = (* Termops.refresh_universes *) (type_of ti) in + let outtype = (* Termops.refresh_universes *) (type_of default) in let special=mkRel (1+nargs-argind) in - let proj=build_projection intype outtype cstr special default gls in + let proj = + Tacmach.New.of_old (build_projection intype outtype cstr special default) gl + in let injt= - mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in - tclTHEN (refine injt) (proof_tac prf) gls + app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in + Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + end -let refute_tac c t1 t2 p gls = +let refute_tac c t1 t2 p = + Proofview.Goal.nf_enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let intype = Termops.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 intype = + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt1)) gl + in + let neweq= new_app_global _eq [|intype;tt1;tt2|] in + let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in - tclTHENS (assert_tac (Name hid) neweq) - [proof_tac p; simplest_elim false_t] gls + Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) + [proof_tac p; simplest_elim false_t] + end -let convert_to_goal_tac c t1 t2 p gls = +let refine_exact_check c gl = + let evm, _ = pf_apply e_type_of gl c in + Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl + +let convert_to_goal_tac c t1 t2 p = + Proofview.Goal.nf_enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let sort = Termops.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 sort = + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt2)) gl + in + let neweq= new_app_global _eq [|sort;tt1;tt2|] in + let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in + let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl 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 endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in + Tacticals.New.tclTHENS (neweq (assert_before (Name e))) + [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] + end -let convert_to_hyp_tac c1 t1 c2 t2 p gls = +let convert_to_hyp_tac c1 t1 c2 t2 p = + Proofview.Goal.nf_enter begin fun gl -> let tt2=constr_of_term t2 in - let h=pf_get_new_id (id_of_string "H") gls in + let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in let false_t=mkApp (c2,[|mkVar h|]) in - tclTHENS (assert_tac (Name h) tt2) + Tacticals.New.tclTHENS (assert_before (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 = Termops.refresh_universes (pf_type_of gls t1) in - let concl=pf_concl gls in - let outsort = mkType (Termops.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 (Termops.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 + simplest_elim false_t] + end + +let discriminate_tac (cstr,u as cstru) p = + Proofview.Goal.nf_enter begin fun gl -> + let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in + let intype = + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls t1)) gl + in + let concl = Proofview.Goal.concl gl in + (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in *) + (* let outsort = mkSort outsort in *) + let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in + (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *) + (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *) + let identity = Universes.constr_of_global _I in + (* let trivial=pf_type_of gls identity in *) + let trivial = Universes.constr_of_global _True in + let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in + let outtype = mkSort outtype in + let pred=mkLambda(Name xid,outtype,mkRel 1) in + let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in + let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in + let injt=app_global _f_equal + [|intype;outtype;proj;t1;t2;mkVar hid|] in + let endt k = + injt (fun injt -> + app_global _eq_rect + [|outtype;trivial;pred;identity;concl;injt|] k) in + let neweq=new_app_global _eq [|intype;t1;t2|] in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) + (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) + [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]) + end (* 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 dummy_args = List.rev (List.init pac.arity meta) 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 + applistc (mkConstructU cinfo.ci_constr) all_args + +let cc_tactic depth additionnal_terms = + Proofview.Goal.nf_enter begin fun gl -> + Coqlib.check_required_library Coqlib.logic_module_name; + let _ = debug (Pp.str "Reading subgoal ...") in + let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in + let _ = debug (Pp.str "Problem built, solving ...") in + let sol = execute true state in + let _ = debug (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 \ + None -> Tacticals.New.tclFAIL 0 (str "congruence failed") + | Some reason -> + debug (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 + | Incomplete -> + let env = Proofview.Goal.env gl in + 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.msg_info + (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 "(") - (Termops.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 - + Pp.msg_info + (Pp.str " Try " ++ + hov 8 + begin + str "\"congruence with (" ++ + prlist_with_sep + (fun () -> str ")" ++ spc () ++ str "(") + (Termops.print_constr_env env) + terms_to_complete ++ + str ")\"," + end ++ + Pp.str " replacing metavariables by arbitrary terms."); + Tacticals.New.tclFAIL 0 (str "Incomplete") + | 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 + | Hyp id -> refute_tac id ta tb p + | HeqG id -> + convert_to_goal_tac id ta tb p + | HeqnH (ida,idb) -> + convert_to_hyp_tac ida ta idb tb p + end 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 + Tacticals.New.tclORELSE + (Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l)) + (Proofview.V82.tactic 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. @@ -453,22 +477,35 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal) the fact that congruence is called internally. *) -let f_equal gl = - let cut_eq c1 c2 = - let ty = Termops.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 f_equal = + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let type_of = Tacmach.New.pf_type_of gl in + let cut_eq c1 c2 = + try (* type_of can raise an exception *) + let ty = (* Termops.refresh_universes *) (type_of c1) in + if eq_constr_nounivs c1 c2 then Proofview.tclUNIT () + else + Tacticals.New.tclTRY (Tacticals.New.tclTHEN + ((new_app_global _eq [|ty; c1; c2|]) Tactics.cut) + (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply))) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + in + Proofview.tclORELSE + begin match kind_of_term concl with + | App (r,[|_;t;t'|]) when Globnames.is_global _eq r -> + begin match kind_of_term t, kind_of_term t' with + | App (f,v), App (f',v') when Int.equal (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 + if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 []) + else Tacticals.New.tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) + in cuts (Array.length v - 1) + | _ -> Proofview.tclUNIT () + end + | _ -> Proofview.tclUNIT () + end + begin function (e, info) -> match e with + | Type_errors.TypeError _ -> Proofview.tclUNIT () + | e -> Proofview.tclZERO ~info e + end + end diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 60a1b2ec..7c1d9f1c 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -1,6 +1,7 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Proof_type.tactic +val proof_tac: Ccproof.proof -> unit Proofview.tactic -val cc_tactic : int -> constr list -> tactic +val cc_tactic : int -> constr list -> unit Proofview.tactic val cc_fail : tactic -val congruence_tac : int -> constr list -> tactic +val congruence_tac : int -> constr list -> unit Proofview.tactic -val f_equal : tactic +val f_equal : unit Proofview.tactic diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 8b3fe770..aa31c6f0 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -1,16 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* This (intern_constr globs c) let add_var id globs= - let l1,l2=globs.ltacvars in - {globs with ltacvars= (id::l1),(id::l2)} + {globs with ltacvars = Id.Set.add id globs.ltacvars} let add_name nam globs= match nam with @@ -56,7 +57,7 @@ let intern_hyp iconstr globs = function Hprop (intern_statement iconstr globs st) let intern_hyps iconstr globs hyps = - snd (list_fold_map (intern_hyp iconstr) globs hyps) + snd (List.fold_map (intern_hyp iconstr) globs hyps) let intern_cut intern_it globs cut= let nglobs,nstat=intern_it globs cut.cut_stat in @@ -73,10 +74,10 @@ let intern_hyp_list args globs = let intern_one globs (loc,(id,opttyp)) = (add_var id globs), (loc,(id,Option.map (intern_constr globs) opttyp)) in - list_fold_map intern_one globs args + List.fold_map intern_one globs args let intern_suffices_clause globs (hyps,c) = - let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in + let nglobs,nhyps = List.fold_map (intern_hyp intern_constr) globs hyps in nglobs,(nhyps,intern_constr_or_thesis nglobs c) let intern_fundecl args body globs= @@ -93,10 +94,11 @@ let rec add_vars_of_simple_pattern globs = function (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p - | CPatCstr (_,_,pl) | CPatCstrExpl (_,_,pl) -> - List.fold_left add_vars_of_simple_pattern globs pl - | CPatNotation(_,_,(pl,pll)) -> - List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) + | CPatCstr (_,_,pl1,pl2) -> + List.fold_left add_vars_of_simple_pattern + (List.fold_left add_vars_of_simple_pattern globs pl1) pl2 + | CPatNotation(_,_,(pl,pll),pl') -> + List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs | _ -> globs @@ -135,33 +137,33 @@ let rec intern_bare_proof_instr globs = function | Pcast (id,typ) -> Pcast (id,intern_constr globs typ) -let rec intern_proof_instr globs instr= +let intern_proof_instr globs instr= {emph = instr.emph; instr = intern_bare_proof_instr globs instr.instr} (* INTERP *) -let interp_justification_items sigma env = - Option.map (List.map (fun c ->understand sigma env (fst c))) +let interp_justification_items env sigma = + Option.map (List.map (fun c -> fst (*FIXME*)(understand env sigma (fst c)))) -let interp_constr check_sort sigma env c = +let interp_constr check_sort env sigma c = if check_sort then - understand_type sigma env (fst c) + fst (understand env sigma ~expected_type:IsType (fst c) (* FIXME *)) else - understand sigma env (fst c) + fst (understand env sigma (fst c)) let special_whd env = let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) -let _eq = Libnames.constr_of_global (Coqlib.glob_eq) +let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq env id = let typ = Environ.named_type id env in let whd = special_whd env typ in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 + if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then args.(0) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." @@ -170,30 +172,30 @@ let get_eq_typ info env = let typ = decompose_eq env (get_last env) in typ -let interp_constr_in_type typ sigma env c = - understand sigma env (fst c) ~expected_type:typ +let interp_constr_in_type typ env sigma c = + fst (understand env sigma (fst c) ~expected_type:(OfType typ))(*FIXME*) -let interp_statement interp_it sigma env st = +let interp_statement interp_it env sigma st = {st_label=st.st_label; - st_it=interp_it sigma env st.st_it} + st_it=interp_it env sigma st.st_it} -let interp_constr_or_thesis check_sort sigma env = function +let interp_constr_or_thesis check_sort env sigma = function Thesis n -> Thesis n - | This c -> This (interp_constr check_sort sigma env c) + | This c -> This (interp_constr check_sort env sigma c) let abstract_one_hyp inject h glob = match h with Hvar (loc,(id,None)) -> - GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob) + GProd (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob) | Hvar (loc,(id,Some typ)) -> - GProd (dummy_loc,Name id, Explicit, fst typ, glob) + GProd (Loc.ghost,Name id, Explicit, fst typ, glob) | Hprop st -> - GProd (dummy_loc,st.st_label, Explicit, inject st.st_it, glob) + GProd (Loc.ghost,st.st_label, Explicit, inject st.st_it, glob) let glob_constr_of_hyps inject hyps head = List.fold_right (abstract_one_hyp inject) hyps head -let glob_prop = GSort (dummy_loc,GProp Null) +let glob_prop = GSort (Loc.ghost,GProp) let rec match_hyps blend names constr = function [] -> [],substl names constr @@ -210,13 +212,13 @@ let rec match_hyps blend names constr = function let rhyps,head = match_hyps blend qnames body q in qhyp::rhyps,head -let interp_hyps_gen inject blend sigma env hyps head = - let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in +let interp_hyps_gen inject blend env sigma hyps head = + let constr= fst(*FIXME*) (understand env sigma (glob_constr_of_hyps inject hyps head)) in match_hyps blend [] constr hyps -let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop) +let interp_hyps env sigma hyps = fst (interp_hyps_gen fst (fun x _ -> x) env sigma hyps glob_prop) -let dummy_prefix= id_of_string "__" +let dummy_prefix= Id.of_string "__" let rec deanonymize ids = function @@ -234,34 +236,34 @@ let rec deanonymize ids = let rec glob_of_pat = function - PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" + PatVar (loc,Anonymous) -> anomaly (Pp.str "Anonymous pattern variable") | PatVar (loc,Name id) -> GVar (loc,id) | PatCstr(loc,((ind,_) as cstr),lpat,_) -> let mind= fst (Global.lookup_inductive ind) in let rec add_params n q = if n<=0 then q else - add_params (pred n) (GHole(dummy_loc, - Evd.TomatchTypeParameter(ind,n))::q) in + add_params (pred n) (GHole(Loc.ghost, + Evar_kinds.TomatchTypeParameter(ind,n), Misctypes.IntroAnonymous, None)::q) in let args = List.map glob_of_pat lpat in - glob_app(loc,GRef(dummy_loc,Libnames.ConstructRef cstr), + glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr,None), add_params mind.Declarations.mind_nparams args) let prod_one_hyp = function (loc,(id,None)) -> (fun glob -> - GProd (dummy_loc,Name id, Explicit, - GHole (loc,Evd.BinderType (Name id)), glob)) + GProd (Loc.ghost,Name id, Explicit, + GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob)) | (loc,(id,Some typ)) -> (fun glob -> - GProd (dummy_loc,Name id, Explicit, fst typ, glob)) + GProd (Loc.ghost,Name id, Explicit, fst typ, glob)) let prod_one_id (loc,id) glob = - GProd (dummy_loc,Name id, Explicit, - GHole (loc,Evd.BinderType (Name id)), glob) + GProd (Loc.ghost,Name id, Explicit, + GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob) let let_in_one_alias (id,pat) glob = - GLetIn (dummy_loc,Name id, glob_of_pat pat, glob) + GLetIn (Loc.ghost,Name id, glob_of_pat pat, glob) let rec bind_primary_aliases map pat = match pat with @@ -275,7 +277,7 @@ let rec bind_primary_aliases map pat = List.fold_left bind_primary_aliases map1 lpat let bind_secondary_aliases map subst = - List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst + Id.Map.fold (fun ids idp map -> (ids,Id.List.assoc idp map)::map) subst map let bind_aliases patvars subst patt = let map = bind_primary_aliases [] patt in @@ -285,10 +287,10 @@ let bind_aliases patvars subst patt = let interp_pattern env pat_expr = let patvars,pats = Constrintern.intern_pattern env pat_expr in match pats with - [] -> anomaly "empty pattern list" + [] -> anomaly (Pp.str "empty pattern list") | [subst,patt] -> (patvars,bind_aliases patvars subst patt,patt) - | _ -> anomaly "undetected disjunctive pattern" + | _ -> anomaly (Pp.str "undetected disjunctive pattern") let rec match_args dest names constr = function [] -> [],names,substl names constr @@ -314,9 +316,9 @@ let rec match_aliases names constr = function let args,bnames,body = match_aliases qnames body q in st::args,bnames,body -let detype_ground c = Detyping.detype false [] [] c +let detype_ground env c = Detyping.detype false [] env Evd.empty c -let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = +let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let et,pinfo = match info.pm_stack with Per(et,pi,_,_)::_ -> et,pi @@ -325,31 +327,31 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let num_params = pinfo.per_nparams in let _ = let expected = mib.Declarations.mind_nparams - num_params in - if List.length params <> expected then + if not (Int.equal (List.length params) expected) then errorlabstrm "suppose it is" (str "Wrong number of extra arguments: " ++ - (if expected = 0 then str "none" else int expected) ++ spc () ++ + (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ str "expected.") in let app_ind = - let rind = GRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in - let rparams = List.map detype_ground pinfo.per_params in + let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind,None) in + let rparams = List.map (detype_ground env) pinfo.per_params in let rparams_rec = List.map (fun (loc,(id,_)) -> GVar (loc,id)) params in let dum_args= - list_tabulate (fun _ -> GHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) - oib.Declarations.mind_nrealargs in - glob_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in + List.init oib.Declarations.mind_nrealargs + (fun _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark (Evar_kinds.Define false),Misctypes.IntroAnonymous, None)) in + glob_app(Loc.ghost,rind,rparams@rparams_rec@dum_args) in let pat_vars,aliases,patt = interp_pattern env pat in let inject = function - Thesis (Plain) -> Glob_term.GSort(dummy_loc,GProp Null) + Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp) | Thesis (For rec_occ) -> - if not (List.mem rec_occ pat_vars) then + if not (Id.List.mem rec_occ pat_vars) then errorlabstrm "suppose it is" (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); - Glob_term.GSort(dummy_loc,GProp Null) + Glob_term.GSort(Loc.ghost,GProp) | This (c,_) -> c in let term1 = glob_constr_of_hyps inject hyps glob_prop in let loc_ids,npatt = @@ -357,13 +359,13 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let npatt= deanonymize rids patt in List.rev (fst !rids),npatt in let term2 = - GLetIn(dummy_loc,Anonymous, - GCast(dummy_loc,glob_of_pat npatt, - CastConv (DEFAULTcast,app_ind)),term1) in + GLetIn(Loc.ghost,Anonymous, + GCast(Loc.ghost,glob_of_pat npatt, + CastConv app_ind),term1) in let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in - let constr = understand sigma env term5 in + let constr = fst (understand env sigma term5)(*FIXME*) in let tparams,nam4,rest4 = match_args destProd [] constr params in let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in @@ -380,22 +382,22 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = pat_pat=patt; pat_expr=pat},thyps -let interp_cut interp_it sigma env cut= - let nenv,nstat = interp_it sigma env cut.cut_stat in +let interp_cut interp_it env sigma cut= + let nenv,nstat = interp_it env sigma cut.cut_stat in {cut with cut_stat=nstat; - cut_by=interp_justification_items sigma nenv cut.cut_by} + cut_by=interp_justification_items nenv sigma cut.cut_by} -let interp_no_bind interp_it sigma env x = - env,interp_it sigma env x +let interp_no_bind interp_it env sigma x = + env,interp_it env sigma x -let interp_suffices_clause sigma env (hyps,cot)= +let interp_suffices_clause env sigma (hyps,cot)= let (locvars,_) as res = match cot with This (c,_) -> - let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in + let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) env sigma hyps c in nhyps,This nc - | Thesis Plain as th -> interp_hyps sigma env hyps,th + | Thesis Plain as th -> interp_hyps env sigma hyps,th | Thesis (For n) -> error "\"thesis for\" is not applicable here." in let push_one hyp env0 = match hyp with @@ -406,66 +408,66 @@ let interp_suffices_clause sigma env (hyps,cot)= let nenv = List.fold_right push_one locvars env in nenv,res -let interp_casee sigma env = function - Real c -> Real (understand sigma env (fst c)) - | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) +let interp_casee env sigma = function + Real c -> Real (fst (understand env sigma (fst c)))(*FIXME*) + | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) env sigma cut) let abstract_one_arg = function (loc,(id,None)) -> (fun glob -> - GLambda (dummy_loc,Name id, Explicit, - GHole (loc,Evd.BinderType (Name id)), glob)) + GLambda (Loc.ghost,Name id, Explicit, + GHole (loc,Evar_kinds.BinderType (Name id),Misctypes.IntroAnonymous,None), glob)) | (loc,(id,Some typ)) -> (fun glob -> - GLambda (dummy_loc,Name id, Explicit, fst typ, glob)) + GLambda (Loc.ghost,Name id, Explicit, fst typ, glob)) let glob_constr_of_fun args body = List.fold_right abstract_one_arg args (fst body) -let interp_fun sigma env args body = - let constr=understand sigma env (glob_constr_of_fun args body) in +let interp_fun env sigma args body = + let constr=fst (*FIXME*) (understand env sigma (glob_constr_of_fun args body)) in match_args destLambda [] constr args -let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function - Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) - | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) - | Phence i -> Phence (interp_bare_proof_instr info sigma env i) +let rec interp_bare_proof_instr info env sigma = function + Pthus i -> Pthus (interp_bare_proof_instr info env sigma i) + | Pthen i -> Pthen (interp_bare_proof_instr info env sigma i) + | Phence i -> Phence (interp_bare_proof_instr info env sigma i) | Pcut c -> Pcut (interp_cut (interp_no_bind (interp_statement (interp_constr_or_thesis true))) - sigma env c) + env sigma c) | Psuffices c -> - Psuffices (interp_cut interp_suffices_clause sigma env c) + Psuffices (interp_cut interp_suffices_clause env sigma c) | Prew (s,c) -> Prew (s,interp_cut (interp_no_bind (interp_statement (interp_constr_in_type (get_eq_typ info env)))) - sigma env c) + env sigma c) - | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) + | Psuppose hyps -> Psuppose (interp_hyps env sigma hyps) | Pcase (params,pat,hyps) -> - let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in + let tparams,tpat,thyps = interp_cases info env sigma params pat hyps in Pcase (tparams,tpat,thyps) | Ptake witl -> - Ptake (List.map (fun c -> understand sigma env (fst c)) witl) - | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, - interp_hyps sigma env hyps) - | Pper (et,c) -> Pper (et,interp_casee sigma env c) + Ptake (List.map (fun c -> fst (*FIXME*) (understand env sigma (fst c))) witl) + | Pconsider (c,hyps) -> Pconsider (interp_constr false env sigma c, + interp_hyps env sigma hyps) + | Pper (et,c) -> Pper (et,interp_casee env sigma c) | Pend bt -> Pend bt | Pescape -> Pescape - | Passume hyps -> Passume (interp_hyps sigma env hyps) - | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps) - | Plet hyps -> Plet (interp_hyps sigma env hyps) - | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) - | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) + | Passume hyps -> Passume (interp_hyps env sigma hyps) + | Pgiven hyps -> Pgiven (interp_hyps env sigma hyps) + | Plet hyps -> Plet (interp_hyps env sigma hyps) + | Pclaim st -> Pclaim (interp_statement (interp_constr true) env sigma st) + | Pfocus st -> Pfocus (interp_statement (interp_constr true) env sigma st) | Pdefine (id,args,body) -> - let nargs,_,nbody = interp_fun sigma env args body in + let nargs,_,nbody = interp_fun env sigma args body in Pdefine (id,nargs,nbody) | Pcast (id,typ) -> - Pcast(id,interp_constr true sigma env typ) + Pcast(id,interp_constr true env sigma typ) -let rec interp_proof_instr info sigma env instr= +let interp_proof_instr info env sigma instr= {emph = instr.emph; - instr = interp_bare_proof_instr info sigma env instr.instr} + instr = interp_bare_proof_instr info env sigma instr.instr} diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/decl_mode/decl_interp.mli index f7227946..b3d6f82b 100644 --- a/plugins/decl_mode/decl_interp.mli +++ b/plugins/decl_mode/decl_interp.mli @@ -1,16 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_proof_instr -> glob_proof_instr val interp_proof_instr : Decl_mode.pm_info -> - Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr + Environ.env -> Evd.evar_map -> glob_proof_instr -> proof_instr diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index 55742386..d169dc13 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Mode_tactic + | Some _ -> Mode_proof let get_current_mode () = - try + try mode_of_pftreestate (Pfedit.get_pftreestate ()) - with e when Errors.noncritical e -> Mode_none + with Proof_global.NoCurrentProof -> Mode_none let check_not_proof_mode str = - if get_current_mode () = Mode_proof then - error str + match get_current_mode () with + | Mode_proof -> error str + | _ -> () let get_info sigma gl= - match info.get (Goal.V82.extra sigma gl) with + match Store.get (Goal.V82.extra sigma gl) info with | None -> invalid_arg "get_info" | Some pm -> pm let try_get_info sigma gl = - info.get (Goal.V82.extra sigma gl) + Store.get (Goal.V82.extra sigma gl) info let get_stack pts = let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in @@ -102,11 +100,13 @@ let proof_cond = Proof.no_cond proof_focus let focus p = let inf = get_stack p in - Proof.focus proof_cond inf 1 p + Proof_global.simple_with_current_proof (fun _ -> Proof.focus proof_cond inf 1) -let unfocus = Proof.unfocus proof_focus +let unfocus () = + Proof_global.simple_with_current_proof (fun _ p -> Proof.unfocus proof_focus p ()) -let maximal_unfocus = Proof_global.maximal_unfocus proof_focus +let maximal_unfocus () = + Proof_global.simple_with_current_proof (fun _ -> Proof.maximal_unfocus proof_focus) let get_top_stack pts = try @@ -116,8 +116,7 @@ let get_top_stack pts = let info = get_info sigma gl in info.pm_stack -let get_last env = - try - let (id,_,_) = List.hd (Environ.named_context env) in id - with Invalid_argument _ -> error "no previous statement to use" +let get_last env = match Environ.named_context env with + | (id,_,_)::_ -> id + | [] -> error "no previous statement to use" diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli index b36f2333..2864ba18 100644 --- a/plugins/decl_mode/decl_mode.mli +++ b/plugins/decl_mode/decl_mode.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val clear_daimon_flag : unit -> unit @@ -27,11 +26,11 @@ val get_current_mode : unit -> command_mode val check_not_proof_mode : string -> unit type split_tree= - Skip_patt of Idset.t * split_tree - | Split_patt of Idset.t * inductive * - (bool array * (Idset.t * split_tree) option) array + Skip_patt of Id.Set.t * split_tree + | Split_patt of Id.Set.t * inductive * + (bool array * (Id.Set.t * split_tree) option) array | Close_patt of split_tree - | End_patt of (identifier * (int * int)) + | End_patt of (Id.t * (int * int)) type elim_kind = EK_dep of split_tree @@ -51,7 +50,7 @@ type per_info = per_wf:recpath} type stack_info = - Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list + Per of Decl_expr.elim_type * per_info * elim_kind * Names.Id.t list | Suppose_case | Claim | Focus_claim @@ -59,7 +58,7 @@ type stack_info = type pm_info = {pm_stack : stack_info list } -val info : pm_info Store.Field.t +val info : pm_info Store.field val get_info : Evd.evar_map -> Proof_type.goal -> pm_info @@ -69,10 +68,12 @@ val get_stack : Proof.proof -> stack_info list val get_top_stack : Proof.proof -> stack_info list -val get_last: Environ.env -> identifier +val get_last: Environ.env -> Id.t +(** [get_last] raises a [UserError] when it cannot find a previous + statement in the environment. *) val focus : Proof.proof -> unit -val unfocus : Proof.proof -> unit +val unfocus : unit -> unit -val maximal_unfocus : Proof.proof -> unit +val maximal_unfocus : unit -> unit diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index e69f2bb6..9d25681d 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -1,34 +1,34 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + let it = sig_it gls in let concl = pf_concl gls in - let hyps = Goal.V82.hyps (project gls) (sig_it gls) in - let extra = Goal.V82.extra (project gls) (sig_it gls) in + let hyps = Goal.V82.hyps (project gls) it in + let extra = Goal.V82.extra (project gls) it in let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in - let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in - { it = [gl] ; sigma= sigma } ) - -open Store.Field + let sigma = Goal.V82.partial_solution sigma it ev in + { it = [gl] ; sigma= sigma; } ) -let tcl_change_info info gls = - let info_gen = Decl_mode.info.set info in +let tcl_change_info info gls = + let info_gen s = Store.set s Decl_mode.info info in tcl_change_info_gen info_gen gls -let tcl_erase_info gls = tcl_change_info_gen (Decl_mode.info.remove) gls +let tcl_erase_info gls = + let info_gen s = Store.remove s Decl_mode.info in + tcl_change_info_gen info_gen gls let special_whd gl= let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in @@ -74,7 +75,7 @@ let special_nf gl= let is_good_inductive env ind = let mib,oib = Inductive.lookup_mind_specif env ind in - oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) + Int.equal oib.mind_nrealargs 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) let check_not_per pts = if not (Proof.is_done pts) then @@ -90,7 +91,7 @@ let mk_evd metalist gls = meta_declare meta typ evd in List.fold_right add_one metalist evd0 -let is_tmp id = (string_of_id id).[0] = '_' +let is_tmp id = (Id.to_string id).[0] == '_' let tmp_ids gls = let ctx = pf_hyps gls in @@ -108,7 +109,7 @@ let clean_tmp gls = clean_all (tmp_ids gls) gls let assert_postpone id t = - assert_tac (Name id) t + assert_before (Name id) t (* start a proof *) @@ -118,7 +119,7 @@ let start_proof_tac gls= tcl_change_info info gls let go_to_proof_mode () = - Pfedit.by start_proof_tac; + ignore (Pfedit.by (Proofview.V82.tactic start_proof_tac)); let p = Proof_global.give_me_the_proof () in Decl_mode.focus p @@ -126,50 +127,34 @@ let go_to_proof_mode () = let daimon_tac gls = set_daimon_flag (); - {it=[];sigma=sig_sig gls} - - -(* marking closed blocks *) - -let rec is_focussing_instr = function - Pthus i | Pthen i | Phence i -> is_focussing_instr i - | Pescape | Pper _ | Pclaim _ | Pfocus _ - | Psuppose _ | Pcase (_,_,_) -> true - | _ -> false - -let mark_rule_as_done = function - Decl_proof true -> Decl_proof false - | Decl_proof false -> - anomaly "already marked as done" - | _ -> anomaly "mark_rule_as_done" - + {it=[];sigma=sig_sig gls;} (* post-instruction focus management *) (* spiwack: This used to fail if there was no focusing command above, but I don't think it ever happened. I hope it doesn't mess things up*) -let goto_current_focus pts = - Decl_mode.maximal_unfocus pts +let goto_current_focus () = + Decl_mode.maximal_unfocus () -let goto_current_focus_or_top pts = - goto_current_focus pts +let goto_current_focus_or_top () = + goto_current_focus () (* return *) -let close_tactic_mode pts = - try goto_current_focus pts +let close_tactic_mode () = + try goto_current_focus () with Not_found -> error "\"return\" cannot be used outside of Declarative Proof Mode." let return_from_tactic_mode () = - close_tactic_mode (Proof_global.give_me_the_proof ()) + close_tactic_mode () (* end proof/claim *) let close_block bt pts = if Proof.no_focused_goal pts then - goto_current_focus pts + goto_current_focus () else let stack = if Proof.is_done pts then @@ -179,7 +164,7 @@ let close_block bt pts = in match bt,stack with B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> - (goto_current_focus pts) + (goto_current_focus ()) | _, Claim::_ -> error "\"end claim\" expected." | _, Focus_claim::_ -> @@ -192,7 +177,7 @@ let close_block bt pts = ET_Case_analysis -> error "\"end cases\" expected." | ET_Induction -> error "\"end induction\" expected." end - | _,_ -> anomaly "Lonely suppose on stack." + | _,_ -> anomaly (Pp.str "Lonely suppose on stack.") (* utility for suppose / suppose it is *) @@ -202,15 +187,15 @@ let close_previous_case pts = Proof.is_done pts then match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." + Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occured ...") | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus (pts) + goto_current_focus () | _ -> error "Not inside a proof per cases or induction." else match get_stack pts with Per (et,_,_,_) :: _ -> () | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus ((pts)) + goto_current_focus () | _ -> error "Not inside a proof per cases or induction." (* Proof instructions *) @@ -225,38 +210,38 @@ let filter_hyps f gls = tclTRY (clear [id]) in tclMAP filter_aux (pf_hyps gls) gls -let local_hyp_prefix = id_of_string "___" +let local_hyp_prefix = Id.of_string "___" let add_justification_hyps keep items gls = let add_aux c gls= match kind_of_term c with Var id -> - keep:=Idset.add id !keep; + keep:=Id.Set.add id !keep; tclIDTAC gls | _ -> let id=pf_get_new_id local_hyp_prefix gls in - keep:=Idset.add id !keep; - tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) - (thin_body [id]) gls in + keep:=Id.Set.add id !keep; + tclTHEN (Proofview.V82.of_tactic (letin_tac None (Names.Name id) c None Locusops.nowhere)) + (Proofview.V82.of_tactic (clear_body [id])) gls in tclMAP add_aux items gls let prepare_goal items gls = - let tokeep = ref Idset.empty in + let tokeep = ref Id.Set.empty in let auxres = add_justification_hyps tokeep items gls in tclTHENLIST [ (fun _ -> auxres); - filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls + filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls let my_automation_tac = ref - (fun gls -> anomaly "No automation registered") + (Proofview.tclZERO (Errors.make_anomaly (Pp.str"No automation registered"))) let register_automation_tac tac = my_automation_tac:= tac -let automation_tac gls = !my_automation_tac gls +let automation_tac = Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> !my_automation_tac) let justification tac gls= tclORELSE - (tclSOLVE [tclTHEN tac assumption]) + (tclSOLVE [tclTHEN tac (Proofview.V82.of_tactic assumption)]) (fun gls -> if get_strictness () then error "Insufficient justification." @@ -267,7 +252,7 @@ let justification tac gls= end) gls let default_justification elems gls= - justification (tclTHEN (prepare_goal elems) automation_tac) gls + justification (tclTHEN (prepare_goal elems) (Proofview.V82.of_tactic automation_tac)) gls (* code for conclusion refining *) @@ -302,21 +287,21 @@ type stackd_elt = let rec replace_in_list m l = function [] -> raise Not_found - | c::q -> if m=fst c then l@q else c::replace_in_list m l q + | c::q -> if Int.equal m (fst c) then l@q else c::replace_in_list m l q let enstack_subsubgoals env se stack gls= let hd,params = decompose_app (special_whd gls se.se_type) in match kind_of_term hd with - Ind ind when is_good_inductive env ind -> + Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *) let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in + Inductive.arities_of_constructors indu (mib,oib) in let process i gentyp = - let constructor = mkConstruct(ind,succ i) + let constructor = mkConstructU ((ind,succ i),u) (* constructors numbering*) in let appterm = applist (constructor,params) in - let apptype = Term.prod_applist gentyp params in + let apptype = prod_applist gentyp params in let rc,_ = Reduction.dest_prod env apptype in let rec meta_aux last lenv = function [] -> (last,lenv,[]) @@ -352,7 +337,7 @@ let rec nf_list evd = if meta_defined evd m then nf_list evd others else - (m,nf_meta evd typ)::nf_list evd others + (m,Reductionops.nf_meta evd typ)::nf_list evd others let find_subsubgoal c ctyp skip submetas gls = let env= pf_env gls in @@ -372,7 +357,7 @@ let find_subsubgoal c ctyp skip submetas gls = try let unifier = Unification.w_unify env se.se_evd Reduction.CUMUL - ~flags:Unification.elim_flags ctyp se.se_type in + ~flags:(Unification.elim_flags ()) ctyp se.se_type in if n <= 0 then {se with se_evd=meta_assign se.se_meta @@ -387,23 +372,23 @@ let find_subsubgoal c ctyp skip submetas gls = dfs n end in let nse= try dfs skip with Stack.Empty -> raise Not_found in - nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0) + nf_list nse.se_evd nse.se_meta_list,Reductionops.nf_meta nse.se_evd (mkMeta 0) let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in - let sort = family_of_sort (Typing.sort_of env evd concl) in + let sort = family_of_sort (Typing.sort_of env (ref evd) concl) in let rec aux env avoid subst = function - [] -> anomaly "concl_refiner: cannot happen" + [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") | (n,typ)::rest -> let _A = subst_meta subst typ in let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (_x,None,_A) env in - let asort = family_of_sort (Typing.sort_of nenv evd _A) in + let asort = family_of_sort (Typing.sort_of nenv (ref evd) _A) in let nsubst = (n,mkVar _x)::subst in - if rest = [] then + if List.is_empty rest then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) else let bsort,_B,nbody = @@ -451,8 +436,8 @@ let thus_tac c ctyp submetas gls = find_subsubgoal c ctyp 0 submetas gls with Not_found -> error "I could not relate this statement to the thesis." in - if list = [] then - exact_check proof gls + if List.is_empty list then + Proofview.V82.of_tactic (exact_check proof) gls else let refiner = concl_refiner list proof gls in Tactics.refine refiner gls @@ -465,12 +450,13 @@ let mk_stat_or_thesis info gls = function error "\"thesis for ...\" is not applicable here." | Thesis Plain -> pf_concl gls -let just_tac _then cut info gls0 = - let last_item = if _then then - let last_id = try get_last (pf_env gls0) with Failure _ -> - error "\"then\" and \"hence\" require at least one previous fact" in - [mkVar last_id] - else [] +let just_tac _then cut info gls0 = + let last_item = + if _then then + try [mkVar (get_last (pf_env gls0))] + with UserError _ -> + error "\"then\" and \"hence\" require at least one previous fact" + else [] in let items_tac gls = match cut.cut_by with @@ -479,9 +465,9 @@ let just_tac _then cut info gls0 = let method_tac gls = match cut.cut_using with None -> - automation_tac gls + Proofview.V82.of_tactic automation_tac gls | Some tac -> - (Tacinterp.eval_tactic tac) gls in + Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in justification (tclTHEN items_tac method_tac) gls0 let instr_cut mkstat _thus _then cut gls0 = @@ -489,28 +475,27 @@ let instr_cut mkstat _thus _then cut gls0 = let stat = cut.cut_stat in let (c_id,_) = match stat.st_label with Anonymous -> - pf_get_new_id (id_of_string "_fact") gls0,false + pf_get_new_id (Id.of_string "_fact") gls0,false | Name id -> id,true in let c_stat = mkstat info gls0 stat.st_it in let thus_tac gls= if _thus then thus_tac (mkVar c_id) c_stat [] gls else tclIDTAC gls in - tclTHENS (assert_postpone c_id c_stat) + tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) [tclTHEN tcl_erase_info (just_tac _then cut info); thus_tac] gls0 - (* iterated equality *) -let _eq = Libnames.constr_of_global (Coqlib.glob_eq) +let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq id gls = let typ = pf_get_hyp_typ gls id in let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 + if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then (args.(0), args.(1), args.(2)) @@ -520,8 +505,7 @@ let decompose_eq id gls = let instr_rew _thus rew_side cut gls0 = let last_id = try get_last (pf_env gls0) - with e when Errors.noncritical e -> - error "No previous equality." + with UserError _ -> error "No previous equality." in let typ,lhs,rhs = decompose_eq last_id gls0 in let items_tac gls = @@ -531,14 +515,14 @@ let instr_rew _thus rew_side cut gls0 = let method_tac gls = match cut.cut_using with None -> - automation_tac gls + Proofview.V82.of_tactic automation_tac gls | Some tac -> - (Tacinterp.eval_tactic tac) gls in + Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in let just_tac gls = justification (tclTHEN items_tac method_tac) gls in let (c_id,_) = match cut.cut_stat.st_label with Anonymous -> - pf_get_new_id (id_of_string "_eq") gls0,false + pf_get_new_id (Id.of_string "_eq") gls0,false | Name id -> id,true in let thus_tac new_eq gls= if _thus then @@ -546,28 +530,27 @@ let instr_rew _thus rew_side cut gls0 = else tclIDTAC gls in match rew_side with Lhs -> - let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in - tclTHENS (assert_postpone c_id new_eq) + let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in + tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info - (tclTHENS (transitivity lhs) - [just_tac;exact_check (mkVar last_id)]); + (tclTHENS (Proofview.V82.of_tactic (transitivity lhs)) + [just_tac;Proofview.V82.of_tactic (exact_check (mkVar last_id))]); thus_tac new_eq] gls0 | Rhs -> - let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in - tclTHENS (assert_postpone c_id new_eq) + let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in + tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info - (tclTHENS (transitivity rhs) - [exact_check (mkVar last_id);just_tac]); + (tclTHENS (Proofview.V82.of_tactic (transitivity rhs)) + [Proofview.V82.of_tactic (exact_check (mkVar last_id));just_tac]); thus_tac new_eq] gls0 - (* tactics for claim/focus *) let instr_claim _thus st gls0 = let info = get_its_info gls0 in let (id,_) = match st.st_label with - Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false + Anonymous -> pf_get_new_id (Id.of_string "_claim") gls0,false | Name id -> id,true in let thus_tac gls= if _thus then @@ -575,7 +558,7 @@ let instr_claim _thus st gls0 = else tclIDTAC gls in let ninfo1 = {pm_stack= (if _thus then Focus_claim else Claim)::info.pm_stack} in - tclTHENS (assert_postpone id st.st_it) + tclTHENS (Proofview.V82.of_tactic (assert_postpone id st.st_it)) [thus_tac; tcl_change_info ninfo1] gls0 @@ -584,10 +567,10 @@ let instr_claim _thus st gls0 = let push_intro_tac coerce nam gls = let (hid,_) = match nam with - Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false + Anonymous -> pf_get_new_id (Id.of_string "_hyp") gls,false | Name id -> id,true in tclTHENLIST - [intro_mustbe_force hid; + [Proofview.V82.of_tactic (intro_mustbe_force hid); coerce hid] gls @@ -597,7 +580,7 @@ let assume_tac hyps gls = tclTHEN (push_intro_tac (fun id -> - convert_hyp (id,None,st.st_it)) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label)) hyps tclIDTAC gls let assume_hyps_or_theses hyps gls = @@ -607,7 +590,7 @@ let assume_hyps_or_theses hyps gls = tclTHEN (push_intro_tac (fun id -> - convert_hyp (id,None,c)) nam) + Proofview.V82.of_tactic (convert_hyp (id,None,c))) nam) | Hprop {st_label=nam;st_it=Thesis (tk)} -> tclTHEN (push_intro_tac @@ -619,7 +602,7 @@ let assume_st hyps gls = (fun st -> tclTHEN (push_intro_tac - (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) + (fun id -> Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label)) hyps tclIDTAC gls let assume_st_letin hyps gls = @@ -628,7 +611,7 @@ let assume_st_letin hyps gls = tclTHEN (push_intro_tac (fun id -> - convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (id,Some (fst st.st_it),snd st.st_it))) st.st_label)) hyps tclIDTAC gls (* suffices *) @@ -653,12 +636,12 @@ let rec build_applist prod = function [] -> [],prod | n::q -> let (_,typ,_) = destProd prod in - let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in + let ctx,head = build_applist (prod_applist prod [mkMeta n]) q in (n,typ)::ctx,head let instr_suffices _then cut gls0 = let info = get_its_info gls0 in - let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in + let c_id = pf_get_new_id (Id.of_string "_cofact") gls0 in let ctx,hd = cut.cut_stat in let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in let metas = metas_from 1 ctx in @@ -666,7 +649,7 @@ let instr_suffices _then cut gls0 = let c_term = applist (mkVar c_id,List.map mkMeta metas) in let thus_tac gls= thus_tac c_term c_head c_ctx gls in - tclTHENS (assert_postpone c_id c_stat) + tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) [tclTHENLIST [ assume_tac ctx; tcl_erase_info; @@ -680,13 +663,13 @@ let conjunction_arity id gls = let hd,params = decompose_app (special_whd gls typ) in let env =pf_env gls in match kind_of_term hd with - Ind ind when is_good_inductive env ind -> + Ind (ind,u as indu) when is_good_inductive env ind -> let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in - let _ = if Array.length gentypes <> 1 then raise Not_found in - let apptype = Term.prod_applist gentypes.(0) params in + Inductive.arities_of_constructors indu (mib,oib) in + let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in + let apptype = prod_applist gentypes.(0) params in let rc,_ = Reduction.dest_prod env apptype in List.length rc | _ -> raise Not_found @@ -695,9 +678,9 @@ let rec intron_then n ids ltac gls = if n<=0 then ltac ids gls else - let id = pf_get_new_id (id_of_string "_tmp") gls in + let id = pf_get_new_id (Id.of_string "_tmp") gls in tclTHEN - (intro_mustbe_force id) + (Proofview.V82.of_tactic (intro_mustbe_force id)) (intron_then (pred n) (id::ids) ltac) gls @@ -710,9 +693,9 @@ let rec consider_match may_intro introduced available expected gls = | [],hyps -> if may_intro then begin - let id = pf_get_new_id (id_of_string "_tmp") gls in + let id = pf_get_new_id (Id.of_string "_tmp") gls in tclIFTHENELSE - (intro_mustbe_force id) + (Proofview.V82.of_tactic (intro_mustbe_force id)) (consider_match true [] [id] hyps) (fun _ -> error "Not enough sub-hypotheses to match statements.") @@ -722,14 +705,14 @@ let rec consider_match may_intro introduced available expected gls = error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> - tclIFTHENELSE (convert_hyp (id,None,st.st_it)) + tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) begin match st.st_label with Anonymous -> consider_match may_intro ((id,false)::introduced) rest_ids rest | Name hid -> tclTHENLIST - [rename_hyp [id,hid]; + [Proofview.V82.of_tactic (rename_hyp [id,hid]); consider_match may_intro ((hid,true)::introduced) rest_ids rest] end begin @@ -738,7 +721,7 @@ let rec consider_match may_intro introduced available expected gls = try conjunction_arity id gls with Not_found -> error "Matching hypothesis not found." in tclTHENLIST - [general_case_analysis false (mkVar id,NoBindings); + [Proofview.V82.of_tactic (simplest_case (mkVar id)); intron_then nhyps [] (fun l -> consider_match may_intro introduced (List.rev_append l rest_ids) expected)] gls) @@ -750,9 +733,9 @@ let consider_tac c hyps gls = Var id -> consider_match false [] [id] hyps gls | _ -> - let id = pf_get_new_id (id_of_string "_tmp") gls in + let id = pf_get_new_id (Id.of_string "_tmp") gls in tclTHEN - (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) + (Proofview.V82.of_tactic (pose_proof (Name id) c)) (consider_match false [] [id] hyps) gls @@ -783,7 +766,7 @@ let rec build_function args body = let define_tac id args body gls = let t = build_function args body in - letin_tac None (Name id) t None Tacexpr.nowhere gls + Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls (* tactics for reconsider *) @@ -791,11 +774,11 @@ let cast_tac id_or_thesis typ gls = match id_or_thesis with This id -> let (_,body,_) = pf_get_hyp gls id in - convert_hyp (id,body,typ) gls + Proofview.V82.of_tactic (convert_hyp (id,body,typ)) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> - convert_concl typ DEFAULTcast gls + Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls (* per cases *) @@ -804,7 +787,7 @@ let is_rec_pos (main_ind,wft) = None -> false | Some index -> match fst (Rtree.dest_node wft) with - Mrec (_,i) when i = index -> true + Mrec (_,i) when Int.equal i index -> true | _ -> false let rec constr_trees (main_ind,wft) ind = @@ -841,7 +824,7 @@ let map_tree id_fun mapi = function let start_tree env ind rp = - init_tree Idset.empty ind rp (fun _ _ -> None) + init_tree Id.Set.empty ind rp (fun _ _ -> None) let build_per_info etype casee gls = let concl=pf_concl gls in @@ -849,17 +832,17 @@ let build_per_info etype casee gls = let ctyp=pf_type_of gls casee in let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in - let ind = + let (ind,u) = try destInd hd - with e when Errors.noncritical e -> + with DestKO -> error "Case analysis must be done on an inductive object." in let mind,oind = Global.lookup_inductive ind in let nparams,index = match etype with ET_Induction -> mind.mind_nparams_rec,Some (snd ind) | _ -> mind.mind_nparams,None in - let params,real_args = list_chop nparams args in + let params,real_args = List.chop nparams args in let abstract_obj c body = let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in @@ -889,8 +872,8 @@ let per_tac etype casee gls= {pm_stack= Per(etype,per_info,ek,[])::info.pm_stack} gls | Virtual cut -> - assert (cut.cut_stat.st_label=Anonymous); - let id = pf_get_new_id (id_of_string "anonymous_matched") gls in + assert (cut.cut_stat.st_label == Anonymous); + let id = pf_get_new_id (Id.of_string "anonymous_matched") gls in let c = mkVar id in let modified_cut = {cut with cut_stat={cut.cut_stat with st_label=Name id}} in @@ -914,17 +897,17 @@ let register_nodep_subcase id= function | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." end - | _ -> anomaly "wrong stack state" + | _ -> anomaly (Pp.str "wrong stack state") let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let id = pf_get_new_id (Id.of_string "subcase_") gls0 in let clause = build_product hyps thesis in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in let ninfo2 = {pm_stack=stack} in - tclTHENS (assert_postpone id clause) + tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause)) [tclTHENLIST [tcl_change_info ninfo1; assume_tac hyps; clear old_clauses]; @@ -949,17 +932,17 @@ let rec tree_of_pats ((id,_) as cpl) pats = | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> - Skip_patt (Idset.singleton id, + Skip_patt (Id.Set.singleton id, tree_of_pats cpl (rest_args::stack)) | PatCstr (_,(ind,cnum),args,nam) -> let nexti i ati = - if i = pred cnum then + if Int.equal i (pred cnum) then let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.singleton id, + List.map_i (fun j a -> (a,ati.(j))) 0 args in + Some (Id.Set.singleton id, tree_of_pats cpl (nargs::rest_args::stack)) else None - in init_tree Idset.empty ind rp nexti + in init_tree Id.Set.empty ind rp nexti let rec add_branch ((id,_) as cpl) pats tree= match pats with @@ -968,7 +951,7 @@ let rec add_branch ((id,_) as cpl) pats tree= match tree with End_patt cpl0 -> End_patt cpl0 (* this ensures precedence for overlapping patterns *) - | _ -> anomaly "tree is expected to end here" + | _ -> anomaly (Pp.str "tree is expected to end here") end | args::stack -> match args with @@ -977,7 +960,7 @@ let rec add_branch ((id,_) as cpl) pats tree= match tree with Close_patt t -> Close_patt (add_branch cpl stack t) - | _ -> anomaly "we should pop here" + | _ -> anomaly (Pp.str "we should pop here") end | (patt,rp) :: rest_args -> match patt with @@ -985,23 +968,23 @@ let rec add_branch ((id,_) as cpl) pats tree= begin match tree with Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids, + Skip_patt (Id.Set.add id ids, add_branch cpl (rest_args::stack) t) | Split_patt (_,_,_) -> - map_tree (Idset.add id) + map_tree (Id.Set.add id) (fun i bri -> append_branch cpl 1 (rest_args::stack) bri) tree - | _ -> anomaly "No pop/stop expected here" + | _ -> anomaly (Pp.str "No pop/stop expected here") end | PatCstr (_,(ind,cnum),args,nam) -> match tree with Skip_patt (ids,t) -> let nexti i ati = - if i = pred cnum then + if Int.equal i (pred cnum) then let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.add id ids, + List.map_i (fun j a -> (a,ati.(j))) 0 args in + Some (Id.Set.add id ids, add_branch cpl (nargs::rest_args::stack) (skip_args t ids (Array.length ati))) else @@ -1009,57 +992,57 @@ let rec add_branch ((id,_) as cpl) pats tree= skip_args t ids (Array.length ati)) in init_tree ids ind rp nexti | Split_patt (_,ind0,_) -> - if (ind <> ind0) then error + if (not (eq_ind ind ind0)) then error (* this can happen with coercions *) "Case pattern belongs to wrong inductive type."; let mapi i ati bri = - if i = pred cnum then + if Int.equal i (pred cnum) then let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in + List.map_i (fun j a -> (a,ati.(j))) 0 args in append_branch cpl 0 (nargs::rest_args::stack) bri else bri in map_tree_rp rp (fun ids -> ids) mapi tree - | _ -> anomaly "No pop/stop expected here" + | _ -> anomaly (Pp.str "No pop/stop expected here") and append_branch ((id,_) as cpl) depth pats = function Some (ids,tree) -> - Some (Idset.add id ids,append_tree cpl depth pats tree) + Some (Id.Set.add id ids,append_tree cpl depth pats tree) | None -> - Some (Idset.singleton id,tree_of_pats cpl pats) + Some (Id.Set.singleton id,tree_of_pats cpl pats) and append_tree ((id,_) as cpl) depth pats tree = if depth<=0 then add_branch cpl pats tree else match tree with Close_patt t -> Close_patt (append_tree cpl (pred depth) pats t) | Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids,append_tree cpl depth pats t) - | End_patt _ -> anomaly "Premature end of branch" + Skip_patt (Id.Set.add id ids,append_tree cpl depth pats t) + | End_patt _ -> anomaly (Pp.str "Premature end of branch") | Split_patt (_,_,_) -> - map_tree (Idset.add id) + map_tree (Id.Set.add id) (fun i bri -> append_branch cpl (succ depth) pats bri) tree (* suppose it is *) let rec st_assoc id = function [] -> raise Not_found - | st::_ when st.st_label = id -> st.st_it + | st::_ when Name.equal st.st_label id -> st.st_it | _ :: rest -> st_assoc id rest let thesis_for obj typ per_info env= let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in - let ind = destInd cind in - let _ = if ind <> per_info.per_ind then + let ind,u = destInd cind in + let _ = if not (eq_ind ind per_info.per_ind) then errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ + ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in - let params,args = list_chop per_info.per_nparams all_args in + let params,args = List.chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ + ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in - compose_prod rc (whd_beta Evd.empty hd2) + compose_prod rc (Reductionops.whd_beta Evd.empty hd2) let rec build_product_dep pat_info per_info args body gls = match args with @@ -1119,18 +1102,18 @@ let rec register_dep_subcase id env per_info pat = function let case_tac params pat_info hyps gls0 = let info = get_its_info gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let id = pf_get_new_id (Id.of_string "subcase_") gls0 in let et,per_info,ek,old_clauses,rest = match info.pm_stack with Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) - | _ -> anomaly "wrong place for cases" in + | _ -> anomaly (Pp.str "wrong place for cases") in let clause = build_dep_clause params pat_info per_info hyps gls0 in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let nek = register_dep_subcase (id,(List.length params,List.length hyps)) (pf_env gls0) per_info pat_info.pat_pat ek in let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in - tclTHENS (assert_postpone id clause) + tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause)) [tclTHENLIST [tcl_change_info ninfo1; assume_st (params@pat_info.pat_vars); @@ -1141,14 +1124,14 @@ let case_tac params pat_info hyps gls0 = (* end cases *) -type instance_stack = - (constr option*(constr list) list) list +type ('a, 'b) instance_stack = + ('b * (('a option * constr list) list)) list -let initial_instance_stack ids = +let initial_instance_stack ids : (_, _) instance_stack = List.map (fun id -> id,[None,[]]) ids let push_one_arg arg = function - [] -> anomaly "impossible" + [] -> anomaly (Pp.str "impossible") | (head,args) :: ctx -> ((head,(arg::args)) :: ctx) @@ -1157,7 +1140,7 @@ let push_arg arg stacks = let push_one_head c ids (id,stack) = - let head = if Idset.mem id ids then Some c else None in + let head = if Id.Set.mem id ids then Some c else None in id,(head,[]) :: stack let push_head c ids stacks = @@ -1166,7 +1149,7 @@ let push_head c ids stacks = let pop_one (id,stack) = let nstack= match stack with - [] -> anomaly "impossible" + [] -> anomaly (Pp.str "impossible") | [c] as l -> l | (Some head,args)::(head0,args0)::ctx -> let arg = applist (head,(List.rev args)) in @@ -1183,13 +1166,13 @@ let hrec_for fix_id per_info gls obj_id = let typ=pf_get_hyp_typ gls obj_id in let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in - let ind = destInd cind in assert (ind=per_info.per_ind); - let params,args= list_chop per_info.per_nparams all_args in + let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind); + let params,args= List.chop per_info.per_nparams all_args in assert begin try List.for_all2 eq_constr params per_info.per_params with Invalid_argument _ -> false end; let hd2 = applist (mkVar fix_id,args@[obj]) in - compose_lam rc (whd_beta gls.sigma hd2) + compose_lam rc (Reductionops.whd_beta gls.sigma hd2) let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = @@ -1202,18 +1185,18 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls | End_patt (id,(nparams,nhyps)),[] -> begin - match List.assoc id args with + match Id.List.assoc id args with [None,br_args] -> let all_metas = - list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps) in - let param_metas,hyp_metas = list_chop nparams all_metas in + List.init (nparams + nhyps) (fun n -> mkMeta (succ n)) in + let param_metas,hyp_metas = List.chop nparams all_metas in tclTHEN - (tclDO nhrec introf) + (tclDO nhrec (Proofview.V82.of_tactic introf)) (tacnext (applist (mkVar id, List.append param_metas (List.rev_append br_args hyp_metas)))) gls - | _ -> anomaly "wrong stack size" + | _ -> anomaly (Pp.str "wrong stack size") end | Split_patt (ids,ind,br), casee::next_objs -> let (mind,oind) as spec = Global.lookup_inductive ind in @@ -1222,18 +1205,19 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let env=pf_env gls in let ctyp=pf_type_of gls casee in let hd,all_args = decompose_app (special_whd gls ctyp) in - let _ = assert (destInd hd = ind) in (* just in case *) - let params,real_args = list_chop nparams all_args in + let ind', u = destInd hd in + let _ = assert (eq_ind ind' ind) in (* just in case *) + let params,real_args = List.chop nparams all_args in let abstract_obj c body = let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in - let gen_arities = Inductive.arities_of_constructors ind spec in + let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = let sign = - (prod_assum (Term.prod_applist typ params)) in + (prod_assum (prod_applist typ params)) in find_intro_names sign gls in let constr_args_ids = Array.map f_ids gen_arities in let case_term = @@ -1243,7 +1227,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let args_ids = constr_args_ids.(i) in let rec aux n = function [] -> - assert (n=Array.length recargs); + assert (Int.equal n (Array.length recargs)); next_objs,[],nhrec | id :: q -> let objs,recs,nrec = aux (succ n) q in @@ -1252,7 +1236,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = else (mkVar id::objs),recs,nrec in let objs,recs,nhrec = aux 0 args_ids in tclTHENLIST - [tclMAP intro_mustbe_force args_ids; + [tclMAP (fun id -> Proofview.V82.of_tactic (intro_mustbe_force id)) args_ids; begin fun gls1 -> let hrecs = @@ -1269,7 +1253,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = | Some (sub_ids,tree) -> let br_args = List.filter - (fun (id,_) -> Idset.mem id sub_ids) args in + (fun (id,_) -> Id.Set.mem id sub_ids) args in let construct = applist (mkConstruct(ind,succ i),params) in let p_args = @@ -1280,22 +1264,24 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = (refine case_term) (Array.mapi branch_tac br) gls | Split_patt (_, _, _) , [] -> - anomaly "execute_cases : Nothing to split" + anomaly ~label:"execute_cases " (Pp.str "Nothing to split") | Skip_patt _ , [] -> - anomaly "execute_cases : Nothing to skip" + anomaly ~label:"execute_cases " (Pp.str "Nothing to skip") | End_patt (_,_) , _ :: _ -> - anomaly "execute_cases : End of branch with garbage left" - -let understand_my_constr c gls = - let env = pf_env gls in - let nc = names_of_rel_context env in - let rawc = Detyping.detype false [] nc c in - let rec frob = function GEvar _ -> GHole (dummy_loc,QuestionMark Expand) | rc -> map_glob_constr frob rc in - Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc) + anomaly ~label:"execute_cases " (Pp.str "End of branch with garbage left") + +let understand_my_constr env sigma c concl = + let env = env in + let rawc = Detyping.detype false [] env Evd.empty c in + let rec frob = function + | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None) + | rc -> map_glob_constr frob rc + in + Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc) let my_refine c gls = - let oc = understand_my_constr c gls in - Refine.refine oc gls + let oc sigma = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in + Proofview.V82.of_tactic (Tactics.New.refine oc) gls (* end focus/claim *) @@ -1304,43 +1290,41 @@ let end_tac et2 gls = let et1,pi,ek,clauses = match info.pm_stack with Suppose_case::_ -> - anomaly "This case should already be trapped" + anomaly (Pp.str "This case should already be trapped") | Claim::_ -> error "\"end claim\" expected." | Focus_claim::_ -> error "\"end focus\" expected." | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) | [] -> - anomaly "This case should already be trapped" in - let et = - if et1 <> et2 then - match et1 with - ET_Case_analysis -> - error "\"end cases\" expected." - | ET_Induction -> - error "\"end induction\" expected." - else et1 in + anomaly (Pp.str "This case should already be trapped") in + let et = match et1, et2 with + | ET_Case_analysis, ET_Case_analysis -> et1 + | ET_Induction, ET_Induction -> et1 + | ET_Case_analysis, _ -> error "\"end cases\" expected." + | ET_Induction, _ -> error "\"end induction\" expected." + in tclTHEN tcl_erase_info begin match et,ek with _,EK_unknown -> - tclSOLVE [simplest_elim pi.per_casee] + tclSOLVE [Proofview.V82.of_tactic (simplest_elim pi.per_casee)] | ET_Case_analysis,EK_nodep -> tclTHEN - (general_case_analysis false (pi.per_casee,NoBindings)) + (Proofview.V82.of_tactic (simplest_case pi.per_casee)) (default_justification (List.map mkVar clauses)) | ET_Induction,EK_nodep -> tclTHENLIST [generalize (pi.per_args@[pi.per_casee]); - simple_induct (AnonHyp (succ (List.length pi.per_args))); + Proofview.V82.of_tactic (simple_induct (AnonHyp (succ (List.length pi.per_args)))); default_justification (List.map mkVar clauses)] | ET_Case_analysis,EK_dep tree -> execute_cases Anonymous pi (fun c -> tclTHENLIST [my_refine c; clear clauses; - justification assumption]) + justification (Proofview.V82.of_tactic assumption)]) (initial_instance_stack clauses) [pi.per_casee] 0 tree | ET_Induction,EK_dep tree -> let nargs = (List.length pi.per_args) in @@ -1348,20 +1332,20 @@ let end_tac et2 gls = begin fun gls0 -> let fix_id = - pf_get_new_id (id_of_string "_fix") gls0 in + pf_get_new_id (Id.of_string "_fix") gls0 in let c_id = - pf_get_new_id (id_of_string "_main_arg") gls0 in + pf_get_new_id (Id.of_string "_main_arg") gls0 in tclTHENLIST [fix (Some fix_id) (succ nargs); - tclDO nargs introf; - intro_mustbe_force c_id; + tclDO nargs (Proofview.V82.of_tactic introf); + Proofview.V82.of_tactic (intro_mustbe_force c_id); execute_cases (Name fix_id) pi (fun c -> tclTHENLIST [clear [fix_id]; my_refine c; clear clauses; - justification assumption]) + justification (Proofview.V82.of_tactic assumption)]) (initial_instance_stack clauses) [mkVar c_id] 0 tree] gls0 end @@ -1409,7 +1393,7 @@ let rec do_proof_instr_gen _thus _then instr = | Psuppose hyps -> suppose_tac hyps | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps | Pend (B_elim et) -> end_tac et - | Pend _ -> anomaly "Not applicable" + | Pend _ -> anomaly (Pp.str "Not applicable") | Pescape -> escape_tac let eval_instr {instr=instr} = @@ -1454,33 +1438,33 @@ let rec postprocess pts instr = in try Inductiveops.control_only_guard env pfterm; - goto_current_focus_or_top pts + goto_current_focus_or_top () with Type_errors.TypeError(env, Type_errors.IllFormedRecBody(_,_,_,_,_)) -> - anomaly "\"end induction\" generated an ill-formed fixpoint" + anomaly (Pp.str "\"end induction\" generated an ill-formed fixpoint") end | Pend _ -> - goto_current_focus_or_top (pts) + goto_current_focus_or_top () let do_instr raw_instr pts = let has_tactic = preprocess pts raw_instr.instr in begin if has_tactic then - let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in - let gl = { it=List.hd gls ; sigma=sigma } in + let { it=gls ; sigma=sigma; } = Proof.V82.subgoals pts in + let gl = { it=List.hd gls ; sigma=sigma; } in let env= pf_env gl in - let ist = {ltacvars = ([],[]); ltacrecvars = []; - gsigma = sigma; genv = env} in + let ist = {ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; genv = env} in let glob_instr = intern_proof_instr ist raw_instr in let instr = - interp_proof_instr (get_its_info gl) sigma env glob_instr in - Pfedit.by (tclTHEN (eval_instr instr) clean_tmp) + interp_proof_instr (get_its_info gl) env sigma glob_instr in + ignore (Pfedit.by (Proofview.V82.tactic (tclTHEN (eval_instr instr) clean_tmp))) else () end; postprocess pts raw_instr.instr; (* spiwack: this should restore a compatible semantics with v8.3 where we never stayed focused on 0 goal. *) - Decl_mode.maximal_unfocus pts + Proof_global.set_proof_mode "Declarative" ; + Decl_mode.maximal_unfocus () let proof_instr raw_instr = let p = Proof_global.give_me_the_proof () in diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli index 48986c2d..f86bfea7 100644 --- a/plugins/decl_mode/decl_proof_instr.mli +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val return_from_tactic_mode: unit -> unit -val register_automation_tac: tactic -> unit +val register_automation_tac: unit Proofview.tactic -> unit -val automation_tac : tactic +val automation_tac : unit Proofview.tactic val concl_refiner: Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr @@ -28,27 +27,27 @@ val proof_instr: Decl_expr.raw_proof_instr -> unit val tcl_change_info : Decl_mode.pm_info -> tactic val execute_cases : - Names.name -> + Name.t -> Decl_mode.per_info -> (Term.constr -> Proof_type.tactic) -> - (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> + (Id.Set.elt * (Term.constr option * Term.constr list) list) list -> Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic val tree_of_pats : - identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> + Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree val add_branch : - identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> + Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val append_branch : - identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> - (Names.Idset.t * Decl_mode.split_tree) option -> - (Names.Idset.t * Decl_mode.split_tree) option + Id.t *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> + (Id.Set.t * Decl_mode.split_tree) option -> + (Id.Set.t * Decl_mode.split_tree) option val append_tree : - identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> + Id.t * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val build_dep_clause : Term.types Decl_expr.statement list -> @@ -58,7 +57,7 @@ val build_dep_clause : Term.types Decl_expr.statement list -> Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types val register_dep_subcase : - Names.identifier * (int * int) -> + Id.t * (int * int) -> Environ.env -> Decl_mode.per_info -> Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind @@ -69,41 +68,41 @@ val thesis_for : Term.constr -> val close_previous_case : Proof.proof -> unit val pop_stacks : - (Names.identifier * + (Id.t * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Id.t * (Term.constr option * Term.constr list) list) list val push_head : Term.constr -> - Names.Idset.t -> - (Names.identifier * + Id.Set.t -> + (Id.t * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Id.t * (Term.constr option * Term.constr list) list) list val push_arg : Term.constr -> - (Names.identifier * + (Id.t * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Id.t * (Term.constr option * Term.constr list) list) list val hrec_for: - Names.identifier -> + Id.t -> Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> - Names.identifier -> Term.constr + Id.t -> Term.constr val consider_match : bool -> - (Names.Idset.elt*bool) list -> - Names.Idset.elt list -> + (Id.Set.elt*bool) list -> + Id.Set.elt list -> (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> Proof_type.tactic val init_tree: - Names.Idset.t -> - Names.inductive -> + Id.Set.t -> + inductive -> int option * Declarations.wf_paths -> (int -> (int option * Declarations.recarg Rtree.t) array -> - (Names.Idset.t * Decl_mode.split_tree) option) -> + (Id.Set.t * Decl_mode.split_tree) option) -> Decl_mode.split_tree diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 9a1e00ee..03929b3b 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -1,35 +1,33 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + begin Decl_proof_instr.go_to_proof_mode () ; Proof_global.set_proof_mode "Declarative" ; Vernacentries.print_subgoals () @@ -75,24 +71,18 @@ let vernac_decl_proof () = (* spiwack: some bureaucracy is not performed here *) let vernac_return () = - Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () -> + begin Decl_proof_instr.return_from_tactic_mode () ; Proof_global.set_proof_mode "Declarative" ; Vernacentries.print_subgoals () end let vernac_proof_instr instr = - Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () -> + begin Decl_proof_instr.proof_instr instr; Vernacentries.print_subgoals () end -(* We create a new parser entry [proof_mode]. The Declarative proof mode - will replace the normal parser entry for tactics with this one. *) -let proof_mode = Gram.entry_create "vernac:proof_command" -(* Auxiliary grammar entry. *) -let proof_instr = Gram.entry_create "proofmode:instr" - (* Before we can write an new toplevel command (see below) which takes a [proof_instr] as argument, we need to declare how to parse it, print it, globalise it and interprete it. @@ -101,33 +91,28 @@ let proof_instr = Gram.entry_create "proofmode:instr" indirect through the [proof_instr] grammar entry. *) (* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *) -(* [Genarg.create_arg] creates a new embedding into Genarg. *) -let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) = - Genarg.create_arg None "proof_instr" -let _ = Tacinterp.add_interp_genarg "proof_instr" - begin - begin fun e x -> (* declares the globalisation function *) - Genarg.in_gen globwit_proof_instr - (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x)) - end, - begin fun ist gl x -> (* declares the interpretation function *) - Tacmach.project gl , - Genarg.in_gen wit_proof_instr - (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x)) - end, - begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *) - end +(* Only declared at raw level, because only used in vernac commands. *) +let wit_proof_instr : (raw_proof_instr, Empty.t, Empty.t) Genarg.genarg_type = + Genarg.make0 None "proof_instr" + +(* We create a new parser entry [proof_mode]. The Declarative proof mode + will replace the normal parser entry for tactics with this one. *) +let proof_mode : vernac_expr Gram.entry = + Gram.entry_create "vernac:proof_command" +(* Auxiliary grammar entry. *) +let proof_instr : raw_proof_instr Gram.entry = + Pcoq.create_generic_entry "proof_instr" (Genarg.rawwit wit_proof_instr) -let _ = Pptactic.declare_extra_genarg_pprule - (rawwit_proof_instr, pr_raw_proof_instr) - (globwit_proof_instr, pr_glob_proof_instr) - (wit_proof_instr, pr_proof_instr) +let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr + pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr + +let classify_proof_instr _ = VtProofStep false, VtLater (* We use the VERNAC EXTEND facility with a custom non-terminal to populate [proof_mode] with a new toplevel interpreter. The "-" indicates that the rule does not start with a distinguished string. *) -VERNAC proof_mode EXTEND ProofInstr +VERNAC proof_mode EXTEND ProofInstr CLASSIFIED BY classify_proof_instr [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ] END @@ -140,7 +125,7 @@ GEXTEND Gram GLOBAL: proof_mode ; proof_mode: LAST - [ [ c=G_vernac.subgoal_command -> c (Some 1) ] ] + [ [ c=G_vernac.subgoal_command -> c (Some (Vernacexpr.SelectNth 1)) ] ] ; END @@ -171,12 +156,11 @@ let _ = end } -(* Two new vernacular commands *) VERNAC COMMAND EXTEND DeclProof - [ "proof" ] -> [ vernac_decl_proof () ] +[ "proof" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_decl_proof () ] END VERNAC COMMAND EXTEND DeclReturn - [ "return" ] -> [ vernac_return () ] +[ "return" ] => [ VtProofMode "Classic", VtNow ] -> [ vernac_return () ] END let none_is_empty = function @@ -192,7 +176,7 @@ GLOBAL: proof_instr; statement : [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} | i=ident -> {st_label=Anonymous; - st_it=Topconstr.CRef (Libnames.Ident (loc, i))} + st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i), None)} | c=constr -> {st_label=Anonymous;st_it=c} ]]; constr_or_thesis : @@ -205,7 +189,7 @@ GLOBAL: proof_instr; | [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} | i=ident -> {st_label=Anonymous; - st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))} + st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i), None))} | c=constr -> {st_label=Anonymous;st_it=This c} ] ]; @@ -273,7 +257,7 @@ GLOBAL: proof_instr; ; (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) loc_id: - [[ id=ident -> fun x -> (loc,(id,x)) ]]; + [[ id=ident -> fun x -> (!@loc,(id,x)) ]]; hyp: [[ id=loc_id -> id None ; | id=loc_id ; ":" ; c=constr -> id (Some c)]] @@ -405,5 +389,3 @@ GLOBAL: proof_instr; [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]] ; END;; - - diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 102da8cc..27308666 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mt () | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () +let pr_constr env c = pr_constr env Evd.empty c + let pr_justification_items env = function Some [] -> mt () | Some (_::_ as l) -> @@ -75,7 +77,7 @@ and print_vars pconstr gtyp env sep _be _have vars = begin let nenv = match st.st_label with - Anonymous -> anomaly "anonymous variable" + Anonymous -> anomaly (Pp.str "anonymous variable") | Name id -> Environ.push_named (id,None,st.st_it) env in let pr_sep = if sep then pr_comma () else mt () in spc() ++ pr_sep ++ @@ -173,14 +175,14 @@ let rec pr_bare_proof_instr _then _thus env = function str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ pr_casee env c | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et - | _ -> anomaly "unprintable instruction" + | _ -> anomaly (Pp.str "unprintable instruction") let pr_emph = function 0 -> str " " | 1 -> str "* " | 2 -> str "** " | 3 -> str "*** " - | _ -> anomaly "unknown emphasis" + | _ -> anomaly (Pp.str "unknown emphasis") let pr_proof_instr env instr = pr_emph instr.emph ++ spc () ++ diff --git a/plugins/derive/Derive.v b/plugins/derive/Derive.v new file mode 100644 index 00000000..0d5a93b0 --- /dev/null +++ b/plugins/derive/Derive.v @@ -0,0 +1 @@ +Declare ML Module "derive_plugin". \ No newline at end of file diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml new file mode 100644 index 00000000..439b1a5c --- /dev/null +++ b/plugins/derive/derive.ml @@ -0,0 +1,104 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Term.constr) (x:Entries.const_entry_body) + : Entries.const_entry_body = + Future.chain ~pure:true x begin fun ((b,ctx),fx) -> + (f b , ctx) , fx + end + +(** [start_deriving f suchthat lemma] starts a proof of [suchthat] + (which can contain references to [f]) in the context extended by + [f:=?x]. When the proof ends, [f] is defined as the value of [?x] + and [lemma] as the proof. *) +let start_deriving f suchthat lemma = + + let env = Global.env () in + let sigma = Evd.from_env env in + let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in + + (** create a sort variable for the type of [f] *) + (* spiwack: I don't know what the rigidity flag does, picked the one + that looked the most general. *) + let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in + let f_type_type = Term.mkSort f_type_sort in + (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) + let goals = + let open Proofview in + TCons ( env , sigma , f_type_type , (fun sigma f_type -> + TCons ( env , sigma , f_type , (fun sigma ef -> + let env' = Environ.push_named (f , (Some ef) , f_type) env in + let evdref = ref sigma in + let suchthat = Constrintern.interp_type_evars env' evdref suchthat in + TCons ( env' , !evdref , suchthat , (fun sigma _ -> + TNil sigma)))))) + in + + (** The terminator handles the registering of constants when the proof is closed. *) + let terminator com = + let open Proof_global in + (** Extracts the relevant information from the proof. [Admitted] + and [Save] result in user errors. [opaque] is [true] if the + proof was concluded by [Qed], and [false] if [Defined]. [f_def] + and [lemma_def] correspond to the proof of [f] and of + [suchthat], respectively. *) + let (opaque,f_def,lemma_def) = + match com with + | Admitted -> Errors.error"Admitted isn't supported in Derive." + | Proved (_,Some _,_) -> + Errors.error"Cannot save a proof of Derive with an explicit name." + | Proved (opaque, None, obj) -> + match Proof_global.(obj.entries) with + | [_;f_def;lemma_def] -> + opaque , f_def , lemma_def + | _ -> assert false + in + (** The opacity of [f_def] is adjusted to be [false], as it + must. Then [f] is declared in the global environment. *) + let f_def = { f_def with Entries.const_entry_opaque = false } in + let f_def = Entries.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in + let f_kn = Declare.declare_constant f f_def in + let f_kn_term = Term.mkConst f_kn in + (** In the type and body of the proof of [suchthat] there can be + references to the variable [f]. It needs to be replaced by + references to the constant [f] declared above. This substitution + performs this precise action. *) + let substf c = Vars.replace_vars [f,f_kn_term] c in + (** Extracts the type of the proof of [suchthat]. *) + let lemma_pretype = + match Entries.(lemma_def.const_entry_type) with + | Some t -> t + | None -> assert false (* Proof_global always sets type here. *) + in + (** The references of [f] are subsituted appropriately. *) + let lemma_type = substf lemma_pretype in + (** The same is done in the body of the proof. *) + let lemma_body = + map_const_entry_body substf Entries.(lemma_def.const_entry_body) + in + let lemma_def = let open Entries in { lemma_def with + const_entry_body = lemma_body ; + const_entry_type = Some lemma_type ; + const_entry_opaque = opaque ; } + in + let lemma_def = + Entries.DefinitionEntry lemma_def , + Decl_kinds.(IsProof Proposition) + in + ignore (Declare.declare_constant lemma lemma_def) + in + + let () = Proof_global.start_dependent_proof lemma kind goals terminator in + let _ = Proof_global.with_current_proof begin fun _ p -> + Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p + end in + () + + + + diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli new file mode 100644 index 00000000..b49ef6b9 --- /dev/null +++ b/plugins/derive/derive.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Constrexpr.constr_expr -> Names.Id.t -> unit diff --git a/plugins/derive/derive_plugin.mllib b/plugins/derive/derive_plugin.mllib new file mode 100644 index 00000000..5ee0fc6d --- /dev/null +++ b/plugins/derive/derive_plugin.mllib @@ -0,0 +1,2 @@ +Derive +G_derive diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 new file mode 100644 index 00000000..c031e3bc --- /dev/null +++ b/plugins/derive/g_derive.ml4 @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + [ Derive.start_deriving f suchthat lemma ] +END diff --git a/plugins/derive/vo.itarget b/plugins/derive/vo.itarget new file mode 100644 index 00000000..b4809821 --- /dev/null +++ b/plugins/derive/vo.itarget @@ -0,0 +1 @@ +Derive.vo \ No newline at end of file diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v index 3a06c0a3..9dbda821 100644 --- a/plugins/extraction/ExtrOcamlBasic.v +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "Pervasives.max". Extract Constant Pos.compare => "fun x y -> if x=y then Eq else if x - "fun x y c -> if x=y then c else if x if x=y then c else if x "(+)". diff --git a/plugins/extraction/README b/plugins/extraction/README index 64c871fd..458ba0de 100644 --- a/plugins/extraction/README +++ b/plugins/extraction/README @@ -6,7 +6,7 @@ What is it ? ------------ -The extraction is a mechanism allowing to produce functional code +The extraction is a mechanism that produces functional code (Ocaml/Haskell/Scheme) out of any Coq terms (either programs or proofs). @@ -14,7 +14,7 @@ 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 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 @@ -118,7 +118,7 @@ Axioms, and then "Extract Constant ..." [1]: -Exécution de termes de preuves: une nouvelle méthode d'extraction +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 @@ -129,7 +129,7 @@ Types 2002 Post-Workshop Proceedings. http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz [3]: -Programmation fonctionnelle certifiée: l'extraction de programmes +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 diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml index 2fd0e1b5..f2a965c9 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | _ -> false @@ -42,7 +39,7 @@ let pp_apply st par args = match args with (** Same as [pp_apply], but with also protection of the head by parenthesis *) let pp_apply2 st par args = - let par' = args <> [] || par in + let par' = not (List.is_empty args) || par in pp_apply (pp_par par' st) par args let pr_binding = function @@ -82,20 +79,20 @@ let is_digit = function let begins_with_CoqXX s = let n = String.length s in - n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' && + 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*) + 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 + 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; + for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done; s let rec qualify delim = function @@ -112,17 +109,28 @@ let pseudo_qualify = qualify "__" 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 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) + assert (not (String.is_empty s)); + if s.[0] == '_' then Id.of_string ("Coq_"^s) + else Id.of_string (String.capitalize s) type kind = Term | Type | Cons | Mod +module KOrd = +struct + type t = kind * string + let compare (k1, s1) (k2, s2) = + let c = Pervasives.compare k1 k2 (** OK *) in + if c = 0 then String.compare s1 s2 + else c +end + +module KMap = Map.Make(KOrd) + let upperkind = function - | Type -> lang () = Haskell + | Type -> lang () == Haskell | Term -> false | Cons | Mod -> true @@ -131,12 +139,12 @@ let kindcase_id k id = (*s de Bruijn environments for programs *) -type env = identifier list * Idset.t +type env = Id.t list * Id.Set.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 + if Id.Set.mem id avoid then rename_id (lift_subscript id) avoid else id let rec rename_vars avoid = function | [] -> @@ -148,14 +156,14 @@ let rec rename_vars avoid = function | 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) + (id :: idl, Id.Set.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 + let idl, avoid = rename (Id.Set.add id avoid) idl in (id :: idl, avoid) in fst (rename avoid l) @@ -165,7 +173,7 @@ let push_vars 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 + if Id.equal id dummy_name then Id.of_string "__" else id (*S Renamings of global objects. *) @@ -182,37 +190,44 @@ let set_phase, get_phase = let ph = ref Impl in ((:=) ph), (fun () -> !ph) let set_keywords, get_keywords = - let k = ref Idset.empty in + let k = ref Id.Set.empty in ((:=) k), (fun () -> !k) let add_global_ids, get_global_ids = - let ids = ref Idset.empty in + let ids = ref Id.Set.empty in register_cleanup (fun () -> ids := get_keywords ()); - let add s = ids := Idset.add s !ids + let add s = ids := Id.Set.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.replace h, Hashtbl.find h, fun () -> Hashtbl.clear h) - (* We might have built [global_reference] whose canonical part is inaccurate. We must hence compare only the user part, hence using a Hashtbl might be incorrect *) +let mktable_id autoclean = + let m = ref Id.Map.empty in + let clear () = m := Id.Map.empty in + if autoclean then register_cleanup clear; + (fun r v -> m := Id.Map.add r v !m), (fun r -> Id.Map.find r !m), clear + let mktable_ref autoclean = let m = ref Refmap'.empty in let clear () = m := Refmap'.empty in if autoclean then register_cleanup clear; (fun r v -> m := Refmap'.add r v !m), (fun r -> Refmap'.find r !m), clear +let mktable_modpath autoclean = + let m = ref MPmap.empty in + let clear () = m := MPmap.empty in + if autoclean then register_cleanup clear; + (fun r v -> m := MPmap.add r v !m), (fun r -> MPmap.find r !m), clear + (* A table recording objects in the first level of all MPfile *) let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = - mktable false + mktable_modpath false let get_mpfiles_content mp = try get_mpfiles_content mp @@ -258,7 +273,7 @@ let params_ren_add, params_ren_mem = type visible_layer = { mp : module_path; params : module_path list; - content : ((kind*string),label) Hashtbl.t } + mutable content : Label.t KMap.t; } let pop_visible, push_visible, get_visible = let vis = ref [] in @@ -269,35 +284,47 @@ let pop_visible, push_visible, get_visible = | v :: vl -> vis := vl; (* we save the 1st-level-content of MPfile for later use *) - if get_phase () = Impl && modular () && is_modfile v.mp + if get_phase () == Impl && modular () && is_modfile v.mp then add_mpfiles_content v.mp v.content and push mp mps = - vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis + vis := { mp = mp; params = mps; content = KMap.empty } :: !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 +let add_visible ks l = + let visible = top_visible () in + visible.content <- KMap.add ks l visible.content (* table of local module wrappers used to provide non-ambiguous names *) +module DupOrd = +struct + type t = ModPath.t * Label.t + let compare (mp1, l1) (mp2, l2) = + let c = Label.compare l1 l2 in + if Int.equal c 0 then ModPath.compare mp1 mp2 else c +end + +module DupMap = Map.Make(DupOrd) + let add_duplicate, check_duplicate = - let index = ref 0 and dups = ref Gmap.empty in - register_cleanup (fun () -> index := 0; dups := Gmap.empty); + let index = ref 0 and dups = ref DupMap.empty in + register_cleanup (fun () -> index := 0; dups := DupMap.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 + let ren = "Coq__" ^ string_of_int !index in + dups := DupMap.add (mp,l) ren !dups + and check mp l = DupMap.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 () + if flag == Everything then clear_mpfiles_content () (*S Renaming functions *) @@ -312,8 +339,8 @@ let modular_rename k id = 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) + (Id.Set.mem id (get_keywords ())) || + (String.length s >= 4 && String.equal (String.sub s 0 4) prefix) then prefix ^ s else s @@ -321,10 +348,10 @@ let modular_rename k id = with unique numbers *) let modfstlev_rename = - let add_prefixes,get_prefixes,_ = mktable true in + let add_prefixes,get_prefixes,_ = mktable_id true in fun l -> - let coqid = id_of_string "Coq" in - let id = id_of_label l in + let coqid = Id.of_string "Coq" in + let id = Label.to_id l in try let coqset = get_prefixes id in let nextcoq = next_ident_away coqid coqset in @@ -343,23 +370,26 @@ 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 + let mp = match lmp with + | [""] -> modfstlev_rename l + | _ -> modular_rename Mod (Label.to_id l) + in + mp ::lmp | MPbound mbid -> - let s = modular_rename Mod (id_of_mbid mbid) in + let s = modular_rename Mod (MBId.to_id mbid) in if not (params_ren_mem mp) then [s] - else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i] + else let i,_,_ = MBId.repr mbid in [s^"__"^string_of_int i] | MPfile _ -> assert (modular ()); (* see [at_toplevel] above *) - assert (get_phase () = Pre); - let current_mpfile = (list_last (get_visible ())).mp in - if mp <> current_mpfile then mpfiles_add mp; + assert (get_phase () == Pre); + let current_mpfile = (List.last (get_visible ())).mp in + if not (ModPath.equal 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 + let add,get,_ = mktable_modpath 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 @@ -370,17 +400,17 @@ and mp_renaming = 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 l = if lang () != Ocaml && not (modular ()) then [""] else l in let s = let idg = safe_basename_of_global r in - if l = [""] (* this happens only at toplevel of the monolithic case *) - then - let globs = Idset.elements (get_global_ids ()) in + match l with + | [""] -> (* this happens only at toplevel of the monolithic case *) + let globs = Id.Set.elements (get_global_ids ()) in let id = next_ident_away (kindcase_id k idg) globs in string_of_id id - else modular_rename k idg + | _ -> modular_rename k idg in - add_global_ids (id_of_string s); + add_global_ids (Id.of_string s); s::l (* Cached version of the last function *) @@ -399,27 +429,30 @@ let ref_renaming = let rec clash mem mp0 ks = function | [] -> false - | mp :: _ when mp = mp0 -> false + | mp :: _ when ModPath.equal 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 + clash (fun mp k -> KMap.mem k (get_mpfiles_content mp)) mp0 ks (List.rev (mpfiles_list ())) let rec params_lookup mp0 ks = function | [] -> false - | param :: _ when mp0 = param -> true + | param :: _ when ModPath.equal mp0 param -> true | param :: params -> - if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param; + let () = match ks with + | (Mod, mp) when String.equal (List.hd (mp_renaming param)) mp -> params_ren_add param + | _ -> () + in params_lookup mp0 ks params let visible_clash mp0 ks = let rec clash = function | [] -> false - | v :: _ when v.mp = mp0 -> false + | v :: _ when ModPath.equal v.mp mp0 -> false | v :: vis -> - let b = Hashtbl.mem v.content ks in + let b = KMap.mem ks v.content in if b && not (is_mp_bound mp0) then true else begin if b then params_ren_add mp0; @@ -433,9 +466,9 @@ let visible_clash mp0 ks = let visible_clash_dbg mp0 ks = let rec clash = function | [] -> None - | v :: _ when v.mp = mp0 -> None + | v :: _ when ModPath.equal v.mp mp0 -> None | v :: vis -> - try Some (v.mp,Hashtbl.find v.content ks) + try Some (v.mp,KMap.find ks v.content) with Not_found -> if params_lookup mp0 ks v.params then None else clash vis @@ -455,7 +488,7 @@ let opened_libraries () = let to_open = List.filter (fun mp -> - not (List.exists (Hashtbl.mem (get_mpfiles_content mp)) used_ks)) + not (List.exists (fun k -> KMap.mem k (get_mpfiles_content mp)) used_ks)) used_files in mpfiles_clear (); @@ -476,7 +509,7 @@ let opened_libraries () = let pp_duplicate k' prefix mp rls olab = let rls', lbl = - if k'<>Mod then + if k' != Mod then (* Here rls=[s], the ref to print is ., and olab<>None *) rls, Option.get olab else @@ -485,7 +518,7 @@ let pp_duplicate k' prefix mp rls olab = in try dottify (check_duplicate prefix lbl :: rls') with Not_found -> - assert (get_phase () = Pre); (* otherwise it's too late *) + assert (get_phase () == Pre); (* otherwise it's too late *) add_duplicate prefix lbl; dottify rls let fstlev_ks k = function @@ -498,8 +531,8 @@ let fstlev_ks k = function 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 + assert (k != Mod || not (ModPath.equal 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' @@ -510,7 +543,7 @@ let pp_ocaml_local k prefix mp rls olab = 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)); + 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]. *) @@ -519,7 +552,7 @@ let pp_ocaml_extern k base rls = match rls with | [] -> assert false | base_s :: rls' -> if (not (modular ())) (* Pseudo qualification with "" *) - || (rls' = []) (* Case of a file A.v used as a module later *) + || (List.is_empty rls') (* Case of a file A.v used as a module later *) || (not (mpfiles_mem base)) (* Module not opened *) || (mpfiles_clash base (fstlev_ks k rls')) (* Conflict in opened files *) || (visible_clash base (fstlev_ks k rls')) (* Local conflict *) @@ -549,7 +582,7 @@ let pp_haskell_gen k mp rls = match rls with | s::rls' -> let str = pseudo_qualify rls' in let str = if is_upper str && not (upperkind k) then ("_"^str) else str in - let prf = if base_mp mp <> top_visible_mp () then s ^ "." else "" in + let prf = if not (ModPath.equal (base_mp mp) (top_visible_mp ())) then s ^ "." else "" in prf ^ str (* Main name printing function for a reference *) @@ -559,7 +592,7 @@ let pp_global k r = 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 + if ModPath.equal 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) @@ -575,7 +608,7 @@ let pp_global k r = let pp_module mp = let ls = mp_renaming mp in match mp with - | MPdot (mp0,l) when mp0 = top_visible_mp () -> + | MPdot (mp0,l) when ModPath.equal 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 @@ -587,7 +620,7 @@ let pp_module mp = the constants are directly turned into chars *) let mk_ind path s = - make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s) + MutInd.make2 (MPfile (dirpath_of_string path)) (Label.make s) let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii" @@ -598,7 +631,7 @@ let check_extract_ascii () = | Haskell -> "Char" | _ -> raise Not_found in - find_custom (IndRef (ind_ascii,0)) = char_type + String.equal (find_custom (IndRef (ind_ascii, 0))) (char_type) with Not_found -> false let is_list_cons l = @@ -606,14 +639,16 @@ let is_list_cons l = let is_native_char = function | MLcons(_,ConstructRef ((kn,0),1),l) -> - kn = ind_ascii && check_extract_ascii () && is_list_cons l + MutInd.equal kn ind_ascii && check_extract_ascii () && is_list_cons l | _ -> false -let pp_native_char c = +let get_native_char c = let rec cumul = function | [] -> 0 | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l) | _ -> assert false in let l = match c with MLcons(_,_,l) -> l | _ -> assert false in - str ("'"^Char.escaped (Char.chr (cumul l))^"'") + Char.chr (cumul l) + +let pp_native_char c = str ("'"^Char.escaped (get_native_char c)^"'") diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 7375f2d4..a8ab4fd3 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -1,15 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds -val pr_binding : identifier list -> std_ppcmds +val pr_binding : Id.t list -> std_ppcmds -val rename_id : identifier -> Idset.t -> identifier +val rename_id : Id.t -> Id.Set.t -> Id.t -type env = identifier list * Idset.t +type env = Id.t list * Id.Set.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 +val rename_vars: Id.Set.t -> Id.t list -> env +val rename_tvars: Id.Set.t -> Id.t list -> Id.t list +val push_vars : Id.t list -> env -> Id.t list * env +val get_db_name : int -> env -> Id.t type phase = Pre | Impl | Intf @@ -63,13 +62,13 @@ val top_visible_mp : unit -> module_path val push_visible : module_path -> module_path list -> unit val pop_visible : unit -> unit -val check_duplicate : module_path -> label -> string +val check_duplicate : module_path -> Label.t -> string type reset_kind = AllButExternal | Everything val reset_renaming_tables : reset_kind -> unit -val set_keywords : Idset.t -> unit +val set_keywords : Id.Set.t -> unit (** For instance: [mk_ind "Coq.Init.Datatypes" "nat"] *) @@ -80,4 +79,5 @@ val mk_ind : string -> string -> mutual_inductive the constants are directly turned into chars *) val is_native_char : ml_ast -> bool +val get_native_char : ml_ast -> char val pp_native_char : ml_ast -> std_ppcmds diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 84088292..42e69d34 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -1,18 +1,20 @@ (************************************************************************) (* 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))) + begin match Libobject.object_tag o with + | "CONSTANT" -> + let constant = Global.lookup_constant (constant_of_kn kn) in + Some (l, SFBconst constant) + | "INDUCTIVE" -> + let inductive = Global.lookup_mind (mind_of_kn kn) in + Some (l, SFBmind inductive) + | "MODULE" -> + let modl = Global.lookup_module (MPdot (mp, l)) in + Some (l, SFBmodule modl) | "MODULE TYPE" -> - SFBmodtype (Global.lookup_modtype (MPdot (mp,l))) - | _ -> failwith "caught" - in l,seb - | _ -> failwith "caught" + let modtype = Global.lookup_modtype (MPdot (mp, l)) in + Some (l, SFBmodtype modtype) + | "INCLUDE" -> error "No extraction of toplevel Include yet." + | _ -> None + end + | _ -> None in - SEBstruct (List.rev (map_succeed get_reference seg)) + List.rev (List.map_filter get_reference (Lib.contents ())) let environment_until dir_opt = let rec parse = function - | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()] + | [] when Option.is_empty dir_opt -> [Lib.current_mp (), 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 + let meb = + Modops.destr_nofunctor (Global.lookup_module (MPfile d)).mod_type + in + match dir_opt with + | Some d' when DirPath.equal d d' -> [MPfile d, meb] + | _ -> (MPfile d, meb) :: (parse l) in parse (Library.loaded_libraries ()) @@ -61,16 +71,12 @@ 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 - - (* Same, but we'll keep all fields of these modules *) + (* Add the module_path and all its prefixes to the mp visit list. + We'll keep all fields of these modules. *) val add_mp_all : module_path -> unit - (* Add kernel_name / constant / reference / ... in the visit lists. + (* Add reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) - val add_ind : 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 @@ -84,9 +90,6 @@ module type VISIT = sig 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_env for constants - (and still the remaining MPset) *) type must_visit = { mutable ind : KNset.t; mutable con : KNset.t; mutable mp : MPset.t; mutable mp_all : MPset.t } @@ -122,6 +125,15 @@ module Visit : VISIT = struct let add_spec_deps = spec_iter_references add_ref add_ref add_ref end +let add_field_label mp = function + | (lab, SFBconst _) -> Visit.add_ref (ConstRef (Constant.make2 mp lab)) + | (lab, SFBmind _) -> Visit.add_ref (IndRef (MutInd.make2 mp lab, 0)) + | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab)) + +let rec add_labels mp = function + | MoreFunctor (_,_,m) -> add_labels mp m + | NoFunctor sign -> List.iter (add_field_label mp) sign + exception Impossible let check_arity env cb = @@ -131,31 +143,31 @@ let check_arity env cb = let check_fix env cb i = match cb.const_body with | Def 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) + (match kind_of_term (Mod_subst.force_constr lbody) with + | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd) + | CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd) | _ -> raise Impossible) | Undef _ | OpaqueDef _ -> raise Impossible let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) = - na1 = na2 && - array_equal eq_constr ca1 ca2 && - array_equal eq_constr ta1 ta2 + Array.equal Name.equal na1 na2 && + Array.equal eq_constr ca1 ca2 && + Array.equal eq_constr ta1 ta2 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 + if Int.equal 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 msb', msb'' = List.chop (n-1) msb in let labels = Array.make n l in - list_iter_i + List.iteri (fun j -> function | (l,SFBconst cb') -> let check' = check_fix env cb' (j+1) in - if not (fst check = fst check' && + if not ((fst check : bool) == (fst check') && prec_declaration_equal (snd check) (snd check')) then raise Impossible; labels.(j+1) <- l; @@ -163,113 +175,102 @@ let factor_fix env l cb msb = labels, recd, msb'' end -(** Expanding a [struct_expr_body] into a version without abbreviations +(** Expanding a [module_alg_expr] 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,_,_,_ = - let inl = Some (Flags.get_inline_level()) in - Mod_typing.translate_struct_module_entry env mp inl (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 +let expand_mexpr env mp me = + let inl = Some (Flags.get_inline_level()) in + let sign,_,_,_ = Mod_typing.translate_mse env (Some mp) inl me in + sign (** 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 +let rec mp_of_mexpr = function + | MEident mp -> mp + | MEwith (seb,_) -> mp_of_mexpr seb | _ -> assert false -let env_for_mtb_with_def 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 spot = function (l',SFBconst _) -> l = l' | _ -> false in - let before = fst (list_split_when spot sig_b) in - Modops.add_signature mp before empty_delta_resolver env +let env_for_mtb_with_def env mp me idl = + let struc = Modops.destr_nofunctor me in + let l = Label.of_id (List.hd idl) in + let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in + let before = fst (List.split_when spot struc) in + Modops.add_structure 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 +let rec extract_structure_spec env mp = function | [] -> [] | (l,SFBconst cb) :: msig -> - let kn = make_con mp empty_dirpath l in + let kn = Constant.make2 mp l in let s = extract_constant_spec env kn cb in - let specs = extract_sfb_spec env mp msig in + let specs = extract_structure_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 mind = make_mind mp empty_dirpath l in + let mind = MutInd.make2 mp l in let s = Sind (mind, extract_inductive env mind) in - let specs = extract_sfb_spec env mp msig in + let specs = extract_structure_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 + let specs = extract_structure_spec env mp msig in + let spec = extract_mbody_spec env mb.mod_mp 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 + let specs = extract_structure_spec env mp msig in + let spec = extract_mbody_spec env mtb.mod_mp mtb in (l,Smodtype spec) :: specs -(* From [struct_expr_body] to specifications *) +(* From [module_expression] to specifications *) -(* Invariant: the [seb] given to [extract_seb_spec] should either come +(* Invariant: the [me] given to [extract_mexpr_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. + This way, any encountered [MEident] should be a true module type. *) -and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with - | SEBident mp -> Visit.add_mp_all mp; MTident mp - | SEBwith(seb',With_definition_body(idl,cb))-> - let env' = env_for_mtb_with_def 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 *) +and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with + | MEident mp -> Visit.add_mp_all mp; MTident mp + | MEwith(me',WithDef(idl,c))-> + let env' = env_for_mtb_with_def env (mp_of_mexpr me') me_struct idl in + let mt = extract_mexpr_spec env mp1 (me_struct,me') in + (match extract_with_type env' c with (* cb may contain some kn *) | None -> mt | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ))) - | SEBwith(seb',With_module_body(idl,mp))-> + | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all 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' + MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) + | MEapply _ -> extract_msignature_spec env mp1 me_struct + +and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with + | MoreFunctor (mbid, mtb, me_alg') -> + let me_struct' = match me_struct with + | MoreFunctor (mbid',_,me') when MBId.equal mbid' mbid -> me' | _ -> 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 - + let env' = Modops.add_module_type mp mtb env in + MTfunsig (mbid, extract_mbody_spec env mp mtb, + extract_mexpression_spec env' mp1 (me_struct',me_alg')) + | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m) + +and extract_msignature_spec env mp1 = function + | NoFunctor struc -> + let env' = Modops.add_structure mp1 struc empty_delta_resolver env in + MTsig (mp1, extract_structure_spec env' mp1 struc) + | MoreFunctor (mbid, mtb, me) -> + let mp = MPbound mbid in + let env' = Modops.add_module_type mp mtb env in + MTfunsig (mbid, extract_mbody_spec env mp mtb, + extract_msignature_spec env' mp1 me) +and extract_mbody_spec env mp mb = match mb.mod_type_alg with + | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty) + | None -> extract_msignature_spec env mp mb.mod_type (* From a [structure_body] (i.e. a list of [structure_field_body]) to implementations. @@ -278,88 +279,117 @@ and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with important: last to first ensures correct dependencies. *) -let rec extract_sfb env mp all = function +let rec extract_structure env mp ~all = function | [] -> [] - | (l,SFBconst cb) :: msb -> + | (l,SFBconst cb) :: struc -> (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 + let vl,recd,struc = factor_fix env l cb struc in + let vc = Array.map (Constant.make2 mp) vl in + let ms = extract_structure env mp ~all struc 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 ms = extract_structure env mp ~all struc in + let c = Constant.make2 mp 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 mind = make_mind mp empty_dirpath l in + | (l,SFBmind mib) :: struc -> + let ms = extract_structure env mp ~all struc in + let mind = MutInd.make2 mp l in let b = Visit.needed_ind mind in if all || b then let d = Dind (mind, 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 + | (l,SFBmodule mb) :: struc -> + let ms = extract_structure env mp ~all struc in let mp = MPdot (mp,l) in - if all || Visit.needed_mp mp then - (l,SEmodule (extract_module env mp true mb)) :: ms + let all' = all || Visit.needed_mp_all mp in + if all' || Visit.needed_mp mp then + (l,SEmodule (extract_module env mp ~all:all' mb)) :: ms else ms - | (l,SFBmodtype mtb) :: msb -> - let ms = extract_sfb env mp all msb in + | (l,SFBmodtype mtb) :: struc -> + let ms = extract_structure env mp ~all struc 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 + if all || Visit.needed_mp mp then + (l,SEmodtype (extract_mbody_spec env mp mtb)) :: ms else ms -(* From [struct_expr_body] to implementations *) +(* From [module_expr] and [module_expression] 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 -> +and extract_mexpr env mp = function + | MEwith _ -> assert false (* no 'with' syntax for modules *) + | me when lang () != Ocaml -> + (* In Haskell/Scheme, we expand everything. + For now, we also extract everything, dead code will be removed later + (see [Modutil.optimize_struct]. *) + extract_msignature env mp ~all:true (expand_mexpr env mp me) + | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; - Visit.add_mp_all mp; MEident mp - | SEBapply (meb, meb',_) -> - MEapply (extract_seb env mp true meb, - extract_seb env mp true meb') - | SEBfunctor (mbid, mtb, meb) -> + Visit.add_mp_all mp; Miniml.MEident mp + | MEapply (me, arg) -> + Miniml.MEapply (extract_mexpr env mp me, + extract_mexpr env mp (MEident arg)) + +and extract_mexpression env mp = function + | NoFunctor me -> extract_mexpr env mp me + | MoreFunctor (mbid, mtb, me) -> + let mp1 = MPbound mbid in + let env' = Modops.add_module_type mp1 mtb env in + Miniml.MEfunctor + (mbid, + extract_mbody_spec env mp1 mtb, + extract_mexpression env' mp me) + +and extract_msignature env mp ~all = function + | NoFunctor struc -> + let env' = Modops.add_structure mp struc empty_delta_resolver env in + Miniml.MEstruct (mp,extract_structure env' mp ~all struc) + | MoreFunctor (mbid, mtb, me) -> 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 = + let env' = Modops.add_module_type mp1 mtb env in + Miniml.MEfunctor + (mbid, + extract_mbody_spec env mp1 mtb, + extract_msignature env' mp ~all me) + +and extract_module env mp ~all mb = (* A module has an empty [mod_expr] when : - it is a module variable (for instance X inside a Module F [X:SIG]) - it is a module assumption (Declare Module). Since we look at modules from outside, we shouldn't have variables. But a Declare Module at toplevel seems legal (cf #2525). For the moment we don't support this situation. *) - match mb.mod_expr with - | None -> error_no_module_expr mp - | Some me -> - { ml_mod_expr = extract_seb env mp all me; - ml_mod_type = extract_seb_spec env mp (my_type_of_mb mb) } - - -let unpack = function MEstruct (_,sel) -> sel | _ -> assert false + let impl = match mb.mod_expr with + | Abstract -> error_no_module_expr mp + | Algebraic me -> extract_mexpression env mp me + | Struct sign -> + (* This module has a signature, otherwise it would be FullStruct. + We extract just the elements required by this signature. *) + let () = add_labels mp mb.mod_type in + extract_msignature env mp ~all:false sign + | FullStruct -> extract_msignature env mp ~all mb.mod_type + in + (* Slight optimization: for modules without explicit signatures + ([FullStruct] case), we build the type out of the extracted + implementation *) + let typ = match mb.mod_expr with + | FullStruct -> + assert (Option.is_empty mb.mod_type_alg); + mtyp_of_mexpr impl + | _ -> extract_mbody_spec env mp mb + in + { ml_mod_expr = impl; + ml_mod_type = typ } let mono_environment refs mpl = Visit.reset (); @@ -368,7 +398,8 @@ let mono_environment refs 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 (Visit.needed_mp_all mp) m)) + (fun (mp,struc) -> + mp, extract_structure env mp ~all:(Visit.needed_mp_all mp) struc) l (**************************************) @@ -383,7 +414,7 @@ let descr () = match lang () with (* 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 default_id = Id.of_string "Main" let mono_filename f = let d = descr () in @@ -396,10 +427,10 @@ let mono_filename f = else f in let id = - if lang () <> Haskell then default_id + if lang () != Haskell then default_id else - try id_of_string (Filename.basename f) - with e when Errors.noncritical e -> + try Id.of_string (Filename.basename f) + with UserError _ -> error "Extraction: provided filename is not a valid identifier" in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id @@ -409,7 +440,7 @@ let mono_filename f = 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 + Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, Id.of_string f (*s Extraction of one decl to stdout. *) @@ -420,8 +451,9 @@ let print_one_decl struc mp decl = ignore (d.pp_struct struc); set_phase Impl; push_visible mp []; - msgnl (d.pp_decl decl); - pop_visible () + let ans = d.pp_decl decl in + pop_visible (); + ans (*s Extraction of a ml struct to a file. *) @@ -449,31 +481,39 @@ let formatter dry file = (* note: max_indent should be < margin above, otherwise it's ignored *) ft +let get_comment () = + let s = file_comment () in + if String.is_empty s then None + else + let split_comment = Str.split (Str.regexp "[ \t\n]+") s in + Some (prlist_with_sep spc str split_comment) + let print_structure_to_file (fn,si,mo) dry struc = Buffer.clear buf; let d = descr () in reset_renaming_tables AllButExternal; let unsafe_needs = { - mldummy = struct_ast_search ((=) MLdummy) struc; + mldummy = struct_ast_search ((==) MLdummy) struc; tdummy = struct_type_search Mlutil.isDummy struc; - tunknown = struct_type_search ((=) Tunknown) struc; + tunknown = struct_type_search ((==) Tunknown) struc; magic = - if lang () <> Haskell then false + 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); + pp_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 + let comment = get_comment () 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); + pp_with ft (d.preamble mo comment opened unsafe_needs); + pp_with ft (d.pp_struct struc); Option.iter close_out cout; with reraise -> Option.iter close_out cout; raise reraise @@ -486,8 +526,8 @@ let print_structure_to_file (fn,si,mo) dry struc = 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)); + pp_with ft (d.sig_preamble mo comment opened unsafe_needs); + pp_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; with reraise -> close_out cout; raise reraise @@ -495,8 +535,8 @@ let print_structure_to_file (fn,si,mo) dry struc = info_file si) (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) - if Buffer.length buf <> 0 then begin - Pp.message (Buffer.contents buf); + if not (Int.equal (Buffer.length buf) 0) then begin + Pp.msg_info (str (Buffer.contents buf)); Buffer.reset buf end @@ -515,7 +555,7 @@ let init modular library = set_modular modular; set_library library; reset (); - if modular && lang () = Scheme then error_scheme () + if modular && lang () == Scheme then error_scheme () let warns () = warning_opaques (access_opaque ()); @@ -531,7 +571,7 @@ let rec locate_ref = function let mpo = try Some (Nametab.locate_module q) with Not_found -> None and ro = try Some (Smartlocate.global_with_alias r) - with e when Errors.noncritical e -> None + with Nametab.GlobalizationError _ | UserError _ -> None in match mpo, ro with | None, None -> Nametab.error_global_not_found q @@ -576,7 +616,7 @@ let separate_extraction lr = is \verb!Extraction! [qualid]. *) let simple_extraction r = - Vernacentries.dump_global (Genarg.AN r); + Vernacentries.dump_global (Misctypes.AN r); match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> @@ -584,9 +624,13 @@ let simple_extraction r = let struc = optimize_struct ([r],[]) (mono_environment [r] []) in let d = get_decl_in_structure r struc in warns (); - if is_custom r then msgnl (str "(** User defined extraction *)"); - print_one_decl struc (modpath_of_r r) d; - reset () + let flag = + if is_custom r then str "(** User defined extraction *)" ++ fnl() + else mt () + in + let ans = flag ++ print_one_decl struc (modpath_of_r r) d in + reset (); + Pp.msg_info ans | _ -> assert false @@ -602,9 +646,9 @@ let extraction_library is_rec m = Visit.add_mp_all (MPfile dir_m); let env = Global.env () in let l = List.rev (environment_until (Some dir_m)) in - let select l (mp,meb) = + let select l (mp,struc) = if Visit.needed_mp mp - then (mp, unpack (extract_seb env mp true meb)) :: l + then (mp, extract_structure env mp true struc) :: l else l in let struc = List.fold_left select [] l in @@ -612,9 +656,22 @@ let extraction_library is_rec m = warns (); let print = function | (MPfile dir as mp, sel) as e -> - let dry = not is_rec && dir <> dir_m in + let dry = not is_rec && not (DirPath.equal dir dir_m) in print_structure_to_file (module_filename mp) dry [e] | _ -> assert false in List.iter print struc; reset () + +let structure_for_compute c = + init false false; + let env = Global.env () in + let ast, mlt = Extraction.extract_constr env c in + let ast = Mlutil.normalize ast in + let refs = ref Refset.empty in + let add_ref r = refs := Refset.add r !refs in + let () = ast_iter_references add_ref add_ref add_ref ast in + let refs = Refset.elements !refs in + let struc = optimize_struct (refs,[]) (mono_environment refs []) in + let flatstruc = List.map snd (List.flatten (List.map snd struc)) in + flatstruc, ast, mlt diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 31f5a620..e5fe76f5 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val full_extraction : string option -> reference list -> unit val separate_extraction : reference list -> unit -val extraction_library : bool -> identifier -> unit +val extraction_library : bool -> Id.t -> unit (* For debug / external output via coqtop.byte + Drop : *) @@ -24,4 +25,10 @@ val mono_environment : (* Used by the Relation Extraction plugin *) val print_one_decl : - Miniml.ml_structure -> module_path -> Miniml.ml_decl -> unit + Miniml.ml_structure -> module_path -> Miniml.ml_decl -> Pp.std_ppcmds + +(* Used by Extraction Compute *) + +val structure_for_compute : + Term.constr -> + Miniml.ml_flat_structure * Miniml.ml_ast * Miniml.ml_type diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index a5b1e3c6..080512b2 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* error_singleton_become_prop id let sort_of env c = try - let polyprop = (lang() = Haskell) in + let polyprop = (lang() == Haskell) in Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) with SingletonInductiveBecomesProp id -> error_singleton_become_prop id @@ -55,8 +56,8 @@ let sort_of env c = More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with [s = Set], [Prop] or [Type] \item [Default] denotes the other cases. It may be inexact after - instanciation. For example [(X:Type)X] is [Default] and may give [Set] - after instanciation, which is rather [TypeScheme] + instantiation. For example [(X:Type)X] is [Default] and may give [Set] + after instantiation, which is rather [TypeScheme] \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop] \item [Info] is the opposite. The same example [(X:Type)X] shows that an [Info] term might in fact be [Logic] later on. @@ -71,17 +72,19 @@ type flag = info * scheme (*s [flag_of_type] transforms a type [t] into a [flag]. Really important function. *) -let rec flag_of_type env t = +let rec flag_of_type env t : flag = let t = whd_betadeltaiota env none t in match kind_of_term t with | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c - | Sort (Prop Null) -> (Logic,TypeScheme) + | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) | Sort _ -> (Info,TypeScheme) - | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default) + | _ -> 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)) +let is_default env t = match flag_of_type env t with +| (Info, Default) -> true +| _ -> false exception NotDefault of kill_reason @@ -91,7 +94,9 @@ let check_default env t = | Logic,_ -> raise (NotDefault Kother) | _ -> () -let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) +let is_info_scheme env t = match flag_of_type env t with +| (Info, TypeScheme) -> true +| _ -> false (*s [type_sign] gernerates a signature aimed at treating a type application. *) @@ -109,16 +114,31 @@ let rec type_scheme_nb_args env c = if is_info_scheme env t then n+1 else n | _ -> 0 -let _ = register_type_scheme_nb_args type_scheme_nb_args +let _ = Hook.set type_scheme_nb_args_hook type_scheme_nb_args (*s [type_sign_vl] does the same, plus a type var list. *) +(* When generating type variables, we avoid any ' in their names + (otherwise this may cause a lexer conflict in ocaml with 'a'). + We also get rid of unicode characters. Anyway, since type variables + are local, the created name is just a matter of taste... + See also Bug #3227 *) + +let make_typvar n vl = + let id = id_of_name n in + let id' = + let s = Id.to_string id in + if not (String.contains s '\'') && Unicode.is_basic_ascii s then id + else id_of_name Anonymous + in + next_ident_away id' vl + 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 + else Keep::s, (make_typvar n vl) :: vl | _ -> [],[] let rec nb_default_params env c = @@ -136,7 +156,8 @@ let sign_with_implicits r s nb_params = | [] -> [] | sign::s -> let sign' = - if sign = Keep && List.mem i implicits then Kill Kother else sign + if sign == Keep && Int.List.mem i implicits + then Kill Kother else sign in sign' :: add_impl (succ i) s in add_impl (1+nb_params) s @@ -145,11 +166,11 @@ let sign_with_implicits r s nb_params = let rec handle_exn r n fn_name = function | MLexn s -> - (try Scanf.sscanf s "UNBOUND %d" + (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 e when Errors.noncritical e -> MLexn s) + with Scanf.Scan_failure _ | End_of_file -> MLexn s) | a -> ast_map (handle_exn r n fn_name) a (*S Management of type variable contexts. *) @@ -170,8 +191,8 @@ let db_from_sign s = 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)) + if Int.equal i 0 then [] + else (try Int.Map.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. *) @@ -185,34 +206,43 @@ let rec db_from_ind dbmap i = let parse_ind_args si args relmax = let rec parse i j = function - | [] -> Intmap.empty + | [] -> Int.Map.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) + | Rel k -> Int.Map.add (relmax+1-k) j (parse (i+1) (j+1) s) | _ -> parse (i+1) (j+1) s) in parse 1 1 si let oib_equal o1 o2 = - id_ord o1.mind_typename o2.mind_typename = 0 && - list_equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && - begin match o1.mind_arity, o2.mind_arity with - | Monomorphic {mind_user_arity=c1; mind_sort=s1}, - Monomorphic {mind_user_arity=c2; mind_sort=s2} -> - eq_constr c1 c2 && s1 = s2 - | ma1, ma2 -> ma1 = ma2 end && - o1.mind_consnames = o2.mind_consnames + Id.equal o1.mind_typename o2.mind_typename && + List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && + begin + match o1.mind_arity, o2.mind_arity with + | RegularArity {mind_user_arity=c1; mind_sort=s1}, RegularArity {mind_user_arity=c2; mind_sort=s2} -> + eq_constr c1 c2 && Sorts.equal s1 s2 + | TemplateArity p1, TemplateArity p2 -> + let eq o1 o2 = Option.equal Univ.Level.equal o1 o2 in + List.equal eq p1.template_param_levels p2.template_param_levels && + Univ.Universe.equal p1.template_level p2.template_level + | _, _ -> false + end && + Array.equal Id.equal o1.mind_consnames o2.mind_consnames + +let eq_record x y = + Option.equal (Option.equal (fun (_, x, y) (_, x', y') -> Array.for_all2 eq_constant x x')) x y let mib_equal m1 m2 = - array_equal oib_equal m1.mind_packets m1.mind_packets && - m1.mind_record = m2.mind_record && - m1.mind_finite = m2.mind_finite && - m1.mind_ntypes = m2.mind_ntypes && - list_equal eq_named_declaration m1.mind_hyps m2.mind_hyps && - m1.mind_nparams = m2.mind_nparams && - m1.mind_nparams_rec = m2.mind_nparams_rec && - list_equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && - m1.mind_constraints = m2.mind_constraints + Array.equal oib_equal m1.mind_packets m1.mind_packets && + eq_record m1.mind_record m2.mind_record && + (m1.mind_finite : Decl_kinds.recursivity_kind) == m2.mind_finite && + Int.equal m1.mind_ntypes m2.mind_ntypes && + List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps && + Int.equal m1.mind_nparams m2.mind_nparams && + Int.equal m1.mind_nparams_rec m2.mind_nparams_rec && + List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && + (* Univ.UContext.eq *) m1.mind_universes == m2.mind_universes (** FIXME *) + (* m1.mind_universes = m2.mind_universes *) (*S Extraction of a type. *) @@ -235,7 +265,7 @@ let rec extract_type env db j c args = | [] -> assert false (* A lambda cannot be a type. *) | a :: args -> extract_type env db j (subst1 a d) args) | Prod (n,t,d) -> - assert (args = []); + assert (List.is_empty args); let env' = push_rel_assum (n,t) env in (match flag_of_type env t with | (Info, Default) -> @@ -255,10 +285,10 @@ let rec extract_type env db j c args = (match expand env mld with | Tdummy d -> Tdummy d | _ -> - let reason = if lvl=TypeScheme then Ktype else Kother in + 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 + | _ 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 @@ -266,11 +296,11 @@ let rec extract_type env db j c 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 -> + if Int.equal n' 0 then Tunknown else Tvar n') + | Const (kn,u as c) -> let r = ConstRef kn in let cb = lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ,_ = Typeops.type_of_constant env c in (match flag_of_type env typ with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> @@ -279,23 +309,23 @@ let rec extract_type env db j c args = | Undef _ | OpaqueDef _ -> mlt | Def _ when is_custom r -> mlt | Def lbody -> - let newc = applist (Declarations.force lbody, args) in + let newc = applist (Mod_subst.force_constr 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') + if eq_ml_type (expand env mlt) (expand env mlt') then mlt else mlt') | (Info, Default) -> (* Not an ML type, for example [(c:forall X, X->X) Type nat] *) (match cb.const_body with | Undef _ | OpaqueDef _ -> Tunknown (* Brutal approx ... *) | Def lbody -> (* We try to reduce. *) - let newc = applist (Declarations.force lbody, args) in + let newc = applist (Mod_subst.force_constr lbody, args) in extract_type env db j newc [])) - | Ind (kn,i) -> + | Ind ((kn,i),u) -> 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 @@ -308,7 +338,7 @@ let rec extract_type env db j c args = and extract_type_app env db (r,s) args = let ml_args = List.fold_right - (fun (b,c) a -> if b=Keep then + (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 @@ -326,7 +356,7 @@ and extract_type_app env db (r,s) args = (* [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 [] + if Int.equal p 0 then extract_type env db 0 c [] else let c = whd_betaiotazeta Evd.empty c in match kind_of_term c with @@ -335,7 +365,7 @@ and extract_type_scheme env db c p = | _ -> 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 + let eta_args = List.rev_map mkRel (List.interval 1 p) in extract_type env db 0 (lift p c) eta_args @@ -356,9 +386,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *) When at toplevel of the monolithic case, we cannot do much (cf Vector and bug #2570) *) let equiv = - if lang () <> Ocaml || + if lang () != Ocaml || (not (modular ()) && at_toplevel (mind_modpath kn)) || - kn_ord (canonical_mind kn) (user_mind kn) = 0 + KerName.equal (canonical_mind kn) (user_mind kn) then NoEquiv else @@ -375,32 +405,34 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* 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 + Array.mapi + (fun i mip -> + let (ind,u), ctx = + Universes.fresh_inductive_instance env (kn,i) in + let ar = Inductive.type_of_inductive env ((mib,mip),u) in + let info = (fst (flag_of_type env ar) = Info) in + let s,v = if info 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_logical = not info; ip_sign = s; ip_vars = v; - ip_types = t }) + ip_types = t }, u) mib.mind_packets in add_ind kn mib {ind_kind = Standard; ind_nparams = npar; - ind_packets = packets; + ind_packets = Array.map fst packets; ind_equiv = equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do - let p = packets.(i) in + let p,u = packets.(i) in if not p.ip_logical then - let types = arities_of_constructors env (kn,i) in + let types = arities_of_constructors env ((kn,i),u) 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 @@ -420,18 +452,18 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let ip = (kn, 0) in let r = IndRef ip in if is_custom r then raise (I Standard); - if not mib.mind_finite then raise (I Coinductive); - if mib.mind_ntypes <> 1 then raise (I Standard); - let p = packets.(0) in + if mib.mind_finite == Decl_kinds.CoFinite then raise (I Coinductive); + if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); + let p,u = packets.(0) in if p.ip_logical then raise (I Standard); - if Array.length p.ip_types <> 1 then raise (I Standard); + if not (Int.equal (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 not (keep_singleton ()) && - List.length l = 1 && not (type_mem_kn kn (List.hd l)) + Int.equal (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); + if List.is_empty l then raise (I Standard); + if Option.is_empty mib.mind_record 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 @@ -441,10 +473,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *) | _ -> [] 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); + List.skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in + assert (Int.equal (List.length field_names) (List.length typ)); let projs = ref Cset.empty in - let mp,d,_ = repr_mind kn in + let mp = MutInd.modpath kn in let rec select_fields l typs = match l,typs with | [],[] -> [] | _::l, typ::typs when isDummy (expand env typ) -> @@ -452,9 +484,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *) | Anonymous::l, typ::typs -> None :: (select_fields l typs) | Name id::l, typ::typs -> - let knp = make_con mp d (label_of_id id) in + let knp = Constant.make2 mp (Label.of_id id) in (* Is it safe to use [id] for projections [foo.id] ? *) - if List.for_all ((=) Keep) (type2signature env typ) + if List.for_all ((==) Keep) (type2signature env typ) then projs := Cset.add knp !projs; Some (ConstRef knp) :: (select_fields l typs) | _ -> assert false @@ -465,9 +497,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* If so, we use this information. *) begin try let n = nb_default_params env - (Inductive.type_of_inductive env (mib,mip0)) + (Inductive.type_of_inductive env ((mib,mip0),u)) in - let check_proj kn = if Cset.mem kn !projs then add_projection n kn in + let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip + in List.iter (Option.iter check_proj) (lookup_projections ip) with Not_found -> () end; @@ -476,7 +509,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) in let i = {ind_kind = ind_info; ind_nparams = npar; - ind_packets = packets; + ind_packets = Array.map fst packets; ind_equiv = equiv } in add_ind kn mib i; @@ -495,7 +528,7 @@ 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 db' = (try Int.Map.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 | _ -> [] @@ -511,13 +544,14 @@ and mlt_env env r = match r with | _ -> None with Not_found -> let cb = Environ.lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = Typeops.type_of_constant_type env cb.const_type + (* FIXME not sure if we should instantiate univs here *) in match cb.const_body with | Undef _ | OpaqueDef _ -> None | Def l_body -> (match flag_of_type env typ with | Info,TypeScheme -> - let body = Declarations.force l_body in + let body = Mod_subst.force_constr 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) @@ -539,7 +573,7 @@ let record_constant_type env kn opt_typ = lookup_type kn with Not_found -> let typ = match opt_typ with - | None -> Typeops.type_of_constant env kn + | None -> Typeops.type_of_constant_type env (lookup_constant kn env).const_type | Some typ -> typ in let mlt = extract_type env [] 1 typ [] in let schema = (type_maxvar mlt, mlt) @@ -594,10 +628,12 @@ let rec extract_term env mle mlt c 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 + | Const (kn,u) -> + extract_cst_app env mle mlt kn u args + | Construct (cp,u) -> + extract_cons_app env mle mlt cp u args + | Proj (p, c) -> + extract_cst_app env mle mlt (Projection.constant p) Univ.Instance.empty (c :: 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]. *) @@ -645,14 +681,15 @@ and make_mlargs env e s args typs = (*s Extraction of a constant applied to arguments. *) -and extract_cst_app env mle mlt kn args = +and extract_cst_app env mle mlt kn u 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) + if lang () == Ocaml && List.mem_f Constant.equal kn !current_fixpoints + then var2var' (snd schema) else instantiation schema in (* Then the expected type of this constant. *) @@ -674,14 +711,14 @@ and extract_cst_app env mle mlt kn args = (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env mle s args metas in let mla = - if magic1 || lang () <> Ocaml then mla + if magic1 || lang () != Ocaml then mla else try (* for better optimisations later, we discard dependent args of projections and replace them by fake args that will be removed during final pretty-print. *) - let l,l' = list_chop (projection_arity (ConstRef kn)) mla in - if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' + let l,l' = List.chop (projection_arity (ConstRef kn)) mla in + if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla with e when Errors.noncritical e -> mla in @@ -689,7 +726,7 @@ and extract_cst_app env mle mlt kn args = 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] + | UnsafeLogicalSig when lang () != Haskell -> [MLdummy] | _ -> [] in (* Different situations depending of the number of arguments: *) @@ -702,7 +739,7 @@ and extract_cst_app env mle mlt kn args = (* 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 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) @@ -717,14 +754,14 @@ and extract_cst_app env mle mlt kn args = 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 = +and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) u 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 list_tvar = List.map (fun i -> Tvar i) (List.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], ... *) @@ -734,7 +771,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = 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 + 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! *) @@ -742,7 +779,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in let magic2 = needs_magic (a, mlt) in let head mla = - if mi.ind_kind = Singleton then + if mi.ind_kind == Singleton then put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *) else let typeargs = match snd (type_decomp type_cons) with @@ -759,11 +796,11 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = (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 + if Int.equal 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 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') @@ -772,22 +809,22 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = 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 ni = constructors_nrealargs_env env ip in let br_size = Array.length br in - assert (Array.length ni = br_size); - if br_size = 0 then begin + assert (Int.equal (Array.length ni) br_size); + if Int.equal 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 + 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); + assert (Int.equal 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 @@ -816,13 +853,13 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in (List.rev ids, Pusual r, e') in - if mi.ind_kind = Singleton then + if mi.ind_kind == Singleton then begin (* Informative singleton case: *) (* [match c with C i -> t] becomes [let i = c' in t'] *) - assert (br_size = 1); + assert (Int.equal br_size 1); let (ids,_,e') = extract_branch 0 in - assert (List.length ids = 1); + assert (Int.equal (List.length ids) 1); MLletin (tmp_id (List.hd ids),a,e') end else @@ -838,7 +875,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt = 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 + let ei = Array.map2 (extract_maybe_term env mle) metas ci in MLfix (i, Array.map id_of_name fi, ei) (*S ML declarations. *) @@ -846,14 +883,14 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt = (* [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 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 + let rels = (List.firstn d rels) @ rels' in + let eta_args = List.rev_map mkRel (List.interval 1 d) in rels, applist (lift d c,eta_args) (* Let's try to identify some situation where extracted code @@ -864,7 +901,7 @@ let rec gentypvar_ok c = match kind_of_term c with | App (c,v) -> (* if all arguments are variables, these variables will disappear after extraction (see [empty_s] below) *) - array_for_all isRel v && gentypvar_ok c + Array.for_all isRel v && gentypvar_ok c | Cast (c,_,_) -> gentypvar_ok c | _ -> false @@ -891,26 +928,26 @@ let extract_std_constant env kn body typ = and m = nb_lam body in if n <= m then decompose_lam_n n body else - let s,s' = list_chop m s in - if List.for_all ((=) Keep) s' && - (lang () = Haskell || sign_kind s <> UnsafeLogicalSig) + let s,s' = List.chop 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 (* Should we do one eta-expansion to avoid non-generalizable '_a ? *) let rels, c = let n = List.length rels in - let s,s' = list_chop n s in + let s,s' = List.chop n s in let k = sign_kind s in - let empty_s = (k = EmptySig || k = SafeLogicalSig) in - if lang () = Ocaml && empty_s && not (gentypvar_ok c) - && s' <> [] && type_maxvar t <> 0 + let empty_s = (k == EmptySig || k == SafeLogicalSig) in + if lang () == Ocaml && empty_s && not (gentypvar_ok c) + && not (List.is_empty s') && not (Int.equal (type_maxvar t) 0) then decomp_lams_eta_n (n+1) n env body typ else rels,c in let n = List.length rels in - let s = list_firstn n s in - let l,l' = list_chop n l in + let s = List.firstn n s in + let l,l' = List.chop 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 @@ -948,7 +985,7 @@ let extract_fixpoint env vkn (fi,ti,ci) = (* 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 + 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; @@ -988,17 +1025,21 @@ let extract_constant env kn cb = | (Info,TypeScheme) -> (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () - | Def c -> mk_typ (force c) + | Def c -> mk_typ (Mod_subst.force_constr c) | OpaqueDef c -> add_opaque r; - if access_opaque () then mk_typ (force_opaque c) else mk_typ_ax ()) + if access_opaque () then + mk_typ (Opaqueproof.force_proof (Environ.opaque_tables env) c) + else mk_typ_ax ()) | (Info,Default) -> (match cb.const_body with | Undef _ -> warn_info (); mk_ax () - | Def c -> mk_def (force c) + | Def c -> mk_def (Mod_subst.force_constr c) | OpaqueDef c -> add_opaque r; - if access_opaque () then mk_def (force_opaque c) else mk_ax ()) + if access_opaque () then + mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c) + else mk_ax ()) let extract_constant_spec env kn cb = let r = ConstRef kn in @@ -1012,27 +1053,32 @@ let extract_constant_spec env kn cb = | Undef _ | OpaqueDef _ -> Stype (r, vl, None) | Def body -> let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) + let body = Mod_subst.force_constr body in + let t = extract_type_scheme env db 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 +let extract_with_type env c = + let typ = type_of env c in match flag_of_type env typ with | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in let db = db_from_sign s in - let c = match cb.const_body with - | Def body -> force body - (* A "with Definition ..." is necessarily transparent *) - | Undef _ | OpaqueDef _ -> assert false - in let t = extract_type_scheme env db c (List.length s) in Some (vl, t) | _ -> None +let extract_constr env c = + reset_meta_count (); + let typ = type_of env c in + match flag_of_type env typ with + | (_,TypeScheme) -> MLdummy, Tdummy Ktype + | (Logic,_) -> MLdummy, Tdummy Kother + | (Info,Default) -> + let mlt = extract_type env [] 1 typ [] in + extract_term env Mlenv.empty mlt c [], mlt let extract_inductive env kn = let ind = extract_ind env kn in @@ -1043,7 +1089,7 @@ let extract_inductive env kn = | [] -> [] | t::l -> let l' = filter (succ i) l in - if isDummy (expand env t) || List.mem i implicits then l' + if isDummy (expand env t) || Int.List.mem i implicits then l' else t::l' in filter (1+ind.ind_nparams) l in @@ -1058,9 +1104,9 @@ 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 + (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 ? *) @@ -1068,5 +1114,5 @@ let logical_decl = function let logical_spec = function | Stype (_, [], Some (Tdummy _)) -> true | Sval (_,Tdummy _) -> true - | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets + | 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 index f10f3589..6bd2541b 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -1,6 +1,6 @@ (************************************************************************) (* 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 +(** For extracting "module ... with ..." declaration *) + +val extract_with_type : env -> constr -> ( Id.t list * ml_type ) option val extract_fixpoint : env -> constant array -> (constr, types) prec_declaration -> ml_decl val extract_inductive : env -> mutual_inductive -> ml_ind +(** For extraction compute *) + +val extract_constr : env -> constr -> ml_ast * ml_type + (*s Is a [ml_decl] or a [ml_spec] logical ? *) val logical_decl : ml_decl -> bool diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index a2b6b14a..3caa558f 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -1,17 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ ArgId (id_of_string id) ] +| [ preident(id) ] -> [ ArgId (Id.of_string id) ] | [ integer(i) ] -> [ ArgInt i ] END @@ -53,7 +51,7 @@ END (* Extraction commands *) -VERNAC COMMAND EXTEND Extraction +VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY (* Extraction in the Coq toplevel *) | [ "Extraction" global(x) ] -> [ simple_extraction x ] | [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] @@ -63,85 +61,85 @@ VERNAC COMMAND EXTEND Extraction -> [ full_extraction (Some f) l ] END -VERNAC COMMAND EXTEND SeparateExtraction +VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY (* Same, with content splitted in several files *) | [ "Separate" "Extraction" ne_global_list(l) ] -> [ separate_extraction l ] END (* Modular extraction (one Coq library = one ML module) *) -VERNAC COMMAND EXTEND ExtractionLibrary +VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY | [ "Extraction" "Library" ident(m) ] -> [ extraction_library false m ] END -VERNAC COMMAND EXTEND RecursiveExtractionLibrary +VERNAC COMMAND EXTEND RecursiveExtractionLibrary CLASSIFIED AS QUERY | [ "Recursive" "Extraction" "Library" ident(m) ] -> [ extraction_library true m ] END (* Target Language *) -VERNAC COMMAND EXTEND ExtractionLanguage +VERNAC COMMAND EXTEND ExtractionLanguage CLASSIFIED AS SIDEFF | [ "Extraction" "Language" language(l) ] -> [ extraction_language l ] END -VERNAC COMMAND EXTEND ExtractionInline +VERNAC COMMAND EXTEND ExtractionInline CLASSIFIED AS SIDEFF (* Custom inlining directives *) | [ "Extraction" "Inline" ne_global_list(l) ] -> [ extraction_inline true l ] END -VERNAC COMMAND EXTEND ExtractionNoInline +VERNAC COMMAND EXTEND ExtractionNoInline CLASSIFIED AS SIDEFF | [ "Extraction" "NoInline" ne_global_list(l) ] -> [ extraction_inline false l ] END -VERNAC COMMAND EXTEND PrintExtractionInline +VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY | [ "Print" "Extraction" "Inline" ] - -> [ print_extraction_inline () ] + -> [ msg_info (print_extraction_inline ()) ] END -VERNAC COMMAND EXTEND ResetExtractionInline +VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Inline" ] -> [ reset_extraction_inline () ] END -VERNAC COMMAND EXTEND ExtractionImplicit +VERNAC COMMAND EXTEND ExtractionImplicit CLASSIFIED AS SIDEFF (* 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 +VERNAC COMMAND EXTEND ExtractionBlacklist CLASSIFIED AS SIDEFF (* Force Extraction to not use some filenames *) | [ "Extraction" "Blacklist" ne_ident_list(l) ] -> [ extraction_blacklist l ] END -VERNAC COMMAND EXTEND PrintExtractionBlacklist +VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY | [ "Print" "Extraction" "Blacklist" ] - -> [ print_extraction_blacklist () ] + -> [ msg_info (print_extraction_blacklist ()) ] END -VERNAC COMMAND EXTEND ResetExtractionBlacklist +VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Blacklist" ] -> [ reset_extraction_blacklist () ] END (* Overriding of a Coq object by an ML one *) -VERNAC COMMAND EXTEND ExtractionConstant +VERNAC COMMAND EXTEND ExtractionConstant CLASSIFIED AS SIDEFF | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] -> [ extract_constant_inline false x idl y ] END -VERNAC COMMAND EXTEND ExtractionInlinedConstant +VERNAC COMMAND EXTEND ExtractionInlinedConstant CLASSIFIED AS SIDEFF | [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] -> [ extract_constant_inline true x [] y ] END -VERNAC COMMAND EXTEND ExtractionInductive +VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF | [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" string_opt(o) ] -> [ extract_inductive x id idl o ] diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 4f9c6a71..5e08fef5 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Idset.add (id_of_string s)) + List.fold_right (fun s -> Id.Set.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 + Id.Set.empty -let preamble mod_name used_modules usf = +let pp_comment s = str "-- " ++ s ++ fnl () +let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}" + +let preamble mod_name comment 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 "{-# OPTIONS_GHC -cpp -XMagicHash #-}" ++ fnl () ++ + str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}") + ++ fnl () ++ fnl () + ++ + (match comment with + | None -> mt () + | Some com -> pp_bracket_comment com ++ fnl () ++ fnl ()) ++ 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 List.is_empty used_modules then mt () else fnl ()) ++ (if not usf.magic then mt () else str "\ -\nunsafeCoerce :: a -> b\ \n#ifdef __GLASGOW_HASKELL__\ \nimport qualified GHC.Base\ +\nunsafeCoerce :: a -> b\ \nunsafeCoerce = GHC.Base.unsafeCoerce#\ \n#else\ \n-- HUGS\ \nimport qualified IOExts\ +\nunsafeCoerce :: a -> b\ \nunsafeCoerce = IOExts.unsafeCoerce\ \n#endif" ++ fnl2 ()) ++ @@ -74,19 +84,15 @@ let 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_mind 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 e when Errors.noncritical e -> (str "a" ++ int i)) + with Failure _ -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r | Tglob (IndRef(kn,0),l) - when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> + when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> pp_type true vl (List.hd l) | Tglob (r,l) -> pp_par par @@ -140,7 +146,7 @@ let rec pp_expr par env args = | MLglob r -> apply (pp_global Term r) | MLcons (_,r,a) as c -> - assert (args=[]); + assert (List.is_empty args); begin match a with | _ when is_native_char c -> pp_native_char c | [] -> pp_global Cons r @@ -151,13 +157,13 @@ let rec pp_expr par env args = prlist_with_sep spc (pp_expr true env []) a) end | MLtuple l -> - assert (args=[]); + assert (List.is_empty args); pp_boxed_tuple (pp_expr true env []) l | MLcase (_,t, pv) when is_custom_match pv -> if not (is_regular_match pv) then error "Cannot mix yet user-given match and general patterns."; let mkfun (ids,_,e) = - if ids <> [] then named_lams (List.rev ids) e + if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in @@ -185,7 +191,7 @@ let rec pp_expr par env args = and pp_cons_pat par r ppl = pp_par par - (pp_global Cons r ++ space_if (ppl<>[]) ++ prlist_with_sep spc identity ppl) + (pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ prlist_with_sep spc identity ppl) and pp_gen_pat par ids env = function | Pcons (r,l) -> pp_cons_pat par r (List.map (pp_gen_pat true ids env) l) @@ -205,7 +211,7 @@ and pp_pat env pv = prvecti (fun i x -> pp_one_pat env pv.(i) ++ - if i = Array.length pv - 1 then str "}" else + if Int.equal i (Array.length pv - 1) then str "}" else (str ";" ++ fnl ())) pv @@ -218,7 +224,7 @@ and pp_fix par env i (ids,bl) args = (v 1 (str "let {" ++ fnl () ++ prvect_with_sep (fun () -> str ";" ++ fnl ()) (fun (fi,ti) -> pp_function env (pr_id fi) ti) - (array_map2 (fun a b -> a,b) ids bl) ++ + (Array.map2 (fun a b -> a,b) ids bl) ++ str "}") ++ fnl () ++ str "in " ++ pp_apply (pr_id ids.(i)) false args)) @@ -231,8 +237,6 @@ and pp_function env f 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 : " ++ @@ -243,7 +247,7 @@ let pp_singleton kn packet = 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 () ++ + (if not (List.is_empty 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))) @@ -258,10 +262,10 @@ let pp_one_ind ip pl cv = prlist_with_sep (fun () -> (str " ")) (pp_type true pl) l)) in - str (if Array.length cv = 0 then "type " else "data ") ++ + str (if Array.is_empty cv then "type " else "data ") ++ pp_global Type (IndRef ip) ++ prlist_strict (fun id -> str " " ++ pr_lower_id id) pl ++ str " =" ++ - if Array.length cv = 0 then str " () -- empty inductive" + if Array.is_empty cv then str " () -- empty inductive" else (fnl () ++ str " " ++ v 0 (str " " ++ @@ -286,7 +290,7 @@ let rec pp_ind first kn i ind = (*s Pretty-printing of a declaration. *) let pp_decl = function - | Dind (kn,i) when i.ind_kind = Singleton -> + | Dind (kn,i) when i.ind_kind == Singleton -> pp_singleton kn i.ind_packets.(0) ++ fnl () | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) | Dtype (r, l, t) -> @@ -299,7 +303,7 @@ let pp_decl = function 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" + 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 () @@ -310,7 +314,7 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && defs.(i) = MLexn "UNUSED") + (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else @@ -359,7 +363,7 @@ let haskell_descr = { preamble = preamble; pp_struct = pp_struct; sig_suffix = None; - sig_preamble = (fun _ _ _ -> mt ()); + sig_preamble = (fun _ _ _ _ -> mt ()); pp_sig = (fun _ -> mt ()); pp_decl = pp_decl; } diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli index b00fc42f..99559bce 100644 --- a/plugins/extraction/haskell.mli +++ b/plugins/extraction/haskell.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_path list -> unsafe_needs -> std_ppcmds; + (* the second argument is a comment to add to the preamble *) + preamble : + Id.t -> std_ppcmds option -> 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; + (* the second argument is a comment to add to the preamble *) + sig_preamble : + Id.t -> std_ppcmds option -> module_path list -> unsafe_needs -> + std_ppcmds; pp_sig : ml_signature -> std_ppcmds; (* for an isolated declaration print *) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 1462d3e7..9fdb0205 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1,17 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* anonymous_name - | Name id when id = dummy_name -> anonymous_name + | Name id when Id.equal id dummy_name -> anonymous_name | Name id -> id let id_of_mlid = function @@ -54,6 +53,22 @@ let new_meta _ = incr meta_count; Tmeta {id = !meta_count; contents = None} +let rec eq_ml_type t1 t2 = match t1, t2 with +| Tarr (tl1, tr1), Tarr (tl2, tr2) -> + eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2 +| Tglob (gr1, t1), Tglob (gr2, t2) -> + eq_gr gr1 gr2 && List.equal eq_ml_type t1 t2 +| Tvar i1, Tvar i2 -> Int.equal i1 i2 +| Tvar' i1, Tvar' i2 -> Int.equal i1 i2 +| Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2 +| Tdummy k1, Tdummy k2 -> k1 == k2 +| Tunknown, Tunknown -> true +| Taxiom, Taxiom -> true +| _ -> false + +and eq_ml_meta m1 m2 = + Int.equal m1.id m2.id && Option.equal eq_ml_type m1.contents m2.contents + (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *) let type_subst_list l t = @@ -86,7 +101,7 @@ let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t let rec type_occurs alpha t = match t with - | Tmeta {id=beta; contents=None} -> alpha = beta + | Tmeta {id=beta; contents=None} -> Int.equal 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 @@ -95,7 +110,7 @@ let rec type_occurs alpha t = (*s Most General Unificator *) let rec mgu = function - | Tmeta m, Tmeta m' when m.id = m'.id -> () + | Tmeta m, Tmeta m' when Int.equal m.id m'.id -> () | Tmeta m, t | t, Tmeta m -> (match m.contents with | Some u -> mgu (u, t) @@ -103,21 +118,24 @@ let rec mgu = function | None -> m.contents <- Some t) | Tarr(a, b), Tarr(a', b') -> mgu (a, a'); mgu (b, b') - | Tglob (r,l), Tglob (r',l') when r = r' -> + | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' -> List.iter mgu (List.combine l l') - | (Tdummy _, _ | _, Tdummy _) when lang() = Haskell -> () + | (Tdummy _, _ | _, Tdummy _) when lang() == Haskell -> () | Tdummy _, Tdummy _ -> () - | t, u when t = u -> () (* for Tvar, Tvar', Tunknown, Taxiom *) + | Tvar i, Tvar j when Int.equal i j -> () + | Tvar' i, Tvar' j when Int.equal i j -> () + | Tunknown, Tunknown -> () + | Taxiom, Taxiom -> () | _ -> 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_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 +let put_magic p a = if needs_magic p && lang () != Scheme then MLmagic a else a let generalizable a = - lang () <> Ocaml || + lang () != Ocaml || match a with | MLapp _ -> false | _ -> true (* TODO, this is just an approximation for the moment *) @@ -148,7 +166,7 @@ module Mlenv = struct (* [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 m when Option.is_empty m.contents -> 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 @@ -172,12 +190,12 @@ module Mlenv = struct 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 map = ref (Int.Map.empty : int Int.Map.t) in + let add_new i = incr c; map := Int.Map.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) + (try Tvar (Int.Map.find i !map) with Not_found -> if Metaset.mem m mle.free then t else Tvar (add_new i)) @@ -225,21 +243,6 @@ let type_maxvar t = | _ -> 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 @@ -283,13 +286,13 @@ let type_simpl = type_expand (fun _ -> None) (*s Generating a signature from a ML type. *) let type_to_sign env t = match type_expand env t with - | Tdummy d -> Kill d + | Tdummy d when not (conservative_types ()) -> 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 (Tdummy d, b) when not (conservative_types ()) -> Kill d :: f b | Tarr (_, b) -> Keep :: f b | _ -> [] in f (type_expand env t) @@ -318,7 +321,7 @@ let rec sign_kind = function | NonLogicalSig -> NonLogicalSig | UnsafeLogicalSig -> UnsafeLogicalSig | SafeLogicalSig | EmptySig -> - if k = Kother then UnsafeLogicalSig else SafeLogicalSig + if k == Kother then UnsafeLogicalSig else SafeLogicalSig (* Removing the final [Keep] in a signature *) @@ -326,17 +329,17 @@ let rec sign_no_final_keeps = function | [] -> [] | k :: s -> let s' = k :: sign_no_final_keeps s in - if s' = [Keep] then [] else s' + match s' with [Keep] -> [] | _ -> 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 + if List.is_empty 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 + 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) @@ -344,7 +347,7 @@ let type_expunge_from_sign env s t = | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in - if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then + if lang () != Haskell && sign_kind s == UnsafeLogicalSig then Tarr (Tdummy Kother, t) else t @@ -353,7 +356,55 @@ let type_expunge env t = (*S Generic functions over ML ast terms. *) -let mlapp f a = if a = [] then f else MLapp (f,a) +let mlapp f a = if List.is_empty a then f else MLapp (f,a) + +(** Equality *) + +let eq_ml_ident i1 i2 = match i1, i2 with +| Dummy, Dummy -> true +| Id id1, Id id2 -> Id.equal id1 id2 +| Tmp id1, Tmp id2 -> Id.equal id1 id2 +| _ -> false + +let rec eq_ml_ast t1 t2 = match t1, t2 with +| MLrel i1, MLrel i2 -> + Int.equal i1 i2 +| MLapp (f1, t1), MLapp (f2, t2) -> + eq_ml_ast f1 f2 && List.equal eq_ml_ast t1 t2 +| MLlam (na1, t1), MLlam (na2, t2) -> + eq_ml_ident na1 na2 && eq_ml_ast t1 t2 +| MLletin (na1, c1, t1), MLletin (na2, c2, t2) -> + eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2 +| MLglob gr1, MLglob gr2 -> eq_gr gr1 gr2 +| MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) -> + eq_ml_type t1 t2 && eq_gr gr1 gr2 && List.equal eq_ml_ast c1 c2 +| MLtuple t1, MLtuple t2 -> + List.equal eq_ml_ast t1 t2 +| MLcase (t1, c1, p1), MLcase (t2, c2, p2) -> + eq_ml_type t1 t2 && eq_ml_ast c1 c2 && Array.equal eq_ml_branch p1 p2 +| MLfix (i1, id1, t1), MLfix (i2, id2, t2) -> + Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2 +| MLexn e1, MLexn e2 -> String.equal e1 e2 +| MLdummy, MLdummy -> true +| MLaxiom, MLaxiom -> true +| MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 +| _ -> false + +and eq_ml_pattern p1 p2 = match p1, p2 with +| Pcons (gr1, p1), Pcons (gr2, p2) -> + eq_gr gr1 gr2 && List.equal eq_ml_pattern p1 p2 +| Ptuple p1, Ptuple p2 -> + List.equal eq_ml_pattern p1 p2 +| Prel i1, Prel i2 -> + Int.equal i1 i2 +| Pwild, Pwild -> true +| Pusual gr1, Pusual gr2 -> eq_gr gr1 gr2 +| _ -> false + +and eq_ml_branch (id1, p1, t1) (id2, p2, t2) = + List.equal eq_ml_ident id1 id2 && + eq_ml_pattern p1 p2 && + eq_ml_ast t1 t2 (*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]. *) @@ -428,7 +479,7 @@ let ast_iter f = function let ast_occurs k t = try - ast_iter_rel (fun i -> if i = k then raise Found) t; false + ast_iter_rel (fun i -> if Int.equal i k then raise Found) t; false with Found -> true (*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] @@ -444,7 +495,7 @@ let ast_occurs_itvl k k' t = let nb_occur_match = let rec nb k = function - | MLrel i -> if i = k then 1 else 0 + | MLrel i -> if Int.equal i k then 1 else 0 | MLcase(_,a,v) -> (nb k a) + Array.fold_left @@ -466,7 +517,7 @@ 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 + in if Int.equal k 0 then t else liftrec 0 t let ast_pop t = ast_lift (-1) t @@ -490,7 +541,7 @@ 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 + if Int.equal i' 1 then ast_lift n e else if i'<1 then a else MLrel (i-1) | a -> ast_map_lift subst n a @@ -525,17 +576,18 @@ let has_deep_pattern br = | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l) | Pusual _ | Prel _ | Pwild -> false in - array_exists (function (_,pat,_) -> deep pat) br + Array.exists (function (_,pat,_) -> deep pat) br let is_regular_match br = - if Array.length br = 0 then false (* empty match becomes MLexn *) + if Array.is_empty br then false (* empty match becomes MLexn *) else try let get_r (ids,pat,c) = match pat with | Pusual r -> r | Pcons (r,l) -> - if not (list_for_all_i (fun i -> (=) (Prel i)) 1 (List.rev l)) + let is_rel i = function Prel j -> Int.equal i j | _ -> false in + if not (List.for_all_i is_rel 1 (List.rev l)) then raise Impossible; r | _ -> raise Impossible @@ -544,7 +596,11 @@ let is_regular_match br = | ConstructRef (ind,_) -> ind | _ -> raise Impossible in - array_for_all_i (fun i tr -> get_r tr = ConstructRef (ind,i+1)) 0 br + let is_ref i tr = match get_r tr with + | ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) + | _ -> false + in + Array.for_all_i is_ref 0 br with Impossible -> false (*S Operations concerning lambdas. *) @@ -562,7 +618,7 @@ let collect_lams = let collect_n_lams = let rec collect acc n t = - if n = 0 then acc,t + if Int.equal n 0 then acc,t else match t with | MLlam(id,t) -> collect (id::acc) (n-1) t | _ -> assert false @@ -571,7 +627,7 @@ let collect_n_lams = (*s [remove_n_lams] just removes some [MLlam]. *) let rec remove_n_lams n t = - if n = 0 then t + if Int.equal n 0 then t else match t with | MLlam(_,t) -> remove_n_lams (n-1) t | _ -> assert false @@ -609,7 +665,7 @@ let rec anonym_or_dummy_lams a = function (*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)) + if Int.equal n 0 then [] else (MLrel n)::(eta_args (pred n)) (*s Same, but filtered by a signature. *) @@ -621,25 +677,26 @@ let rec eta_args_sign n = function (*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) + | [] -> Int.equal n 0 + | MLrel m :: q -> Int.equal (k+n) m && (test_eta_args_lift k (pred n) q) + | _ -> false (*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 + if Int.equal 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 + if Int.equal m n then [], f, a else if m < n then - list_skipn m ids, f, a + List.skipn m ids, f, a else (* m > n *) - let a1,a2 = list_chop (m-n) a in + let a1,a2 = List.chop (m-n) a in [], MLapp (f,a1), a2 in let p = List.length args in @@ -715,7 +772,7 @@ let branch_as_fun typ (l,p,c) = if i'<1 then c else if i'>nargs then MLrel (i-nargs+1) else raise Impossible - | MLcons _ as cons' when cons' = ast_lift n cons -> MLrel (n+1) + | MLcons _ as cons' when eq_ml_ast cons' (ast_lift n cons) -> MLrel (n+1) | a -> ast_map_lift genrec n a in genrec 0 c @@ -739,27 +796,33 @@ let branch_as_cst (l,_,c) = When searching for the best factorisation below, we'll try both. *) -(* The following structure allows to record which element occurred +(* The following structure allows recording 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 s = try Hashtbl.find h e with Not_found -> Intset.empty in - Hashtbl.replace h e (Intset.add i s) + let h = ref [] in + let clearf () = h := [] in + let rec add k v = function + | [] -> raise Not_found + | (k', s) as p :: l -> + if eq_ml_ast k k' then (k', Int.Set.add v s) :: l + else p :: add k v l + in + let addf k i = + try h := add k i !h + with Not_found -> h := (k, Int.Set.singleton i) :: !h in - let max e0 = - let len = ref 0 and lst = ref Intset.empty and elm = ref e0 in - Hashtbl.iter - (fun e s -> - let n = Intset.cardinal s in + let maxf k = + let len = ref 0 and lst = ref Int.Set.empty and elm = ref k in + List.iter + (fun (e, s) -> + let n = Int.Set.cardinal s in if n > !len then begin len := n; lst := s; elm := e end) - h; + !h; (!elm,!lst) in - (add,max,clear) + (addf,maxf,clearf) (* [factor_branches] return the longest possible list of branches that have the same factorization, either as a function or as a @@ -771,7 +834,7 @@ let is_opt_pat (_,p,_) = match p with | _ -> false let factor_branches o typ br = - if array_exists is_opt_pat br then None (* already optimized *) + if Array.exists is_opt_pat br then None (* already optimized *) else begin census_clean (); for i = 0 to Array.length br - 1 do @@ -782,8 +845,8 @@ let factor_branches o typ br = done; let br_factor, br_set = census_max MLdummy in census_clean (); - let n = Intset.cardinal br_set in - if n = 0 then None + let n = Int.Set.cardinal br_set in + if Int.equal n 0 then None else if Array.length br >= 2 && n < 2 then None else Some (br_factor, br_set) end @@ -794,17 +857,17 @@ 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') + (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 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) + if Int.equal !nb max_int || Int.equal !nb 0 then ([],br) else begin let br = Array.copy br in let ids = ref [] in @@ -837,16 +900,16 @@ let rec iota_red i lift br ((typ,r,a) as cons) = if i >= Array.length br then raise Impossible; let (ids,p,c) = br.(i) in match p with - | Pusual r' | Pcons (r',_) when r'<>r -> iota_red (i+1) lift br cons + | Pusual r' | Pcons (r',_) when not (Globnames.eq_gr r' r) -> iota_red (i+1) lift br cons | Pusual r' -> let c = named_lams (List.rev ids) c in let c = ast_lift lift c in MLapp (c,a) - | Prel 1 when List.length ids = 1 -> + | Prel 1 when Int.equal (List.length ids) 1 -> let c = MLlam (List.hd ids, c) in let c = ast_lift lift c in MLapp(c,[MLcons(typ,r,a)]) - | Pwild when ids = [] -> ast_lift lift c + | Pwild when List.is_empty ids -> ast_lift lift c | _ -> raise Impossible (* TODO: handle some more cases *) (* [iota_gen] is an extension of [iota_red] where we allow to @@ -872,15 +935,11 @@ let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false Unfolding them leads to more natural code (and more dummy removal) *) let is_program_branch = function - | Id id -> - let s = string_of_id id in - let br = "program_branch_" in - let n = String.length br in - (try - ignore (int_of_string (String.sub s n (String.length s - n))); - String.sub s 0 n = br - with e when Errors.noncritical e -> false) | Tmp _ | Dummy -> false + | Id id -> + let s = Id.to_string id in + try Scanf.sscanf s "program_branch_%d%!" (fun _ -> true) + with Scanf.Scan_failure _ | End_of_file -> false let expand_linear_let o id e = o.opt_lin_let || is_tmp id || is_program_branch id || is_imm_apply e @@ -901,7 +960,7 @@ let rec simpl o = function if (is_atomic c) || (is_atomic e) || (let n = nb_occur_match e in - (n = 0 || (n=1 && expand_linear_let o id e))) + (Int.equal n 0 || (Int.equal n 1 && expand_linear_let o id e))) then simpl o (ast_subst c e) else @@ -954,14 +1013,14 @@ and simpl_case o typ br e = (* 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 + if not (Int.equal n 0) then simpl o (named_lams ids (MLcase (typ, ast_lift n e, br))) else (* Can we merge several branches as the same constant or function ? *) - if lang() = Scheme || is_custom_match br + if lang() == Scheme || is_custom_match br then MLcase (typ, e, br) else match factor_branches o typ br with - | Some (f,ints) when Intset.cardinal ints = Array.length br -> + | Some (f,ints) when Int.equal (Int.Set.cardinal 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) -> @@ -970,7 +1029,7 @@ and simpl_case o typ br e = else ([], Pwild, ast_pop f) in let brl = Array.to_list br in - let brl_opt = list_filter_i (fun i _ -> not (Intset.mem i ints)) brl in + let brl_opt = List.filteri (fun i _ -> not (Int.Set.mem i ints)) brl in let brl_opt = brl_opt @ [last_br] in MLcase (typ, e, Array.of_list brl_opt) | None -> MLcase (typ, e, br) @@ -996,9 +1055,9 @@ let rec select_via_bl l args = match l,args with 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 + let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in + if Int.equal n n' then ids,c + else if Int.equal n' 0 then [],ast_lift (-n) c else begin let v = Array.make n None in let rec parse_ids i j = function @@ -1016,15 +1075,15 @@ let kill_some_lams bl (ids,c) = let kill_dummy_lams c = let ids,c = collect_lams c in let bl = List.map sign_of_id ids in - if not (List.mem Keep bl) then raise Impossible; + if not (List.memq Keep bl) then raise Impossible; let rec fst_kill n = function | [] -> raise Impossible | Kill _ :: bl -> n | Keep :: bl -> fst_kill (n+1) bl in let skip = max 0 ((fst_kill 0 bl) - 1) in - let ids_skip, ids = list_chop skip ids in - let _, bl = list_chop skip bl in + let ids_skip, ids = List.chop skip ids in + let _, bl = List.chop skip bl in let c = named_lams ids_skip c in let ids',c = kill_some_lams bl (ids,c) in ids, named_lams ids' c @@ -1052,7 +1111,7 @@ 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 + 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] @@ -1061,10 +1120,10 @@ let case_expunge s e = if all lambdas are logical dummy and the target language is strict. *) let term_expunge s (ids,c) = - if s = [] then c + if List.is_empty 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 + if List.is_empty ids && lang () != Haskell && List.mem (Kill Kother) s then MLlam (Dummy, ast_lift 1 c) else named_lams ids c @@ -1076,7 +1135,7 @@ let kill_dummy_args ids r t = let m = List.length ids in let bl = List.rev_map sign_of_id ids in let rec found n = function - | MLrel r' when r' = r + n -> true + | MLrel r' when Int.equal r' (r + n) -> true | MLmagic e -> found n e | _ -> false in @@ -1086,7 +1145,7 @@ let kill_dummy_args ids r t = 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)) + named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> let a = select_via_bl bl (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) @@ -1153,7 +1212,7 @@ 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' + if eq_ml_ast a a' then a else norm a' in norm a (*S Special treatment of fixpoint for pretty-printing purpose. *) @@ -1165,7 +1224,7 @@ let general_optimize_fix f ids n args m c = | 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; + in List.iteri 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 @@ -1176,7 +1235,7 @@ let optimize_fix a = else let ids,a' = collect_lams a in let n = List.length ids in - if n = 0 then a + if Int.equal n 0 then a else match a' with | MLfix(_,[|f|],[|c|]) -> let new_f = MLapp (MLrel (n+1),eta_args n) in @@ -1244,7 +1303,7 @@ let rec non_stricts add cand = function let cand = if add then 1::cand else cand in pop 1 (non_stricts add cand t) | MLrel n -> - List.filter ((<>) n) cand + List.filter (fun m -> not (Int.equal m n)) cand | MLapp (t,l)-> let cand = non_stricts false cand t in List.fold_left (non_stricts false) cand l @@ -1268,7 +1327,7 @@ let rec non_stricts add cand = function 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 + List.merge Int.compare cand c) [] v (* [merge] may duplicates some indices, but I don't mind. *) | MLmagic t -> non_stricts add cand t @@ -1304,7 +1363,7 @@ let is_not_strict t = restriction for the moment. *) -open Declarations +open Declareops let inline_test r t = if not (auto_inline ()) then false @@ -1312,7 +1371,7 @@ let inline_test r t = let c = match r with ConstRef c -> c | _ -> assert false in let has_body = try constant_has_body (Global.lookup_constant c) - with e when Errors.noncritical e -> false + with Not_found -> false in has_body && (let t1 = eta_red t in @@ -1320,10 +1379,8 @@ let inline_test r t = 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 d, id = Libnames.split_dirpath (dirpath_of_string s) in + Constant.make2 (MPfile d) (Label.of_id id) let manual_inline_set = List.fold_right (fun x -> Cset_env.add (con_of_string x)) @@ -1355,6 +1412,6 @@ 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) && + || (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 index 94e6ae69..0a71d2c8 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -1,15 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 eq_ml_type : ml_type -> ml_type -> bool val isDummy : ml_type -> bool val isKill : sign -> bool @@ -78,10 +77,10 @@ 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 anonymous_name : Id.t +val dummy_name : Id.t +val id_of_name : Name.t -> Id.t +val id_of_mlid : ml_ident -> Id.t val tmp_id : ml_ident -> ml_ident (*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 2c923241..8158ac64 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -1,27 +1,25 @@ (************************************************************************) (* 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" + | _ -> anomaly ~label:"extraction" (Pp.str "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]. *) @@ -32,16 +30,16 @@ let se_iter do_decl do_spec do_mp = | 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 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' + 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 + let r = ConstRef (Constant.make2 mp_w (Label.of_id l')) in mt_iter mt; do_decl (Dtype(r,l,t)) | MTwith (mt,ML_With_module(idl,mp))-> let mp_mt = msid_of_mt mt in let mp_w = - List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl + List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl in mt_iter mt; do_mp mp_w; do_mp mp | MTsig (_, sign) -> List.iter spec_iter sign @@ -110,13 +108,13 @@ let ind_iter_references do_term do_cons do_type kn ind = 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 + 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_kind; + if lang () == Ocaml then record_iter_references do_term ind.ind_kind; Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets let decl_iter_references do_term do_cons do_type = @@ -199,6 +197,11 @@ let rec msig_of_ms = function let signature_of_structure s = List.map (fun (mp,ms) -> mp,msig_of_ms ms) s +let rec mtyp_of_mexpr = function + | MEfunctor (id,ty,e) -> MTfunsig (id,ty, mtyp_of_mexpr e) + | MEstruct (mp,str) -> MTsig (mp, msig_of_ms str) + | _ -> assert false + (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) @@ -208,18 +211,18 @@ let is_modular = function let rec search_structure l m = function | [] -> raise Not_found - | (lab,d)::_ when lab=l && is_modular d = m -> d + | (lab,d)::_ when Label.equal lab l && (is_modular d : bool) == m -> d | _::fields -> search_structure l m fields 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 sel = List.assoc_f ModPath.equal base_mp struc in let rec go ll sel = match ll with | [] -> assert false | l :: ll -> - match search_structure l (ll<>[]) sel with + match search_structure l (not (List.is_empty ll)) sel with | SEdecl d -> d | SEmodtype m -> assert false | SEmodule m -> @@ -228,7 +231,7 @@ let get_decl_in_structure r struc = | _ -> error_not_visible r in go ll sel with Not_found -> - anomaly "reference not found in extracted structure" + anomaly (Pp.str "reference not found in extracted structure") (*s Optimization of a [ml_structure]. *) @@ -251,7 +254,7 @@ let dfix_to_mlfix rv av i = (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 ids = Array.map (fun r -> Label.to_id (label_of_r r)) rv in let c = Array.map (subst 0) av in MLfix(i, ids, c) @@ -297,8 +300,6 @@ and optim_me to_appear s = function For non-library extraction, we recompute a minimal set of dependencies for first-level definitions (no module pruning yet). *) -exception NoDepCheck - let base_r = function | ConstRef c as r -> r | IndRef (kn,_) -> IndRef (kn,0) @@ -353,7 +354,7 @@ let rec depcheck_se = function let se' = depcheck_se se in let refs = declared_refs d in let refs' = List.filter is_needed refs in - if refs' = [] then + if List.is_empty refs' then (List.iter remove_info_axiom refs; List.iter remove_opaque refs; se') @@ -362,7 +363,7 @@ let rec depcheck_se = function (* Hack to avoid extracting unused part of a Dfix *) match d with | Dfix (rv,trms,tys) when (List.for_all is_custom refs') -> - let trms' = Array.create (Array.length rv) (MLexn "UNUSED") in + let trms' = Array.make (Array.length rv) (MLexn "UNUSED") in ((l,SEdecl (Dfix (rv,trms',tys))) :: se') | _ -> (compute_deps_decl d; t::se') end @@ -376,14 +377,22 @@ let rec depcheck_struct = function | (mp,lse)::struc -> let struc' = depcheck_struct struc in let lse' = depcheck_se lse in - if lse' = [] then struc' else (mp,lse')::struc' + if List.is_empty lse' then struc' else (mp,lse')::struc' + +let is_prefix pre s = + let len = String.length pre in + let rec is_prefix_aux i = + if Int.equal i len then true + else pre.[i] == s.[i] && is_prefix_aux (succ i) + in + is_prefix_aux 0 let check_implicits = function | MLexn s -> - if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then + 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 + if is_prefix "UNBOUND" s then assert false; + if is_prefix "IMPLICIT" s then error_non_implicit (String.sub s 9 (String.length s - 9)); end; false @@ -397,7 +406,7 @@ let optimize_struct to_appear struc = in ignore (struct_ast_search check_implicits opt_struc); if library () then - List.filter (fun (_,lse) -> lse<>[]) opt_struc + List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc else begin reset_needed (); List.iter add_needed (fst to_appear); diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index 58d8167d..ca32f029 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -1,17 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool) -> ml_structure -> bool type do_ref = global_reference -> unit +val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> 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 mtyp_of_mexpr : ml_module_expr -> ml_module_type + val msid_of_mt : ml_module_type -> module_path val get_decl_in_structure : global_reference -> ml_structure -> ml_decl diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 70e71eeb..30ac3d3f 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* '\'' - then str ("'"^s) - else str ("' "^s) +let pp_tvar id = str ("'" ^ Id.to_string id) let pp_abst = function | [] -> mt () @@ -36,10 +32,10 @@ let pp_abst = function str " ->" ++ spc () let pp_parameters l = - (pp_boxed_tuple pp_tvar l ++ space_if (l<>[])) + (pp_boxed_tuple pp_tvar l ++ space_if (not (List.is_empty l))) let pp_string_parameters l = - (pp_boxed_tuple str l ++ space_if (l<>[])) + (pp_boxed_tuple str l ++ space_if (not (List.is_empty l))) let pp_letin pat def body = let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in @@ -48,7 +44,7 @@ let pp_letin pat def body = (*s Ocaml renaming issues. *) let keywords = - List.fold_right (fun s -> Idset.add (id_of_string s)) + List.fold_right (fun s -> Id.Set.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"; @@ -57,22 +53,30 @@ let keywords = "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 + Id.Set.empty let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") -let preamble _ used_modules usf = +let pp_comment s = str "(* " ++ hov 0 s ++ str " *)" + +let pp_header_comment = function + | None -> mt () + | Some com -> pp_comment com ++ fnl () ++ fnl () + +let preamble _ comment used_modules usf = + pp_header_comment comment ++ prlist pp_open used_modules ++ - (if used_modules = [] then mt () else fnl ()) ++ + (if List.is_empty 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 = +let sig_preamble _ comment used_modules usf = + pp_header_comment comment ++ fnl () ++ fnl () ++ prlist pp_open used_modules ++ - (if used_modules = [] then mt () else fnl ()) ++ + (if List.is_empty 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*) @@ -93,7 +97,7 @@ 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] = ')') + l >= 2 && s.[0] == '(' && s.[l-1] == ')') let get_infix r = let s = find_custom r in @@ -110,22 +114,21 @@ let pp_one_field r i = function let pp_field r fields i = pp_one_field r i (List.nth fields i) -let pp_fields r fields = list_map_i (pp_one_field r) 0 fields +let pp_fields r fields = List.map_i (pp_one_field r) 0 fields (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses are needed or not. *) -let rec pp_type par vl t = +let 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 e when Errors.noncritical e -> - (str "'a" ++ int i)) + with Failure _ -> (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 not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> + when not (keep_singleton ()) && MutInd.equal 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 @@ -149,7 +152,7 @@ let is_bool_patt p s = | Pcons (r,[]) -> r | _ -> raise Not_found in - find_custom r = s + String.equal (find_custom r) s with Not_found -> false @@ -186,7 +189,7 @@ let rec pp_expr par env args = hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) | MLglob r -> (try - let args = list_skipn (projection_arity r) args in + 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 e when Errors.noncritical e -> apply (pp_global Term r)) @@ -203,35 +206,35 @@ let rec pp_expr par env args = | MLaxiom -> pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") | MLcons (_,r,a) as c -> - assert (args=[]); + assert (List.is_empty args); begin match a with | _ when is_native_char c -> pp_native_char c | [a1;a2] when is_infix r -> let pp = pp_expr true env [] in pp_par par (pp a1 ++ str (get_infix r) ++ pp a2) | _ when is_coinductive r -> - let ne = (a<>[]) in + let ne = not (List.is_empty a) in let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple)) | [] -> pp_global Cons r | _ -> let fds = get_record_fields r in - if fds <> [] then + if not (List.is_empty fds) then pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a) else let tuple = pp_tuple (pp_expr true env []) a in - if str_global Cons r = "" (* hack Extract Inductive prod *) + if String.is_empty (str_global Cons r) (* hack Extract Inductive prod *) then tuple else pp_par par (pp_global Cons r ++ spc () ++ tuple) end | MLtuple l -> - assert (args = []); + assert (List.is_empty args); pp_boxed_tuple (pp_expr true env []) l | MLcase (_, t, pv) when is_custom_match pv -> if not (is_regular_match pv) then error "Cannot mix yet user-given match and general patterns."; let mkfun (ids,_,e) = - if ids <> [] then named_lams (List.rev ids) e + if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in @@ -250,7 +253,7 @@ let rec pp_expr par env args = (try pp_record_proj par env typ t pv args with Impossible -> (* Second, can this match be printed as a let-in ? *) - if Array.length pv = 1 then + if Int.equal (Array.length pv) 1 then let s1,s2 = pp_one_pat env pv.(0) in hv 0 (apply2 (pp_letin s1 head s2)) else @@ -265,8 +268,8 @@ let rec pp_expr par env args = and pp_record_proj par env typ t pv args = (* Can a match be printed as a mere record projection ? *) let fields = record_fields_of_type typ in - if fields = [] then raise Impossible; - if Array.length pv <> 1 then raise Impossible; + if List.is_empty fields then raise Impossible; + if not (Int.equal (Array.length pv) 1) then raise Impossible; if has_deep_pattern pv then raise Impossible; let (ids,pat,body) = pv.(0) in let n = List.length ids in @@ -277,7 +280,7 @@ and pp_record_proj par env typ t pv args = | _ -> raise Impossible in let rec lookup_rel i idx = function - | Prel j :: l -> if i = j then idx else lookup_rel i (idx+1) l + | Prel j :: l -> if Int.equal i j then idx else lookup_rel i (idx+1) l | Pwild :: l -> lookup_rel i (idx+1) l | _ -> raise Impossible in @@ -301,15 +304,15 @@ and pp_record_pat (fields, args) = str " }" and pp_cons_pat r ppl = - if is_infix r && List.length ppl = 2 then + if is_infix r && Int.equal (List.length ppl) 2 then List.hd ppl ++ str (get_infix r) ++ List.hd (List.tl ppl) else let fields = get_record_fields r in - if fields <> [] then pp_record_pat (pp_fields r fields, ppl) - else if str_global Cons r = "" then + if not (List.is_empty fields) then pp_record_pat (pp_fields r fields, ppl) + else if String.is_empty (str_global Cons r) then pp_boxed_tuple identity ppl (* Hack Extract Inductive prod *) else - pp_global Cons r ++ space_if (ppl<>[]) ++ pp_boxed_tuple identity ppl + pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ pp_boxed_tuple identity ppl and pp_gen_pat ids env = function | Pcons (r, l) -> pp_cons_pat r (List.map (pp_gen_pat ids env) l) @@ -339,7 +342,7 @@ and pp_pat env pv = (fun i x -> let s1,s2 = pp_one_pat env x in hv 2 (hov 4 (str "| " ++ s1 ++ str " ->") ++ spc () ++ hov 2 s2) ++ - if i = Array.length pv - 1 then mt () else fnl ()) + if Int.equal i (Array.length pv - 1) then mt () else fnl ()) pv and pp_function env t = @@ -347,7 +350,7 @@ and pp_function env t = let bl,env' = push_vars (List.map id_of_mlid bl) env in match t' with | MLcase(Tglob(r,_),MLrel 1,pv) when - not (is_coinductive r) && get_record_fields r = [] && + not (is_coinductive r) && List.is_empty (get_record_fields r) && not (is_custom_match pv) -> if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then pr_binding (List.rev (List.tl bl)) ++ @@ -371,7 +374,7 @@ and pp_fix par env i (ids,bl) args = 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) ++ + (Array.map2 (fun id b -> (id,b)) ids bl) ++ fnl () ++ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) @@ -390,7 +393,7 @@ let pp_Dfix (rv,c,t) = (if init then failwith "empty phrase" else mt ()) else let void = is_inline_custom rv.(i) || - (not (is_custom rv.(i)) && c.(i) = MLexn "UNUSED") + (not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then pp init (i+1) else @@ -413,20 +416,19 @@ let pp_equiv param_list name = function | 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 ()) ++ + (if Int.equal i 0 then mt () else fnl ()) ++ hov 3 (str "| " ++ cnames.(i) ++ - (if typs = [] then mt () else str " of ") ++ + (if List.is_empty 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 *)" + if Int.equal (Array.length ctyps) 0 then str " unit (* empty inductive *)" else fnl () ++ v 0 (prvecti pp_constructor ctyps) let pp_logical_ind packet = @@ -525,7 +527,7 @@ let pp_decl = function pp_string_parameters ids, str "=" ++ spc () ++ str s with Not_found -> pp_parameters l, - if t = Taxiom then str "(* AXIOM TO BE REALIZED *)" + 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) @@ -632,7 +634,7 @@ and pp_module_type params = function str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MTsig (mp, sign) -> push_visible mp params; - let l = map_succeed pp_specif sign in + let l = List.map pp_specif sign in pop_visible (); str "sig " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ @@ -640,11 +642,11 @@ and pp_module_type params = function | 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 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' + 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 + let r = ConstRef (Constant.make2 mp_w (Label.of_id l)) in push_visible mp_mt []; let pp_w = str " with type " ++ ids ++ pp_global Type r in pop_visible(); @@ -652,7 +654,7 @@ and pp_module_type params = function | 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 + 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 @@ -672,7 +674,7 @@ let rec pp_structure_elem = function | (l,SEmodule m) -> let typ = (* virtual printing of the type, in order to have a correct mli later*) - if Common.get_phase () = Pre then + if Common.get_phase () == Pre then str ": " ++ pp_module_type [] m.ml_mod_type else mt () in @@ -705,7 +707,7 @@ and pp_module_expr params = function str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MEstruct (mp, sel) -> push_visible mp params; - let l = map_succeed pp_structure_elem sel in + let l = List.map pp_structure_elem sel in pop_visible (); str "struct " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli index 36035b5a..4e796792 100644 --- a/plugins/extraction/ocaml.mli +++ b/plugins/extraction/ocaml.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Idset.add (id_of_string s)) + List.fold_right (fun s -> Id.Set.add (Id.of_string s)) [ "define"; "let"; "lambda"; "lambdas"; "match"; "apply"; "car"; "cdr"; "error"; "delay"; "force"; "_"; "__"] - Idset.empty + Id.Set.empty -let preamble _ _ usf = +let pp_comment s = str";; "++h 0 s++fnl () + +let pp_header_comment = function + | None -> mt () + | Some com -> pp_comment com ++ fnl () ++ fnl () + +let preamble _ comment _ usf = + pp_header_comment comment ++ str ";; This extracted scheme code relies on some additional macros\n" ++ - str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++ + str ";; available at http://www.pps.univ-paris-diderot.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 + let s = Id.to_string id in for i = 0 to String.length s - 1 do - if s.[i] = '\'' then s.[i] <- '~' + if s.[i] == '\'' then s.[i] <- '~' done; str s @@ -86,11 +92,11 @@ let rec pp_expr env args = | MLglob r -> apply (pp_global Term r) | MLcons (_,r,args') -> - assert (args=[]); + assert (List.is_empty args); let st = str "`" ++ paren (pp_global Cons r ++ - (if args' = [] then mt () else spc ()) ++ + (if List.is_empty args' then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args') in if is_coinductive r then paren (str "delay " ++ st) else st @@ -99,7 +105,7 @@ let rec pp_expr env args = error "Cannot handle general patterns in Scheme yet." | MLcase (_,t,pv) when is_custom_match pv -> let mkfun (ids,_,e) = - if ids <> [] then named_lams (List.rev ids) e + if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in apply @@ -129,7 +135,7 @@ let rec pp_expr env args = and pp_cons_args env = function | MLcons (_,r,args) when is_coinductive r -> paren (pp_global Cons r ++ - (if args = [] then mt () else spc ()) ++ + (if List.is_empty args then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args) | e -> str "," ++ pp_expr env [] e @@ -141,7 +147,7 @@ and pp_one_pat env (ids,p,t) = in let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in let args = - if ids = [] then mt () + if List.is_empty ids then mt () else (str " " ++ prlist_with_sep spc pr_id (List.rev ids)) in (pp_global Cons r ++ args), (pp_expr env' [] t) @@ -161,7 +167,7 @@ and pp_fix env j (ids,bl) args = (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)) ++ + (Array.map2 (fun id b -> (id,b)) ids bl)) ++ fnl () ++ hov 2 (pp_apply (pr_id (ids.(j))) true args)))) @@ -177,7 +183,7 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && defs.(i) = MLexn "UNUSED") + (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else @@ -222,7 +228,7 @@ let scheme_descr = { preamble = preamble; pp_struct = pp_struct; sig_suffix = None; - sig_preamble = (fun _ _ _ -> mt ()); + sig_preamble = (fun _ _ _ _ -> mt ()); pp_sig = (fun _ -> mt ()); pp_decl = pp_decl; } diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli index 2a2bf48e..f0e36e09 100644 --- a/plugins/extraction/scheme.mli +++ b/plugins/extraction/scheme.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* kn = kn' + | ConstructRef ((kn',_),_) -> Names.eq_mind kn kn' | ConstRef _ -> false | VarRef _ -> assert false @@ -54,21 +55,19 @@ let is_modfile = function | _ -> false let raw_string_of_modfile = function - | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) + | MPfile f -> String.capitalize (Id.to_string (List.hd (DirPath.repr f))) | _ -> assert false -let current_toplevel () = fst (Lib.current_prefix ()) - let is_toplevel mp = - mp = initial_path || mp = current_toplevel () + ModPath.equal mp initial_path || ModPath.equal mp (Lib.current_mp ()) let at_toplevel mp = is_modfile mp || is_toplevel mp -let rec mp_length mp = - let mp0 = current_toplevel () in +let mp_length mp = + let mp0 = Lib.current_mp () in let rec len = function - | mp when mp = mp0 -> 1 + | mp when ModPath.equal mp mp0 -> 1 | MPdot (mp,_) -> 1 + len mp | _ -> 1 in len mp @@ -80,7 +79,7 @@ let rec prefixes_mp mp = match mp with | _ -> 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 + | MPdot (mp,l) -> if Int.equal 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 = @@ -91,12 +90,12 @@ let common_prefix_from_list mp0 mpl = in f mpl let rec parse_labels2 ll mp1 = function - | mp when mp1=mp -> mp,ll + | mp when ModPath.equal 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_top = Lib.current_mp () in let mp,_,l = repr_of_r r in parse_labels2 [l] mp_top mp @@ -138,7 +137,7 @@ let is_coinductive r = | IndRef (kn,_) -> kn | _ -> assert false in - try Mindmap_env.find kn !inductive_kinds = Coinductive + try Mindmap_env.find kn !inductive_kinds == Coinductive with Not_found -> false let is_coinductive_type = function @@ -163,40 +162,39 @@ let record_fields_of_type = function (*s Recursors table. *) (* NB: here we can use the equivalence between canonical - and user constant names : Cset is fine, no need for [Cset_env] *) + and user constant names. *) -let recursors = ref Cset.empty -let init_recursors () = recursors := Cset.empty +let recursors = ref KNset.empty +let init_recursors () = recursors := KNset.empty -let add_recursors env kn = - let mk_con id = - make_con_equiv - (modpath (user_mind kn)) - (modpath (canonical_mind kn)) - empty_dirpath (label_of_id id) +let add_recursors env ind = + let kn = MutInd.canonical ind in + let mk_kn id = + KerName.make (KerName.modpath kn) DirPath.empty (Label.of_id id) in - let mib = Environ.lookup_mind kn env in + let mib = Environ.lookup_mind ind env in Array.iter (fun mip -> let id = mip.mind_typename in - let c_rec = mk_con (Nameops.add_suffix id "_rec") - and c_rect = mk_con (Nameops.add_suffix id "_rect") in - recursors := Cset.add c_rec (Cset.add c_rect !recursors)) + let kn_rec = mk_kn (Nameops.add_suffix id "_rec") + and kn_rect = mk_kn (Nameops.add_suffix id "_rect") in + recursors := KNset.add kn_rec (KNset.add kn_rect !recursors)) mib.mind_packets let is_recursor = function - | ConstRef kn -> Cset.mem kn !recursors + | ConstRef c -> KNset.mem (Constant.canonical c) !recursors | _ -> false (*s Record tables. *) (* NB: here, working modulo name equivalence is ok *) -let projs = ref (Refmap.empty : int Refmap.t) +let projs = ref (Refmap.empty : (inductive*int) Refmap.t) let init_projs () = projs := Refmap.empty -let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs +let add_projection n kn ip = projs := Refmap.add (ConstRef kn) (ip,n) !projs let is_projection r = Refmap.mem r !projs -let projection_arity r = Refmap.find r !projs +let projection_arity r = snd (Refmap.find r !projs) +let projection_info r = Refmap.find r !projs (*s Table of used axioms *) @@ -240,11 +238,11 @@ let safe_basename_of_global r = let last_chance r = try Nametab.basename_of_global r with Not_found -> - anomaly "Inductive object unknown to extraction and not globally visible" + anomaly (Pp.str "Inductive object unknown to extraction and not globally visible") in match r with - | ConstRef kn -> id_of_label (con_label kn) - | IndRef (kn,0) -> id_of_label (mind_label kn) + | ConstRef kn -> Label.to_id (con_label kn) + | IndRef (kn,0) -> Label.to_id (mind_label kn) | IndRef (kn,i) -> (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename with Not_found -> last_chance r) @@ -254,8 +252,8 @@ let safe_basename_of_global r = | VarRef _ -> assert false let string_of_global r = - try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) - with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r) + try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r) + with Not_found -> Id.to_string (safe_basename_of_global r) let safe_pr_global r = str (string_of_global r) @@ -263,15 +261,15 @@ let safe_pr_global r = str (string_of_global r) let safe_pr_long_global r = try Printer.pr_global r - with e when Errors.noncritical e -> match r with + with Not_found -> match r with | ConstRef kn -> let mp,_,l = repr_con kn in - str ((string_of_mp mp)^"."^(string_of_label l)) + str ((string_of_mp mp)^"."^(Label.to_string 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 lid = DirPath.repr (Nametab.dirpath_of_module mp) in + str (String.concat "." (List.rev_map Id.to_string lid)) let pr_long_global ref = pr_path (Nametab.path_of_global ref) @@ -281,18 +279,18 @@ let err s = errorlabstrm "Extraction" s let warning_axioms () = let info_axioms = Refset'.elements !info_axioms in - if info_axioms = [] then () + if List.is_empty info_axioms then () else begin - let s = if List.length info_axioms = 1 then "axiom" else "axioms" in + let s = if Int.equal (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 () + if List.is_empty log_axioms then () else begin - let s = if List.length log_axioms = 1 then "axiom was" else "axioms were" + let s = if Int.equal (List.length log_axioms) 1 then "axiom was" else "axioms were" in msg_warning (str ("The following logical "^s^" encountered:") ++ @@ -302,14 +300,11 @@ let warning_axioms () = str "Having invalid logical axiom in the environment when extracting" ++ spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ fnl ()) - end; - if !Flags.load_proofs = Flags.Dont && info_axioms@log_axioms <> [] then - msg_warning - (str "Some of these axioms might be due to option -dont-load-proofs.") + end let warning_opaques accessed = let opaques = Refset'.elements !opaques in - if opaques = [] then () + if List.is_empty opaques then () else let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in if accessed then @@ -337,7 +332,7 @@ let warning_both_mod_and_cst q mp r = let error_axiom_scheme r i = err (str "The type scheme axiom " ++ spc () ++ - safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ + safe_pr_global r ++ spc () ++ str "needs " ++ int i ++ str " type variable(s).") let check_inside_module () = @@ -409,9 +404,9 @@ let error_MPfile_as_mod mp b = let msg_non_implicit r n id = let name = match id with | Anonymous -> "" - | Name id -> "(" ^ string_of_id id ^ ") " + | Name id -> "(" ^ Id.to_string id ^ ") " in - "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) + "The " ^ (String.ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) let error_non_implicit msg = err (str (msg ^ " still occurs after extraction.") ++ @@ -420,16 +415,16 @@ let error_non_implicit msg = 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."))) + match base_mp (Lib.current_mp ()) with + | MPfile dp' when not (DirPath.equal dp dp') -> + err (str ("Please load library "^(DirPath.to_string dp^" first."))) | _ -> () end | _ -> () let info_file f = - Flags.if_verbose message - ("The file "^f^" has been created by extraction.") + Flags.if_verbose msg_info + (str ("The file "^f^" has been created by extraction.")) (*S The Extraction auxiliary commands *) @@ -481,7 +476,7 @@ type opt_flag = opt_lin_let : bool; (* 512 *) opt_lin_beta : bool } (* 1024 *) -let kth_digit n k = (n land (1 lsl k) <> 0) +let kth_digit n k = not (Int.equal (n land (1 lsl k)) 0) let flag_of_int n = { opt_kill_dum = kth_digit n 0; @@ -518,7 +513,7 @@ let _ = declare_bool_option optdepr = false; optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; - optread = (fun () -> !int_flag_ref <> 0); + optread = (fun () -> not (Int.equal !int_flag_ref 0)); optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} let _ = declare_int_option @@ -531,12 +526,37 @@ let _ = declare_int_option | None -> chg_flag 0 | Some i -> chg_flag (max i 0))} +(* This option controls whether "dummy lambda" are removed when a + toplevel constant is defined. *) +let conservative_types_ref = ref false +let conservative_types () = !conservative_types_ref + +let _ = declare_bool_option + {optsync = true; + optdepr = false; + optname = "Extraction Conservative Types"; + optkey = ["Extraction"; "Conservative"; "Types"]; + optread = (fun () -> !conservative_types_ref); + optwrite = (fun b -> conservative_types_ref := b) } + + +(* Allows to print a comment at the beginning of the output files *) +let file_comment_ref = ref "" +let file_comment () = !file_comment_ref + +let _ = declare_string_option + {optsync = true; + optdepr = false; + optname = "Extraction File Comment"; + optkey = ["Extraction"; "File"; "Comment"]; + optread = (fun () -> !file_comment_ref); + optwrite = (fun s -> file_comment_ref := s) } (*s Extraction Lang *) type lang = Ocaml | Haskell | Scheme -let lang_ref = ref Ocaml +let lang_ref = Summary.ref Ocaml ~name:"ExtrLang" let lang () = !lang_ref @@ -546,18 +566,13 @@ let extr_lang : lang -> obj = 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 inline_table = Summary.ref empty_inline_table ~name:"ExtrInline" let to_inline r = Refset'.mem r (fst !inline_table) @@ -584,11 +599,6 @@ let inline_extraction : bool * global_reference list -> obj = (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 = @@ -604,7 +614,6 @@ let extraction_inline b l = 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 -> @@ -626,15 +635,15 @@ let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) (*s Extraction Implicit *) -type int_or_id = ArgInt of int | ArgId of identifier +type int_or_id = ArgInt of int | ArgId of Id.t -let implicits_table = ref Refmap'.empty +let implicits_table = Summary.ref Refmap'.empty ~name:"ExtrImplicit" 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 typ = Global.type_of_global_unsafe r in let rels,_ = decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in let names = List.rev_map fst rels in @@ -645,7 +654,7 @@ let add_implicits r l = else err (int i ++ str " is not a valid argument number for " ++ safe_pr_global r) | ArgId id -> - (try list_index (Name id) names + (try List.index Name.equal (Name id) names with Not_found -> err (str "No argument " ++ pr_id id ++ str " for " ++ safe_pr_global r)) @@ -664,11 +673,6 @@ let implicit_extraction : global_reference * int_or_id list -> obj = 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 = @@ -678,21 +682,21 @@ let extraction_implicit r l = (*s Extraction Blacklist of filenames not to use while extracting *) -let blacklist_table = ref Idset.empty +let blacklist_table = Summary.ref Id.Set.empty ~name:"ExtrBlacklist" let modfile_ids = ref [] let modfile_mps = ref MPmap.empty let reset_modfile () = - modfile_ids := Idset.elements !blacklist_table; + modfile_ids := Id.Set.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 = 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 + let s' = Id.to_string id' in modfile_ids := id' :: !modfile_ids; modfile_mps := MPmap.add mp s' !modfile_mps; s' @@ -701,16 +705,16 @@ let string_of_modfile mp = let file_of_modfile mp = let s0 = match mp with - | MPfile f -> string_of_id (List.hd (repr_dirpath f)) + | MPfile f -> Id.to_string (List.hd (DirPath.repr f)) | _ -> assert false in let s = String.copy (string_of_modfile mp) in - if s.[0] <> s0.[0] then s.[0] <- s0.[0]; + 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))) + List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize s))) l !blacklist_table (* Registration of operations for rollback. *) @@ -723,40 +727,33 @@ let blacklist_extraction : string list -> obj = 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 + let l = List.rev_map Id.to_string 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)) + prlist_with_sep fnl pr_id (Id.Set.elements !blacklist_table) (* Reset part *) let reset_blacklist : unit -> obj = declare_object {(default_object "Reset Extraction Blacklist") with - cache_function = (fun (_,_)-> blacklist_table := Idset.empty); - load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)} + cache_function = (fun (_,_)-> blacklist_table := Id.Set.empty); + load_function = (fun _ (_,_)-> blacklist_table := Id.Set.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 (use_type_scheme_nb_args, type_scheme_nb_args_hook) = Hook.make () -let customs = ref Refmap'.empty +let customs = Summary.ref Refmap'.empty ~name:"ExtrCustom" let add_custom r ids s = customs := Refmap'.add r (ids,s) !customs @@ -768,13 +765,13 @@ 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 custom_matchs = Summary.ref Refmap'.empty ~name:"ExtrCustomMatchs" 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; + if Array.is_empty pv then raise Not_found; let (_,pat,_) = pv.(0) in match pat with | Pusual (ConstructRef (ip,_)) -> IndRef ip @@ -800,11 +797,6 @@ let in_customs : global_reference * string list * string -> obj = (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 : global_reference * string -> obj = declare_object {(default_object "ML extractions custom matchs") with @@ -814,11 +806,6 @@ let in_custom_matchs : global_reference * string -> obj = 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 = @@ -827,12 +814,12 @@ let extract_constant_inline inline r ids s = match g with | ConstRef kn -> let env = Global.env () in - let typ = Typeops.type_of_constant env kn in + let typ = Global.type_of_global_unsafe (ConstRef 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 + let nargs = Hook.get use_type_scheme_nb_args env typ in + if not (Int.equal (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)) @@ -847,12 +834,12 @@ let extract_inductive r s l optstr = | 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 (); + if not (Int.equal 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 + List.iteri (fun j s -> let g = ConstructRef (ip,succ j) in Lib.add_anonymous_leaf (inline_extraction (true,[g])); diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 14792f8f..1acbe355 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* identifier +val safe_basename_of_global : global_reference -> Id.t (*s Warning and Error messages. *) @@ -29,7 +30,7 @@ val error_inductive : global_reference -> 'a val error_nb_cons : unit -> 'a val error_module_clash : module_path -> module_path -> 'a val error_no_module_expr : module_path -> 'a -val error_singleton_become_prop : identifier -> 'a +val error_singleton_become_prop : Id.t -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a val error_not_visible : global_reference -> 'a @@ -37,7 +38,7 @@ val error_MPfile_as_mod : module_path -> bool -> '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 msg_non_implicit : global_reference -> int -> Name.t -> string val error_non_implicit : string -> 'a val info_file : string -> unit @@ -45,10 +46,9 @@ 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 repr_of_r : global_reference -> module_path * DirPath.t * Label.t val modpath_of_r : global_reference -> module_path -val label_of_r : global_reference -> label -val current_toplevel : unit -> module_path +val label_of_r : global_reference -> Label.t val base_mp : module_path -> module_path val is_modfile : module_path -> bool val string_of_modfile : module_path -> string @@ -60,8 +60,8 @@ val mp_length : module_path -> int val prefixes_mp : module_path -> MPset.t val common_prefix_from_list : module_path -> module_path list -> module_path option -val get_nth_label_mp : int -> module_path -> label -val labels_of_ref : global_reference -> module_path * label list +val get_nth_label_mp : int -> module_path -> Label.t +val labels_of_ref : global_reference -> module_path * Label.t list (*s Some table-related operations *) @@ -85,9 +85,10 @@ val record_fields_of_type : ml_type -> global_reference option list val add_recursors : Environ.env -> mutual_inductive -> unit val is_recursor : global_reference -> bool -val add_projection : int -> constant -> unit +val add_projection : int -> constant -> inductive -> unit val is_projection : global_reference -> bool val projection_arity : global_reference -> int +val projection_info : global_reference -> inductive * int (* arity *) val add_info_axiom : global_reference -> unit val remove_info_axiom : global_reference -> unit @@ -131,6 +132,14 @@ type opt_flag = val optims : unit -> opt_flag +(*s Controls whether dummy lambda are removed *) + +val conservative_types : unit -> bool + +(*s A comment to print at the beginning of the files *) + +val file_comment : unit -> string + (*s Target language. *) type lang = Ocaml | Haskell | Scheme @@ -162,7 +171,7 @@ 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 type_scheme_nb_args_hook : (Environ.env -> Term.constr -> int) Hook.t val is_custom : global_reference -> bool val is_inline_custom : global_reference -> bool @@ -176,7 +185,7 @@ val find_custom_match : ml_branch array -> string val extraction_language : lang -> unit val extraction_inline : bool -> reference list -> unit -val print_extraction_inline : unit -> unit +val print_extraction_inline : unit -> Pp.std_ppcmds val reset_extraction_inline : unit -> unit val extract_constant_inline : bool -> reference -> string list -> string -> unit @@ -184,14 +193,14 @@ val extract_inductive : reference -> string -> string list -> string option -> unit -type int_or_id = ArgInt of int | ArgId of identifier +type int_or_id = ArgInt of int | ArgId of Id.t val extraction_implicit : reference -> int_or_id list -> unit (*s Table of blacklisted filenames *) -val extraction_blacklist : identifier list -> unit +val extraction_blacklist : Id.t list -> unit val reset_extraction_blacklist : unit -> unit -val print_extraction_blacklist : unit -> unit +val print_extraction_blacklist : unit -> Pp.std_ppcmds diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v deleted file mode 100644 index a5a85790..00000000 --- a/plugins/field/LegacyField.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 8a55d582..00000000 --- a/plugins/field/LegacyField_Tactic.v +++ /dev/null @@ -1,431 +0,0 @@ -(************************************************************************) -(* 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 - 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 - 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] - 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 - 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 | 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 - | _ => idtac - end; - match get_component Adiv FT with - | Some ?X1 => unfold X1 - | _ => 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] || - compute). - -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; 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 deleted file mode 100644 index 39926f65..00000000 --- a/plugins/field/LegacyField_Theory.v +++ /dev/null @@ -1,648 +0,0 @@ -(************************************************************************) -(* 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; intro; inversion H3; auto). - elim (H1 e0); intro y; elim (H2 e); intro y0; - try - (left; rewrite y; rewrite y0; auto) || - (right; red; intro; inversion H3; auto). - elim (H0 e); intro y. - left; rewrite y; auto. - right; red; intro; inversion H1; auto. - elim (H0 e); intro y. - left; rewrite y; auto. - right; red; intro; inversion H1; auto. - elim (eq_nat_dec n n0); intro y. - left; rewrite y; auto. - right; red; 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 ; 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; 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; fold merge_mult; - unfold interp_ExprA at 2; fold interp_ExprA; - rewrite (H0 e e3 lvar); unfold interp_ExprA at 1; - fold interp_ExprA; unfold interp_ExprA at 5; - fold interp_ExprA; 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; 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; 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; rewrite merge_mult_correct; - simpl; rewrite merge_mult_correct; simpl; - 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; legacy ring. -simpl; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); - rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0. -simpl; rewrite (H0 lvar); auto. -simpl; rewrite merge_mult_correct; simpl; - rewrite merge_mult_correct; simpl; rewrite AmultT_assoc; - rewrite assoc_mult_correct1; rewrite H2; simpl; - 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; rewrite (H0 lvar); auto. -simpl; rewrite (H0 lvar); auto. -simpl; 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; fold merge_plus; - unfold interp_ExprA at 2; fold interp_ExprA; - rewrite (H0 e e3 lvar); unfold interp_ExprA at 1; - fold interp_ExprA; unfold interp_ExprA at 5; - fold interp_ExprA; 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; 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; 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; rewrite merge_plus_correct; - simpl; rewrite merge_plus_correct; simpl; - 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; rewrite (H0 lvar); auto. -simpl; rewrite (H0 lvar); auto. -simpl; rewrite merge_plus_correct; simpl; - rewrite merge_plus_correct; simpl; rewrite AplusT_assoc; - rewrite assoc_plus_correct; rewrite H2; simpl; - 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; - 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; fold assoc; unfold interp_ExprA; - fold interp_ExprA; rewrite assoc_mult_correct; - rewrite (H0 lvar); simpl; auto. -simpl; rewrite (H0 lvar); auto. -simpl; rewrite (H0 lvar); auto. -simpl; rewrite (H0 lvar); auto. -unfold assoc; fold assoc; unfold interp_ExprA; - fold interp_ExprA; rewrite assoc_mult_correct; - simpl; 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; 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. -rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl; - apply AmultT_Or. -rewrite distrib_mult_right_correct; simpl; 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; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl; 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; rewrite <- (H lvar); rewrite <- (H0 lvar); - unfold distrib; simpl; auto. -simpl; rewrite <- (H lvar); rewrite <- (H0 lvar); - unfold distrib; simpl; apply distrib_mult_left_correct. -simpl; fold AoppT; rewrite <- (H lvar); - unfold distrib; simpl; rewrite distrib_mult_right_correct; - simpl; fold AoppT; 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; 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; intros; try rewrite merge_mult_correct; - auto. - simpl; 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; 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; case (eqExprA EAzero (EAinv a)); intros; - [ inversion e0 | simpl; trivial ]. -simpl; case (eqExprA EAone (EAinv a)); intros; - [ inversion e0 | simpl; trivial ]. -simpl; case (eqExprA (EAplus e0 e1) (EAinv a)); intros; - [ inversion e2 | simpl; trivial ]. -simpl; case (eqExprA e0 (EAinv a)); intros. -rewrite e2; simpl; fold AinvT. -rewrite <- - (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a)) - (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ]. -simpl; rewrite H0; auto; legacy ring. -simpl; fold AoppT; case (eqExprA (EAopp e0) (EAinv a)); - intros; [ inversion e1 | simpl; trivial ]. -unfold monom_remove; case (eqExprA (EAinv e0) (EAinv a)); intros. -case (eqExprA e0 a); intros. -rewrite e2; simpl; fold AinvT; rewrite AinvT_r; auto. -inversion e1; simpl; exfalso; auto. -simpl; trivial. -unfold monom_remove; case (eqExprA (EAvar n) (EAinv a)); intros; - [ inversion e0 | simpl; 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; 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; case (eqExprA a e0); intros. -rewrite <- e2; apply monom_simplif_rem_correct; auto. -simpl; 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; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. -unfold inverse_simplif; 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 deleted file mode 100644 index 089ff1e8..00000000 --- a/plugins/field/field.ml4 +++ /dev/null @@ -1,191 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mkApp (init_constant "None",[|ac3|]) - | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|]) - -module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) - -(* Table of theories *) -let th_tab = ref (Cmap.empty : constr Cmap.t) - -let lookup env typ = - try Cmap.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 := Cmap.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 := Cmap.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 : types * constr -> Libobject.obj = - 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 deleted file mode 100644 index 3c3e87af..00000000 --- a/plugins/field/field_plugin.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Field -Field_plugin_mod diff --git a/plugins/field/vo.itarget b/plugins/field/vo.itarget deleted file mode 100644 index 22b56f33..00000000 --- a/plugins/field/vo.itarget +++ /dev/null @@ -1,4 +0,0 @@ -LegacyField_Compl.vo -LegacyField_Tactic.vo -LegacyField_Theory.vo -LegacyField.vo diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 79d4c5b5..62a8605a 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 let construct_nhyps ind gls = - let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in + let nparams = (fst (Global.lookup_inductive (fst 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 @@ -52,12 +51,11 @@ let construct_nhyps ind gls = (* 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 myhyps t = + let t1=prod_applist t largs in let t2=snd (decompose_prod_n_assum nevar t1) in fst (decompose_prod_assum t2) in - Array.init lp myhyps + Array.map myhyps types let special_nf gl= let infos=Closure.create_clos_infos !red_flags (pf_env gl) in @@ -69,14 +67,14 @@ let special_whd gl= 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 + | False of pinductive*constr list + | And of pinductive*constr list*bool + | Or of pinductive*constr list*bool + | Exists of pinductive*constr list | Forall of constr*constr | Atom of constr -let rec kind_of_formula gl term = +let 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 @@ -87,26 +85,26 @@ let rec kind_of_formula gl term = |_-> match match_with_nodep_ind cciterm with Some (i,l,n)-> - let ind=destInd i in + let ind,u=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) + if Int.equal nconstr 0 then + False((ind,u),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 + Int.equal (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) + if Int.equal nconstr 1 then + And((ind,u),l,is_trivial) else - Or(ind,l,is_trivial) + Or((ind,u),l,is_trivial) | _ -> match match_with_sigma_type cciterm with Some (i,l)-> Exists((destInd i),l) @@ -118,7 +116,7 @@ type side = Hyp | Concl | Hint let no_atoms = (false,{positive=[];negative=[]}) -let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *) +let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *) let build_atoms gl metagen side cciterm = let trivial =ref false @@ -144,9 +142,9 @@ let build_atoms gl metagen side cciterm = 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 + List.fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) - array_exists (function []->true|_->false) v + Array.exists (function []->true|_->false) v then trivial:=true; Array.iter f v | Exists(i,l)-> @@ -154,7 +152,7 @@ let build_atoms gl metagen side cciterm = 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 + List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in build_rec (var::env) polarity b @@ -171,7 +169,7 @@ let build_atoms gl metagen side 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 + let env=List.rev_map (fun _->mkMeta (metagen true)) rels in build_rec env false head;trivial:=false (* special for hints *) end; (!trivial, @@ -188,19 +186,19 @@ type right_pattern = type left_arrow_pattern= LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list + | LLfalse of pinductive*constr list + | LLand of pinductive*constr list + | LLor of pinductive*constr list | LLforall of constr - | LLexists of inductive*constr list + | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse - | Land of inductive - | Lor of inductive + | Land of pinductive + | Lor of pinductive | Lforall of metavariable*constr*bool - | Lexists of inductive + | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id:global_reference; @@ -226,7 +224,7 @@ let build_formula side nam typ gl metagen= | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> - let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in + let (_,_,d)=List.last (ind_hyps 0 i l gl).(0) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 44bbb335..29ea1e77 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -1,14 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* metavariable -val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array +val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array -val ind_hyps : int -> inductive -> constr list -> +val ind_hyps : int -> pinductive -> constr list -> Proof_type.goal Tacmach.sigma -> rel_context array type atoms = {positive:constr list;negative:constr list} @@ -48,19 +49,19 @@ type right_pattern = type left_arrow_pattern= LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list + | LLfalse of pinductive*constr list + | LLand of pinductive*constr list + | LLor of pinductive*constr list | LLforall of constr - | LLexists of inductive*constr list + | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse - | Land of inductive - | Lor of inductive + | Land of pinductive + | Lor of pinductive | Lforall of metavariable*constr*bool - | Lexists of inductive + | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id: global_reference; diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 5b882036..c28da42a 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -1,25 +1,23 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* >) "Firstorder default solver" -VERNAC COMMAND EXTEND Firstorder_Set_Solver +VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ set_default_solver - (Vernacexpr.use_section_locality ()) - (Tacinterp.glob_tactic t) ] + (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (Tacintern.glob_tactic t) ] END -VERNAC COMMAND EXTEND Firstorder_Print_Solver +VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY | [ "Print" "Firstorder" "Solver" ] -> [ - Pp.msgnl + Pp.msg_info (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ] END @@ -82,10 +80,11 @@ let gen_ground_tac flag taco ids bases gl= | None-> snd (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 + let seq,gl = extend_with_ref_list ids seq gl in + extend_with_auto_hints bases seq gl in + let result=ground_tac (Proofview.V82.of_tactic solver) startseq gl in qflag:=backup;result - with reraise ->qflag:=backup;raise reraise + with reraise -> qflag:=backup;raise reraise (* special for compatibility with Intuition @@ -103,12 +102,13 @@ let normalize_evaluables= unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) +open Pp 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 +let pr_firstorder_using_raw _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_reference l +let pr_firstorder_using_glob _ _ _ l = str "using " ++ prlist_with_sep pr_comma (pr_or_var (fun x -> (pr_global (snd x)))) l +let pr_firstorder_using_typed _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_global l ARGUMENT EXTEND firstorder_using PRINTED BY pr_firstorder_using_typed @@ -128,29 +128,31 @@ END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> - [ gen_ground_tac true (Option.map eval_tactic t) l [] ] + [ Proofview.V82.tactic (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 ] + [ Proofview.V82.tactic (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' ] + [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l l') ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> - [ gen_ground_tac false (Option.map eval_tactic t) [] [] ] + [ Proofview.V82.tactic (gen_ground_tac false (Option.map eval_tactic t) [] []) ] END +open Proofview.Notations -let default_declarative_automation gls = - tclORELSE - (tclORELSE (Auto.h_trivial [] None) +let default_declarative_automation = + Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *) + Tacticals.New.tclORELSE + (Tacticals.New.tclORELSE (Auto.h_trivial [] None) (Cctac.congruence_tac !congruence_depth [])) - (gen_ground_tac true - (Some (tclTHEN + (Proofview.V82.tactic (gen_ground_tac true + (Some (Tacticals.New.tclTHEN (snd (default_solver ())) (Cctac.congruence_tac !congruence_depth []))) - [] []) gls + [] [])) diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 7c80b9bb..2248b669 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* () in + with DestKO -> () + in List.iter f (Classops.coercions ()); red_flags:= Closure.RedFlags.red_add_transparent Closure.betaiotazeta - (Names.Idpred.full,Names.Cpred.complement !predref) + (Names.Id.Pred.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 gl); + then Pp.msg_debug (Printer.pr_goal gl); tclORELSE (axiom_tac seq.gl seq) begin try @@ -120,5 +119,6 @@ let ground_tac solver startseq gl= end with Heap.EmptyHeap->solver end gl in - wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl + let seq, gl' = startseq gl in + wrap (List.length (pf_hyps gl)) true (toptac []) seq gl' diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli index 380326e7..5b320786 100644 --- a/plugins/firstorder/ground.mli +++ b/plugins/firstorder/ground.mli @@ -1,11 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic + (Proof_type.goal Tacmach.sigma -> Sequent.t * Proof_type.goal Tacmach.sigma) -> Tacmach.tactic diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index d45ab0c3..a88778c7 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -1,28 +1,27 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ((-) =? (-) ==? 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 + | Phantom(_),Real((m,_),_)-> if Int.equal m 0 then -1 else 1 + | Real((m,_),_),Phantom(_)-> if Int.equal 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 Libnames.RefOrdered.compare id1 id2 + else Globnames.RefOrdered.compare id1 id2 module OrderedInstance= struct - type t=instance * Libnames.global_reference + type t=instance * Globnames.global_reference let compare (inst1,id1) (inst2,id2)= (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) @@ -76,7 +75,7 @@ let match_one_quantified_hyp setref seq lf= 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" + | _ -> anomaly (Pp.str "can't happen") let give_instances lf seq= let setref=ref IS.empty in @@ -99,36 +98,36 @@ let rec collect_quantified seq= let dummy_constr=mkMeta (-1) -let dummy_bvid=id_of_string "x" +let dummy_bvid=Id.of_string "x" -let mk_open_instance id gl m t= +let mk_open_instance id idc 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 + let typ=pf_type_of gl idc 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 revt=substl (List.init m (fun i->mkRel (m-i))) t in let rec aux n avoid= - if n=0 then [] else + if Int.equal 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 rawt=Detyping.detype false [] env evmap nt in let rec raux n t= - if n=0 then t else + if Int.equal n 0 then t else match t with GLambda(loc,name,k,_,t0)-> let t1=raux (n-1) t0 in - GLambda(loc,name,k,GHole (dummy_loc,Evd.BinderType name),t1) - | _-> anomaly "can't happen" in + GLambda(loc,name,k,GHole (Loc.ghost,Evar_kinds.BinderType name,Misctypes.IntroAnonymous,None),t1) + | _-> anomaly (Pp.str "can't happen") in let ntt=try - Pretyping.Default.understand evmap env (raux m rawt) + fst (Pretyping.understand env evmap (raux m rawt))(*FIXME*) with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt @@ -141,50 +140,53 @@ let left_instance_tac (inst,id) continue seq= if lookup (id,None) seq then tclFAIL 0 (Pp.str "already done") else - tclTHENS (cut dom) + tclTHENS (Proofview.V82.of_tactic (cut dom)) [tclTHENLIST - [introf; + [Proofview.V82.of_tactic introf; + pf_constr_of_global id (fun idc -> (fun gls->generalize - [mkApp(constr_of_global id, - [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); - introf; + [mkApp(idc, + [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls)); + Proofview.V82.of_tactic introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; - tclTRY assumption] + tclTRY (Proofview.V82.of_tactic 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 + pf_constr_of_global id (fun idc -> + fun gl-> + let (rc,ot) = mk_open_instance id idc gl m t in + let gt= + it_mkLambda_or_LetIn + (mkApp(idc,[|ot|])) rc in + generalize [gt] gl) else - generalize [mkApp(constr_of_global id,[|t|])] + pf_constr_of_global id (fun idc -> + generalize [mkApp(idc,[|t|])]) in tclTHENLIST [special_generalize; - introf; + Proofview.V82.of_tactic 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) + tclTHENS (Proofview.V82.of_tactic (cut dom)) [tclTHENLIST - [introf; + [Proofview.V82.of_tactic introf; (fun gls-> - split (Glob_term.ImplicitBindings - [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); + Proofview.V82.of_tactic (split (ImplicitBindings + [mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; - tclTRY assumption] + tclTRY (Proofview.V82.of_tactic assumption)] | Real ((0,t),_) -> - (tclTHEN (split (Glob_term.ImplicitBindings [t])) + (tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [t]))) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index 709eb96f..2f69ad7b 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -1,15 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Formula.t list * Sequent.t diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index b043ba5f..382d5409 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -1,22 +1,24 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic) -> Sequent.t -> tactic @@ -25,13 +27,13 @@ type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq gls= - check_for_interrupt (); + Control.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" + []->anomaly (Pp.str "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 @@ -51,38 +53,38 @@ 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)) + try pf_constr_of_global (find_left t seq) exact_no_check 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)|])]; + [pf_constr_of_global (find_left a seq) (fun left -> + pf_constr_of_global id (fun id -> + generalize [mkApp(id, [|left|])])); clear_global id; - intro] + Proofview.V82.of_tactic 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 + tclIFTHENELSE (Proofview.V82.of_tactic 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)))) + (Proofview.V82.of_tactic (any_constructor false (Some (Proofview.V82.tactic (tclCOMPLETE (wrap 0 true continue seq)))))) backtrack let arrow_tac backtrack continue seq= - tclIFTHENELSE intro (wrap 1 true continue seq) + tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 1 true continue seq) (tclORELSE - (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq))) + (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 1 true continue seq))) backtrack) (* left connectives rules *) @@ -90,9 +92,9 @@ 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); + [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim); clear_global id; - tclDO n intro]) + tclDO n (Proofview.V82.of_tactic intro)]) (wrap n false continue seq) backtrack gls @@ -101,59 +103,58 @@ let left_or_tac ind backtrack id continue seq gls= let f n= tclTHENLIST [clear_global id; - tclDO n intro; + tclDO n (Proofview.V82.of_tactic intro); wrap n false continue seq] in tclIFTHENSVELSE - (simplest_elim (constr_of_global id)) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) (Array.map f v) backtrack gls let left_false_tac id= - simplest_elim (constr_of_global id) + Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim) (* 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 ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= + let rcs=ind_hyps 0 indu largs gl in let vargs=Array.of_list largs in - (* construire le terme H->B, le generaliser etc *) - let myterm i= + (* construire le terme H->B, le generaliser etc *) + let myterm idc i= let rc=rcs.(i) in let p=List.length rc in - let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in + let cstr=mkApp ((mkConstructU ((ind,(i+1)),u)),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 head=mkApp ((lift p idc),[|capply|]) in + it_mkLambda_or_LetIn head rc in let lp=Array.length rcs in - let newhyps=list_tabulate myterm lp in + let newhyps idc =List.init lp (myterm idc) in tclIFTHENELSE (tclTHENLIST - [generalize newhyps; + [pf_constr_of_global id (fun idc -> generalize (newhyps idc)); clear_global id; - tclDO lp intro]) + tclDO lp (Proofview.V82.of_tactic 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 + let d idc =mkLambda (Anonymous,b, + mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in tclORELSE - (tclTHENS (cut c) + (tclTHENS (Proofview.V82.of_tactic (cut c)) [tclTHENLIST - [introf; + [Proofview.V82.of_tactic introf; clear_global id; wrap 1 false continue seq]; - tclTHENS (cut cc) - [exact_no_check (constr_of_global id); + tclTHENS (Proofview.V82.of_tactic (cut cc)) + [pf_constr_of_global id exact_no_check; tclTHENLIST - [generalize [d]; + [pf_constr_of_global id (fun idc -> generalize [d idc]); clear_global id; - introf; - introf; + Proofview.V82.of_tactic introf; + Proofview.V82.of_tactic introf; tclCOMPLETE (wrap 2 true continue seq)]]]) backtrack @@ -161,9 +162,9 @@ let ll_arrow_tac a b c backtrack id continue seq= let forall_tac backtrack continue seq= tclORELSE - (tclIFTHENELSE intro (wrap 0 true continue seq) + (tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 0 true continue seq) (tclORELSE - (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) + (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 0 true continue seq))) backtrack)) (if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") @@ -173,24 +174,25 @@ let forall_tac backtrack continue seq= 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)) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) (tclTHENLIST [clear_global id; - tclDO n intro; + tclDO n (Proofview.V82.of_tactic intro); (wrap (n-1) false continue seq)]) backtrack gls let ll_forall_tac prod backtrack id continue seq= tclORELSE - (tclTHENS (cut prod) + (tclTHENS (Proofview.V82.of_tactic (cut prod)) [tclTHENLIST - [intro; + [Proofview.V82.of_tactic intro; + pf_constr_of_global id (fun idc -> (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); + let term=mkApp(idc,[|mkVar(id0)|]) in + tclTHEN (generalize [term]) (clear [id0]) gls)); clear_global id; - intro; + Proofview.V82.of_tactic intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; tclCOMPLETE (wrap 0 true continue (deepen seq))]) backtrack @@ -202,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq= 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"))] + [AllOccurrences,EvalConstRef (fst (destConst (constant "not"))); + AllOccurrences,EvalConstRef (fst (destConst (constant "iff")))] let normalize_evaluables= onAllHypsAndConcl diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index d5fe398f..596e8535 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic) -> Sequent.t -> tactic @@ -19,7 +19,7 @@ type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac -val basename_of_global: global_reference -> identifier +val basename_of_global: global_reference -> Id.t val clear_global: global_reference -> tactic @@ -33,19 +33,19 @@ val or_tac : seqtac with_backtracking val arrow_tac : seqtac with_backtracking -val left_and_tac : inductive -> lseqtac with_backtracking +val left_and_tac : pinductive -> lseqtac with_backtracking -val left_or_tac : inductive -> lseqtac with_backtracking +val left_or_tac : pinductive -> lseqtac with_backtracking val left_false_tac : global_reference -> tactic -val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking +val ll_ind_tac : pinductive -> 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 left_exists_tac : pinductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 50cf14a9..2f7f21e4 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -1,18 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 50 | LLarrow (_,_,_) -> -10 -let left_reversible lpat=(priority lpat)>0 - module OrderedFormula= struct type t=Formula.t @@ -69,12 +67,14 @@ module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= - (Libnames.RefOrdered.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 + let c = Globnames.RefOrdered.compare id1 id2 in + if c = 0 then + let cmp (i1, c1) (i2, c2) = + let c = Int.compare i1 i2 in + if c = 0 then OrderedConstr.compare c1 c2 else c + in + Option.compare cmp co1 co2 + else c end module CM=Map.Make(OrderedConstr) @@ -90,7 +90,7 @@ let 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 + let l0=List.filter (fun id-> not (Globnames.eq_gr id nam)) l in match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm @@ -120,10 +120,10 @@ let lookup item seq= let p (id2,o)= match o with None -> false - | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in + | Some ((m2,t2) as c2)-> Globnames.eq_gr id id2 && m2>m && more_general c2 c in History.exists p seq.history -let rec add_formula side nam t seq gl= +let add_formula side nam t seq gl= match build_formula side nam t gl seq.cnt with Left f-> begin @@ -163,8 +163,6 @@ let find_left t seq=List.hd (CM.find t seq.context) 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 @@ -191,36 +189,36 @@ let empty_seq depth= depth=depth} let expand_constructor_hints = - list_map_append (function + List.map_append (function | IndRef ind -> - list_tabulate (fun i -> ConstructRef (ind,i+1)) - (Inductiveops.nconstructors ind) + List.init (Inductiveops.nconstructors ind) + (fun i -> ConstructRef (ind,i+1)) | gr -> [gr]) -let extend_with_ref_list l seq gl= +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 f gr (seq,gl) = + let gl, c = pf_eapply Evd.fresh_global gl gr in let typ=(pf_type_of gl c) in - add_formula Hyp gr typ seq gl in - List.fold_right f l seq + (add_formula Hyp gr typ seq gl,gl) in + List.fold_right f l (seq,gl) -open Auto +open Hints 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 (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> (try - let gr=global_of_constr c in + 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 g _ _ l = List.iter f l in let h dbname= let hdb= try @@ -229,18 +227,18 @@ let extend_with_auto_hints l seq gl= error ("Firstorder: "^dbname^" : No such Hint database") in Hint_db.iter g hdb in List.iter h l; - !seqref + !seqref, gl (*FIXME: forgetting about universes*) let print_cmap map= let print_entry c l s= - let xc=Constrextern.extern_constr false (Global.env ()) c in + let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty c in str "| " ++ - Util.prlist Printer.pr_global l ++ + prlist Printer.pr_global l ++ str " : " ++ Ppconstr.pr_constr_expr xc ++ cut () ++ s in - msgnl (v 0 + (v 0 (str "-----" ++ cut () ++ CM.fold print_entry map (mt ()) ++ diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 44b5ed3e..dc3f05be 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -1,17 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Formula.t * t val empty_seq : int -> t val extend_with_ref_list : global_reference list -> - t -> Proof_type.goal sigma -> t + t -> Proof_type.goal sigma -> t * Proof_type.goal sigma -val extend_with_auto_hints : Auto.hint_db_name list -> - t -> Proof_type.goal sigma -> t +val extend_with_auto_hints : Hints.hint_db_name list -> + t -> Proof_type.goal sigma -> t * Proof_type.goal sigma -val print_cmap: global_reference list CM.t -> unit +val print_cmap: global_reference list CM.t -> Pp.std_ppcmds diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 00eb9981..0a172034 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -1,16 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (try - head_reduce (List.assoc i !sigma) + head_reduce (Int.List.assoc i !sigma) with Not_found->t) | _->t in Queue.add (t1,t2) bige; @@ -44,17 +42,17 @@ let unif t1 t2= 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 not (Int.equal i j) then if i let t=subst_meta !sigma nt2 in - if Intset.is_empty (free_rels t) && + if Int.Set.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) && + if Int.Set.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 @@ -65,7 +63,7 @@ let unif t1 t2= Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; let l=Array.length va in - if l<>(Array.length vb) then + if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else for i=0 to l-1 do @@ -74,13 +72,13 @@ let unif t1 t2= | App(ha,va),App(hb,vb)-> Queue.add (ha,hb) bige; let l=Array.length va in - if l<>(Array.length vb) then + if not (Int.equal 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)) + | _->if not (eq_constr_nounivs nt1 nt2) then raise (UFAIL (nt1,nt2)) done; assert false (* this place is unreachable but needed for the sake of typing *) @@ -90,7 +88,7 @@ let value i t= let add x y= if x<0 then y else if y<0 then x else x+y in let rec vaux term= - if isMeta term && destMeta term = i then 0 else + if isMeta term && Int.equal (destMeta term) i 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 @@ -107,7 +105,7 @@ let mk_rel_inst t= match kind_of_term t with Meta n-> (try - mkRel (d+(List.assoc n !rel_env)) + mkRel (d+(Int.List.assoc n !rel_env)) with Not_found-> let m= !new_rel in incr new_rel; @@ -119,7 +117,7 @@ let mk_rel_inst t= let unif_atoms i dom t1 t2= try - let t=List.assoc i (unif t1 t2) in + let t=Int.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 @@ -127,7 +125,7 @@ let unif_atoms i dom t1 t2= | 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 + let l=List.init n (fun i->mkMeta (k+i)) in substl l t let more_general (m1,t1) (m2,t2)= diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index 697548be..15318546 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ~ x < y. unfold not; intros. apply H. -apply Rplus_lt_reg_r with x. +apply Rplus_lt_reg_l with x. replace (x + 0) with x. replace (x + (y - x)) with y. try exact H0. @@ -177,7 +177,7 @@ unfold not; intros. apply H. case H0; intros. left. -apply Rplus_lt_reg_r with x. +apply Rplus_lt_reg_l with x. replace (x + 0) with x. replace (x + (y - x)) with y. try exact H1. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index c39c2387..50a5150d 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -1,18 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let h =ref [] in - for k=1 to (n-(!i)-1) do pop r0 h; done; + 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; + for _k = 1 to !i do pop r0 h; done; i:=!i+1; {coef=ie;hist=(!h);strict=s}) le ;; -(* additionne deux inéquations *) +(* 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) *) +(* 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 *) +(* 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 *) +(* 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. +(* 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 @@ -136,8 +136,8 @@ let deduce_add lneg 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. +(* é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 @@ -146,38 +146,37 @@ let deduce1 s = (List.map ie_tl lnul)@lnew |_->assert false ;; -(* algorithme de Fourier: on élimine successivement toutes les variables. +(* 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 + for _i = 1 to n - 1 do lie:= deduce1 !lie; done; !lie ;; -(* donne [] si le système a des solutions, +(* 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 +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. +cette inéquation étant absurde. *) + +exception Contradiction of (rational * bool * rational list) list + 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 e when Errors.noncritical e -> ()); - !res -;; + let check = function + | {coef=[c];hist=lc;strict=s} -> + if (rinf c r0 && (not s)) || (rinfeq c r0 && s) + then raise (Contradiction [c,s,lc]) + |_->assert false + in + try List.iter check lr; [] + with Contradiction l -> l (* Exemples: diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 763383dd..8006a3e1 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* r0;; +let flin_coef f x = try Constrhash.find f.fhom x with Not_found -> r0;; let flin_add f x c = let cx = flin_coef f x in - Constrhash.remove f.fhom x; - Constrhash.add f.fhom x (rplus cx c); + Constrhash.replace f.fhom x (rplus cx c); f ;; let flin_add_cste f c = @@ -75,24 +73,25 @@ let flin_emult a f = ;; (*****************************************************************************) -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 + sec_dir = DirPath.empty && + DirPath.to_string dir = "Coq.Reals.Rdefinitions" + -> Label.to_string 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 + |Const (c,_) -> string_of_R_constant c | _ -> "not_of_constant" +exception NoRational + let rec rational_of_constr c = match kind_of_term c with | Cast (c,_,_) -> (rational_of_constr c) @@ -114,15 +113,17 @@ let rec rational_of_constr c = | "Rminus" -> rminus (rational_of_constr args.(0)) (rational_of_constr args.(1)) - | _ -> failwith "not a rational") - | Const kn -> + | _ -> raise NoRational) + | Const (kn,_) -> (match (string_of_R_constant kn) with "R1" -> r1 |"R0" -> r0 - | _ -> failwith "not a rational") - | _ -> failwith "not a rational" + | _ -> raise NoRational) + | _ -> raise NoRational ;; +exception NoLinear + let rec flin_of_constr c = try( match kind_of_term c with @@ -138,39 +139,34 @@ let rec flin_of_constr c = 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 e when Errors.noncritical e -> - (flin_add (flin_zero()) - args.(1) - a)) - with e when Errors.noncritical e -> - (flin_add (flin_zero()) - args.(0) - (rational_of_constr args.(1)))) + (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 NoRational -> + flin_add (flin_zero()) args.(1) a + with NoRational -> + 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) + 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 e when Errors.noncritical e -> - (flin_add (flin_zero()) - args.(0) - (rinv b))) - |_->assert false) - | Const c -> + (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 NoRational -> + flin_add (flin_zero()) args.(0) (rinv b)) + |_-> raise NoLinear) + | Const (c,_) -> (match (string_of_R_constant c) with "R1" -> flin_one () |"R0" -> flin_zero () - |_-> assert false) - |_-> assert false) - with e when Errors.noncritical e -> - flin_add (flin_zero()) - c - r1 + |_-> raise NoLinear) + |_-> raise NoLinear) + with NoRational | NoLinear -> flin_add (flin_zero()) c r1 ;; let flin_to_alist f = @@ -179,9 +175,9 @@ let flin_to_alist f = !res ;; -(* Représentation des hypothèses qui sont des inéquations ou des équations. +(* Représentation des hypothèses qui sont des inéquations ou des équations. *) -type hineq={hname:constr; (* le nom de l'hypothèse *) +type hineq={hname:constr; (* le nom de l'hypothèse *) htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) hleft:constr; hright:constr; @@ -189,54 +185,57 @@ type hineq={hname:constr; (* le nom de l'hypoth hstrict:bool} ;; -(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 +(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 *) + +exception NoIneq + 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 + | 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; + |"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; + |"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; + |"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; + |"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"-> + |_-> raise NoIneq) + | Ind ((kn,i),_) -> + if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; + 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; @@ -251,20 +250,18 @@ let ineq1_of_constr (h,t) = hflin= flin_minus (flin_of_constr t2) (flin_of_constr t1); hstrict=false}] - |_-> assert false) - |_-> assert false) - else - assert false - |_-> assert false) - |_-> assert false + |_-> raise NoIneq) + |_-> raise NoIneq) + |_-> raise NoIneq) + |_-> raise NoIneq ;; -(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) +(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) *) let fourier_lineq lineq1 = let nvar=ref (-1) in - let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) + let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) List.iter (fun f -> Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin nvar:=(!nvar)+1; @@ -273,7 +270,7 @@ let fourier_lineq lineq1 = f.hflin.fhom) lineq1; let sys= List.map (fun h-> - let v=Array.create ((!nvar)+1) r0 in + let v=Array.make ((!nvar)+1) r0 in Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c) h.hflin.fhom; ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) @@ -345,14 +342,14 @@ 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, +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) +let rational_to_fraction x= (x.num,x.den) ;; (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) @@ -363,7 +360,7 @@ let int_to_real n = 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; + 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))) @@ -379,11 +376,11 @@ let rational_to_real x = let tac_zero_inf_pos gl (n,d) = let tacn=ref (apply (get coq_Rlt_zero_1)) in let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do - tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; - for i=1 to d-1 do - tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd]) + for _i = 1 to n - 1 do + tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; + for _i = 1 to d - 1 do + tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; + (Tacticals.New.tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd]) ;; (* preuve que 0<=n*1/d @@ -393,11 +390,11 @@ let tac_zero_infeq_pos gl (n,d)= then (apply (get coq_Rle_zero_zero)) else (apply (get coq_Rle_zero_1))) in let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do - tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; - for i=1 to d-1 do - tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) + for _i = 1 to n - 1 do + tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; + for _i = 1 to d - 1 do + tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; + (Tacticals.New.tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) ;; (* preuve que 0<(-n)*(1/d) => False @@ -405,14 +402,14 @@ let tac_zero_infeq_pos gl (n,d)= 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)) + (Tacticals.New.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)) + (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) (tac_zero_inf_pos gl (-n,d))) ;; @@ -425,18 +422,16 @@ let my_cut c 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 tac_use h = + let tac = exact h.hname in + match h.htype with + "Rlt" -> tac + |"Rle" -> tac + |"Rgt" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_gt_to_lt)) tac) + |"Rge" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_ge_to_le)) tac) + |"eqTLR" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) tac) + |"eqTRL" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) tac) + |_->assert false ;; (* @@ -464,58 +459,61 @@ let mkAppL a = mkApp(List.hd l, Array.of_list (List.tl l)) ;; -(* Résolution d'inéquations linéaires dans R *) -let rec fourier gl= +exception GoalDone + +(* Résolution d'inéquations linéaires dans R *) +let rec fourier () = + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in 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 + let goal = strip_outer_cast concl 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 + 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)) + (Tacticals.New.tclTHEN + (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_ge_lt)) (intro_using fhyp)) - fourier) + (fourier ())) |"Rle" -> - (tclTHEN - (tclTHEN (apply (get coq_Rfourier_not_gt_le)) + (Tacticals.New.tclTHEN + (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_gt_le)) (intro_using fhyp)) - fourier) + (fourier ())) |"Rgt" -> - (tclTHEN - (tclTHEN (apply (get coq_Rfourier_not_le_gt)) + (Tacticals.New.tclTHEN + (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_le_gt)) (intro_using fhyp)) - fourier) + (fourier ())) |"Rge" -> - (tclTHEN - (tclTHEN (apply (get coq_Rfourier_not_lt_ge)) + (Tacticals.New.tclTHEN + (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_lt_ge)) (intro_using fhyp)) - fourier) - |_->assert false) - |_->assert false - in tac gl) - with e when Errors.noncritical e -> - (* les hypothèses *) + (fourier ())) + |_-> raise GoalDone) + |_-> raise GoalDone + with GoalDone -> + (* les hypothèses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) - (list_of_sign (pf_hyps gl)) in + (list_of_sign (Proofview.Goal.hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) - with e when Errors.noncritical e -> ()) + with NoIneq -> ()) hyps; - (* lineq = les inéquations découlant des hypothèses *) - if !lineq=[] then Util.error "No inequalities"; + (* lineq = les inéquations découlant des hypothèses *) + if !lineq=[] then Errors.error "No inequalities"; let res=fourier_lineq (!lineq) in - let tac=ref tclIDTAC in + let tac=ref (Proofview.tclUNIT ()) in if res=[] - then Util.error "fourier failed" - (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) + then Errors.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 + (* lc=coefficients multiplicateurs des inéquations qui donnent 0 let s=ref (h1.hstrict) in @@ -554,11 +552,11 @@ let rec fourier gl= let tc=rational_to_real cres in (* puis sa preuve *) let tac1=ref (if h1.hstrict - then (tclTHENS (apply (get coq_Rfourier_lt)) + then (Tacticals.New.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)) + else (Tacticals.New.tclTHENS (apply (get coq_Rfourier_le)) [tac_use h1; tac_zero_inf_pos gl (rational_to_fraction c1)])) in @@ -566,20 +564,20 @@ let rec fourier gl= List.iter (fun (h,c)-> (if (!s) then (if h.hstrict - then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt)) + then tac1:=(Tacticals.New.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)) + else tac1:=(Tacticals.New.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)) + then tac1:=(Tacticals.New.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)) + else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_le)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]))); @@ -589,42 +587,43 @@ let rec fourier gl= 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 + tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq)) + [Tacticals.New.tclTHEN (change_concl (mkAppL [| get coq_not; ineq|] )) - (tclTHEN (apply (if sres then get coq_Rnot_lt_lt + (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt else get coq_Rnot_le_le)) - (tclTHENS (Equality.replace + (Tacticals.New.tclTHENS (Equality.replace (mkAppL [|get coq_Rminus;!t2;!t1|] ) tc) [tac2; - (tclTHENS + (Tacticals.New.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 ... *) +(* 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)))] + [Tacticals.New.tclORELSE + (* TODO : Ring.polynom []*) (Proofview.tclUNIT ()) + (Proofview.tclUNIT ()); + Tacticals.New.pf_constr_of_global (get coq_sym_eqT) (fun symeq -> + (Tacticals.New.tclTHEN (apply symeq) + (apply (get coq_Rinv_1))))] ) ])); !tac1]); - tac:=(tclTHENS (cut (get coq_False)) - [tclTHEN intro (contradiction None); + tac:=(Tacticals.New.tclTHENS (cut (get coq_False)) + [Tacticals.New.tclTHEN intro (contradiction None); !tac]) |_-> assert false) |_-> assert false ); (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) - (!tac gl) + !tac (* ((tclABSTRACT None !tac) gl) *) - + end ;; (* diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index c6c4d68f..d00f0564 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -1,15 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ fourier ] + [ "fourierz" ] -> [ fourier () ] END diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index 51ede26e..a63941f0 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -1,10 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A) -> A -> A := 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. +Theorem le_lt_SS x y : x <= y -> x < S (S y). +Proof. + intros. now apply Nat.lt_succ_r, Nat.le_le_succ_r. 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. +Theorem Splus_lt x y : y < S (x + y). +Proof. + apply Nat.lt_succ_r. rewrite Nat.add_comm. apply Nat.le_add_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. +Theorem SSplus_lt x y : x < S (S (x + y)). +Proof. + apply le_lt_SS, Nat.le_add_r. 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]. +Definition max m n : max_type m n. +Proof. + destruct (Compare_dec.le_gt_dec m n) as [h|h]. + - exists n; [exact h | apply le_n]. + - exists m; [apply le_n | apply Nat.lt_le_incl; exact h]. Defined. + +Definition Acc_intro_generator_function := fun A R => @Acc_intro_generator A R 100. diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b5876ffa..c8214ada 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,45 +1,37 @@ open Printer +open Errors open Util open Term +open Vars +open Context open Namegen open Names open Declarations +open Declareops open Pp -open Entries -open Hiddentac -open Evd open Tacmach open Proof_type open Tacticals open Tactics open Indfun_common open Libnames +open Globnames +open Misctypes -let msgnl = Pp.msgnl - +(* 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 + then Pp.msg_debug strm else () - - - let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v - with reraise -> - let e = Cerrors.process_vernac_interp_error reraise in - let goal = - try (Printer.pr_goal g) - with e when Errors.noncritical e -> assert false - in - msgnl (str "observation "++ s++str " raised exception " ++ + with e -> + let e = Cerrors.process_vernac_interp_error e in + let goal = begin try (Printer.pr_goal g) with _ -> assert false end in + msg_debug (str "observation "++ s++str " raised exception " ++ Errors.print e ++ str " on goal " ++ goal ); raise e;; @@ -49,16 +41,55 @@ let observe_tac_stream s tac g = else tac g let observe_tac s tac g = observe_tac_stream (str s) tac g + *) + + +let debug_queue = Stack.create () + +let rec print_debug_queue b e = + if not (Stack.is_empty debug_queue) + then + begin + let lmsg,goal = Stack.pop debug_queue in + if b then + Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + else + begin + Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); + end; + print_debug_queue false e; + end -(* let tclTRYD tac = *) -(* if !Flags.debug || do_observe () *) -(* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *) -(* else tac *) +let observe strm = + if do_observe () + then Pp.msg_debug strm + else () + +let do_observe_tac s tac g = + let goal = Printer.pr_goal g in + let lmsg = (str "observation : ") ++ s in + Stack.push (lmsg,goal) debug_queue; + try + let v = tac g in + ignore(Stack.pop debug_queue); + v + with reraise -> + let reraise = Errors.push reraise in + if not (Stack.is_empty debug_queue) + then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise)); + iraise reraise + +let observe_tac_stream s tac g = + if do_observe () + then do_observe_tac s tac g + else tac g +let observe_tac s = observe_tac_stream (str s) + let list_chop ?(msg="") n l = try - list_chop n l + List.chop n l with Failure (msg') -> failwith (msg ^ msg') @@ -70,17 +101,17 @@ let make_refl_eq constructor type_of_t t = type pte_info = { - proving_tac : (identifier list -> Tacmach.tactic); + proving_tac : (Id.t list -> Tacmach.tactic); is_valid : constr -> bool } -type ptes_info = pte_info Idmap.t +type ptes_info = pte_info Id.Map.t type 'a dynamic_info = { nb_rec_hyps : int; - rec_hyps : identifier list ; - eq_hyps : identifier list; + rec_hyps : Id.t list ; + eq_hyps : Id.t list; info : 'a } @@ -89,28 +120,17 @@ type body_info = constr dynamic_info let finish_proof dynamic_infos g = observe_tac "finish" - ( h_assumption) + (Proofview.V82.of_tactic assumption) g let refine c = - Tacmach.refine_no_check c + Tacmach.refine 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 eq_constr u v = eq_constr_nounivs u v let is_trivial_eq t = let res = try @@ -157,11 +177,11 @@ 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))) + ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (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]) + (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) ]] g exception TOREMOVE @@ -171,7 +191,7 @@ 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 *) + tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) (fun g -> let context_hyps = fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) @@ -188,7 +208,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = let find_rectype env c = - let (t, l) = decompose_app (Reduction.whd_betaiotazeta c) in + let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in match kind_of_term t with | Ind ind -> (t, l) | Construct _ -> (t,l) @@ -216,7 +236,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = failwith "NoChange"; end in - let eq_constr = Reductionops.is_conv env sigma in + let eq_constr = Evarconv.e_conv env (ref 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"; @@ -245,12 +265,12 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let t2 = destRel t2 in begin try - let t1' = Intmap.find t2 sub in + let t1' = Int.Map.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 + Int.Map.add t2 t1 sub end else if isAppConstruct t1 && isAppConstruct t2 then @@ -264,18 +284,17 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = 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 Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in let end_of_type_with_pop = Termops.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 + let sub = Int.Map.bindings 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'' + sub in let old_context_length = List.length context + 1 in let witness_fun = @@ -284,11 +303,11 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = ) in let new_type_of_hyp,ctxt_size,witness_fun = - list_fold_left_i + 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!"; + let witness = Int.Map.find i sub in + if not (Option.is_empty b') then anomaly (Pp.str "can not redefine a rel!"); (Termops.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) @@ -304,12 +323,13 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = in let prove_new_hyp : tactic = tclTHEN - (tclDO ctxt_size intro) + (tclDO ctxt_size (Proofview.V82.of_tactic 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 + let evm, _ = pf_apply Typing.e_type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in let simpl_eq_tac = @@ -332,14 +352,14 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = new_ctxt,new_end_of_type,simpl_eq_tac -let is_property ptes_info t_x full_type_of_hyp = +let is_property (ptes_info: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 + if isVar pte && Array.for_all closed0 args then try - let info = Idmap.find (destVar pte) ptes_info in + let info = Id.Map.find (destVar pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false @@ -352,10 +372,10 @@ let isLetIn t = let h_reduce_with_zeta = - h_reduce - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) @@ -374,17 +394,17 @@ let rewrite_until_var arg_num eq_ids : tactic = then tclIDTAC g else match eq_ids with - | [] -> anomaly "Cannot find a way to prove recursive property"; + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property"); | eq_id::eq_ids -> tclTHEN - (tclTRY (Equality.rewriteRL (mkVar eq_id))) + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) (do_rewrite eq_ids) g in do_rewrite eq_ids -let rec_pte_id = id_of_string "Hrec" +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 @@ -398,13 +418,8 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = 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 - - ] + [ h_reduce_with_zeta (Locusops.onHyp hyp_id); + scan_type new_context new_typ_of_hyp ] else if isProd type_of_hyp then begin @@ -413,14 +428,14 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = 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 (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST [ - tclDO context_length intro; + tclDO context_length (Proofview.V82.of_tactic intro); (fun g -> let context_hyps_ids = fst (list_chop ~msg:"rec hyp : context_hyps" @@ -434,7 +449,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = in (* observe_tac "rec hyp " *) (tclTHENS - (assert_tac (Name rec_pte_id) t_x) + (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) [ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); (* observe_tac "prove rec hyp" *) @@ -471,7 +486,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let prove_trivial = let nb_intro = List.length context in tclTHENLIST [ - tclDO nb_intro intro; + tclDO nb_intro (Proofview.V82.of_tactic intro); (fun g -> let context_hyps = fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) @@ -533,7 +548,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = thin [hyp_id],[] -let clean_goal_with_heq ptes_infos continue_tac dyn_infos = +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = fun g -> let env = pf_env g and sigma = project g @@ -562,7 +577,7 @@ let clean_goal_with_heq ptes_infos continue_tac dyn_infos = ] g -let heq_id = id_of_string "Heq" +let heq_id = Id.of_string "Heq" let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = fun g -> @@ -570,12 +585,12 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclTHENLIST [ (* We first introduce the variables *) - tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); + tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps)); (* Then the equation itself *) - intro_using heq_id; + Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) - tclMAP introduction_no_check dyn_infos.rec_hyps; + tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) 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 @@ -585,9 +600,9 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = | 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 + pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq ); - anomaly "cannot compute new term value" + anomaly (Pp.str "cannot compute new term value") in let fun_body = mkLambda(Anonymous, @@ -615,17 +630,20 @@ let my_orelse tac1 tac2 g = (* observe (str "using snd tac since : " ++ Errors.print e); *) tac2 g -let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = +let instanciate_hyps_with_args (do_prove:Id.t 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 + let c = mkApp(mkVar hid,args) in + let evm, _ = pf_apply Typing.e_type_of g c in tclTHENLIST[ - pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); + Refiner.tclEVARS evm; + Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); thin [hid]; - h_rename [prov_hid,hid] + Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) ] g ) ( (* @@ -642,23 +660,23 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id ) ) in - if args_id = [] + if List.is_empty args_id then tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; do_prove hyps ] else tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.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 + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let remaining_hyps = - List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps in do_prove remaining_hyps g ) @@ -687,11 +705,11 @@ let build_proof in tclTHENSEQ [ - h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); + Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; - pattern_option [(false,[1]),t] None; + pattern_option [Locus.AllOccurrencesBut [1],t] None; (fun g -> observe_tac "toto" ( - tclTHENSEQ [h_simplest_case t; + tclTHENSEQ [Proofview.V82.of_tactic (Simple.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 @@ -716,7 +734,7 @@ let build_proof match kind_of_term( pf_concl g) with | Prod _ -> tclTHEN - intro + (Proofview.V82.of_tactic intro) (fun g' -> let (id,_,_) = pf_last_hyp g' in let new_term = @@ -746,6 +764,7 @@ let build_proof begin match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> let new_infos = { dyn_infos with @@ -753,7 +772,7 @@ let build_proof } in build_proof_args do_finalize new_infos g - | Const c when not (List.mem c fnames) -> + | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> let new_infos = { dyn_infos with info = (f,args) @@ -775,9 +794,10 @@ let build_proof tclTHENLIST [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + (fun hyp_id -> + h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; - h_reduce_with_zeta Tacticals.onConcl; + h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g @@ -797,6 +817,7 @@ let build_proof | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> error "Prod" | Prod _ -> error "Prod" | LetIn _ -> let new_infos = @@ -807,28 +828,28 @@ let build_proof tclTHENLIST [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; - h_reduce_with_zeta Tacticals.onConcl; + h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g - | Rel _ -> anomaly "Free var in goal conclusion !" + | Rel _ -> anomaly (Pp.str "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 + observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (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 - | [] -> + 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) *) -(* ); *) + | 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 *) @@ -842,14 +863,14 @@ let build_proof g in (* observe_tac "build_proof_args" *) (tac ) g - in - let do_finish_proof dyn_infos = + in + let do_finish_proof dyn_infos = (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) + ptes_infos + finish_proof dyn_infos) in - (* observe_tac "build_proof" *) - (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) + (* observe_tac "build_proof" *) + (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) @@ -863,18 +884,11 @@ let build_proof (* 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; + name : Id.t; types : types; offset : int; nb_realargs : int; @@ -901,9 +915,6 @@ let prove_rec_hyp 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 @@ -911,17 +922,17 @@ let generalize_non_dep hyp g = 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 (Termops.occur_var_in_decl env hyp) keep - or Termops.occur_var env hyp hyp_typ - or Termops.is_section_variable hyp (* should be dangerous *) + if Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env hyp) keep + || Termops.occur_var env hyp hyp_typ + || 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 "h_generalize" *) (Simple.generalize (List.map mkVar to_revert) )) ((* observe_tac "thin" *) (thin to_revert)) g @@ -936,11 +947,9 @@ 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 f_def = Global.lookup_constant (fst (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 (body_of_constant f_def)) - in + let f_body = Option.get (Global.body_of_constant_body f_def)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 = @@ -955,20 +964,20 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = 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 + (Typeops.type_of_constant_type (Global.env ()) (*FIXME*)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 eqn type_ctxt in - let f_id = id_of_label (con_label (destConst f)) in + let f_id = Label.to_id (con_label (fst (destConst f))) in let prove_replacement = tclTHENSEQ [ - tclDO (nb_params + rec_args_num + 1) intro; + tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic 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,Glob_term.NoBindings)); - intros_reflexivity] g + (* observe_tac "h_case" *) (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); + (Proofview.V82.of_tactic intros_reflexivity)] g ) ] in @@ -977,11 +986,12 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = 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 + (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) + Evd.empty + lemma_type + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); + Lemmas.save_proof (Vernacexpr.Proved(false,None)) @@ -989,10 +999,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = 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 + let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) 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 + let f_id = Label.to_id (con_label (fst (destConst f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) @@ -1001,12 +1011,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (destConst f) in + let finfos = find_Function_infos (fst (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" + | _ -> Errors.anomaly (Pp.str "Not a constant") ) } | _ -> () @@ -1016,12 +1026,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN - (tclDO nb_intro_to_do intro) + (tclDO nb_intro_to_do (Proofview.V82.of_tactic 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' + tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g' ) g @@ -1034,7 +1044,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (fun na -> let new_id = match na with - Name id -> fresh_id !avoid (string_of_id id) + Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; @@ -1055,9 +1065,8 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in let get_body const = - match body_of_constant (Global.lookup_constant const) with - | Some b -> - let body = force b in + match Global.body_of_constant const with + | Some body -> Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) @@ -1137,7 +1146,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : typess in let pte_to_fix,rev_info = - list_fold_left_i + 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 @@ -1175,14 +1184,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : 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) + (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info) ) 0 - (Idmap.empty,[]) + (Id.Map.empty,[]) (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info - | _ -> Idmap.empty,[] + | _ -> Id.Map.empty,[] in let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in @@ -1194,19 +1203,19 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (fun fi -> fi.name,fi.idx + 1 ,fi.types) (pre_info@others_infos) in - if other_fix_infos = [] + if List.is_empty other_fix_infos then - (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) + (* observe_tac ("h_fix") *) (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" + Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0 + | _ -> anomaly (Pp.str "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 "introducing params" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params)); + (* observe_tac "introducing predictes" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates)); + (* observe_tac "introducing branches" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches)); (* observe_tac "building fixes" *) mk_fixes; ] in @@ -1217,14 +1226,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : try let pte = try destVar pte - with e when Errors.noncritical e -> - anomaly "Property is not a variable" + with DestKO -> anomaly (Pp.str "Property is not a variable") in - let fix_info = Idmap.find pte ptes_to_fix in + let fix_info = Id.Map.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in tclTHENSEQ [ - (* observe_tac ("introducing args") *) (tclDO nb_args intro); + (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic 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 @@ -1258,7 +1266,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : build_proof interactive_proof (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = @@ -1268,7 +1276,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in observe_tac "cleaning" (clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos) in @@ -1288,7 +1296,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let nb_args = min (princ_info.nargs) (List.length ctxt) in tclTHENSEQ [ - tclDO nb_args intro; + tclDO nb_args (Proofview.V82.of_tactic 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 @@ -1307,12 +1315,12 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef fname)]; + [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]; let do_prove = build_proof interactive_proof (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = @@ -1322,7 +1330,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos in @@ -1346,15 +1354,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (* 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 h_intros = Recdef.h_intros -and list_rewrite = Recdef.list_rewrite -and evaluable_of_global_reference = Recdef.evaluable_of_global_reference +(* let 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 list_rewrite = Recdef.list_rewrite *) +(* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) @@ -1362,7 +1368,7 @@ 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 !!" + | None -> anomaly (Pp.str "No tcc proof !!") | Some lemma -> fun gls -> (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) @@ -1387,14 +1393,14 @@ 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 ) + tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) 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_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 + 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 @@ -1402,17 +1408,6 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = backtrack gls - -let build_clause eqs = - { - Tacexpr.onhyps = - Some (List.map - (fun id -> (Glob_term.all_occurrences_expr, id), Termops.InHyp) - eqs - ); - Tacexpr.concl_occs = Glob_term.no_occurrences_expr - } - let rec rewrite_eqs_in_eqs eqs = match eqs with | [] -> tclIDTAC @@ -1422,8 +1417,9 @@ let rec rewrite_eqs_in_eqs eqs = (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 Termops.all_occurrences true (* dep proofs also: *) true id (mkVar eq) false)) + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) + (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences + true (* dep proofs also: *) true id (mkVar eq) false))) gl ) eqs @@ -1435,22 +1431,22 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (tclTHENSEQ [ backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) + (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) - (apply (mkVar hrec)) + (Proofview.V82.of_tactic (apply (mkVar hrec))) [ tclTHENSEQ [ - keep (tcc_hyps@eqs); - apply (Lazy.force acc_inv); + (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); + (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); (fun g -> if is_mes then - unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + unfold_in_concl [(Locus.AllOccurrences, 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)); + [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); (observe_tac "finishing using" ( @@ -1458,7 +1454,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = Eauto.eauto_with_bases (true,5) [Evd.empty,Lazy.force refl_equal] - [Auto.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty empty_transparent_state false] ) ) ) @@ -1471,13 +1467,13 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = let is_valid_hypothesis predicates_name = - let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in + let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.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 + then Id.Set.mem (destVar pte) predicates_name else false else false in @@ -1499,7 +1495,7 @@ let prove_principle_for_gen fun na -> let new_id = match na with - | Name id -> fresh_id !avoid (string_of_id id) + | Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; @@ -1531,7 +1527,7 @@ let prove_principle_for_gen (* 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 + Util.List.chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with @@ -1542,25 +1538,25 @@ let prove_principle_for_gen 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 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))))) + Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = - tclTHEN (h_generalize (List.map mkVar l)) (clear l) + tclTHEN (Tactics.Simple.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) + (Proofview.V82.of_tactic (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)) + (Proofview.V82.tactic (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|])) + Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) ) ) ) @@ -1570,7 +1566,7 @@ let prove_principle_for_gen 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 !!") + | None -> error "No tcc proof !!" | Some lemma -> lemma in (* let rec list_diff del_list check_list = *) @@ -1588,18 +1584,18 @@ let prove_principle_for_gen let hyps = pf_ids_of_hyps gls in let hid = next_ident_away_in_goal - (id_of_string "prov") + (Id.of_string "prov") hyps in tclTHENSEQ [ generalize [lemma]; - h_intro hid; - Elim.h_decompose_and (mkVar hid); + Proofview.V82.of_tactic (Simple.intro hid); + Proofview.V82.of_tactic (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 = [] + tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); + if List.is_empty !tcc_list then begin tcc_list := [hid]; @@ -1617,22 +1613,22 @@ let prove_principle_for_gen (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 + (* observe_tac "" *) Proofview.V82.of_tactic (assert_by (Name acc_rec_arg_id) (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (prove_rec_arg_acc) + (Proofview.V82.tactic 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)); + (* observe_tac "h_fix " *) (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); + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> let body = let _,args = destApp (pf_concl gl') in - array_last args + Array.last args in let body_info rec_hyps = { @@ -1677,14 +1673,14 @@ let prove_principle_for_gen is_valid = is_valid_hypothesis predicates_names } in - let ptes_info : pte_info Idmap.t = + let ptes_info : pte_info Id.Map.t = List.fold_left (fun map pte_id -> - Idmap.add pte_id + Id.Map.add pte_id pte_info map ) - Idmap.empty + Id.Map.empty predicates_names in let make_proof rec_hyps = diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 04fcc8d4..545f8931 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,58 +1,25 @@ open Printer +open Errors open Util open Term +open Vars +open Context open Namegen open Names -open Declarations +open Declareops open Pp open Entries -open Hiddentac -open Evd -open Tacmach -open Proof_type -open Tacticals open Tactics open Indfun_common open Functional_principles_proofs +open Misctypes 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 + then Pp.msg_debug s (* Transform an inductive induction principle into @@ -63,14 +30,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 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 = + let rec change_predicates_names (avoid:Id.t 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 " + | (Anonymous,_,_)::_ -> anomaly (Pp.str "Anonymous property binder ") in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = @@ -91,7 +58,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) in let new_predicates = - list_map_i + List.map_i change_predicate_sort 0 princ_type_info.predicates @@ -99,16 +66,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 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 + | Some (Globnames.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 + let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> match kind_of_term t with - | Var id -> Idset.mem id set + | Var id -> Id.Set.mem id set | _ -> false in let pre_princ = @@ -126,17 +93,17 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 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 + | Ind((u,_),_) -> MutInd.equal u rel_as_kn + | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn | _ -> false in let get_fun_num c = match kind_of_term c with - | Ind(_,num) -> num - | Construct((_,num),_) -> num + | Ind((_,num),_) -> num + | Construct(((_,num),_),_) -> num | _ -> assert false in - let dummy_var = mkVar (id_of_string "________") in + let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in (* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) @@ -157,7 +124,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 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 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) -> @@ -191,7 +158,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x : name = get_name (Termops.ids_of_context env) x in + let new_x : Name.t = get_name (Termops.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 @@ -220,7 +187,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 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 (Termops.ids_of_context env) x in + let new_x : Name.t = get_name (Termops.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 @@ -255,7 +222,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let pre_res = replace_vars - (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_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 @@ -271,8 +238,10 @@ 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) + let args,ty = decompose_prod t in + let s = destSort ty in + Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); + compose_prod args (mkSort toSort) ) in let princName_as_constr = Constrintern.global_reference princName in @@ -288,23 +257,6 @@ let change_property_sort toSort princ princName = ) 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 e when Errors.noncritical e -> mt () - ) ++msg) - 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 @@ -319,23 +271,25 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro (* 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_________") [] + next_ident_away_in_goal (Id.of_string "___________princ_________") [] in + let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof new_princ_name - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - new_principle_type - (hook new_principle_type) + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) + (*FIXME*) Evd.empty + new_principle_type + hook ; (* let _tim1 = System.get_time () in *) - Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); + ignore (Pfedit.by (Proofview.V82.tactic (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 + get_proof_clean true, Ephemeron.create hook end @@ -347,7 +301,7 @@ let generate_functional_principle try let f = funs.(i) in - let type_sort = Termops.new_sort_in_family InType in + let type_sort = Universes.new_sort_in_family InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -357,42 +311,35 @@ let generate_functional_principle match new_princ_name with | Some (id) -> id,id | None -> - let id_of_f = id_of_label (con_label f) in + let id_of_f = Label.to_id (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 + let hook new_principle_type _ _ = + if Option.is_empty sorts then - (* let id_of_f = id_of_label (con_label f) in *) + (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let s = Termops.new_sort_in_family fam_sort in + let s = Universes.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_secctx = None; - const_entry_type = None; - const_entry_opaque = false } - in + let ce = Declare.definition_entry value in (*FIXME, no poly, nothing *) ignore( Declare.declare_constant name (Entries.DefinitionEntry ce, - Decl_kinds.IsDefinition (Decl_kinds.Scheme) - ) + Decl_kinds.IsDefinition (Decl_kinds.Scheme)) ); - Flags.if_verbose - (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) - name; + Declare.definition_message 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 + 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 !!!! @@ -403,10 +350,10 @@ let generate_functional_principle begin try let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + then if String.equal (String.sub s 0 n) "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -420,26 +367,25 @@ let generate_functional_principle exception Not_Rec let get_funs_constant mp dp = - let rec get_funs_constant const e : (Names.constant*int) array = + let 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 + let const = make_con mp dp (Label.of_id id) in const,i | Anonymous -> - anomaly "Anonymous fix" + anomaly (Pp.str "Anonymous fix") ) na | _ -> [|const,0|] in function const -> let find_constant_body const = - match body_of_constant (Global.lookup_constant const) with - | Some b -> - let body = force b in + match Global.body_of_constant const with + | Some body -> let body = Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) @@ -462,7 +408,7 @@ let get_funs_constant mp dp = let first_params = List.hd l_params in List.iter (fun params -> - if not (list_equal (fun (n1, c1) (n2, c2) -> n1 = n2 && eq_constr c1 c2) first_params params) + if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && eq_constr c1 c2) first_params params) then error "Not a mutal recursive block" ) l_params @@ -474,14 +420,15 @@ let get_funs_constant mp dp = match kind_of_term body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) | _ -> - if is_first && (List.length l_bodies = 1) + if is_first && Int.equal (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 *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - ia1 = ia2 && na1 = na2 && array_equal eq_constr ta1 ta2 && array_equal eq_constr ca1 ca2 + Array.equal Int.equal ia1 ia2 && Array.equal Name.equal na1 na2 && + Array.equal eq_constr ta1 ta2 && Array.equal eq_constr ca1 ca2 in if not (eq_infos first_infos (extract_info false body)) then error "Not a mutal recursive block" @@ -494,7 +441,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition_entry list = +let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry list = let env = Global.env () and sigma = Evd.empty in let funs = List.map fst fas in @@ -513,26 +460,27 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition 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) + (function cst -> List.assoc_f Constant.equal cst this_block_funs_indexes) funs in let ind_list = List.map (fun (idx) -> let ind = first_fun_kn,idx in - ind,true,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),true,prop_sort ) funs_indexes in + let sigma, schemes = + Indrec.build_mutual_induction_scheme env sigma ind_list + in let l_schemes = - List.map - (Typing.type_of env sigma) - (Indrec.build_mutual_induction_scheme env sigma ind_list) + List.map (Typing.type_of env sigma) schemes in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fas in @@ -540,9 +488,9 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition let first_type,other_princ_types = match l_schemes with s::l_schemes -> s,l_schemes - | _ -> anomaly "" + | _ -> anomaly (Pp.str "") in - let (_,(const,_,_)) = + let ((_,(const,_)),_) = try build_functional_principle false first_type @@ -556,10 +504,10 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition begin try let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + then if String.equal (String.sub s 0 n) "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -574,13 +522,13 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition let finfos = find_Function_infos this_block_funs.(0) in try let equation = Option.get finfos.equation_lemma in - Declarations.is_opaque (Global.lookup_constant equation) + Declareops.is_opaque (Global.lookup_constant equation) 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 = [] + if List.is_empty other_princ_types then [const] else @@ -590,7 +538,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition 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 ctxt,fix = decompose_lam_assum (fst(fst(Future.force 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 *) @@ -616,7 +564,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let (_,(const,_,_)) = + let ((_,(const,_)),_) = build_functional_principle false (List.nth other_princ_types (!i - 1)) @@ -632,7 +580,8 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt in {const with - Entries.const_entry_body = princ_body; + Entries.const_entry_body = + (Future.from_val (Term_typing.mk_pure_proof princ_body)); Entries.const_entry_type = Some scheme_type } ) @@ -648,11 +597,11 @@ let build_scheme fas = (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" + match Smartlocate.global_with_alias f with + | Globnames.ConstRef c -> c + | _ -> Errors.error "Functional Scheme can only be used with functions" with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f) + Errors.error ("Cannot find "^ Libnames.string_of_reference f) in (f_as_constant,sort) ) @@ -665,8 +614,7 @@ let build_scheme fas = (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 + Declare.definition_message princ_id ) fas bodies_types; @@ -681,10 +629,10 @@ let build_case_scheme fa = (* Constrintern.global_reference id *) (* in *) let funs = (fun (_,f,_) -> - try Libnames.constr_of_global (Nametab.global f) + try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in - let first_fun = destConst funs in + Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in + let first_fun,u = 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 @@ -696,16 +644,18 @@ let build_case_scheme fa = 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 + List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes in let ind_fun = let ind = first_fun_kn,funs_indexes in - ind,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),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 sigma, scheme = + (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in + let scheme_type = (Typing.type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fa in @@ -722,6 +672,6 @@ let build_case_scheme fa = (Some princ_name) this_block_funs 0 - (prove_princ_for_struct false 0 [|destConst funs|]) + (prove_princ_for_struct false 0 [|fst (destConst funs)|]) in () diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 1c02c16e..a16b834f 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -1,6 +1,6 @@ open Names open Term - +open Misctypes val generate_functional_principle : (* do we accept interactive proving *) @@ -10,7 +10,7 @@ val generate_functional_principle : (* *) sorts array option -> (* Name of the new principle *) - (identifier) option -> + (Id.t) option -> (* the compute functions to use *) constant array -> (* We prove the nth- principle *) @@ -27,8 +27,8 @@ val compute_new_princ_type_from_rel : constr array -> sorts array -> exception No_graph_found -val make_scheme : (constant*Glob_term.glob_sort) list -> Entries.definition_entry list +val make_scheme : (constant*glob_sort) list -> Entries.definition_entry list -val build_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) list -> unit -val build_case_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) -> unit +val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit +val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index ffaa2208..fd48ab59 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -1,35 +1,38 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function - | Glob_term.ImplicitBindings l -> + | ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc prc l - | Glob_term.ExplicitBindings l -> + pr_sequence prc l + | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Glob_term.NoBindings -> mt () + pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) @@ -69,18 +72,23 @@ END TACTIC EXTEND newfuninv [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> [ - Invfun.invfun hyp fname + Proofview.V82.tactic (Invfun.invfun hyp fname) ] END -let pr_intro_as_pat prc _ _ pat = +let pr_intro_as_pat _prc _ _ pat = match pat with - | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat + | Some pat -> + spc () ++ str "as" ++ spc () ++ (* Miscprint.pr_intro_pattern prc pat *) + str"" | None -> mt () +let out_disjunctive = function + | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) + | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected." -ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat +ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] | [] ->[ None ] END @@ -96,7 +104,7 @@ TACTIC EXTEND newfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ] END (***** debug only ***) TACTIC EXTEND snewfunind @@ -107,11 +115,11 @@ TACTIC EXTEND snewfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ] END -let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc +let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc ARGUMENT EXTEND constr_coma_sequence' TYPED AS constr_list @@ -133,34 +141,37 @@ module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic -module FunctionGram = -struct - let gec s = Gram.entry_create ("Function."^s) - (* types *) - let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc" -end -open FunctionGram +type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located + +let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) = + Genarg.create_arg None "function_rec_definition_loc" + +let function_rec_definition_loc = + Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) GEXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> loc, g ]] + [ [ g = Vernac.rec_definition -> !@loc, g ]] ; - END -type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type +END -let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype), - (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype), - (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) = - Genarg.create_arg None "function_rec_definition_loc" +(* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function - ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] -> - [ - do_generate_principle false (List.map snd recsl); - - ] + ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] + => [ let hard = List.exists (function + | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true + | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in + match + Vernac_classifier.classify_vernac + (Vernacexpr.VernacFixpoint(None, List.map snd recsl)) + with + | Vernacexpr.VtSideff ids, _ when hard -> + Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) + | x -> x ] + -> [ do_generate_principle false (List.map snd recsl) ] END let pr_fun_scheme_arg (princ_name,fun_name,s) = @@ -175,23 +186,25 @@ END let warning_error names e = - let e = Cerrors.process_vernac_interp_error e in + let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in 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) ++ + h 1 (pr_enum Libnames.pr_reference names) ++ if do_observe () then (spc () ++ Errors.print 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) ++ + h 1 (pr_enum Libnames.pr_reference names) ++ if do_observe () then Errors.print e else mt ()) | _ -> raise e VERNAC COMMAND EXTEND NewFunctionalScheme - ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> + ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] + => [ Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater ] + -> [ begin try @@ -202,13 +215,13 @@ VERNAC COMMAND EXTEND NewFunctionalScheme | (_,fun_name,_)::_ -> begin begin - make_graph (Nametab.global fun_name) + make_graph (Smartlocate.global_with_alias 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 when Errors.noncritical e -> + Errors.error ("Cannot generate induction principle(s)") + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e @@ -225,15 +238,14 @@ END (***** debug only ***) VERNAC COMMAND EXTEND NewFunctionalCase - ["Functional" "Case" fun_scheme_arg(fas) ] -> - [ - Functional_principles_types.build_case_scheme fas - ] + ["Functional" "Case" fun_scheme_arg(fas) ] + => [ Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater ] + -> [ Functional_principles_types.build_case_scheme fas ] END (***** debug only ***) -VERNAC COMMAND EXTEND GenerateGraph -["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] +VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY +["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ] END @@ -273,7 +285,7 @@ let constr_head_match u t= if isApp u then let uhd,args= destApp u in - uhd=t + Constr.equal uhd t else false (** [hdMatchSub inu t] returns the list of occurrences of [t] in @@ -296,22 +308,25 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = 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; + let max_rel = try Int.Set.max_elt freeset with Not_found -> -1 in + {fname = f; largs = args; free = Int.Set.is_empty freeset; max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + let mkEq typ c1 c2 = - mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) + mkApp (make_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) + (Proofview.V82.of_tactic (Tactics.letin_tac None (Name idunsafe) cstr None Locusops.allHypsAndConcl)) (tclTHENFIRST - (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) - Tactics.reflexivity) + (Proofview.V82.of_tactic (Tactics.assert_before Anonymous (mkEq typ (mkVar idunsafe) cstr))) + (Proofview.V82.of_tactic Tactics.reflexivity)) gl @@ -357,7 +372,7 @@ let poseq_list_ids lcstr gl = 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 + List.fold_right (List.add_set Pervasives.(=)) pre_res [] in (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); res) @@ -367,7 +382,7 @@ let find_fapp (test:constr -> bool) g : fapp_info list = 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) +let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) (nexttac:Proof_type.tactic) g = let test = match oid with | Some id -> @@ -377,7 +392,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l 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"; + if List.is_empty ordered_info_list then Errors.error "function not found in goal\n"; let taclist: Proof_type.tactic list = List.map (fun info -> @@ -419,10 +434,10 @@ TACTIC EXTEND finduction ["finduction" ident(id) natural_opt(oi)] -> [ match oi with - | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" + | Some(n) when n<=0 -> Errors.error "numerical argument must be > 0" | _ -> let heuristic = chose_heuristic oi in - finduction (Some id) heuristic tclIDTAC + Proofview.V82.tactic (finduction (Some id) heuristic tclIDTAC) ] END @@ -432,13 +447,13 @@ TACTIC EXTEND fauto [ "fauto" tactic(tac)] -> [ let heuristic = chose_heuristic None in - finduction None heuristic (Tacinterp.eval_tactic tac) + Proofview.V82.tactic (finduction None heuristic (Proofview.V82.of_tactic (Tacinterp.eval_tactic tac))) ] | [ "fauto" ] -> [ let heuristic = chose_heuristic None in - finduction None heuristic tclIDTAC + Proofview.V82.tactic (finduction None heuristic tclIDTAC) ] END @@ -446,31 +461,31 @@ END TACTIC EXTEND poseq [ "poseq" ident(x) constr(c) ] -> - [ poseq x c ] + [ Proofview.V82.tactic (poseq x c) ] END -VERNAC COMMAND EXTEND Showindinfo +VERNAC COMMAND EXTEND Showindinfo CLASSIFIED AS QUERY [ "showindinfo" ident(x) ] -> [ Merge.showind x ] END -VERNAC COMMAND EXTEND MergeFunind +VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF [ "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 f1,ctx = Constrintern.interp_constr (Global.env()) Evd.empty + (CRef (Libnames.Ident (Loc.ghost,id1),None)) in + let f2,ctx' = Constrintern.interp_constr (Global.env()) Evd.empty + (CRef (Libnames.Ident (Loc.ghost,id2),None)) 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 + if not (Int.equal ar1 (List.length cl1)) then + Errors.error ("not the right number of arguments for " ^ Id.to_string id1) in let _ = - if ar2 <> List.length cl2 then - Util.error ("not the right number of arguments for " ^ string_of_id id2) in + if not (Int.equal ar2 (List.length cl2)) then + Errors.error ("not the right number of arguments for " ^ Id.to_string id2) in Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id ] END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index b9e0e62a..a2577e2b 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -2,26 +2,30 @@ open Printer open Pp open Names open Term +open Vars open Glob_term -open Libnames +open Glob_ops +open Globnames open Indfun_common +open Errors open Util open Glob_termops +open Misctypes let observe strm = if do_observe () - then Pp.msgnl strm + then Pp.msg_debug strm else () -let observennl strm = +(*let observennl strm = if do_observe () then Pp.msg strm - else () + else ()*) type binder_type = - | Lambda of name - | Prod of name - | LetIn of name + | Lambda of Name.t + | Prod of Name.t + | LetIn of Name.t type glob_context = (binder_type*glob_constr) list @@ -54,7 +58,7 @@ type 'a build_entry_pre_return = type 'a build_entry_return = { result : 'a build_entry_pre_return list; - to_avoid : identifier list + to_avoid : Id.t list } (* @@ -86,7 +90,7 @@ let combine_results in (* and then we flatten the map *) { result = List.concat pre_result; - to_avoid = list_union res1.to_avoid res2.to_avoid + to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid } @@ -111,9 +115,9 @@ let ids_of_binder = function 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 + let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: - (if idmap_is_empty new_mapping + (if Id.Map.is_empty new_mapping then l else change_vars_in_binder new_mapping l ) @@ -122,7 +126,7 @@ 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) + if Id.List.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l @@ -130,28 +134,28 @@ 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 + List.exists (is_free_in id) args || Id.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) = + let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) = match na with - | Name id when List.mem id avoid -> + | Name id when Id.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 + Name new_id,Id.Map.add id new_id mapping,new_id::avoid | _ -> na,mapping,avoid in - let next_bt_away bt (avoid:identifier list) = + let next_bt_away bt (avoid:Id.t list) = match bt with | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let new_na,mapping,new_avoid = next_name_away na Id.Map.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 + let new_na,mapping,new_avoid = next_name_away na Id.Map.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 + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in Lambda new_na,mapping,new_avoid in let rec do_apply avoid ctxt body args = @@ -170,7 +174,7 @@ let apply_args ctxt body args = 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 mapping = Id.Map.add id new_id Id.Map.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 @@ -266,11 +270,11 @@ let make_discr_match_el = end *) let make_discr_match_brl i = - list_map_i + List.map_i (fun j (_,idl,patl,_) -> - if j=i - then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref)) + if Int.equal j i + then (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_True_ref)) + else (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_False_ref)) ) 0 (* @@ -285,10 +289,6 @@ let make_discr_match brl = 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 *) (**********************************************************************) @@ -304,18 +304,17 @@ let build_constructors_of_type ind' argl = Impargs.implicits_of_global constructref in let cst_narg = - Inductiveops.mis_constructor_nargs_env + Inductiveops.constructor_nallargs_env (Global.env ()) construct in - let argl = match argl with - | None -> + let argl = + if List.is_empty argl + then Array.to_list - (Array.init cst_narg (fun _ -> mkGHole ()) + (Array.init (cst_narg - npar) (fun _ -> mkGHole ()) ) - | Some l -> - Array.to_list - (Array.init npar (fun _ -> mkGHole ()))@l + else argl in let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) @@ -324,40 +323,6 @@ let build_constructors_of_type ind' argl = ) 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,_ = glob_decompose_app b in - match f with - | GRef(_,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 - | GCast(_,b,_) -> find_type_of nb b - | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *) - | _ -> raise (Invalid_argument "not a ref") - - - - (******************) (* Main functions *) (******************) @@ -368,14 +333,14 @@ 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 + let value = Option.map (fun x-> fst (Pretyping.understand env Evd.empty x)) raw_value in + let typ,ctx = Pretyping.understand env Evd.empty ~expected_type:Pretyping.IsType 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); + observe (str "new rel env := " ++ Printer.pr_rel_context_of env Evd.empty); match pat with | PatVar(_,na) -> Environ.push_rel (na,None,typ) env @@ -385,14 +350,14 @@ let add_pat_variables pat typ env : Environ.env = 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 constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (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 + Context.fold_rel_context (fun (na,v,t) (env,ctxt) -> match na with | Anonymous -> assert false @@ -411,7 +376,7 @@ let add_pat_variables pat typ env : Environ.env = ~init:(env,[]) ) in - observe (str "new var env := " ++ Printer.pr_named_context_of res); + observe (str "new var env := " ++ Printer.pr_named_context_of res Evd.empty); res @@ -423,7 +388,7 @@ let rec pattern_to_term_and_type env typ = function mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = - Inductiveops.mis_constructor_nargs_env + Inductiveops.constructor_nallargs_env (Global.env ()) constr in @@ -432,7 +397,7 @@ let rec pattern_to_term_and_type env typ = function 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 constructor = List.find (fun cs -> eq_constructor (fst 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 @@ -440,7 +405,7 @@ let rec pattern_to_term_and_type env typ = function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) + (fun i -> Detyping.detype false [] env Evd.empty csta.(i)) ) in let patl_as_term = @@ -508,12 +473,12 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | u::l -> match t with | GLambda(loc,na,_,nat,b) -> - GLetIn(dummy_loc,na,u,aux b l) + GLetIn(Loc.ghost,na,u,aux b l) | _ -> - GApp(dummy_loc,t,l) + GApp(Loc.ghost,t,l) in build_entry_lc env funnames avoid (aux f args) - | GVar(_,id) when Idset.mem id funnames -> + | GVar(_,id) when Id.Set.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 @@ -521,10 +486,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = 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_as_constr,ctx = Pretyping.understand env Evd.empty 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 res_raw_type = Detyping.detype false [] env Evd.empty 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 = mkGVar res in let new_result = @@ -568,7 +533,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_b = replace_var_by_term id - (GVar(dummy_loc,id)) + (GVar(Loc.ghost,id)) b in (Name new_id,new_b,new_avoid) @@ -629,7 +594,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = 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_as_constr,ctx = Pretyping.understand env Evd.empty v in let v_type = Typing.type_of env Evd.empty v_as_constr in let new_env = match n with @@ -645,7 +610,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand env Evd.empty 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 @@ -654,11 +619,11 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind None in - assert (Array.length case_pats = 2); + let case_pats = build_constructors_of_type (fst ind) [] in + assert (Int.equal (Array.length case_pats) 2); let brl = - list_map_i - (fun i x -> (dummy_loc,[],[case_pats.(i)],x)) + List.map_i + (fun i x -> (Loc.ghost,[],[case_pats.(i)],x)) 0 [lhs;rhs] in @@ -670,14 +635,14 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | GLetTuple(_,nal,_,b,e) -> begin let nal_as_glob_constr = - Some (List.map + List.map (function Name id -> mkGVar id | Anonymous -> mkGHole () ) - nal) + nal in - let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand env Evd.empty 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 @@ -686,10 +651,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind nal_as_glob_constr in - assert (Array.length case_pats = 1); + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in + assert (Int.equal (Array.length case_pats) 1); let br = - (dummy_loc,[],[case_pats.(0)],e) + (Loc.ghost,[],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr @@ -724,7 +689,7 @@ and build_entry_lc_from_case env funname make_discr in let types = List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in + let case_arg_as_constr,ctx = Pretyping.understand env Evd.empty case_arg in Typing.type_of env Evd.empty case_arg_as_constr ) el in @@ -746,7 +711,8 @@ and build_entry_lc_from_case env funname make_discr { 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 + List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) + [] results } and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid @@ -761,7 +727,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (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 -> glob_constr -> glob_constr) list = + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> @@ -775,7 +741,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve in let raw_typ_of_id = Detyping.detype false [] - (Termops.names_of_rel_context env_with_pat_ids) typ_of_id + env_with_pat_ids Evd.empty typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) pat_ids @@ -816,18 +782,18 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let those_pattern_preconds = (List.flatten ( - list_map3 + 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 typ = Detyping.detype false [] new_env Evd.empty 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 + if Id.Set.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 + Detyping.detype false [] new_env Evd.empty typ_of_id in raw_typ_of_id )::acc @@ -871,14 +837,14 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let is_res id = try - String.sub (string_of_id id) 0 3 = "res" + String.equal (String.sub (Id.to_string id) 0 4) "_res" with Invalid_argument _ -> false let same_raw_term rt1 rt2 = match rt1,rt2 with - | GRef(_,r1), GRef (_,r2) -> r1=r2 + | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = @@ -892,7 +858,7 @@ let decompose_raw_eq lhs rhs = observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in let slrhs = List.length lrhs in - if same_raw_term lhd rhd && sllhs = slrhs + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) List.fold_right2 decompose_raw_eq llhs lrhs acc @@ -928,7 +894,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in - let t' = Pretyping.Default.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand env Evd.empty new_t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -937,18 +903,18 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in mkGProd(n,new_t,new_b), - Idset.filter not_free_in_t id_to_exclude + Id.Set.filter not_free_in_t id_to_exclude | _ -> (* the first args is the name of the function! *) assert false end - | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt]) - when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt]) + when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try Pretyping.Default.understand Evd.empty env t + try fst (Pretyping.understand env Evd.empty t)(*FIXME*) with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in @@ -970,36 +936,36 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in mkGProd(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 jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in + let ty',ctx = Pretyping.understand env Evd.empty ty in let ind,args' = Inductive.find_inductive env ty' in - let mib,_ = Global.lookup_inductive ind in + let mib,_ = Global.lookup_inductive (fst ind) in let nparam = mib.Declarations.mind_nparams in let params,arg' = - ((Util.list_chop nparam args')) + ((Util.List.chop nparam args')) in let rt_typ = - GApp(Util.dummy_loc, - GRef (Util.dummy_loc,Libnames.IndRef ind), + GApp(Loc.ghost, + GRef (Loc.ghost,Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] - (Termops.names_of_rel_context env) + env Evd.empty p) params)@(Array.to_list (Array.make (List.length args' - nparam) (mkGHole ())))) in let eq' = - GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt]) + GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); - let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in + let eq'_as_constr,ctx = Pretyping.understand env Evd.empty 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 + let ty' = snd (Util.List.chop nparam ty) in List.fold_left2 (fun acc var_as_constr arg -> if isRel var_as_constr @@ -1011,11 +977,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | Anonymous -> acc | Name id' -> (id',Detyping.detype false [] - (Termops.names_of_rel_context env) + env + Evd.empty arg)::acc else if isVar var_as_constr then (destVar var_as_constr,Detyping.detype false [] - (Termops.names_of_rel_context env) + env + Evd.empty arg)::acc else acc ) @@ -1041,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = 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 + let t',ctx = Pretyping.understand env Evd.empty eq' in Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1056,10 +1024,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then mkGProd(n,t,new_b),id_to_exclude - else new_b, Idset.add id id_to_exclude + else new_b, Id.Set.add id id_to_exclude *) - | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) - when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2]) + when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try @@ -1079,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t' = Pretyping.Default.understand Evd.empty env t in + let t',ctx = Pretyping.understand env Evd.empty t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1088,14 +1056,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (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) - | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id + (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t' = Pretyping.Default.understand Evd.empty env t in + let t',ctx = Pretyping.understand env Evd.empty t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1104,17 +1072,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (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) - | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id + (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | GLambda(_,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_glob_constr rt); - let t' = Pretyping.Default.understand Evd.empty env t in + let t',ctx = Pretyping.understand env Evd.empty t in match n with | Name id -> let new_env = Environ.push_rel (n,None,t') env in @@ -1124,19 +1092,19 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (args@[mkGVar id])new_crossed_types (depth + 1 ) b in - if Idset.mem id id_to_exclude && depth >= nb_args + if Id.Set.mem id id_to_exclude && depth >= nb_args then - new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) + new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else - GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude - | _ -> anomaly "Should not have an anonymous function here" + GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + | _ -> anomaly (Pp.str "Should not have an anonymous function here") (* We have renamed all the anonymous functions during alpha_renaming phase *) end | GLetIn(_,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 t',ctx = Pretyping.understand env Evd.empty 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 = @@ -1145,13 +1113,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = 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) - | _ -> GLetIn(dummy_loc,n,t,new_b), - Idset.filter not_free_in_t id_to_exclude + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> GLetIn(Loc.ghost,n,t,new_b), + Id.Set.filter not_free_in_t id_to_exclude end | GLetTuple(_,nal,(na,rto),t,b) -> - assert (rto=None); + assert (Option.is_empty rto); begin let not_free_in_t id = not (is_free_in id t) in let new_t,id_to_exclude' = @@ -1161,7 +1129,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (crossed_types) depth t in - let t' = Pretyping.Default.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand env Evd.empty new_t in let new_env = Environ.push_rel (na,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1170,15 +1138,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (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) *) +(* | Name id when Id.Set.mem id id_to_exclude -> *) +(* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) - GLetTuple(dummy_loc,nal,(na,None),t,new_b), - Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') + GLetTuple(Loc.ghost,nal,(na,None),t,new_b), + Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end - | _ -> mkGApp(mkGVar relname,args@[rt]),Idset.empty + | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty (* debuging wrapper *) @@ -1201,7 +1169,7 @@ let rebuild_cons env nb_args relname args crossed_types rt = *) let rec compute_cst_params relnames params = function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params - | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames -> + | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) | GApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) @@ -1219,11 +1187,11 @@ 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',(GVar(_,id'))::rtl' - when id_ord id id' == 0 && not is_defined -> + when Id.compare 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 * Glob_term.glob_constr * bool) list array) csts = +let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts = let rels_params = Array.mapi (fun i args -> @@ -1237,12 +1205,12 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b let l = ref [] in let _ = try - list_iter_i + List.iteri (fun i ((n,nt,is_defined) as param) -> - if array_for_all + if Array.for_all (fun l -> let (n',nt',is_defined') = List.nth l i in - n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined') + Name.equal n n' && Notation_ops.eq_glob_constr nt nt' && (is_defined : bool) == is_defined') rels_params then l := param::!l @@ -1255,22 +1223,23 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b 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,GType None)) + | Constrexpr.CProdN(loc,n,t') -> + Constrexpr.CProdN(loc,n,rebuild_return_type t') + | Constrexpr.CLetIn(loc,na,t,t') -> + Constrexpr.CLetIn(loc,na,t,rebuild_return_type t') + | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous], + Constrexpr.Default Decl_kinds.Explicit,rt], + Constrexpr.CSort(Loc.ghost,GType [])) let do_build_inductive - funnames (funsargs: (Names.name * glob_constr * bool) list list) - returned_types - (rtl:glob_constr list) = + mp_dp + funnames (funsargs: (Name.t * glob_constr * bool) list list) + returned_types + (rtl:glob_constr list) = let _time1 = System.get_time () in -(* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) - let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in + (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) + let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.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 @@ -1281,12 +1250,22 @@ let do_build_inductive 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 + let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.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 (Constrintern.global_reference id)) env + let c = + match mp_dp with + | None -> (Constrintern.global_reference id) + | Some(mp,dp) -> mkConst (make_con mp dp (Label.of_id id)) + in + Environ.push_named (id,None, + try + Typing.type_of env Evd.empty c + with Not_found -> + raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) + ) env ) funnames (Global.env ()) @@ -1294,19 +1273,19 @@ let do_build_inductive 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 * Glob_term.glob_constr * bool ) list = + let rel_first_args :(Name.t * Glob_term.glob_constr * 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_glob_constr Idset.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else - Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + Constrexpr.CProdN + (Loc.ghost, + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1318,8 +1297,9 @@ let do_build_inductive 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 + Util.Array.fold_left2 (fun env rel_name rel_ar -> + Environ.push_named (rel_name,None, + fst (with_full_print (Constrintern.interp_constr env Evd.empty) rel_ar)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = @@ -1344,9 +1324,9 @@ let do_build_inductive (*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)) + Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in - let rel_constructors i rt : (identifier*glob_constr) list = + let rel_constructors i rt : (Id.t*glob_constr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in @@ -1360,19 +1340,19 @@ let do_build_inductive rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list = - (snd (list_chop nrel_params funargs)) + let rel_first_args :(Name.t * Glob_term.glob_constr * 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_glob_constr Idset.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else - Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + Constrexpr.CProdN + (Loc.ghost, + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1384,31 +1364,40 @@ let do_build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in + let rel_params_ids = + List.fold_left + (fun acc (na,_,_) -> + match na with + Anonymous -> acc + | Name id -> id::acc + ) + [] + rels_params + in let rel_params = List.map (fun (n,t,is_defined) -> if is_defined then - Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t) + Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t) else - Topconstr.LocalRawAssum - ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t) + Constrexpr.LocalRawAssum + ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.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_glob_type Idset.empty) ((* zeta_normalize *) t) + false,((Loc.ghost,id), + with_full_print + (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) ) )) (rel_constructors) in let rel_ind i ext_rel_constructors = - ((dummy_loc,relnames.(i)), + ((Loc.ghost,relnames.(i)), rel_params, Some rel_arities.(i), ext_rel_constructors),[] @@ -1437,7 +1426,7 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false false)) Decl_kinds.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in @@ -1448,7 +1437,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ msg in @@ -1463,7 +1452,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ Errors.print reraise in @@ -1472,9 +1461,9 @@ let do_build_inductive -let build_inductive funnames funsargs returned_types rtl = +let build_inductive mp_dp funnames funsargs returned_types rtl = try - do_build_inductive funnames funsargs returned_types rtl + do_build_inductive mp_dp funnames funsargs returned_types rtl with e when Errors.noncritical e -> raise (Building_graph e) diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index 5c91292b..b0a05ec3 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -1,5 +1,4 @@ - - +open Names (* [build_inductive parametrize funnames funargs returned_types bodies] @@ -8,9 +7,10 @@ *) val build_inductive : - Names.identifier list -> (* The list of function name *) - (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *) - Topconstr.constr_expr list -> (* The list of function returned type *) + (ModPath.t * DirPath.t) option -> + Id.t list -> (* The list of function name *) + (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *) + Constrexpr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) unit diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 6cc932b1..291f835e 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,24 +1,25 @@ open Pp open Glob_term +open Errors open Util open Names -(* Ocaml 3.06 Map.S does not handle is_empty *) -let idmap_is_empty m = m = Idmap.empty +open Decl_kinds +open Misctypes (* Some basic functions to rebuild glob_constr - In each of them the location is Util.dummy_loc + In each of them the location is Loc.ghost *) -let mkGRef ref = GRef(dummy_loc,ref) -let mkGVar id = GVar(dummy_loc,id) -let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl) -let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b) -let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b) -let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b) -let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl) -let mkGSort s = GSort(dummy_loc,s) -let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous) -let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) +let mkGRef ref = GRef(Loc.ghost,ref,None) +let mkGVar id = GVar(Loc.ghost,id) +let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl) +let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b) +let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b) +let mkGLetIn(n,t,b) = GLetIn(Loc.ghost,n,t,b) +let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl) +let mkGSort s = GSort(Loc.ghost,s) +let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) +let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t) (* Some basic functions to decompose glob_constrs @@ -107,7 +108,7 @@ let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) to [P1 \/ ( .... \/ Pn)] *) let rec glob_make_or_list = function - | [] -> raise (Invalid_argument "mk_or") + | [] -> invalid_arg "mk_or" | [e] -> e | e::l -> glob_make_or e (glob_make_or_list l) @@ -115,7 +116,7 @@ let rec glob_make_or_list = function let remove_name_from_mapping mapping na = match na with | Anonymous -> mapping - | Name id -> Idmap.remove id mapping + | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = @@ -124,7 +125,7 @@ let change_vars = | GVar(loc,id) -> let new_id = try - Idmap.find id mapping + Id.Map.find id mapping with Not_found -> id in GVar(loc,new_id) @@ -179,13 +180,12 @@ let change_vars = | GRec _ -> error "Local (co)fixes are not supported" | GSort _ -> rt | GHole _ -> rt - | GCast(loc,b,CastConv (k,t)) -> - GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) - | GCast(loc,b,CastCoerce) -> - GCast(loc,change_vars mapping b,CastCoerce) + | GCast(loc,b,c) -> + GCast(loc,change_vars mapping b, + Miscops.map_cast_type (change_vars mapping) c) 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 + let new_mapping = List.fold_right Id.Map.remove idl mapping in + if Id.Map.is_empty new_mapping then br else (loc,idl,patl,change_vars new_mapping res) in @@ -197,27 +197,27 @@ 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 new_id),(new_id::excluded),Id.Map.empty | PatVar(loc,Name id) -> - if List.mem id excluded + if Id.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 + (Id.Map.add id new_id Id.Map.empty) + else pat,excluded,Id.Map.empty | PatCstr(loc,constr,patl,na) -> let new_na,new_excluded,map = match na with - | Name id when List.mem id excluded -> + | Name id when Id.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 + Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty + | _ -> na,excluded,Id.Map.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_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) ) ([],new_excluded,map) patl @@ -229,9 +229,9 @@ let alpha_patl excluded patl = 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_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) ) - ([],excluded,Idmap.empty) + ([],excluded,Id.Map.empty) patl in (List.rev patl,new_excluded,map) @@ -263,7 +263,7 @@ let rec alpha_rt excluded rt = match rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt | GLambda(loc,Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in + 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 @@ -279,10 +279,10 @@ let rec alpha_rt excluded rt = | GLambda(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = - if new_id = id + if Id.equal new_id id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in @@ -293,10 +293,10 @@ let rec alpha_rt excluded rt = let new_id = Namegen.next_ident_away id excluded in let new_excluded = new_id::excluded in let t,b = - if new_id = id + if Id.equal new_id id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_t = alpha_rt new_excluded t in @@ -305,10 +305,10 @@ let rec alpha_rt excluded rt = | GLetIn(loc,Name id,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = - if new_id = id + if Id.equal new_id id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in @@ -325,18 +325,18 @@ let rec alpha_rt excluded rt = | Anonymous -> (na::nal,excluded,mapping) | Name id -> let new_id = Namegen.next_ident_away id excluded in - if new_id = id + if Id.equal new_id id then na::nal,id::excluded,mapping else - (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) + (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) ) - ([],excluded,Idmap.empty) + ([],excluded,Id.Map.empty) nal in let new_nal = List.rev rev_new_nal in let new_rto,new_t,new_b = - if idmap_is_empty mapping + if Id.Map.is_empty mapping then rto,t,b else let replace = change_vars mapping in (Option.map replace rto, t,replace b) @@ -359,10 +359,9 @@ let rec alpha_rt excluded rt = | GRec _ -> error "Not handled GRec" | GSort _ -> rt | GHole _ -> rt - | GCast (loc,b,CastConv (k,t)) -> - GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) - | GCast (loc,b,CastCoerce) -> - GCast(loc,alpha_rt excluded b,CastCoerce) + | GCast (loc,b,c) -> + GCast(loc,alpha_rt excluded b, + Miscops.map_cast_type (alpha_rt excluded) c) | GApp(loc,f,args) -> GApp(loc, alpha_rt excluded f, @@ -385,14 +384,14 @@ and alpha_br excluded (loc,ids,patl,res) = let is_free_in id = let rec is_free_in = function | GRef _ -> false - | GVar(_,id') -> id_ord id' id == 0 + | GVar(_,id') -> Id.compare id' id == 0 | GEvar _ -> false | GPatVar _ -> false | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) -> let check_in_b = match n with - | Name id' -> id_ord id' id <> 0 + | Name id' -> not (Id.equal id' id) | _ -> true in is_free_in t || (check_in_b && is_free_in b) @@ -401,7 +400,7 @@ let is_free_in id = List.exists is_free_in_br brl | GLetTuple(_,nal,_,b,t) -> let check_in_nal = - not (List.exists (function Name id' -> id'= id | _ -> false) nal) + not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) in is_free_in t || (check_in_nal && is_free_in b) @@ -410,10 +409,10 @@ let is_free_in id = | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> false | GHole _ -> false - | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t + | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t | GCast (_,b,CastCoerce) -> is_free_in b and is_free_in_br (_,ids,_,rt) = - (not (List.mem id ids)) && is_free_in rt + (not (Id.List.mem id ids)) && is_free_in rt in is_free_in @@ -425,7 +424,7 @@ let rec pattern_to_term = function mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = - Inductiveops.mis_constructor_nargs_env + Inductiveops.constructor_nallargs_env (Global.env ()) constr in @@ -439,7 +438,7 @@ let rec pattern_to_term = function let patl_as_term = List.map pattern_to_term patternl in - mkGApp(mkGRef(Libnames.ConstructRef constr), + mkGApp(mkGRef(Globnames.ConstructRef constr), implicit_args@patl_as_term ) @@ -449,7 +448,7 @@ let replace_var_by_term x_id term = let rec replace_var_by_pattern rt = match rt with | GRef _ -> rt - | GVar(_,id) when id_ord id x_id == 0 -> term + | GVar(_,id) when Id.compare id x_id == 0 -> term | GVar _ -> rt | GEvar _ -> rt | GPatVar _ -> rt @@ -458,7 +457,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) - | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GLambda(loc,name,k,t,b) -> GLambda(loc, name, @@ -466,7 +465,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern t, replace_var_by_pattern b ) - | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GProd(loc,name,k,t,b) -> GProd(loc, name, @@ -474,7 +473,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern t, replace_var_by_pattern b ) - | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt + | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt | GLetIn(loc,name,def,b) -> GLetIn(loc, name, @@ -482,7 +481,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern b ) | GLetTuple(_,nal,_,_,_) - when List.exists (function Name id -> id = x_id | _ -> false) nal -> + when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> rt | GLetTuple(loc,nal,(na,rto),def,b) -> GLetTuple(loc, @@ -506,12 +505,11 @@ let replace_var_by_term x_id term = | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt - | GCast(loc,b,CastConv(k,t)) -> - GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) - | GCast(loc,b,CastCoerce) -> - GCast(loc,replace_var_by_pattern b,CastCoerce) + | GCast(loc,b,c) -> + GCast(loc,replace_var_by_pattern b, + Miscops.map_cast_type replace_var_by_pattern c) and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = - if List.exists (fun id -> id_ord id x_id == 0) idl + if List.exists (fun id -> Id.compare id x_id == 0) idl then br else (loc,idl,patl,replace_var_by_pattern res) in @@ -529,13 +527,12 @@ let rec are_unifiable_aux = function match eq with | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with e when Errors.noncritical e -> - anomaly "are_unifiable_aux" + try (List.combine cpl1 cpl2) @ eqs + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux") in are_unifiable_aux eqs' @@ -552,13 +549,12 @@ let rec eq_cases_pattern_aux = function match eq with | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with e when Errors.noncritical e -> - anomaly "eq_cases_pattern_aux" + try (List.combine cpl1 cpl2) @ eqs + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux") in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable @@ -574,13 +570,13 @@ let eq_cases_pattern pat1 pat2 = let ids_of_pat = let rec ids_of_pat ids = function | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Idset.add id ids + | PatVar(_,Name id) -> Id.Set.add id ids | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl in - ids_of_pat Idset.empty + ids_of_pat Id.Set.empty let id_of_name = function - | Names.Anonymous -> id_of_string "x" + | Names.Anonymous -> Id.of_string "x" | Names.Name x -> x (* TODO: finish Rec caes *) @@ -594,7 +590,7 @@ let ids_of_glob_constr c = | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc - | GCast (loc,c,CastConv(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc + | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc | GLetTuple (_,nal,(na,po),b,c) -> @@ -605,7 +601,7 @@ let ids_of_glob_constr c = | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) - List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c) + List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c) @@ -662,10 +658,9 @@ let zeta_normalize = | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt - | GCast(loc,b,CastConv(k,t)) -> - GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) - | GCast(loc,b,CastCoerce) -> - GCast(loc,zeta_normalize_term b,CastCoerce) + | GCast(loc,b,c) -> + GCast(loc,zeta_normalize_term b, + Miscops.map_cast_type zeta_normalize_term c) and zeta_normalize_br (loc,idl,patl,res) = (loc,idl,patl,zeta_normalize_term res) in @@ -680,7 +675,7 @@ let expand_as = match pat with | PatVar _ -> map | PatCstr(_,_,patl,Name id) -> - Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) + Id.Map.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 = @@ -689,7 +684,7 @@ let expand_as = | GVar(_,id) -> begin try - Idmap.find id map + Id.Map.find id map with Not_found -> rt end | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) @@ -703,12 +698,13 @@ let expand_as = GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) | GRec _ -> error "Not handled GRec" - | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t)) - | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce) + | GCast(loc,b,c) -> + GCast(loc,expand_as map b, + Miscops.map_cast_type (expand_as map) c) | GCases(loc,sty,po,el,brl) -> GCases(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 + expand_as Id.Map.empty diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index bfd15357..0f10636f 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,11 +1,9 @@ +open Names open Glob_term - -(* Ocaml 3.06 Map.S does not handle is_empty *) -val idmap_is_empty : 'a Names.Idmap.t -> bool - +open Misctypes (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) -val get_pattern_id : cases_pattern -> Names.identifier list +val get_pattern_id : cases_pattern -> Id.t list (* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. [pat] must not contain occurences of anonymous pattern @@ -14,14 +12,14 @@ val pattern_to_term : cases_pattern -> glob_constr (* Some basic functions to rebuild glob_constr - In each of them the location is Util.dummy_loc + In each of them the location is Util.Loc.ghost *) -val mkGRef : Libnames.global_reference -> glob_constr -val mkGVar : Names.identifier -> glob_constr +val mkGRef : Globnames.global_reference -> glob_constr +val mkGVar : Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr -val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr -val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Names.name * glob_constr * glob_constr -> glob_constr +val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr +val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr +val mkGLetIn : Name.t * glob_constr * glob_constr -> glob_constr val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr val mkGSort : glob_sort -> glob_constr val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) @@ -30,15 +28,15 @@ val mkGCast : glob_constr* glob_constr -> glob_constr Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -val glob_decompose_prod : glob_constr -> (Names.name*glob_constr) list * glob_constr +val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr val glob_decompose_prod_or_letin : - glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr -val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr + glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr +val glob_decompose_prod_n : int -> glob_constr -> (Name.t*glob_constr) list * glob_constr val glob_decompose_prod_or_letin_n : int -> glob_constr -> - (Names.name*glob_constr option*glob_constr option) list * glob_constr -val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list -> glob_constr + (Name.t*glob_constr option*glob_constr option) list * glob_constr +val glob_compose_prod : glob_constr -> (Name.t*glob_constr) list -> glob_constr val glob_compose_prod_or_letin: glob_constr -> - (Names.name*glob_constr option*glob_constr option) list -> glob_constr + (Name.t*glob_constr option*glob_constr option) list -> glob_constr val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) @@ -60,7 +58,7 @@ val glob_make_or_list : glob_constr list -> glob_constr (* Replace the var mapped in the glob_constr/context *) -val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr +val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr @@ -72,27 +70,27 @@ val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr [avoid] with the variables appearing in the result. *) val alpha_pat : - Names.Idmap.key list -> + Id.Map.key list -> Glob_term.cases_pattern -> - Glob_term.cases_pattern * Names.Idmap.key list * - Names.identifier Names.Idmap.t + Glob_term.cases_pattern * Id.Map.key list * + Id.t Id.Map.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 -> glob_constr -> glob_constr +val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) -val alpha_br : Names.identifier list -> - Util.loc * Names.identifier list * Glob_term.cases_pattern list * +val alpha_br : Id.t list -> + Loc.t * Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr -> - Util.loc * Names.identifier list * Glob_term.cases_pattern list * + Loc.t * Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr (* Reduction function *) val replace_var_by_term : - Names.identifier -> + Id.t -> Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr @@ -100,7 +98,7 @@ val replace_var_by_term : (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) -val is_free_in : Names.identifier -> glob_constr -> bool +val is_free_in : Id.t -> glob_constr -> bool val are_unifiable : cases_pattern -> cases_pattern -> bool @@ -109,13 +107,13 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool (* - ids_of_pat : cases_pattern -> Idset.t + ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Names.Idset.t +val ids_of_pat : cases_pattern -> Id.Set.t (* TODO: finish this function (Fix not treated) *) -val ids_of_glob_constr: glob_constr -> Names.Idset.t +val ids_of_glob_constr: glob_constr -> Id.Set.t (* removing let_in construction in a glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d2c065a0..6dbd61cf 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,11 +1,16 @@ +open Errors open Util open Names open Term open Pp open Indfun_common open Libnames +open Globnames open Glob_term open Declarations +open Declareops +open Misctypes +open Decl_kinds let is_rec_info scheme_info = let test_branche min acc (_,_,br) = @@ -14,15 +19,13 @@ let is_rec_info scheme_info = 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 + Int.Set.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) + 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 + Tactics.induction_destruct (is_rec_info scheme_info) false let functional_induction with_clean c princl pat = Dumpglob.pause (); @@ -33,7 +36,7 @@ let functional_induction with_clean c princl pat = | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with - | Const c' -> + | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' @@ -54,7 +57,7 @@ let functional_induction with_clean c princl pat = (or f_rec, f_rect) i*) let princ_name = Indrec.make_elimination_ident - (id_of_label (con_label c')) + (Label.to_id (con_label c')) (Tacticals.elimination_sort_of_goal g) in try @@ -63,7 +66,7 @@ let functional_induction with_clean c princl pat = errorlabstrm "" (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in - (princ,Glob_term.NoBindings, Tacmach.pf_type_of g princ) + (princ,NoBindings, Tacmach.pf_type_of g princ) | _ -> raise (UserError("",str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> @@ -75,50 +78,43 @@ let functional_induction with_clean c princl pat = if princ_infos.Tactics.farg_in_concl then [c] else [] in - List.map (fun c -> Tacexpr.ElimOnConstr (Evd.empty,(c,NoBindings))) (args@c_list) + let encoded_pat_as_patlist = + List.make (List.length args + List.length c_list - 1) None @ [pat] in + List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))),(None,pat),None)) + (args@c_list) encoded_pat_as_patlist in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right - (fun a acc -> - try Idset.add (destVar a) acc - with e when Errors.noncritical e -> acc - ) + (fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc) args - Idset.empty + Id.Set.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 old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in + let old_idl = Id.Set.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 - ) + List.filter (fun id -> not (Id.Set.mem id old_idl)) (Tacmach.pf_ids_of_hyps g) in let flag = - Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.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) + (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) + (Tactics.reduce flag Locusops.allHypsAndConcl) g else Tacticals.tclIDTAC g in Tacticals.tclTHEN - (choose_dest_or_ind + (Proofview.V82.of_tactic (choose_dest_or_ind princ_infos - args_as_induction_constr - princ' - (None,pat) - None) + (args_as_induction_constr,princ'))) subst_and_reduce g in @@ -127,14 +123,14 @@ let functional_induction with_clean c princl pat = let rec abstract_glob_constr c = function | [] -> c - | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_glob_constr c bl) - | Topconstr.LocalRawAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl + | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl) + | Constrexpr.LocalRawAssum (idl,k,t)::bl -> + List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl (abstract_glob_constr c bl) -let interp_casted_constr_with_implicits sigma env impls c = - Constrintern.intern_gen false sigma env ~impls - ~allow_patvar:false ~ltacvars:([],[]) c +let interp_casted_constr_with_implicits env sigma impls c = + Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls + ~allow_patvar:false c (* Construct a fixpoint as a Glob_term @@ -149,26 +145,21 @@ let build_newrecursive 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, Idmap.add recname impl impls)) + let arityc = Constrexpr_ops.prod_constr_expr arityc bl in + let arity,ctx = Constrintern.interp_type env0 sigma arityc in + let evdref = ref (Evd.from_env env0) in + let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in + let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in + (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) - let fs = States.freeze() in - let def = - try - List.map - (fun (_,bl,_,def) -> - let def = abstract_glob_constr def bl in - interp_casted_constr_with_implicits - sigma rec_sign rec_impls def - ) - lnameargsardef - with reraise -> - States.unfreeze fs; raise reraise in - States.unfreeze fs; def + let f (_,bl,_,def) = + let def = abstract_glob_constr def bl in + interp_casted_constr_with_implicits + rec_sign sigma rec_impls def + in + States.with_state_protection (List.map f) lnameargsardef in recdef,rec_impls @@ -178,15 +169,15 @@ let build_newrecursive l = match body_opt with | Some body -> (fixna,bll,ar,body) - | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") + | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") ) l in build_newrecursive l' (* 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 is_rec names = + let names = List.fold_right Id.Set.add names Id.Set.empty in + let check_id id names = Id.Set.mem id names in let rec lookup names = function | GVar(_,id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false @@ -195,11 +186,11 @@ let rec is_rec names = | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b) -> - lookup names t || lookup (Nameops.name_fold Idset.remove na names) b + lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b | GLetTuple(_,nal,_,t,b) -> lookup names t || lookup (List.fold_left - (fun acc na -> Nameops.name_fold Idset.remove na acc) + (fun acc na -> Nameops.name_fold Id.Set.remove na acc) names nal ) @@ -209,7 +200,7 @@ let rec is_rec names = 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 + let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in lookup names @@ -217,8 +208,8 @@ let rec is_rec 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 + | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl + | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl let prepare_body ((name,_,args,types,_),_) rt = let n = local_binders_length args in @@ -226,12 +217,14 @@ let prepare_body ((name,_,args,types,_),_) rt = let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') +let process_vernac_interp_error e = + fst (Cerrors.process_vernac_interp_error (e, Exninfo.null)) 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 (Constrintern.global_reference id)) fix_names + List.map (fun id -> fst (destConst (Constrintern.global_reference id))) fix_names in (* Then we check that the graphs have been defined @@ -248,38 +241,45 @@ let derive_inversion fix_names = Ensures by : register_built i*) (List.map - (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) + (fun id -> fst (destInd (Constrintern.global_reference (mk_rel_id id)))) fix_names ) with e when Errors.noncritical e -> - let e' = Cerrors.process_vernac_interp_error e in + let e' = process_vernac_interp_error e in msg_warning (str "Cannot build inversion information" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) with e when Errors.noncritical e -> () let warning_error names e = - let e = Cerrors.process_vernac_interp_error e in + let e = process_vernac_interp_error e in let e_explain e = match e with - | ToShow e -> spc () ++ Errors.print e - | _ -> if do_observe () then (spc () ++ Errors.print e) else mt () + | ToShow e -> + let e = process_vernac_interp_error e in + spc () ++ Errors.print e + | _ -> + if do_observe () + then + let e = process_vernac_interp_error e in + (spc () ++ Errors.print 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) + 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) + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) | _ -> raise e let error_error names e = - let e = Cerrors.process_vernac_interp_error e in + let e = process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> spc () ++ Errors.print e @@ -293,7 +293,7 @@ let error_error names e = e_explain e) | _ -> raise e -let generate_principle on_error +let generate_principle mp_dp on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = @@ -303,14 +303,14 @@ let generate_principle on_error let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in try (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive names funs_args funs_types recdefs; + Glob_term_to_relation.build_inductive mp_dp 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 f_R_mut = Ident (Loc.ghost,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!") @@ -326,11 +326,10 @@ let generate_principle on_error in let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in let _ = - list_map_i + 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 + let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in + let princ_type = Global.type_of_global_unsafe princ in Functional_principles_types.generate_functional_principle interactive_proof princ_type @@ -352,15 +351,11 @@ let generate_principle on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> - let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in - let ce,imps = - Command.interp_definition bl None body (Some ret_type) - in - Command.declare_definition - fname (Decl_kinds.Global,Decl_kinds.Definition) - ce imps (fun _ _ -> ()) + let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + Command.do_definition fname (Decl_kinds.Global,(*FIXME*)false,Decl_kinds.Definition) + bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())) | _ -> - Command.do_fixpoint fixpoint_exprl + Command.do_fixpoint Global false(*FIXME*) fixpoint_exprl 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 @@ -373,39 +368,39 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref 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 type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in let rec_arg_num = let names = List.map snd - (Topconstr.names_of_local_assums args) + (Constrexpr_ops.names_of_local_assums args) in match wf_arg with | None -> - if List.length names = 1 then 1 + if Int.equal (List.length names) 1 then 1 else error "Recursive argument must be specified" | Some wf_arg -> - list_index (Name wf_arg) names + List.index Name.equal (Name wf_arg) names in let unbounded_eq = let f_app_args = - Topconstr.CAppExpl - (dummy_loc, - (None,(Ident (dummy_loc,fname))) , + Constrexpr.CAppExpl + (Loc.ghost, + (None,(Ident (Loc.ghost,fname)),None) , (List.map (function | _,Anonymous -> assert false - | _,Name e -> (Topconstr.mkIdentC e) + | _,Name e -> (Constrexpr_ops.mkIdentC e) ) - (Topconstr.names_of_local_assums args) + (Constrexpr_ops.names_of_local_assums args) ) ) in - Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))), + Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(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 + let eq = Constrexpr_ops.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 @@ -433,7 +428,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> begin match args with - | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x + | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x | _ -> error "Recursive argument must be specified" end | Some wf_args -> @@ -441,15 +436,15 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas match List.find (function - | Topconstr.LocalRawAssum(l,k,t) -> + | Constrexpr.LocalRawAssum(l,k,t) -> List.exists - (function (_,Name id) -> id = wf_args | _ -> false) + (function (_,Name id) -> Id.equal id wf_args | _ -> false) l | _ -> false ) args with - | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args + | Constrexpr.LocalRawAssum(_,k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in @@ -457,31 +452,31 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas match wf_rel_expr_opt with | None -> 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"))) + let make_dir l = DirPath.make (List.rev_map Id.of_string l) in + Libnames.Qualid (Loc.ghost,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) + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in + Constrexpr_ops.mkLambdaC ([(Loc.ghost,Name wf_arg)],Constrexpr_ops.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]) + Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) in wf_rel_from_mes,true | Some wf_rel_expr -> let wf_rel_with_mes = - let a = Names.id_of_string "___a" in - let b = Names.id_of_string "___b" in - Topconstr.mkLambdaC( - [dummy_loc,Name a;dummy_loc,Name b], - Topconstr.Default Lib.Explicit, + let a = Names.Id.of_string "___a" in + let b = Names.Id.of_string "___b" in + Constrexpr_ops.mkLambdaC( + [Loc.ghost,Name a;Loc.ghost,Name b], + Constrexpr.Default Explicit, wf_arg_type, - Topconstr.mkAppC(wf_rel_expr, + Constrexpr_ops.mkAppC(wf_rel_expr, [ - Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC a]); - Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC b]) + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) ]) ) in @@ -493,124 +488,62 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas let map_option f = function | None -> None | Some v -> Some (f v) - -let decompose_lambda_n_assum_constr_expr = - let rec decompose_lambda_n_assum_constr_expr acc n e = - if n = 0 then (List.rev acc,e) - else - match e with - | Topconstr.CLambdaN(_, [],e') -> decompose_lambda_n_assum_constr_expr acc n e' - | Topconstr.CLambdaN(lambda_loc,(nal,bk,nal_type)::bl,e') -> - let nal_length = List.length nal in - if nal_length <= n - then - decompose_lambda_n_assum_constr_expr - (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) - (n - nal_length) - (Topconstr.CLambdaN(lambda_loc,bl,e')) - else - let nal_keep,nal_expr = list_chop n nal in - (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), - Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') - ) - | Topconstr.CLetIn(_, na,nav,e') -> - decompose_lambda_n_assum_constr_expr - (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' - | _ -> error "Not enough product or assumption" - in - decompose_lambda_n_assum_constr_expr [] - -let decompose_prod_n_assum_constr_expr = - let rec decompose_prod_n_assum_constr_expr acc n e = - (* Pp.msgnl (str "n := " ++ int n ++ fnl ()++ *) - (* str "e := " ++ Ppconstr.pr_lconstr_expr e); *) - if n = 0 then - (* let _ = Pp.msgnl (str "return_type := " ++ Ppconstr.pr_lconstr_expr e) in *) - (List.rev acc,e) - else - match e with - | Topconstr.CProdN(_, [],e') -> decompose_prod_n_assum_constr_expr acc n e' - | Topconstr.CProdN(lambda_loc,(nal,bk,nal_type)::bl,e') -> - let nal_length = List.length nal in - if nal_length <= n - then - (* let _ = Pp.msgnl (str "first case") in *) - decompose_prod_n_assum_constr_expr - (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) - (n - nal_length) - (if bl = [] then e' else (Topconstr.CLambdaN(lambda_loc,bl,e'))) - else - (* let _ = Pp.msgnl (str "second case") in *) - let nal_keep,nal_expr = list_chop n nal in - (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), - Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') - ) - | Topconstr.CArrow(_,premisse,concl) -> - (* let _ = Pp.msgnl (str "arrow case") in *) - decompose_prod_n_assum_constr_expr - (Topconstr.LocalRawAssum([dummy_loc,Names.Anonymous], - Topconstr.Default Lib.Explicit,premisse) - ::acc) - (pred n) - concl - | Topconstr.CLetIn(_, na,nav,e') -> - decompose_prod_n_assum_constr_expr - (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' - | _ -> error "Not enough product or assumption" - in - decompose_prod_n_assum_constr_expr [] +open Constrexpr open Topconstr - -let id_of_name = function - | Name id -> id - | _ -> assert false - let rec rebuild_bl (aux,assoc) bl typ = +let make_assoc assoc l1 l2 = + let fold assoc a b = match a, b with + | (_, Name na), (_, Name id) -> Id.Map.add na id assoc + | _, _ -> assoc + in + List.fold_left2 fold assoc l1 l2 + +let rec rebuild_bl (aux,assoc) bl typ = match bl,typ with | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) - | (Topconstr.LocalRawAssum(nal,bk,_))::bl',typ -> + | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ -> rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ - | (Topconstr.LocalRawDef(na,_))::bl',CLetIn(_,_,nat,typ') -> - rebuild_bl ((Topconstr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) + | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') -> + rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) bl' typ' | _ -> assert false and rebuild_nal (aux,assoc) bk bl' nal lnal typ = match nal,typ with | [], _ -> rebuild_bl (aux,assoc) bl' typ - | na::nal,CArrow(_,nat,typ') -> - rebuild_nal - ((LocalRawAssum([na],bk,replace_vars_constr_expr assoc nat))::aux,assoc) - bk bl' nal (pred lnal) typ' | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> let lnal' = List.length nal' in if lnal' >= lnal then - let old_nal',new_nal' = list_chop lnal nal' in - rebuild_bl ((LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't)::aux),(List.rev_append (List.combine (List.map id_of_name (List.map snd old_nal')) (List.map id_of_name (List.map snd nal))) assoc)) bl' - (if new_nal' = [] && rest = [] - then typ' - else if new_nal' = [] - then CProdN(dummy_loc,rest,typ') - else CProdN(dummy_loc,((new_nal',bk',nal't)::rest),typ')) + let old_nal',new_nal' = List.chop lnal nal' in + let nassoc = make_assoc assoc old_nal' nal in + let assum = LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't) in + rebuild_bl ((assum :: aux), nassoc) bl' + (if List.is_empty new_nal' && List.is_empty rest + then typ' + else if List.is_empty new_nal' + then CProdN(Loc.ghost,rest,typ') + else CProdN(Loc.ghost,((new_nal',bk',nal't)::rest),typ')) else - let captured_nal,non_captured_nal = list_chop lnal' nal in - rebuild_nal ((LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't)::aux), (List.rev_append (List.combine (List.map id_of_name (List.map snd captured_nal)) ((List.map id_of_name (List.map snd nal)))) assoc)) - bk bl' non_captured_nal (lnal - lnal') (CProdN(dummy_loc,rest,typ')) + let captured_nal,non_captured_nal = List.chop lnal' nal in + let nassoc = make_assoc assoc nal' captured_nal in + let assum = LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in + rebuild_nal ((assum :: aux), nassoc) + bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ')) | _ -> assert false let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in + let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = - with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in + with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) Evd.empty)) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> - let new_bl',new_ret_type,_ = rebuild_bl ([],[]) bl fix_typ in + let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) bl fix_typ in (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel @@ -618,23 +551,24 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex fixpoint_exprl_with_new_bl -let do_generate_principle on_error register_built interactive_proof +let do_generate_principle mp_dp on_error register_built interactive_proof (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = - List.iter (fun (_,l) -> if l <> [] then error "Function does not support notations for now") fixpoint_exprl; + List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let _is_struct = match fixpoint_exprl with - | [((_,(wf_x,Topconstr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> + | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> let ((((_,name),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook = generate_principle + mp_dp on_error true register_built @@ -645,7 +579,7 @@ let do_generate_principle on_error register_built interactive_proof if register_built then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; false - |[((_,(wf_x,Topconstr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> + |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> let ((((_,name),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -654,9 +588,10 @@ let do_generate_principle on_error register_built interactive_proof let fixpoint_exprl = [fixpoint_expr] in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in let pre_hook = generate_principle + mp_dp on_error true register_built @@ -670,7 +605,7 @@ let do_generate_principle on_error register_built interactive_proof | _ -> List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> match ord with - | Topconstr.CMeasureRec _ | Topconstr.CWfRec _ -> + | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () @@ -685,6 +620,7 @@ let do_generate_principle on_error register_built interactive_proof let is_rec = List.exists (is_rec fix_names) recdefs in if register_built then register_struct is_rec fixpoint_exprl; generate_principle + mp_dp on_error false register_built @@ -697,18 +633,15 @@ let do_generate_principle on_error register_built interactive_proof in () -open Topconstr let rec add_args id new_args b = match b with - | CRef r -> + | CRef (r,_) -> begin match r with - | Libnames.Ident(loc,fname) when fname = id -> - CAppExpl(dummy_loc,(None,r),new_args) + | Libnames.Ident(loc,fname) when Id.equal fname id -> + CAppExpl(Loc.ghost,(None,r,None),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) + | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo") | CProdN(loc,nal,b1) -> CProdN(loc, List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, @@ -719,12 +652,12 @@ let rec add_args id new_args b = 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) -> + | CAppExpl(loc,(pf,r,us),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) + | Libnames.Ident(loc,fname) when Id.equal fname id -> + CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl)) + | _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl) end | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), @@ -733,7 +666,7 @@ let rec add_args id new_args b = 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, + (na, 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) -> @@ -752,32 +685,29 @@ let rec add_args id new_args 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) + | CCast(loc,b1,b2) -> + CCast(loc,add_args id new_args b1, + Miscops.map_cast_type (add_args id new_args) b2) | 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" + | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") + | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") | CPrim _ -> b - | CDelimiters _ -> anomaly "add_args : CDelimiters" -exception Stop of Topconstr.constr_expr + | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters") +exception Stop of Constrexpr.constr_expr (* [chop_n_arrow n t] chops the [n] first arrows in [t] - Acts on Topconstr.constr_expr + Acts on Constrexpr.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 : + | Constrexpr.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 @@ -796,8 +726,8 @@ let rec chop_n_arrow n t = aux (n - nal_l) nal_ta' else let new_t' = - Topconstr.CProdN(dummy_loc, - ((snd (list_chop n nal)),k,t'')::nal_ta',t') + Constrexpr.CProdN(Loc.ghost, + ((snd (List.chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') in @@ -806,13 +736,13 @@ let rec chop_n_arrow n t = chop_n_arrow new_n t' with Stop t -> t end - | _ -> anomaly "Not enough products" + | _ -> anomaly (Pp.str "Not enough products") -let rec get_args b t : Topconstr.local_binder list * - Topconstr.constr_expr * Topconstr.constr_expr = +let rec get_args b t : Constrexpr.local_binder list * + Constrexpr.constr_expr * Constrexpr.constr_expr = match b with - | Topconstr.CLambdaN (loc, (nal_ta), b') -> + | Constrexpr.CLambdaN (loc, (nal_ta), b') -> begin let n = (List.fold_left (fun n (nal,_,_) -> @@ -820,7 +750,7 @@ let rec get_args b t : Topconstr.local_binder list * 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'' + (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t @@ -836,17 +766,15 @@ let make_graph (f_ref:global_reference) = | _ -> raise (UserError ("", str "Not a function reference") ) in Dumpglob.pause (); - (match body_of_constant c_body with + (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" - | Some b -> + | Some body -> 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) + with_full_print (fun () -> + (Constrextern.extern_constr false env Evd.empty body, + Constrextern.extern_type false env Evd.empty + ((*FIXNE*) Typeops.type_of_constant_type env c_body.const_type) ) ) () @@ -854,7 +782,7 @@ let make_graph (f_ref:global_reference) = let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = match b with - | Topconstr.CFix(loc,l_id,fixexprl) -> + | Constrexpr.CFix(loc,l_id,fixexprl) -> let l = List.map (fun (id,(n,recexp),bl,t,b) -> @@ -863,34 +791,34 @@ let make_graph (f_ref:global_reference) = List.flatten (List.map (function - | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_,_) -> + | Constrexpr.LocalRawDef (na,_)-> [] + | Constrexpr.LocalRawAssum (nal,_,_) -> List.map (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) + CRef(Libnames.Ident(loc, Nameops.out_name n),None)) nal ) nal_tas ) in let b' = add_args (snd id) new_args b in - (((id, ( Some (dummy_loc,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + (((id, ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> - let id = id_of_label (con_label c) in - [((dummy_loc,id),(None,Topconstr.CStructRec),nal_tas,t,Some b),[]] + let id = Label.to_id (con_label c) in + [((Loc.ghost,id),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in - do_generate_principle error_error false false expr_list; - (* We register the infos *) let mp,dp,_ = repr_con c in + do_generate_principle (Some (mp,dp)) error_error false false expr_list; + (* We register the infos *) List.iter - (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (label_of_id id))) + (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) expr_list); Dumpglob.continue () -let do_generate_principle = do_generate_principle warning_error true +let do_generate_principle = do_generate_principle None warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index e65b5808..e7206914 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,11 +1,4 @@ -open Util -open Names -open Term -open Pp -open Indfun_common -open Libnames -open Glob_term -open Declarations +open Misctypes val do_generate_principle : bool -> @@ -16,9 +9,9 @@ val do_generate_principle : val functional_induction : bool -> Term.constr -> - (Term.constr * Term.constr Glob_term.bindings) option -> - Genarg.intro_pattern_expr Util.located option -> + (Term.constr * Term.constr bindings) option -> + Tacexpr.or_and_intro_pattern option -> Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma -val make_graph : Libnames.global_reference -> unit +val make_graph : Globnames.global_reference -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 827191b1..76f8c6d2 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -1,9 +1,9 @@ open Names open Pp - open Libnames - -let mk_prefix pre id = id_of_string (pre^(string_of_id id)) +open Globnames +open Refiner +let mk_prefix pre id = Id.of_string (pre^(Id.to_string 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" @@ -12,10 +12,7 @@ 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_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid let fresh_name avoid s = Name (fresh_id avoid s) @@ -29,7 +26,7 @@ let array_get_start a = (Array.length a - 1) (fun i -> a.(i)) with Invalid_argument "index out of bounds" -> - invalid_argument "array_get_start" + invalid_arg "array_get_start" let id_of_name = function Name id -> id @@ -51,10 +48,8 @@ let locate_constant ref = let locate_with_msg msg f x = - try - f x - with - | Not_found -> raise (Util.UserError("", msg)) + try f x + with Not_found -> raise (Errors.UserError("", msg)) let filter_map filter f = @@ -78,7 +73,7 @@ let chop_rlambda_n = | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> - raise (Util.UserError("chop_rlambda_n", + raise (Errors.UserError("chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -90,7 +85,7 @@ let chop_rprod_n = else match rt with | Glob_term.GProd(_,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")) + | _ -> raise (Errors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -111,34 +106,27 @@ let list_add_set_eq eq_fun x l = let const_of_id id = let _,princ_ref = - qualid_of_reference (Libnames.Ident (Util.dummy_loc,id)) + qualid_of_reference (Libnames.Ident (Loc.ghost,id)) in try Nametab.locate_constant princ_ref - with Not_found -> Util.error ("cannot find "^ string_of_id id) + with Not_found -> Errors.error ("cannot find "^ Id.to_string id) let def_of_const t = match (Term.kind_of_term t) with Term.Const sp -> - (try (match Declarations.body_of_constant (Global.lookup_constant sp) with - | Some c -> Declarations.force c + (try (match Environ.constant_opt_value_in (Global.env()) sp with + | Some c -> c | _ -> assert false) - with e when Errors.noncritical e -> assert false) + with Not_found -> 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 dp = Names.DirPath.make (List.rev_map Id.of_string sl) in + Nametab.locate (make_qualid dp (Id.of_string s)) let eq = lazy(coq_constant "eq") let refl_equal = lazy(coq_constant "eq_refl") @@ -147,47 +135,40 @@ 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 definition_message = Declare.definition_message -let save with_clean id const (locality,kind) hook = - let {const_entry_body = pft; - const_entry_secctx = _; - const_entry_type = tpo; - const_entry_opaque = opacity } = const in +let get_locality = function +| Discharge -> true +| Local -> true +| Global -> false + +let save with_clean id const (locality,_,kind) hook = + let fix_exn = Future.fix_exn_of const.Entries.const_entry_body 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 + | Discharge when Lib.sections_are_opened () -> + let k = Kindops.logical_kind_of_goal_kind kind in + let c = SectionLocalDef const 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 + | Discharge | Local | Global -> + let local = get_locality locality in + let k = Kindops.logical_kind_of_goal_kind kind in + let kn = declare_constant id ~local (DefinitionEntry const, k) in + (locality, ConstRef kn) + in if with_clean then Pfedit.delete_current_proof (); - hook l r; + Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id let cook_proof _ = - let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in - (id,(entry,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 (id,(entry,_,strength)) = Pfedit.cook_proof () in + (id,(entry,strength)) let get_proof_clean do_reduce = let result = cook_proof do_reduce in @@ -197,7 +178,8 @@ let get_proof_clean do_reduce = 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 + 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; @@ -248,8 +230,9 @@ type function_info = (* let function_table = ref ([] : function_db) *) -let from_function = ref Cmap.empty -let from_graph = ref Indmap.empty +let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn" +let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr" + (* let rec do_cache_info finfo = function | [] -> raise Not_found @@ -272,15 +255,14 @@ let cache_Function (_,(finfos)) = *) let cache_Function (_,finfos) = - from_function := Cmap.add finfos.function_constant finfos !from_function; + from_function := Cmap_env.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) + let do_subst_con c = Mod_subst.subst_constant subst c + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in @@ -346,22 +328,29 @@ let discharge_Function (_,finfos) = } open Term + +let pr_ocst c = + Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ()) + 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 e when Errors.noncritical e -> 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 () + str "function_constant := " ++ + Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ + str "function_constant_type := " ++ + (try + Printer.pr_lconstr + (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) + with e when Errors.noncritical e -> mt ()) ++ fnl () ++ + str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ + str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ + str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++ + str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++ + str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++ + str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ 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 l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in + Pp.prlist_with_sep fnl pr_info l let in_Function : function_info -> Libobject.obj = Libobject.declare_object @@ -375,36 +364,16 @@ let in_Function : function_info -> Libobject.obj = } - -(* 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" + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Errors.anomaly (Pp.str "Not a constant") ) with Not_found -> None let find_Function_infos f = - Cmap.find f !from_function + Cmap_env.find f !from_function let find_Function_of_graph ind = @@ -416,7 +385,7 @@ let update_Function finfo = let add_Function is_general f = - let f_id = id_of_label (con_label f) in + let f_id = Label.to_id (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) @@ -425,7 +394,7 @@ let add_Function is_general f = 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" + with | IndRef ind -> ind | _ -> Errors.anomaly (Pp.str "Not an inductive") in let finfos = { function_constant = f; @@ -475,8 +444,7 @@ let function_debug_sig = let _ = declare_bool_option function_debug_sig -let do_observe () = - !function_debug = true +let do_observe () = !function_debug @@ -499,25 +467,37 @@ 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 when Errors.noncritical e -> raise (ToShow e) - let jmeq () = try - (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq") - with e when Errors.noncritical e -> raise (ToShow e) - -let jmeq_rec () = - try - Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_rec" + Coqlib.check_required_library Coqlib.jmeq_module_name; + Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq" with e when Errors.noncritical e -> raise (ToShow e) let jmeq_refl () = try - Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_refl" + Coqlib.check_required_library Coqlib.jmeq_module_name; + Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl" with e when Errors.noncritical e -> raise (ToShow e) + +let h_intros l = + tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l + +let h_id = Id.of_string "h" +let hrec_id = Id.of_string "hrec" +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 ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") + +let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) + match r with + ConstRef sp -> EvalConstRef sp + | VarRef id -> EvalVarRef id + | _ -> assert false;; + +let list_rewrite (rev:bool) (eqs: (constr*bool) list) = + tclREPEAT + (List.fold_right + (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) + (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index e0076735..67ddf374 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -5,23 +5,21 @@ 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 mk_rel_id : Id.t -> Id.t +val mk_correct_id : Id.t -> Id.t +val mk_complete_id : Id.t -> Id.t +val mk_equation_id : Id.t -> Id.t 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 fresh_id : Id.t list -> string -> Id.t +val fresh_name : Id.t list -> string -> Name.t +val get_name : Id.t list -> ?default:string -> Name.t -> Name.t val array_get_start : 'a array -> 'a array -val id_of_name : name -> identifier +val id_of_name : Name.t -> Id.t val locate_ind : Libnames.reference -> inductive val locate_constant : Libnames.reference -> constant @@ -36,38 +34,31 @@ val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list val chop_rlambda_n : int -> Glob_term.glob_constr -> - (name*Glob_term.glob_constr*bool) list * Glob_term.glob_constr + (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr val chop_rprod_n : int -> Glob_term.glob_constr -> - (name*Glob_term.glob_constr) list * Glob_term.glob_constr + (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr 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 const_of_id: Id.t -> 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] -*) - -val new_save_named : bool -> unit - -val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> - Tacexpr.declaration_hook -> unit +val save : bool -> Id.t -> Entries.definition_entry -> Decl_kinds.goal_kind -> + unit Lemmas.declaration_hook Ephemeron.key -> 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) + Names.Id.t * + (Entries.definition_entry * Decl_kinds.goal_kind) -(* [with_full_print f a] applies [f] to [a] in full printing environment +(* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings *) @@ -112,3 +103,14 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool + +val h_intros: Names.Id.t list -> Proof_type.tactic +val h_id : Names.Id.t +val hrec_id : Names.Id.t +val acc_inv_id : Term.constr Util.delayed +val ltof_ref : Globnames.global_reference Util.delayed +val well_founded_ltof : Term.constr Util.delayed +val acc_rel : Term.constr Util.delayed +val well_founded : Term.constr Util.delayed +val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference +val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index c770c7ce..0c7b0a0b 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1,39 +1,40 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) + | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) + | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) let pr_bindings prc prlc = function - | Glob_term.ImplicitBindings l -> + | ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc prc l - | Glob_term.ExplicitBindings l -> + pr_sequence prc l + | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Glob_term.NoBindings -> mt () + pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = @@ -45,17 +46,17 @@ 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 msgnl = Pp.msgnl *) let observe strm = if do_observe () - then Pp.msgnl strm + then Pp.msg_debug strm else () -let observennl strm = +(*let observennl strm = if do_observe () then begin Pp.msg strm;Pp.pp_flush () end - else () + else ()*) let do_observe_tac s tac g = @@ -64,22 +65,25 @@ let do_observe_tac s tac g = with e when Errors.noncritical e -> assert false in try - let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v + let v = tac g in + msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with reraise -> - let e' = Cerrors.process_vernac_interp_error reraise in + let reraise = Errors.push reraise in + let e = Cerrors.process_vernac_interp_error reraise in msgnl (str "observation "++ s++str " raised exception " ++ - Errors.print e' ++ str " on goal " ++ goal ); - raise reraise;; - + Errors.iprint e ++ str " on goal " ++ goal ); + iraise reraise;; -let observe_tac_msg s tac g = - if do_observe () +let observe_tac_strm s tac g = + if do_observe () then do_observe_tac s tac g else tac g - -let observe_tac s tac g = - observe_tac_msg (str s) tac g + +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 = @@ -109,57 +113,47 @@ let id_to_constr id = 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 gr,u = destInd graph in + let graph_arity = Inductive.type_of_inductive (Global.env()) + (Global.lookup_inductive gr, u) in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with - | [] | [_] -> anomaly "Not a valid context" + | [] | [_] -> anomaly (Pp.str "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) + let rec args_from_decl i accu = function + | [] -> accu + | (_, Some _, _) :: l -> + args_from_decl (succ i) accu l + | _ :: l -> + let t = mkRel i in + args_from_decl (succ i) (t :: accu) l 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 + let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in + let named_ctxt = List.map_filter filter fun_ctxt in + let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in + let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_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 + let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) 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 make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + in let res_eq_f_of_args = - mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp(make_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 + let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in + let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in + let graph_applied = 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*) @@ -178,7 +172,7 @@ let generate_type g_to_f f graph i = 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 + let f_as_constant,u = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in @@ -195,7 +189,7 @@ let find_induction_principle f = (* let fname = *) (* match kind_of_term f with *) (* | Const c' -> *) -(* id_of_label (con_label c') *) +(* Label.to_id (con_label c') *) (* | _ -> error "Must be used with a function" *) (* in *) @@ -217,6 +211,11 @@ let rec generate_fresh_id x avoid i = let id = Namegen.next_ident_away_in_goal x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -242,6 +241,261 @@ let rec generate_fresh_id x avoid i = \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\] + *) + (* we the get the definition of the graphs block *) + let graph_ind,u = 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 -> Loc.ghost, IntroNaming (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 eq_ind = make_eq () in + let eq_construct = mkConstructUi (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 -> Id.Set.add id acc + | _ -> anomaly (Pp.str "Not an identifier") + ) + (List.nth intro_pats (pred i)) + Id.Set.empty + in + let pre_args g = + List.fold_right + (fun (id,b,t) pre_args -> + if Id.Set.mem id this_branche_ids + then + match b with + | None -> id::pre_args + | Some b -> pre_args + else pre_args + ) + (pf_hyps g) + ([]) + in + let pre_args g = List.rev (pre_args g) in + let pre_tac g = + List.fold_right + (fun (id,b,t) pre_tac -> + if Id.Set.mem id this_branche_ids + then + match b with + | None -> pre_tac + | Some b -> + tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac + else pre_tac + ) + (pf_hyps g) + tclIDTAC + in +*) + let pre_args = + List.fold_right + (fun (_,pat) acc -> + match pat with + | IntroNaming (IntroIdentifier id) -> id::acc + | _ -> anomaly (Pp.str "Not an identifier") + ) + (List.nth intro_pats (pred i)) + [] + in + (* and get the real args of the branch by unfolding the defined constant *) + (* + 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 g = + 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 -> + (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);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 g = + let params_id = fst (List.chop princ_infos.nparams args_names) in + (List.map mkVar params_id)@((constructor_args g)) + 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 g = applist((mkConstruct(constructor)),constructor_args g) 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 + [ + observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns l)); + (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false ; + Genredexpr.rConst = [] + } + ) + Locusops.onConcl; + observe_tac ("toto ") tclIDTAC; + + (* introducing the the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); + (* replacing [res] with its value *) + observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); + (* Conclusion *) + observe_tac "exact" (fun g -> Proofview.V82.of_tactic (exact_check (app_constructor g)) g) + ] + ) + g + in + (* end of branche proof *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> + match ctxt with + | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") + | hres::res::(x,_,t)::ctxt -> + Termops.it_mkLambda_or_LetIn + (Termops.it_mkProd_or_LetIn concl [hres;res]) + ((x,None,t)::ctxt) + ) + lemmas_types_infos + in + 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 + (*(Loc.ghost,Glob_term.NamedHyp id,p)*)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 + (*(Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))*) (nf_zeta p)::bindings,id::avoid) + ([],avoid) + princ_infos.predicates + (lemmas))) + in + (* Glob_term.ExplicitBindings *) (params_bindings@lemmas_bindings) + in + tclTHENSEQ + [ + observe_tac "principle" (Proofview.V82.of_tactic (assert_by + (Name principle_id) + princ_type + (exact_check f_principle))); + observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); + (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC; + tclTHEN_i + (observe_tac "functional_induction" ( + (fun gl -> + let term = mkApp (mkVar principle_id,Array.of_list bindings) in + let gl', _ty = pf_eapply Typing.e_type_of gl term in + Proofview.V82.of_tactic (apply term) gl') + )) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) + ] + g + + +(* 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 @@ -252,7 +506,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem Array.map (fun (_,(ctxt,concl)) -> match ctxt with - | [] | [_] | [_;_] -> anomaly "bad context" + | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") | hres::res::(x,_,t)::ctxt -> Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) @@ -270,13 +524,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem 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 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 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 @@ -285,44 +539,43 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem 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)))) + (fun id -> Loc.ghost, 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 (Loc.ghost,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 this_branche_ids empty add i = - List.fold_right - (fun (_,pat) acc -> - match pat with - | Genarg.IntroIdentifier id -> add id acc - | _ -> anomaly "Not an identifier" - ) - (List.nth intro_pats (pred i)) - empty - in 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 -> Id.Set.add id acc + | _ -> anomaly (Pp.str "Not an identifier") + ) + (List.nth intro_pats (pred i)) + Id.Set.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 Idset.empty Idset.add i) + if Id.Set.mem id this_branche_ids then match b with - | None -> - (id::pre_args,pre_tac) + | None -> (id::pre_args,pre_tac) | Some b -> (pre_args, - tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac + tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac ) - else (pre_args,pre_tac) ) (pf_hyps g) @@ -333,7 +586,6 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem 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 = @@ -350,9 +602,9 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem | 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) + 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 @@ -362,7 +614,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem 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 + 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 @@ -390,11 +642,11 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem 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 + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with | [res;hres] -> res,hres | _ -> assert false in - observe_tac_msg (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor) + observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); ( tclTHENSEQ [ @@ -414,13 +666,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (* replacing [res] with its value *) observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)); (* Conclusion *) - observe_tac "exact" (h_exact app_constructor) + observe_tac "exact" (exact_check app_constructor) ] ) g in (* end of branche proof *) - let param_names = fst (list_chop princ_infos.nparams args_names) in + 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 @@ -431,7 +683,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Glob_term.NamedHyp id,p)::bindings,id::avoid + (Loc.ghost,Glob_term.NamedHyp id,p)::bindings,id::avoid ) ([],pf_ids_of_hyps g) princ_infos.params @@ -441,7 +693,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem 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,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid) + (Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -453,18 +705,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem observe_tac "principle" (assert_by (Name principle_id) princ_type - (h_exact f_principle)); + (exact_check 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)); - h_apply false false [dummy_loc,(mkVar principle_id,bindings)] g + 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) - (tclTHEN (tclMAP h_intro (this_branche_ids [] (fun a b -> a::b) i)) (prove_branche i)) 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] @@ -472,8 +727,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem 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]) + | (id,None,t) when not (Id.equal id hyp) && + (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.Simple.generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -490,7 +745,7 @@ 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 + let eq_ind = make_eq () in match kind_of_term (pf_concl g) with | Prod(_,t,t') -> begin @@ -498,66 +753,79 @@ and intros_with_rewrite_aux : tactic = | 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 - + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g + else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) + then tclTHENSEQ[ + unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]; + tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) )) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g + else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) + then tclTHENSEQ[ + unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]; + tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) )) + (pf_ids_of_hyps g); + 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; + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); generalize_dependent_of (destVar args.(1)) id; - tclTRY (Equality.rewriteLR (mkVar id)); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g else if isVar args.(2) then - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id; + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); generalize_dependent_of (destVar args.(2)) id; - tclTRY (Equality.rewriteRL (mkVar id)); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); intros_with_rewrite ] g else begin - let id = pf_get_new_id (id_of_string "y") g in + let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ[ - h_intro id; - tclTRY (Equality.rewriteLR (mkVar id)); + Proofview.V82.of_tactic (Simple.intro id); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g end | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> - Tauto.tauto g + Proofview.V82.of_tactic Tauto.tauto g | Case(_,_,v,_) -> tclTHENSEQ[ - h_case false (v,Glob_term.NoBindings); + Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite ] g | LetIn _ -> tclTHENSEQ[ - h_reduce - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) - onConcl + Locusops.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 + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g end | LetIn _ -> tclTHENSEQ[ - h_reduce - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) - onConcl + Locusops.onConcl ; intros_with_rewrite ] g @@ -569,14 +837,14 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ - h_case false (v,Glob_term.NoBindings); - intros; + Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] - | _ -> reflexivity - with e when Errors.noncritical e -> reflexivity + | _ -> Proofview.V82.of_tactic reflexivity + with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity in - let eq_ind = Coqlib.build_coq_eq () in + let eq_ind = make_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> @@ -586,15 +854,15 @@ let rec reflexivity_with_destruct_cases g = 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 + then Proofview.V82.of_tactic (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 + then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) in (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity; + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); (* We reach this point ONLY if the same value is matched (at least) two times @@ -654,23 +922,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = 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 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 + 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 *) + (* we also compute fresh names for each hyptohesis of each branch + 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)) + (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type)) ) branches in @@ -680,28 +949,34 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = *) 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 + let infos = + try find_Function_infos (fst (destConst funcs.(j))) + with Not_found -> error "No graph found" + in + if infos.is_general + || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs then let eq_lemma = try Option.get (infos).equation_lemma - with Option.IsNone -> anomaly "Cannot find equation lemma" + with Option.IsNone -> anomaly (Pp.str "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 - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); + (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) - onConcl + Locusops.onConcl ; - h_generalize (List.map mkVar ids); + Simple.generalize (List.map mkVar ids); thin ids ] - else unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef (destConst f))] + else + unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))] in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -725,21 +1000,21 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (* 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; + observe_tac "intros_with_rewrite (all)" 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_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]); + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (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; + (Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); + Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i - (observe_tac "elim" ((elim false (mkVar hres,Glob_term.NoBindings) (Some (mkVar graph_principle_id,Glob_term.NoBindings))))) + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -747,7 +1022,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = -let do_save () = Lemmas.save_named false +let do_save () = Lemmas.save_proof (Vernacexpr.Proved(false,None)) (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness @@ -758,15 +1033,14 @@ let do_save () = Lemmas.save_named false *) let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = - let previous_state = States.freeze () in let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConst funs in - try + States.with_state_protection_on_exception (fun () -> let graphs_constr = Array.map mkInd graphs in let lemmas_types_infos = - Util.array_map2_i + Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f,u = 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 @@ -783,15 +1057,15 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g if the block contains only one function we can safely reuse [f_rect] *) try - if Array.length funs_constr <> 1 then raise Not_found; + if not (Int.equal (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 ) + (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type ) ) - (make_scheme (array_map_to_list (fun const -> const,Glob_term.GType None) funs)) + (make_scheme (Array.map_to_list (fun const -> const,GType []) funs)) ) in let proving_tac = @@ -799,28 +1073,29 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g in Array.iteri (fun i f_as_constant -> - let f_id = id_of_label (con_label f_as_constant) in + let f_id = Label.to_id (con_label f_as_constant) in (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_correct_id f_id in Lemmas.start_proof lem_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)); + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (*FIXME*) Evd.empty + (fst lemmas_types_infos.(i)) + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (Pfedit.by + (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") + (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in update_Function {finfo with correctness_lemma = Some lem_cst} ) funs; let lemmas_types_infos = - Util.array_map2_i + Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f = fst (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 @@ -832,51 +1107,46 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g funs_constr graphs_constr in - let kn,_ as graph_ind = destInd graphs_constr.(0) in + let kn,_ as graph_ind = fst (destInd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in - let schemes = - Array.of_list + let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty (Array.to_list (Array.mapi - (fun i _ -> (kn,i),true,InType) + (fun i _ -> ((kn,i),Univ.Instance.empty)(*FIXME*),true,InType) mib.Declarations.mind_packets ) ) ) in + let schemes = + Array.of_list scheme + 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 + let f_id = Label.to_id (con_label f_as_constant) in (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_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)); + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (*FIXME*) Evd.empty + (fst lemmas_types_infos.(i)) + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (Pfedit.by + (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") + (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst,u = destConst (Constrintern.global_reference lem_id) in update_Function {finfo with completeness_lemma = Some lem_cst} ) - funs; - with reraise -> - (* In case of problem, we reset all the lemmas *) - Pfedit.delete_all_proofs (); - States.unfreeze previous_state; - raise reraise - - - - + funs) + () (***********************************************) @@ -890,13 +1160,13 @@ 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' + let ((kn',num) as ind'),u = destInd i in + if MutInd.equal 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" + anomaly (Pp.str "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 @@ -904,12 +1174,12 @@ let revert_graph kn post_tac hid g = match info.completeness_lemma with | None -> tclIDTAC g | Some f_complete -> - let f_args,res = array_chop (Array.length args - 1) args in + 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])]; + Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; thin [hid]; - h_intro hid; + Proofview.V82.of_tactic (Simple.intro hid); post_tac hid ] g @@ -937,26 +1207,26 @@ let revert_graph kn post_tac hid g = 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 old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.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 ()) -> + | App(eq,args) when eq_constr eq (make_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)) + ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.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])]; + Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; thin [hid]; - h_intro hid; - Inv.inv FullInversion None (Glob_term.NamedHyp hid); + Proofview.V82.of_tactic (Simple.intro hid); + Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); (fun g -> - let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in + let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g ); ] g @@ -968,14 +1238,16 @@ let invfun qhyp f = let f = match f with | ConstRef f -> f - | _ -> raise (Util.UserError("",str "Not a function")) + | _ -> raise (Errors.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 + Proofview.V82.of_tactic ( + Tactics.try_intros_until (fun hid -> Proofview.V82.tactic (functional_inversion kn hid (mkConst f) f_correct)) qhyp + ) with | Not_found -> error "No graph found" | Option.IsNone -> error "Cannot use equivalence with graph!" @@ -985,16 +1257,17 @@ let invfun qhyp f g = match f with | Some f -> invfun qhyp f g | None -> + Proofview.V82.of_tactic begin Tactics.try_intros_until - (fun hid g -> + (fun hid -> Proofview.V82.tactic begin fun 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 ()) -> + | App(eq,args) when eq_constr eq (make_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 finfos = find_Function_infos (fst (destConst f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in @@ -1003,14 +1276,14 @@ let invfun qhyp f g = try let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (destConst f2) in + let finfos = find_Function_infos (fst (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") + errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") | Option.IsNone -> if do_observe () then @@ -1023,6 +1296,7 @@ let invfun qhyp f g = else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") - ) + end) qhyp + end g diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index e1f10be2..ea699580 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* x,lift n y) ldecl -let understand = Pretyping.Default.understand Evd.empty (Global.env()) +let understand = Pretyping.understand (Global.env()) Evd.empty (** Operations on names and identifiers *) let id_of_name = function - Anonymous -> id_of_string "H" + 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) +let name_of_string str = Name (Id.of_string str) +let string_of_name nme = Id.to_string (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 - | GVar (_,x) -> Pervasives.compare x f = 0 + | GVar (_,x) -> Id.equal x f | _ -> 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 + let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in + let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in true with e when Errors.noncritical e -> 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 next_ident_fresh (id:Id.t) = let res = ref id in while ident_global_exist !res do res := Nameops.lift_subscript !res done; !res @@ -128,19 +131,15 @@ let prNamedRLDecl s lc = prstr "\n"; end -let showind (id:identifier) = +let showind (id:Id.t) = let cstrid = Constrintern.global_reference 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 + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst 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?"); + Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc @@ -152,23 +151,15 @@ 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 +match Array.findi pred arr with +| None -> Array.length arr (* all elt are positive *) +| Some i -> i -(* Like list_chop but except that [i] is the size of the suffix of [l]. *) +(* 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 + 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 @@ -234,7 +225,7 @@ let linkmonad f lnkvar = 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) +module Link = Map.Make (Int) let pr_links l = Printf.printf "links:\n"; @@ -254,7 +245,7 @@ type 'a merged_arg = type merge_infos = { - ident:identifier; (** new inductive name *) + ident:Id.t; (** new inductive name *) mib1: mutual_inductive_body; oib1: one_inductive_body; mib2: mutual_inductive_body; @@ -357,17 +348,17 @@ let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = (** {1 Utilities for merging} *) -let ind1name = id_of_string "__ind1" -let ind2name = id_of_string "__ind2" +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"; + if mib1.mind_finite == Decl_kinds.CoFinite then error "First argument is coinductive"; + if mib2.mind_finite == Decl_kinds.CoFinite then error "Second argument is coinductive"; + if not (Int.equal mib1.mind_ntypes 1) then error "First argument is mutual"; + if not (Int.equal mib2.mind_ntypes 1) then error "Second argument is mutual"; () (* @@ -381,11 +372,11 @@ let build_raw_params prms_decl avoid = let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in let res,_ = glob_decompose_prod dummy_glob_constr in let comblist = List.combine prms_decl res in - comblist, res , (avoid @ (Idset.elements (ids_of_glob_constr dummy_glob_constr))) + comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr))) *) let ids_of_rawlist avoid rawl = - List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl) + List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl) @@ -463,7 +454,7 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array ([],[],[],[]) arity_ctxt in (* let arity_ctxt2 = build_raw_params oib2.mind_arity_ctxt - (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) + (Id.Set.elements (ids_of_glob_constr 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 @@ -514,16 +505,16 @@ let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = | GApp(_,f1, arr1), GApp(_,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 - GApp (dummy_loc,GVar (dummy_loc,shift.ident) , args) + GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args) | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2!\n";Pp.flush_all() in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3!\n";Pp.flush_all() in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in raise NoMerge @@ -532,16 +523,16 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = match c1 , c2 with | GApp(_,f1, arr1), GApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in - GApp (dummy_loc,GVar(dummy_loc,shift.ident) , args) + GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge @@ -550,8 +541,8 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = 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 * glob_constr option * glob_constr option) list) - filter_shift_stable : (Names.name * glob_constr option * glob_constr option) list = + (ltyp:(Name.t * glob_constr option * glob_constr option) list) + filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list = let mergeonehyp t reldecl = match reldecl with | (nme,x,Some (GApp(_,i,args) as ind)) @@ -567,11 +558,11 @@ let rec merge_rec_hyps shift accrec | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable -let rec build_suppl_reccall (accrec:(name * glob_constr) list) concl2 shift = +let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift = List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec -let find_app (nme:identifier) ltyp = +let find_app (nme:Id.t) ltyp = try ignore (List.map @@ -591,9 +582,9 @@ let prnt_prod_or_letin nm letbdy typ = let rec merge_types shift accrec1 - (ltyp1:(name * glob_constr option * glob_constr option) list) - (concl1:glob_constr) (ltyp2:(name * glob_constr option * glob_constr option) list) concl2 - : (name * glob_constr option * glob_constr option) list * glob_constr = + (ltyp1:(Name.t * glob_constr option * glob_constr option) list) + (concl1:glob_constr) (ltyp2:(Name.t * glob_constr option * glob_constr option) list) concl2 + : (Name.t * glob_constr option * glob_constr option) list * glob_constr = 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 @@ -603,7 +594,7 @@ let rec merge_types shift accrec1 let res = match ltyp1 with | [] -> - let isrec1 = (accrec1<>[]) in + let isrec1 = not (List.is_empty accrec1) in let isrec2 = find_app ind2name ltyp2 in let rechyps = if isrec1 && isrec2 @@ -657,22 +648,22 @@ let rec merge_types shift accrec1 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) +let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array) (lnk:int merged_arg array) = - array_fold_lefti + Array.fold_left_i (fun i acc e -> - if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) + if Int.equal 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 + | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc | _ -> acc) - Idmap.empty lnk + Id.Map.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 + Array.of_list (List.rev_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 + Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in build_link_map_aux allargs1 allargs2 lnk @@ -749,18 +740,18 @@ let fresh_cstror_suffix , cstror_suffix_init = (** [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) +let merge_constructor_id id1 id2 shift:Id.t = + let id = Id.to_string 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 glob_constr first, each of them having distinct var names. *) -let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) - (typcstr1:(identifier * glob_constr) list) - (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list = +let merge_constructors (shift:merge_infos) (avoid:Id.Set.t) + (typcstr1:(Id.t * glob_constr) list) + (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list = List.flatten (List.map (fun (id1,rawtyp1) -> @@ -776,20 +767,20 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) (** [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) +let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (oib2:one_inductive_body) = (* building glob_constr 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 + Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in let lcstr1: glob_constr 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 avoid2 = Id.Set.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 avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in let params1 = try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) @@ -810,14 +801,14 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) [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 +let 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) + merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0) let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *) - Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) x + Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let params = prms2 @ prms1 in @@ -828,15 +819,15 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in let typ = glob_constr_to_constr_expr tp in - LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) + LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) [] params in - let concl = Constrextern.extern_constr false (Global.env()) concl in + let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in let arity,_ = List.fold_left (fun (acc,env) (nm,_,c) -> - let typ = Constrextern.extern_constr false env c in + let typ = Constrextern.extern_constr false env Evd.empty 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) + CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) (shift.funresprms2 @ shift.funresprms1 @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in @@ -849,33 +840,22 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = [rawlist], named ident. FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(identifier * glob_constr) list) = - let lident = dummy_loc, shift.ident in + (rawlist:(Id.t * glob_constr) list) = + let lident = Loc.ghost, 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),glob_constr_to_constr_expr t)) + (fun (id,t) -> false, ((Loc.ghost,id),glob_constr_to_constr_expr t)) rawlist in lident , bindlist , Some cstr_expr , lcstor_expr - -let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = - match rdecl with - | (nme,None,t) -> - let traw = Detyping.detype false [] [] t in - GProd (dummy_loc,nme,Explicit,traw,t2) - | (_,Some _,_) -> assert false - - - - let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = match rdecl with | (nme,None,t) -> - let traw = Detyping.detype false [] [] t in - GProd (dummy_loc,nme,Explicit,traw,t2) + let traw = Detyping.detype false [] (Global.env()) Evd.empty t in + GProd (Loc.ghost,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false @@ -893,7 +873,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) 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 + List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in let _ = prstr "\nend rawlist\n" in (* FIX: retransformer en constr ici let shift_prm = @@ -904,15 +884,16 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let indexpr = glob_constr_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 + let mie,impls = Command.interp_mutual_inductive indl [] + false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) - ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls) + ignore (Command.declare_mutual_inductive_with_eliminations mie impls) (* Find infos on identifier id. *) -let find_Function_infos_safe (id:identifier): Indfun_common.function_info = +let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = let kn_of_id x = - let f_ref = Libnames.Ident (dummy_loc,x) in + let f_ref = Libnames.Ident (Loc.ghost,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) @@ -927,8 +908,8 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info = 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 merge (id1:Id.t) (id2:Id.t) (args1:Id.t array) + (args2:Id.t 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) ?? *) @@ -938,7 +919,7 @@ let merge (id1:identifier) (id2:identifier) (args1:identifier array) as above: vars may be linked inside args2?? *) Array.mapi (fun i c -> - match array_find_i (fun i x -> x=c) args1 with + match Array.findi (fun i x -> Id.equal x c) args1 with | Some j -> Linked j | None -> Unlinked) args2 in @@ -955,7 +936,7 @@ let remove_last_arg c = 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 rec remove_n_fst_list n l = if Int.equal 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 = @@ -977,7 +958,7 @@ let funify_branches relinfo nfuns branch = | _ -> assert false in let is_dom c = match kind_of_term c with - | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct + | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct | _ -> false in let _dom_i c = assert (is_dom c); diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index a33ae1d6..5558556e 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1,59 +1,111 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + (try (match constant_opt_value_in (Global.env ()) sp with + | Some c -> c + | _ -> raise Not_found) + with Not_found -> + anomaly (str "Cannot find definition of constant " ++ + (Id.print (Label.to_id (con_label (fst 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 constr_of_global x = + fst (Universes.unsafe_constr_of_global x) + +let constant sl s = constr_of_global (find_reference sl s) + +let const_of_ref = function + ConstRef kn -> kn + | _ -> anomaly (Pp.str "ConstRef expected") + + +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 + + + + + +(* Generic values *) let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in List.fold_right @@ -61,14 +113,98 @@ let pf_get_new_ids idl g = idl [] -let pf_get_new_id id g = - List.hd (pf_get_new_ids [id] g) +let compute_renamed_type gls c = + rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] + (pf_type_of gls c) +let h'_id = Id.of_string "h'" +let teq_id = Id.of_string "teq" +let ano_id = Id.of_string "anonymous" +let x_id = Id.of_string "x" +let k_id = Id.of_string "k" +let v_id = Id.of_string "v" +let def_id = Id.of_string "def" +let p_id = Id.of_string "p" +let rec_res_id = Id.of_string "rec_res";; +let lt = function () -> (coq_init_constant "lt") +let le = function () -> (coq_init_constant "le") +let ex = function () -> (coq_init_constant "ex") +let nat = function () -> (coq_init_constant "nat") +let iter_ref () = + try find_reference ["Recdef"] "iter" + with Not_found -> error "module Recdef not loaded" +let iter = function () -> (constr_of_global (delayed_force iter_ref)) +let eq = function () -> (coq_init_constant "eq") +let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") +let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm") +let le_trans = function () -> (coq_constant arith_Nat "le_trans") +let le_lt_trans = function () -> (coq_constant arith_Nat "le_lt_trans") +let lt_S_n = function () -> (coq_constant arith_Lt "lt_S_n") +let le_n = function () -> (coq_init_constant "le_n") +let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") +let coq_O = function () -> (coq_init_constant "O") +let coq_S = function () -> (coq_init_constant "S") +let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") +let max_ref = function () -> (find_reference ["Recdef"] "max") +let max_constr = function () -> (constr_of_global (delayed_force max_ref)) +let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" + +let f_S t = mkApp(delayed_force coq_S, [|t|]);; -let h_intros l = - tclMAP h_intro l +let rec n_x_id ids n = + if Int.equal n 0 then [] + else let x = next_ident_away_in_goal x_id ids in + x::n_x_id (x::ids) (n-1);; -let debug_queue = Stack.create () +let simpl_iter clause = + reduce + (Lazy + {rBeta=true;rIota=true;rZeta= true; rDelta=false; + rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) + clause + +(* Others ugly things ... *) +let (value_f:constr list -> global_reference -> constr) = + fun al fterm -> + let d0 = Loc.ghost 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 context = List.map + (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) + in + let env = Environ.push_rel_context context (Global.env ()) in + let glob_body = + GCases + (d0,RegularStyle,None, + [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), + (Anonymous,None)], + [d0, [v_id], [PatCstr(d0,(destIndRef + (delayed_force coq_sig_ref),1), + [PatVar(d0, Name v_id); + PatVar(d0, Anonymous)], + Anonymous)], + GVar(d0,v_id)]) + in + let body = fst (understand env Evd.empty glob_body)(*FIXME*) in + it_mkLambda_or_LetIn body context + +let (declare_f : Id.t -> 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);; + + + +(* Debuging mechanism *) +let debug_queue = Stack.create () let rec print_debug_queue b e = if not (Stack.is_empty debug_queue) @@ -76,267 +212,445 @@ let rec print_debug_queue b e = begin let lmsg,goal = Stack.pop debug_queue in if b then - msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) else begin - msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal); + Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); end; print_debug_queue false e; end - +let observe strm = + if do_observe () + then Pp.msg_debug strm + else () + let do_observe_tac s tac g = let goal = Printer.pr_goal g in - let lmsg = (str "recdef : ") ++ (str s) in + let lmsg = (str "recdef : ") ++ s in + observe (s++fnl()); Stack.push (lmsg,goal) debug_queue; try let v = tac g in ignore(Stack.pop debug_queue); v with reraise -> + let reraise = Errors.push reraise in if not (Stack.is_empty debug_queue) - then - print_debug_queue true reraise; - raise reraise + then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise)); + iraise reraise let observe_tac s tac g = - if Tacinterp.get_debug () <> Tactic_debug.DebugOff + if do_observe () 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);; +(* Conclusion tactics *) -let def_of_const t = - match (kind_of_term t) with - Const sp -> - (try (match body_of_constant (Global.lookup_constant sp) with - | Some c -> Declarations.force c - | _ -> assert false) - with e when Errors.noncritical e -> - anomaly ("Cannot find definition of constant "^ - (string_of_id (id_of_label (con_label sp)))) - ) - |_ -> assert false +(* 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 -> clear [] + | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) + in + tclTHENLIST + [ + clear_tac; + if is_mes + then tclTHENLIST + [ + unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref))]; + tac + ] + else tac + ] + g -let type_of_const t = - match (kind_of_term t) with - Const sp -> Typeops.type_of_constant (Global.env()) sp - |_ -> assert false +let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = + if is_mes + then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) + else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) + + + + -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 check_not_nested f t = - match kind_of_term t with - | App(g, _) when eq_constr f g -> - errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") - | Var(_) when eq_constr t f -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") - | _ -> iter_constr (check_not_nested f) t - - - - -let rec (find_call_occs : int -> int -> constr -> constr -> - (constr list -> constr) * constr list list) = - fun nb_arg nb_lam f expr -> - match (kind_of_term expr) with - App (g, args) when eq_constr g f -> - if Array.length args <> nb_arg then errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function"); - Array.iter (check_not_nested f) args; - (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_arg 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_arg 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(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function") - | Var(id) -> (fun l -> expr), [] - | Meta(_) -> error "Found a metavariable. Can not treat such a term" - | Evar(_) -> error "Found an evar. Can not treat such a term" - | Sort(_) -> (fun l -> expr), [] - | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b - | Prod(na,t,b) -> - error "Found a product. Can not treat such a term" - | Lambda(na,t,b) -> +(* Travelling term. + Both definitions of [f_terminate] and [f_equation] use the same generic + travelling mechanism. +*) + +(* [check_not_nested forbidden e] checks that [e] does not contains any variable + of [forbidden] +*) +let check_not_nested forbidden e = + let rec check_not_nested e = + match kind_of_term e with + | Rel _ -> () + | Var x -> + if Id.List.mem x forbidden + then error ("check_not_nested : failure "^Id.to_string x) + | Meta _ | Evar _ | Sort _ -> () + | Cast(e,_,t) -> check_not_nested e;check_not_nested t + | Prod(_,t,b) -> check_not_nested t;check_not_nested b + | Lambda(_,t,b) -> check_not_nested t;check_not_nested b + | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v + | App(f,l) -> check_not_nested f;Array.iter check_not_nested l + | Proj (p,c) -> check_not_nested c + | Const _ -> () + | Ind _ -> () + | Construct _ -> () + | Case(_,t,e,a) -> + check_not_nested t;check_not_nested e;Array.iter check_not_nested a + | Fix _ -> error "check_not_nested : Fix" + | CoFix _ -> error "check_not_nested : Fix" + in + try + check_not_nested e + with UserError(_,p) -> + errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + +(* ['a info] contains the local information for travelling *) +type 'a infos = + { nb_arg : int; (* function number of arguments *) + concl_tac : tactic; (* final tactic to finish proofs *) + rec_arg_id : Id.t; (*name of the declared recursive argument *) + is_mes : bool; (* type of recursion *) + ih : Id.t; (* induction hypothesis name *) + f_id : Id.t; (* function name *) + f_constr : constr; (* function term *) + f_terminate : constr; (* termination proof term *) + func : global_reference; (* functionnal reference *) + info : 'a; + is_main_branch : bool; (* on the main branch or on a matched expression *) + is_final : bool; (* final first order term or not *) + values_and_bounds : (Id.t*Id.t) list; + eqs : Id.t list; + forbidden_ids : Id.t list; + acc_inv : constr lazy_t; + acc_id : Id.t; + args_assoc : ((constr list)*constr) list; + } + + +type ('a,'b) journey_info_tac = + 'a -> (* the arguments of the constructor *) + 'b infos -> (* infos of the caller *) + ('b infos -> tactic) -> (* the continuation tactic of the caller *) + 'b infos -> (* argument of the tactic *) + tactic + +(* journey_info : specifies the actions to do on the different term constructors during the travelling of the term +*) +type journey_info = + { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; + lambdA : ((Name.t*types*constr),constr) journey_info_tac; + casE : ((constr infos -> tactic) -> constr infos -> tactic) -> + ((case_info * constr * constr * constr array),constr) journey_info_tac; + otherS : (unit,constr) journey_info_tac; + apP : (constr*(constr list),constr) journey_info_tac; + app_reC : (constr*(constr list),constr) journey_info_tac; + message : string + } + + + +let rec add_vars forbidden e = + match kind_of_term e with + | Var x -> x::forbidden + | _ -> fold_constr add_vars forbidden e + + +let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = + fun g -> + let rev_context,b = decompose_lam_n nb_lam e in + let ids = List.fold_left (fun acc (na,_) -> + let pre_id = + match na with + | Name x -> x + | Anonymous -> ano_id + in + pre_id::acc + ) [] rev_context in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + tclTHENLIST + [ + h_intros (List.rev rev_ids); + Proofview.V82.of_tactic (intro_using teq_id); + onLastHypId (fun heq -> + tclTHENLIST[ + thin to_intros; + h_intros to_intros; + (fun g' -> + let ty_teq = pf_type_of g' (mkVar heq) in + let teq_lhs,teq_rhs = + let _,args = try destApp ty_teq with DestKO -> assert false in + args.(1),args.(2) + in + let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in + let new_infos = { + infos with + info = new_b'; + eqs = heq::infos.eqs; + forbidden_ids = + if forbid_new_ids + then add_vars infos.forbidden_ids new_b' + else infos.forbidden_ids + } in + finalize_tac new_infos g' + ) + ] + ) + ] g + +let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = + match kind_of_term expr_info.info with + | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint" + | Proj _ -> error "Function cannot treat projections" + | LetIn(na,b,t,e) -> begin - match find_call_occs nb_arg (succ nb_lam) f b with - | _, [] -> (* Lambda are authorized as long as they do not contain - recursives calls *) - (fun l -> expr),[] - | _ -> error "Found a lambda which body contains a recursive call. Such terms are not allowed" + let new_continuation_tac = + jinfo.letiN (na,b,t,e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final=false} end - | LetIn(na,v,t,b) -> + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") + | Prod _ -> begin - match find_call_occs nb_arg nb_lam f v, find_call_occs nb_arg (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 "Found a letin with recursive calls in both variable value and body. Such terms are not allowed." + try + check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when Errors.noncritical e -> + errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end - | Const(_) -> (fun l -> expr), [] - | Ind(_) -> (fun l -> expr), [] - | Construct (_, _) -> (fun l -> expr), [] - | Case(i,t,a,r) -> - (match find_call_occs nb_arg nb_lam f a with - cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) - | _ -> (fun l -> expr),[]) - | Fix(_) -> error "Found a local fixpoint. Can not treat such a term" - | CoFix(_) -> error "Found a local cofixpoint : 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)));; + | Lambda(n,t,b) -> + begin + try + check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when Errors.noncritical e -> + errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + end + | Case(ci,t,a,l) -> + begin + let continuation_tac_a = + jinfo.casE + (travel jinfo) (ci,t,a,l) + expr_info continuation_tac in + travel + jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; + is_final = false} + end + | App _ -> + let f,args = decompose_app expr_info.info in + if eq_constr f (expr_info.f_constr) + then jinfo.app_reC (f,args) expr_info continuation_tac expr_info + else + begin + match kind_of_term f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ + | Sort _ | Prod _ | Var _ -> + let new_infos = {expr_info with info=(f,args)} in + let new_continuation_tac = + jinfo.apP (f,args) expr_info continuation_tac in + travel_args jinfo + expr_info.is_main_branch new_continuation_tac new_infos + | Case _ -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) + end + | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> + let new_continuation_tac = + jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info +and travel_args jinfo is_final continuation_tac infos = + let (f_args',args) = infos.info in + match args with + | [] -> + continuation_tac {infos with info = f_args'; is_final = is_final} + | arg::args' -> + let new_continuation_tac new_infos = + let new_arg = new_infos.info in + travel_args jinfo is_final + continuation_tac + {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} + in + travel jinfo new_continuation_tac + {infos with info=arg;is_final=false} +and travel jinfo continuation_tac expr_info = + observe_tac + (str jinfo.message ++ Printer.pr_lconstr expr_info.info) + (travel_aux jinfo continuation_tac expr_info) -let find_reference sl s = - (locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; +(* Termination proof *) -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 rec prove_lt hyple g = + begin + try + let (varx,varz) = match decompose_app (pf_concl g) with + | _, x::z::_ when isVar x && isVar z -> x, z + | _ -> assert false + in + let h = + List.find (fun id -> + match decompose_app (pf_type_of g (mkVar id)) with + | _, t::_ -> eq_constr t varx + | _ -> false + ) hyple + in + let y = + List.hd (List.tl (snd (decompose_app (pf_type_of g (mkVar h))))) in + tclTHENLIST[ + Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); + observe_tac (str "prove_lt") (prove_lt hyple) + ] + with Not_found -> + ( + ( + tclTHENLIST[ + Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); + (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) + ]) + ) + end + g + +let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = + match lbounds with + | [] -> + 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[ + Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); + Proofview.V82.of_tactic (intro_then + (fun id -> + Proofview.V82.tactic begin + observe_tac (str "destruct_bounds_aux") + (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) + [ + tclTHENLIST[Proofview.V82.of_tactic (intro_using h_id); + Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); + Proofview.V82.of_tactic default_full_auto]; + tclTHENLIST[ + observe_tac (str "clearing k ") (clear [id]); + h_intros [k;h';def]; + observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl); + observe_tac (str "unfold functional") + (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference infos.func)]); + observe_tac (str "test" ) ( + tclTHENLIST[ + list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e,true)::acc) + infos.eqs + (List.map (fun e -> (e,true)) rechyps) + ); + (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + + (observe_tac (str "finishing") + (tclORELSE + (Proofview.V82.of_tactic intros_reflexivity) + (observe_tac (str "calling prove_lt") (prove_lt hyple))))]) + ] + ] + )end)) + ] g + | (_,v_bound)::l -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); + clear [v_bound]; + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 + (fun p_hyp -> + (onNthHypId 2 + (fun p -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_elim + (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); + tclDO 3 (Proofview.V82.of_tactic intro); + onNLastHypsId 3 (fun lids -> + match lids with + [hle2;hle1;pmax] -> + destruct_bounds_aux infos + ((mkVar pmax), + hle1::hle2::hyple,(mkVar p_hyp)::rechyps) + l + | _ -> assert false) ; + ] + ) + ) + ) + ] g + +let destruct_bounds infos = + destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds + +let terminate_app f_and_args expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + continuation_tac infos; + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) + ] + else continuation_tac infos + +let terminate_others _ expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + continuation_tac infos; + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + observe_tac (str "destruct_bounds") (destruct_bounds infos) + ] + else continuation_tac infos + +let terminate_letin (na,b,t,e) expr_info continuation_tac info = + let new_e = subst1 info.info e in + let new_forbidden = + let forbid = + try + check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b; + true + with e when Errors.noncritical e -> false + in + if forbid + then + match na with + | Anonymous -> info.forbidden_ids + | Name id -> id::info.forbidden_ids + else info.forbidden_ids + in + continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} + +let pf_type c tac gl = + let evars, ty = Typing.e_type_of (pf_env gl) (project gl) c in + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl -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);; +let pf_typel l tac = + let rec aux tys l = + match l with + | [] -> tac (List.rev tys) + | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) + in aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -344,390 +658,355 @@ let mkCaseEq a : tactic = 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 = + Id.t list -> constr -> goal sigma -> tactic * Id.t 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 + Util.List.map_filter + (fun (id, _, t) -> + if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t) + then None else Some 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|]):: + let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in + pf_typel new_hyps (fun _ -> tclTHENLIST - [h_generalize new_hyps; + [Simple.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 Termops.all_occurrences true (* 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 e when Errors.noncritical e -> - Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false - in - args.(1),args.(2) - in - cont_function (mkVar teq::eqs) (Termops.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" + Proofview.V82.of_tactic (change_in_concl None + (fun sigma -> + pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2); + Proofview.V82.of_tactic (simplest_case expr)]), to_revert -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) +let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = + let b = + try + check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; + false + with e when Errors.noncritical e -> + true in - tclTHENSEQ - [ - clear_tac; - if is_mes - then tclTHEN - (unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference - (delayed_force ltof_ref))]) - tac - else tac - ] + let a' = infos.info in + let new_info = + {infos with + info = mkCase(ci,t,a',l); + is_main_branch = expr_info.is_main_branch; + is_final = expr_info.is_final} in + let destruct_tac,rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] a' g in + let to_thin_intro = List.rev rev_to_thin_intro in + observe_tac (str "treating case " ++ int (Array.length l) ++ spc () ++ Printer.pr_lconstr a') + (try + (tclTHENS + destruct_tac + (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case b to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) + )) + with + | UserError("Refiner.thensn_tac3",_) + | UserError("Refiner.tclFAIL_s",_) -> + (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + )) g + +let terminate_app_rec (f,args) expr_info continuation_tac _ = + List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids)) + args; + begin + try + let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let new_infos = {expr_info with info = v} in + tclTHENLIST[ + continuation_tac new_infos; + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + observe_tac (str "destruct_bounds (3)") + (destruct_bounds new_infos) + ] + else + tclIDTAC + ] + with Not_found -> + observe_tac (str "terminate_app_rec not found") (tclTHENS + (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) + [ + tclTHENLIST[ + Proofview.V82.of_tactic (intro_using rec_res_id); + Proofview.V82.of_tactic intro; + onNthHypId 1 + (fun v_bound -> + (onNthHypId 2 + (fun v -> + let new_infos = { expr_info with + info = (mkVar v); + values_and_bounds = + (v,v_bound)::expr_info.values_and_bounds; + args_assoc=(args,mkVar v)::expr_info.args_assoc + } in + tclTHENLIST[ + continuation_tac new_infos; + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + observe_tac (str "destruct_bounds (2)") + (destruct_bounds new_infos) + ] + else + tclIDTAC + ] + ) + ) + ) + ]; + observe_tac (str "proving decreasing") ( + tclTHENS (* proof of args < formal args *) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + [ + observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); + tclTHENLIST + [ + tclTRY(list_rewrite true + (List.map + (fun e -> mkVar e,true) + expr_info.eqs + ) + ); + tclUSER expr_info.concl_tac true + (Some ( + expr_info.ih::expr_info.acc_id:: + (fun (x,y) -> y) + (List.split expr_info.values_and_bounds) + ) + ); + ] + ]) + ]) + end +let terminate_info = + { message = "prove_terminate with term "; + letiN = terminate_letin; + lambdA = (fun _ _ _ _ -> assert false); + casE = terminate_case; + otherS = terminate_others; + apP = terminate_app; + app_reC = terminate_app_rec; + } -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 Termops.all_occurrences - (* dep proofs also: *) true 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 prove_terminate = travel terminate_info -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 = Termops.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 = Termops.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) - ) +(* Equation proof *) +let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = + terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos -let rec_leaf_terminate nb_arg f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = - match find_call_occs nb_arg 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 rec prove_le g = + let x,z = + let _,args = decompose_app (pf_concl g) in + (List.hd args,List.hd (List.tl args)) + in + tclFIRST[ + Proofview.V82.of_tactic assumption; + Proofview.V82.of_tactic (apply (delayed_force le_n)); + begin + try + let matching_fun = + pf_is_matching g + (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in + let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) + in + let y = + let _,args = decompose_app t in + List.hd (List.tl args) + in + tclTHENLIST[ + Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); + observe_tac (str "prove_le (rec)") (prove_le) + ] + with Not_found -> tclFAIL 0 (mt()) + end; + ] + g -let proveterminate nb_arg 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 nb_arg 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_ndecls.(i)) - 0 (Array.to_list l)) g) - | _, _::_ -> - (match find_call_occs nb_arg 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 nb_arg 0 f_constr expr with - _,[] -> - (try observe_tac "base_leaf" (base_leaf func eqs expr) - with reraise -> - (msgerrnl (str "failure in base case");raise reraise )) - | _, _::_ -> - observe_tac "rec_leaf" - (rec_leaf is_mes acc_inv hrec func eqs expr)) in - v - with reraise -> +let rec make_rewrite_list expr_info max = function + | [] -> tclIDTAC + | (_,p,hp)::l -> + observe_tac (str "make_rewrite_list") (tclTHENS + (observe_tac (str "rewrite heq on " ++ pr_id p ) ( + (fun g -> + let t_eq = compute_renamed_type g (mkVar hp) in + let k,def = + 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 + Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences + true (* dep proofs also: *) true + (mkVar hp, + ExplicitBindings[Loc.ghost,NamedHyp def, + expr_info.f_constr;Loc.ghost,NamedHyp k, + (f_S max)]) false) g) ) + ) + [make_rewrite_list expr_info max l; + tclTHENLIST[ (* x < S max proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); + observe_tac (str "prove_le(2)") prove_le + ] + ] ) + +let make_rewrite expr_info l hp max = + tclTHENFIRST + (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) + (observe_tac (str "make_rewrite") (tclTHENS + (fun g -> + let t_eq = compute_renamed_type g (mkVar hp) in + let k,def = + 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 + observe_tac (str "general_rewrite_bindings") + (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences + true (* dep proofs also: *) true + (mkVar hp, + ExplicitBindings[Loc.ghost,NamedHyp def, + expr_info.f_constr;Loc.ghost,NamedHyp k, + (f_S (f_S max))]) false)) g) + [observe_tac(str "make_rewrite finalize") ( + (* tclORELSE( h_reflexivity) *) + (tclTHENLIST[ + simpl_iter Locusops.onConcl; + observe_tac (str "unfold functional") + (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference expr_info.func)]); + + (list_rewrite true + (List.map (fun e -> mkVar e,true) expr_info.eqs)); + (observe_tac (str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity))])) + ; + tclTHENLIST[ (* x < S (S max) proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_SS)); + observe_tac (str "prove_le (3)") prove_le + ] + ]) + ) + +let rec compute_max rew_tac max l = + match l with + | [] -> rew_tac max + | (_,p,_)::l -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_elim + (mkApp(delayed_force max_constr, [| max; mkVar p|]))); + tclDO 3 (Proofview.V82.of_tactic intro); + onNLastHypsId 3 (fun lids -> + match lids with + | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l + | _ -> assert false + )] + +let rec destruct_hex expr_info acc l = + match l with + | [] -> begin - msgerrnl(str "failure in proveterminate"); - raise reraise + match List.rev acc with + | [] -> tclIDTAC + | (_,p,hp)::tl -> + observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end - in - proveterminate + | (v,hex)::l -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case (mkVar hex)); + clear [hex]; + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 (fun hp -> + onNthHypId 2 (fun p -> + observe_tac + (str "destruct_hex after " ++ pr_id hp ++ spc () ++ pr_id p) + (destruct_hex expr_info ((v,p,hp)::acc) l) + ) + ) + ] + +let rec intros_values_eq expr_info acc = + tclORELSE( + tclTHENLIST[ + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 (fun hex -> + (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) + ) + ]) + (tclCOMPLETE ( + destruct_hex expr_info [] acc + )) + +let equation_others _ expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then + tclTHEN + (continuation_tac infos) + (intros_values_eq expr_info []) + else continuation_tac infos + +let equation_app f_and_args expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then intros_values_eq expr_info [] + else continuation_tac infos + +let equation_app_rec (f,args) expr_info continuation_tac info = + begin + try + let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let new_infos = {expr_info with info = v} in + observe_tac (str "app_rec found") (continuation_tac new_infos) + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST + [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; + observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) + ] + else + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) + ] + end -let hyp_terminates nb_args func = - let a_arrow_b = arg_type (constr_of_global func) in +let equation_info = + {message = "prove_equation with term "; + letiN = (fun _ -> assert false); + lambdA = (fun _ _ _ _ -> assert false); + casE = equation_case; + otherS = equation_others; + apP = equation_app; + app_reC = equation_app_rec +} + +let prove_eq = travel equation_info + +(* wrappers *) +(* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F +*) +let compute_terminate_type nb_args func = + let _,a_arrow_b,_ = destLambda(def_of_const (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) + List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) in @@ -744,18 +1023,12 @@ let hyp_terminates nb_args func = delayed_force nat, (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in - let value = mkApp(delayed_force coq_sig, + let value = mkApp(constr_of_global (delayed_force coq_sig_ref), [|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 @@ -763,14 +1036,14 @@ let termination_proof_header is_mes input_type ids args_id relation let nargs = List.length args_id in let pre_rec_args = List.rev_map - mkVar (fst (list_chop (rec_arg_num - 1) args_id)) + 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_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))) + (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) (wf_thm::ids) in let hrec = next_ident_away_in_goal hrec_id @@ -787,46 +1060,46 @@ let termination_proof_header is_mes input_type ids args_id relation (h_intros args_id) (tclTHENS (observe_tac - "first assert" - (assert_tac + (str "first assert") + (Proofview.V82.of_tactic (assert_before (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 + (str "second assert") + (Proofview.V82.of_tactic (assert_before (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)); + observe_tac (str "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|])) + (str "apply wf_thm") + (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) ) ] ; (* rest of the proof *) - tclTHENSEQ - [observe_tac "generalize" + tclTHENLIST + [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> - tclTHEN (h_generalize [mkVar id]) (h_clear false [id])) + tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id])) )) ; - observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); + observe_tac (str "fix") (fix (Some hrec) (nargs+1)); h_intros args_id; - h_intro wf_rec_arg; - observe_tac "tac" (tac wf_rec_arg hrec acc_inv) + Proofview.V82.of_tactic (Simple.intro wf_rec_arg); + observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ] ) g @@ -838,10 +1111,8 @@ let rec instantiate_lambda t l = match l with | [] -> t | a::l -> - let (bound_name, _, body) = destLambda t in + let (_, _, 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 @@ -852,7 +1123,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly "Anonymous function" + | Anonymous -> anomaly (Pp.str "Anonymous function") in let n_names_types,_ = decompose_lam_n nb_args body1 in let n_ids,ids = @@ -862,7 +1133,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a | Name id -> let n_id = next_ident_away_in_goal id ids in n_id::n_ids,n_id::ids - | _ -> anomaly "anonymous argument" + | _ -> anomaly (Pp.str "anonymous argument") ) ([],(f_id::ids)) n_names_types @@ -877,20 +1148,28 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a relation rec_arg_num rec_arg_id - (fun rec_arg_id hrec acc_inv g -> - (proveterminate - nb_args - [rec_arg_id] - is_mes - acc_inv - hrec - (mkVar f_id) - func - base_leaf_terminate - (rec_leaf_terminate nb_args (mkVar f_id) concl_tac) - [] - expr - ) + (fun rec_arg_id hrec acc_id acc_inv g -> + (prove_terminate (fun infos -> tclIDTAC) + { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O; + nb_arg = nb_args; + concl_tac = concl_tac; + rec_arg_id = rec_arg_id; + is_mes = is_mes; + ih = hrec; + f_id = f_id; + f_constr = mkVar f_id; + func = func; + info = expr; + acc_inv = acc_inv; + acc_id = acc_id; + values_and_bounds = []; + eqs = []; + forbidden_ids = []; + args_assoc = [] + } + ) g ) (tclUSER_if_not_mes concl_tac) @@ -900,7 +1179,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in - List.map (Goal.V82.abstract_type sigma) sgs + sigma, List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in @@ -913,7 +1192,8 @@ let build_and_l l = | App(_,_) -> let (f,_) = decompose_app t in eq_constr f (well_founded ()) - | _ -> false + | _ -> + false in let compare t1 t2 = let b1,b2= is_well_founded t1,is_well_founded t2 in @@ -928,7 +1208,7 @@ let build_and_l l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (apply (constr_of_global conj_constr)) + (Proofview.V82.of_tactic (apply (constr_of_global conj_constr))) [tclIDTAC; tac ],nb+1 @@ -936,12 +1216,12 @@ let build_and_l 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 + let rec_res_name = Id.to_string rec_res_id in + let id_name = Id.to_string id in try - String.sub id_name 0 (String.length rec_res_name) = rec_res_name - with e when Errors.noncritical e -> false - + String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name + with Invalid_argument _ -> false + let clear_goals = let rec clear_goal t = match kind_of_term t with @@ -957,12 +1237,12 @@ let clear_goals = let build_new_goal_type () = - let sub_gls_types = get_current_subgoals_types () in + let sigma, 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); *) + (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sub_gls_types in - res + sigma, res let is_opaque_constant c = let cb = Global.lookup_constant c in @@ -971,48 +1251,47 @@ let is_opaque_constant c = | Declarations.Undef _ -> true | Declarations.Def _ -> false -let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal build_proof sigma 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") + try add_suffix current_proof_name "_subproof" with e when Errors.noncritical e -> - anomaly "open_new_goal with an unamed theorem" + anomaly (Pp.str "open_new_goal with an unamed theorem") in - let sign = initialize_named_context_for_proof () in let na = next_global_ident_away name [] in if Termops.occur_existential gls_type then - Util.error "\"abstract\" cannot handle existentials"; + Errors.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 + let na_ref = Libnames.Ident (Loc.ghost,na) in + let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c - | _ -> anomaly "equation_lemma: not a constant" + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant") in - let lemma = mkConst (Lib.make_con na) in + let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Some lemma ; let lid = ref [] in let h_num = ref (-1) in - Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); - build_proof + Proof_global.discard_all (); + build_proof Evd.empty ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - tclTHENSEQ + tclTHENLIST [ - h_generalize [lemma]; - h_intro hid; + Simple.generalize [lemma]; + Proofview.V82.of_tactic (Simple.intro hid); (fun g -> let ids = pf_ids_of_hyps g in tclTHEN - (Elim.h_decompose_and (mkVar hid)) + (Proofview.V82.of_tactic (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]; + lid := List.rev (List.subtract Id.equal ids' ids); + if List.is_empty !lid then lid := [hid]; tclIDTAC g ) g @@ -1021,40 +1300,39 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (fun g -> match kind_of_term (pf_concl g) with | App(f,_) when eq_constr f (well_founded ()) -> - Auto.h_auto None [] (Some []) g + Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; - (observe_tac "finishing using" + (observe_tac (str "finishing using") ( tclCOMPLETE( tclFIRST[ tclTHEN - (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) + (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) e_assumption; Eauto.eauto_with_bases (true,5) - [Evd.empty,delayed_force refl_equal] - [Auto.Hint_db.empty empty_transparent_state false] + [Evd.empty,Lazy.force refl_equal] + [Hints.Hint_db.empty empty_transparent_state false] ] ) ) ) g) ; - Lemmas.save_named opacity; + Lemmas.save_proof (Vernacexpr.Proved(opacity,None)); in - start_proof + Lemmas.start_proof na - (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) - sign - gls_type - hook ; + (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) + sigma gls_type + (Lemmas.mk_hook hook); if Indfun_common.is_strict_tcc () then - by (tclIDTAC) + ignore (by (Proofview.V82.tactic (tclIDTAC))) else begin - by ( + ignore (by (Proofview.V82.tactic begin fun g -> tclTHEN (decompose_and_tac) @@ -1062,23 +1340,21 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (tclFIRST (List.map (fun c -> - tclTHENSEQ + Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [intros; - h_simplest_apply (interp_constr Evd.empty (Global.env()) c); - tclCOMPLETE Auto.default_auto - ] + Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); + Tacticals.New.tclCOMPLETE Auto.default_auto + ]) ) using_lemmas) ) tclIDTAC) - g) + g end)) end; try - by tclIDTAC; (* raises UserError _ if the proof is complete *) - if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) + ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *) with UserError _ -> defined () -;; let com_terminate @@ -1090,25 +1366,28 @@ let com_terminate relation rec_arg_num thm_name using_lemmas - nb_args + nb_args ctx hook = - let start_proof (tac_start:tactic) (tac_end:tactic) = + let start_proof ctx (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; + Lemmas.start_proof thm_name + (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) + ctx (compute_terminate_type 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 )) + ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); + ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num )))) in - start_proof tclIDTAC tclIDTAC; + start_proof ctx tclIDTAC tclIDTAC; try - let new_goal_type = build_new_goal_type () in - open_new_goal start_proof using_lemmas tcc_lemma_ref + let sigma, new_goal_type = build_new_goal_type () in + let sigma = + Evd.from_env ~ctx:(Evd.evar_universe_context sigma) Environ.empty_env + in + open_new_goal start_proof sigma + 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 () @@ -1116,301 +1395,87 @@ let com_terminate -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 context = List.map - (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) - in - let env = Environ.push_rel_context context (Global.env ()) in - let glob_body = - GCases - (d0,RegularStyle,None, - [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(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)], - GVar(d0,v_id)]) - in - let body = understand Evd.empty env glob_body in - it_mkLambda_or_LetIn body context - -let (declare_fun : identifier -> logical_kind -> constr -> global_reference) = - fun f_id kind value -> - let ce = {const_entry_body = value; - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false } 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 = + (cont_tactic:Id.t 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 nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; - unfold_in_concl [(Termops.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|]);; + unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]; + observe_tac (str "simplest_case") + (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, + Array.of_list (List.map mkVar x))))); + observe_tac (str "prove_eq") (cont_tactic x)] g;; - -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, Termops.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 Termops.all_occurrences - true (* 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 Termops.all_occurrences true (* 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 nb_arg (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 nb_arg 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 nb_arg termine f functional) - eqs ci.ci_cstr_ndecls.(i)) - 0 (Array.to_list l)) g) - | _,_::_ -> - (match find_call_occs nb_arg 0 f expr with - _,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f) - | fn,args -> - fun g -> - let ids = Termops.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 nb_arg 0 f expr with - _,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f) - | fn,args -> - fun g -> - let ids = Termops.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 : int -> identifier -> +let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference -> constr -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c - | _ -> anomaly "terminate_lemma: not a constant" + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant") in let (evmap, env) = Lemmas.get_current_context() in - let f_constr = (constr_of_global f_ref) in + let evmap = + Evd.from_env ~ctx:(Evd.evar_universe_context evmap) Environ.empty_env + 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 + (Lemmas.start_proof eq_name (Global, false, Proof Lemma) + ~sign:(Environ.named_context_val env) + evmap + equation_lemma_type + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (by + (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> - prove_eq nb_arg - (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) - ) + prove_eq (fun _ -> tclIDTAC) + {nb_arg=nb_arg; + f_terminate = constr_of_global terminate_ref; + f_constr = f_constr; + concl_tac = tclIDTAC; + func=functional_ref; + info=(instantiate_lambda + (def_of_const (constr_of_global functional_ref)) + (f_constr::List.map mkVar x) + ); + is_main_branch = true; + is_final = true; + values_and_bounds = []; + eqs = []; + forbidden_ids = []; + acc_inv = lazy (assert false); + acc_id = Id.of_string "____"; + args_assoc = []; + f_id = Id.of_string "______"; + rec_arg_id = Id.of_string "______"; + is_mes = false; + ih = Id.of_string "______"; + } ) - ); -(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) + ))); + (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () -> Lemmas.save_named opacity) () ; + Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; (* 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 previous_label = Lib.current_command_label () in - 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 + let env = Global.env() in + let evd = ref (Evd.from_env env) in + let function_type = interp_type_evars env evd type_of_f in + let env = push_named (function_name,None,function_type) 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 + let ty = interp_type_evars env evd ~impls:rec_impls eq in + let evm, nf = Evarutil.nf_evars_and_universes !evd in + let equation_lemma_type = nf_betaiotazeta (nf ty) in + let function_type = nf function_type 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 @@ -1430,35 +1495,35 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num 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 Decl_kinds.Definition) res in + let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(Evd.universe_context evm) 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 + fst (*FIXME*)(interp_constr env_with_pre_rec_args - r + Evd.empty + 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 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 - let _ = Table.extraction_inline true [Ident (dummy_loc,term_id)] in -(* message "start second proof"; *) - let stop = ref false in - begin - try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) + let _ = Table.extraction_inline true [Ident (Loc.ghost,term_id)] in + (* message "start second proof"; *) + let stop = + try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + false with e when Errors.noncritical e -> begin - if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e) - else anomaly "Cannot create equation Lemma" + if do_observe () + then msg_debug (str "Cannot create equation Lemma " ++ Errors.print e) + else anomaly (Pp.str "Cannot create equation Lemma") ; - stop := true; + true end - end; - if not !stop + in + if not stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in let f_ref = destConst (constr_of_global f_ref) @@ -1471,9 +1536,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num spc () ++ str"is defined" )++ fnl () ++ h 1 (Ppconstr.pr_id equation_id ++ spc () ++ str"is defined" ) - ) + ) in - try + States.with_state_protection_on_exception (fun () -> com_terminate tcc_lemma_name tcc_lemma_constr @@ -1483,11 +1548,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num term_id using_lemmas (List.length res_vars) - hook - with reraise -> - begin - (try ignore (Backtrack.backto previous_label) - with e when Errors.noncritical e -> ()); - (* anomaly "Cannot create termination Lemma" *) - raise reraise - end + evm (Lemmas.mk_hook hook)) + () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli new file mode 100644 index 00000000..f60eedbe --- /dev/null +++ b/plugins/funind/recdef.mli @@ -0,0 +1,20 @@ + + +(* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *) +val tclUSER_if_not_mes : + Proof_type.tactic -> + bool -> + Names.Id.t list option -> + Proof_type.tactic +val recursive_definition : +bool -> + Names.Id.t -> + Constrintern.internalization_env -> + Constrexpr.constr_expr -> + Constrexpr.constr_expr -> + int -> Constrexpr.constr_expr -> (Term.pconstant -> + Term.constr option ref -> + Term.pconstant -> + Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit + + diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v deleted file mode 100644 index 04336747..00000000 --- a/plugins/micromega/CheckerMaker.v +++ /dev/null @@ -1,132 +0,0 @@ -(************************************************************************) -(* 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. -*) \ No newline at end of file diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index 31c4a565..dd4d596f 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (sos_Z || psatz_Z d) ; + abstract( intros __wit __varmap __ff ; change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity + apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)) | 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 ; + try (abstract(intros __wit __varmap __ff ; change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) | 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 ; + try (abstract(intros __wit __varmap __ff ; change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) | _ => fail "Unsupported domain" end in tac. @@ -53,26 +73,22 @@ 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 + | Z => lia | 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 ; + try (abstract(intros __wit __varmap __ff ; change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) | R => unfold Rdiv in * ; 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 ; + try abstract((intros __wit __varmap __ff ; change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) | _ => fail "Unsupported domain" end in tac. @@ -80,19 +96,6 @@ Ltac psatzl dom := Ltac lra := first [ psatzl R | psatzl Q ]. -Ltac lia := - zify ; unfold Z.succ in * ; - (*cbv delta - [Z.add Z.sub Z.opp Z.mul Z.pow Z.gt Z.ge Z.le Z.lt iff not] ;*) xlia ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. - -Ltac nia := - zify ; unfold Z.succ in * ; - xnlia ; - 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: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index cbd7e334..6c157def 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* c - | PEX j => env j + | 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) @@ -78,7 +78,7 @@ Lemma Qeval_expr_simpl : forall env e, Qeval_expr env e = match e with | PEc c => c - | PEX j => env j + | 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) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 65911a72..e9ab6962 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* C -> bool. Variable phi : C -> R. (* Power coefficients *) -Variable E : Set. (* the type of exponents *) +Variable E : Type. (* the type of exponents *) Variable pow_phi : N -> E. Variable rpow : R -> E -> R. @@ -78,9 +78,9 @@ Record SORaddon := mk_SOR_addon { 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 _ _ ) + 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. @@ -141,8 +141,8 @@ Qed. 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 rplus rtimes phi env p. +Definition eval_pol : PolEnv -> PolC -> R := + Pphi rplus rtimes phi. Inductive Op1 : Set := (* relations with 0 *) | Equal (* == 0 *) @@ -412,12 +412,12 @@ Proof. induction e. (* PsatzIn *) simpl ; intros. - destruct (nth_in_or_default n l (Pc cO, Equal)). + destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq]. (* index is in bounds *) - apply H ; congruence. + apply H. congruence. (* index is out-of-bounds *) inversion H0. - rewrite e. simpl. + rewrite Heq. simpl. now apply addon.(SORrm).(morph0). (* PsatzSquare *) simpl. intros. inversion H0. @@ -679,7 +679,8 @@ match o with | 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. +Definition eval_pexpr : PolEnv -> PExpr C -> R := + PEeval rplus rtimes rminus ropp phi pow_phi rpow. Record Formula (T:Type) : Type := { Flhs : PExpr T; @@ -910,7 +911,7 @@ Proof. unfold pow_N. ring. Qed. -Definition denorm (p : Pol C) := xdenorm xH p. +Definition denorm := xdenorm xH. Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). Proof. @@ -947,7 +948,7 @@ Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). Fixpoint map_PExpr (e : PExpr S) : PExpr C := match e with | PEc c => PEc (C_of_S c) - | PEX p => PEX _ p + | PEX _ p => PEX _ p | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) @@ -960,8 +961,8 @@ Definition map_Formula (f : Formula S) : Formula C := Build_Formula (map_PExpr l) o (map_PExpr r). -Definition eval_sexpr (env : PolEnv) (e : PExpr S) : R := - PEeval rplus rtimes rminus ropp phiS pow_phi rpow env e. +Definition eval_sexpr : PolEnv -> PExpr S -> R := + PEeval rplus rtimes rminus ropp phiS pow_phi rpow. Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop := let (lhs, op, rhs) := f in diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index a1d200ea..39d0c6b1 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop ) (f:BFormula A) {struct f}: Prop := match f with - | TT => True - | FF => False + | TT _ => True + | FF _ => False | A a => ev a - | X p => p + | 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) @@ -54,9 +54,9 @@ Set Implicit Arguments. Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U := match f with - | TT => TT _ - | FF => FF _ - | X p => X _ p + | TT _ => TT _ + | FF _ => FF _ + | X _ p => X _ p | A a => A (fct a) | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) @@ -172,9 +172,9 @@ Set Implicit Arguments. 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 *) + | 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 => diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 4391a01b..6e1fe222 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* req y x. Proof. - destruct sor.(SORsetoid). + destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_). apply Equivalence_Symmetric. Qed. Lemma req_trans : forall x y z, req x y -> req y z -> req x z. Proof. - destruct sor.(SORsetoid). + destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive). apply Equivalence_Transitive. Qed. @@ -93,6 +93,7 @@ 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. +Declare Equivalent Keys gen_order_phi_Z gen_phiZ. Notation phi_pos := (gen_phiPOS 1 rplus rtimes). Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 4aecb39a..84a8d13c 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* c - | PEX x => env x + | 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 => Z.pow (Zeval_expr env e1) (Z.of_N n) @@ -155,12 +155,16 @@ Proof. Qed. Definition psub := psub Z0 Z.add Z.sub Z.opp Zeq_bool. +Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. +Declare Equivalent Keys padd RingMicromega.padd. Definition norm := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. +Declare Equivalent Keys norm RingMicromega.norm. Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). +Declare Equivalent Keys eval_pol RingMicromega.eval_pol. Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs. Proof. @@ -202,11 +206,10 @@ Definition normalise (t:Formula Z) : cnf (NFormula Z) := 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. + unfold normalise, xnormalise; cbn -[padd]; intros env t. rewrite Zeval_formula_compat. unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o; simpl; + destruct t as [lhs o rhs]; case_eq o; cbn -[padd]; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; @@ -216,7 +219,6 @@ Proof. generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). - Transparent padd. Qed. Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := @@ -317,7 +319,7 @@ Qed. Require Import QArith. -Inductive ZArithProof : Type := +Inductive ZArithProof := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 32aeb993..b4f305dd 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let v = Ml2C.positive v in - 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) + let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in + if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *) then mn else Mc.PEmul(mn,acc)) mn @@ -105,10 +105,10 @@ let list_to_polynomial vars l = | 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) + if Pervasives.(=) 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 + let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else Mc.PEadd (mn, p) in xtopoly p' (i+1) l in @@ -116,7 +116,7 @@ let list_to_polynomial vars l = let rec fixpoint f x = let y' = f x in - if y' = x then y' + if Pervasives.(=) y' x then y' else fixpoint f y' let rec_simpl_cone n_spec e = @@ -153,9 +153,9 @@ let factorise_linear_cone c = 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 + if Pervasives.(=) 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 + if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None | _ -> None in let rec rebuild_cone l pending = @@ -199,7 +199,7 @@ open Mfourier let constrain_monomial mn l = let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in - if mn = Monomial.const + if Pervasives.(=) mn Monomial.const then { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; op = Eq ; @@ -230,6 +230,7 @@ let string_of_op = function | Mc.NonEqual -> "<> 0" +module MonSet = Set.Make(Monomial) (* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) @@ -238,8 +239,6 @@ let build_linear_system l = (* Gather the monomials: HINT add up of the polynomials ==> This does not work anymore *) let l' = List.map fst l in - let module MonSet = Set.Make(Monomial) in - let monomials = List.fold_left (fun acc p -> Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) @@ -299,27 +298,28 @@ exception Found of Monomial.t exception Strict +module MonMap = Map.Make(Monomial) + 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 + if Pervasives.(=) 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 (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in + (m,if Int.equal (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 + let cmp x y = Int.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,[])) + (mp,cstr::l)) l (MonMap.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 ; *) @@ -332,8 +332,8 @@ let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) with x when Errors.noncritical x -> - if debug - then (Printf.printf "raw certificate %s" (Printexc.to_string x); + if debug + then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; None @@ -367,7 +367,7 @@ let linear_prover n_spec l = let build_system 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 + (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in List.map (fun ((x,y),i) -> match y with Mc.NonEqual -> failwith "cannot happen" @@ -378,7 +378,7 @@ let linear_prover n_spec l = let linear_prover n_spec l = try linear_prover n_spec l - with x when x <> Sys.Break -> + with x when Errors.noncritical x -> (print_string (Printexc.to_string x); None) let linear_prover_with_cert spec l = @@ -394,7 +394,7 @@ let make_linear_system l = 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 + (fun mn _ l -> if Pervasives.(=) 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 ; @@ -406,9 +406,7 @@ 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 @@ -417,7 +415,7 @@ 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 eq x y = Int.equal (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 @@ -477,7 +475,7 @@ let rec scale_term t = 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 + if Int.equal (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)) @@ -499,7 +497,7 @@ let get_index_of_ith_match f i l = | [] -> failwith "bad index" | e::l -> if f e then - (if j = i then res else get (j+1) (res+1) l ) + (if Int.equal j i then res else get (j+1) (res+1) l ) else get j (res+1) l in get 0 0 l @@ -559,7 +557,7 @@ let q_cert_of_pos pos = | 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 + if Int.equal (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) @@ -590,7 +588,7 @@ let z_cert_of_pos pos = | 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 + if Int.equal (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) -> @@ -631,7 +629,7 @@ struct let rec xid_of_hyp i l = match l with | [] -> failwith "id_of_hyp" - | hyp'::l -> if hyp = hyp' then i else xid_of_hyp (i+1) l in + | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in xid_of_hyp 0 l end @@ -757,7 +755,7 @@ let check_sat (cstr,prf) = if eq_num gcd (Int 1) then Normalise(cstr,prf) else - if sign_num (mod_num cst gcd) = 0 + if Int.equal (sign_num (mod_num cst gcd)) 0 then (* We can really normalise *) begin assert (sign_num gcd >=1 ) ; @@ -797,18 +795,18 @@ let pivot v (c1,p1) (c2,p2) = 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 + if Int.equal ((sign_num a) * (sign_num b)) (-1) then let cv1 = abs_num b and cv2 = abs_num a in Some (xpivot cv1 cv2) else - if op1 = Eq + if op1 == Eq then let cv1 = minus_num (b */ (Int (sign_num a))) and cv2 = abs_num a in Some (xpivot cv1 cv2) - else if op2 = Eq + else if op2 == Eq then let cv1 = abs_num b and cv2 = minus_num (a */ (Int (sign_num b))) in @@ -817,7 +815,7 @@ let pivot v (c1,p1) (c2,p2) = exception FoundProof of prf_rule -let rec simpl_sys sys = +let simpl_sys sys = List.fold_left (fun acc (c,p) -> match check_sat (c,p) with | Tauto -> acc @@ -831,7 +829,7 @@ let rec simpl_sys sys = Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm *) let rec ext_gcd a b = - if sign_big_int b = 0 + if Int.equal (sign_big_int b) 0 then (unit_big_int,zero_big_int) else let (q,r) = quomod_big_int a b in @@ -852,7 +850,7 @@ let pp_ext_gcd a b = exception Result of (int * (proof * cstr_compat)) let split_equations psys = - List.partition (fun (c,p) -> c.op = Eq) + List.partition (fun (c,p) -> c.op == Eq) let extract_coprime (c1,p1) (c2,p2) = @@ -860,9 +858,9 @@ let extract_coprime (c1,p1) (c2,p2) = match vect1 , vect2 with | _ , [] | [], _ -> None | (v1,n1)::vect1' , (v2, n2) :: vect2' -> - if v1 = v2 + if Pervasives.(=) v1 v2 then - if compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int = 0 + if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0 then Some (v1,n1,n2) else exist2 vect1' vect2' @@ -871,7 +869,7 @@ let extract_coprime (c1,p1) (c2,p2) = then exist2 vect1' vect2 else exist2 vect1 vect2' in - if c1.op = Eq && c2.op = Eq + if c1.op == Eq && c2.op == Eq then exist2 c1.coeffs c2.coeffs else None @@ -928,7 +926,7 @@ let reduce_coprime psys = (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = let is_unary_equation (cstr,prf) = - if cstr.op = Eq + if cstr.op == Eq then try Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) @@ -944,12 +942,12 @@ let reduce_unary psys = let reduce_non_lin_unary psys = let is_unary_equation (cstr,prf) = - if cstr.op = Eq + if cstr.op == Eq then try let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in let x' = LinPoly.MonT.retrieve x in - if List.for_all (fun (y,_) -> y = x || snd (Monomial.div (LinPoly.MonT.retrieve y) x') = 0) cstr.coeffs + if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs then Some x else None with Not_found -> None @@ -976,7 +974,7 @@ let reduce_var_change psys = Some ((x,v),(x',numerator v')) with Not_found -> rel_prime vect in - let rel_prime (cstr,prf) = if cstr.op = Eq then rel_prime cstr.coeffs else None in + let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in let (oeq,sys) = extract rel_prime psys in @@ -1007,7 +1005,7 @@ let reduce_var_change psys = let reduce_pivot psys = let is_equation (cstr,prf) = - if cstr.op = Eq + if cstr.op == Eq then try Some (fst (List.hd cstr.coeffs)) @@ -1067,7 +1065,7 @@ let reduce_var_change psys = (* For lia, there are no equations => these precautions are not needed *) (* For nlia, there are equations => do not enumerate over equations! *) let all_planes sys = - let (eq,ineq) = List.partition (fun c -> c.op = Eq) sys in + let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in match eq with | [] -> List.rev_map (fun c -> c.coeffs) ineq | _ -> @@ -1197,8 +1195,6 @@ let reduce_var_change psys = let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in - let module MonMap = Map.Make(Monomial) in - let collect_square = List.fold_left (fun acc ((p,_),_) -> Poly.fold (fun m _ acc -> diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7e10464a..2812e36e 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ,=,<>,<=,>=} pExpr2 + * pExpr1 \{<,>,=,<>,<=,>=\} pExpr2 * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are * parametrized by 'cst, which is used as the type of constants. *) @@ -65,7 +66,7 @@ type 'cst formula = | 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 + | I of 'cst formula * Names.Id.t option * 'cst formula (** * Formula pretty-printer. @@ -82,7 +83,7 @@ let rec pp_formula o f = | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" pp_formula f1 (match n with - | Some id -> Names.string_of_id id + | Some id -> Names.Id.to_string id | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f @@ -111,7 +112,7 @@ let rec ids_of_formula f = (** * A clause is a list of (tagged) nFormulas. * nFormulas are normalized formulas, i.e., of the form: - * cPol {=,<>,>,>=} 0 + * cPol \{=,<>,>,>=\} 0 * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). *) @@ -242,10 +243,10 @@ let rec add_term t0 = function * MODULE: Ordered set of integers. *) -module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end) +module ISet = Set.Make(Int) (** - * Given a set of integers s={i0,...,iN} and a list m, return the list of + * 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. *) @@ -535,10 +536,10 @@ struct let get_left_construct term = match Term.kind_of_term term with - | Term.Construct(_,i) -> (i,[| |]) + | Term.Construct((_,i),_) -> (i,[| |]) | Term.App(l,rst) -> (match Term.kind_of_term l with - | Term.Construct(_,i) -> (i,rst) + | Term.Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -577,7 +578,7 @@ struct let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) - let rec dump_n x = + let dump_n x = match x with | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) @@ -590,12 +591,12 @@ struct let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) + let 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 parse_z term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.Z0 @@ -622,7 +623,7 @@ struct let parse_q term = match Term.kind_of_term term with - | Term.App(c, args) -> if c = Lazy.force coq_Qmake then + | Term.App(c, args) -> if Constr.equal c (Lazy.force coq_Qmake) then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } else raise ParseError | _ -> raise ParseError @@ -780,7 +781,7 @@ struct Printf.fprintf o "0" in pp_cone o e - let rec dump_op = function + let dump_op = function | Mc.OpEq-> Lazy.force coq_OpEq | Mc.OpNEq-> Lazy.force coq_OpNEq | Mc.OpLe -> Lazy.force coq_OpLe @@ -808,7 +809,7 @@ struct let assoc_const x l = try - snd (List.find (fun (x',y) -> x = Lazy.force x') l) + snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) with Not_found -> raise ParseError @@ -830,25 +831,33 @@ struct coq_Qeq, Mc.OpEq ] - let parse_zop (op,args) = + let has_typ gl t1 typ = + let ty = Retyping.get_type_of (Tacmach.pf_env gl) (Tacmach.project gl) t1 in + Constr.equal ty typ + + + let is_convertible gl t1 t2 = + Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2 + + let parse_zop gl (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 + | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> + if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" - let parse_rop (op,args) = + let parse_rop gl (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 + | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> + if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" - let parse_qop (op,args) = + let parse_qop gl (op,args) = (assoc_const op qop_table, args.(0) , args.(1)) let is_constant t = (* This is an approx *) @@ -864,7 +873,7 @@ struct let assoc_ops x l = try - snd (List.find (fun (x',y) -> x = Lazy.force x') l) + snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) with Not_found -> Ukn "Oups" @@ -901,10 +910,7 @@ struct let parse_expr parse_constant parse_exp ops_spec env term = if debug - then (Pp.pp (Pp.str "parse_expr: "); - Pp.pp (Printer.prterm term); - Pp.pp (Pp.str "\n"); - Pp.pp_flush ()); + then Pp.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); (* let constant_or_variable env term = @@ -941,7 +947,7 @@ struct let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) - with e when e <> Sys.Break -> + with e when Errors.noncritical e -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end @@ -994,9 +1000,9 @@ struct let rec rconstant term = match Term.kind_of_term term with | Const x -> - if term = Lazy.force coq_R0 + if Constr.equal term (Lazy.force coq_R0) then Mc.C0 - else if term = Lazy.force coq_R1 + else if Constr.equal term (Lazy.force coq_R1) then Mc.C1 else raise ParseError | App(op,args) -> @@ -1010,8 +1016,8 @@ struct with ParseError -> match op with - | op when op = Lazy.force coq_Rinv -> Mc.CInv(rconstant args.(0)) - | op when op = Lazy.force coq_IQR -> Mc.CQ (parse_q args.(0)) + | op when Constr.equal op (Lazy.force coq_Rinv) -> Mc.CInv(rconstant args.(0)) + | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0)) (* | op when op = Lazy.force coq_IZR -> Mc.CZ (parse_z args.(0))*) | _ -> raise ParseError end @@ -1021,11 +1027,7 @@ struct let rconstant term = if debug - then (Pp.pp_flush (); - Pp.pp (Pp.str "rconstant: "); - Pp.pp (Printer.prterm term); - Pp.pp (Pp.str "\n"); - Pp.pp_flush ()); + then Pp.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); let res = rconstant term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; @@ -1063,26 +1065,22 @@ struct Mc.PEpow(expr,exp)) rop_spec - let parse_arith parse_op parse_expr env cstr = + let parse_arith parse_op parse_expr env cstr gl = if debug - then (Pp.pp_flush (); - Pp.pp (Pp.str "parse_arith: "); - Pp.pp (Printer.prterm cstr); - Pp.pp (Pp.str "\n"); - Pp.pp_flush ()); + then Pp.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); match kind_of_term cstr with | App(op,args) -> - let (op,lhs,rhs) = parse_op (op,args) in + let (op,lhs,rhs) = parse_op gl (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_zarith = parse_arith parse_zop parse_zexpr - let parse_qarith = parse_arith parse_qop parse_qexpr + let parse_qarith = parse_arith parse_qop parse_qexpr - let parse_rarith = parse_arith parse_rop parse_rexpr + let parse_rarith = parse_arith parse_rop parse_rexpr (* generic parsing of arithmetic expressions *) @@ -1115,14 +1113,13 @@ struct * This is the big generic function for formula parsers. *) - let parse_formula parse_atom env tg term = + let parse_formula gl parse_atom env tg term = let parse_atom env tg t = try - let (at,env) = parse_atom env t in + let (at,env) = parse_atom env t gl in (A(at,tg,t), env,Tag.next tg) - with e when e <> Sys.Break -> (X(t),env,tg) - in + with e when Errors.noncritical e -> (X(t),env,tg) in let rec xparse_formula env tg term = match kind_of_term term with @@ -1177,7 +1174,7 @@ struct | (e::l) -> let (name,expr,typ) = e in xset (Term.mkNamedLetIn - (Names.id_of_string name) + (Names.Id.of_string name) expr typ acc) l in xset concl l @@ -1199,13 +1196,13 @@ let same_proof sg cl1 cl2 = match sg with | [] -> true | n::sg -> - (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false) + (try Int.equal (List.nth cl1 n) (List.nth cl2 n) with Invalid_argument _ -> 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 + | Mc.PsatzIn n -> Names.Id.Set.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 @@ -1214,7 +1211,7 @@ let tags_of_clause tgs wit clause = (*let tags_of_cnf wits cnf = List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) - Names.Idset.empty wits cnf *) + Names.Id.Set.empty wits cnf *) let find_witness prover polys1 = try_any prover polys1 @@ -1263,7 +1260,7 @@ let btree_of_array typ a = let btree_of_array typ a = try btree_of_array typ a - with x when x <> Sys.Break -> + with x when Errors.noncritical x -> failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) let dump_varmap typ env = @@ -1324,24 +1321,24 @@ let rec pp_proof_term o = function (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 = +let rec parse_hyps gl 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 + let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in try - let (c,env,tg) = parse_formula parse_arith env tg t in + let (c,env,tg) = parse_formula gl parse_arith env tg t in ((i,c)::lhyps, env,tg) - with e when e <> Sys.Break -> (lhyps,env,tg) + with e when Errors.noncritical e -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) (*exception ParseError*) -let parse_goal parse_arith env hyps term = +let parse_goal gl 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 + let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in + let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in (lhyps,f,env) (* with Failure x -> raise ParseError*) @@ -1385,22 +1382,31 @@ let rcst_domain_spec = lazy { * witness. *) -let micromega_order_change spec cert cert_typ env ff gl = + + +let micromega_order_change spec cert cert_typ env ff : Tacmach.tactic = + let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in 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 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 + (* todo : directly generate the proof term - or generalize befor conversion? *) + Tacticals.tclTHENSEQ [ + (fun gl -> + Proofview.V82.of_tactic (Tactics.change_concl (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|])); + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|])); ("__wit", cert, cert_typ) ] - (Tacmach.pf_concl gl) - ) - gl + (Tacmach.pf_concl gl))) gl); + Tactics.generalize env ; + Tacticals.tclTHENSEQ (List.map (fun id -> Proofview.V82.of_tactic (Tactics.introduction id)) ids) ; + ] + + (** * The datastructures that aggregate prover attributes. @@ -1476,7 +1482,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) - let res = try prover.compact prf remap with x when x <> Sys.Break -> + let res = try prover.compact prf remap with x when Errors.noncritical 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 @@ -1494,7 +1500,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = 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 + is_sublist Pervasives.(=) hyps new_cl in let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) @@ -1644,7 +1650,7 @@ let micromega_gen 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 (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in @@ -1658,8 +1664,6 @@ let micromega_gen (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff' ]) 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 @@ -1679,7 +1683,7 @@ let micromega_order_changer cert env ff gl = let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) env in - Tactics.change_in_concl None + Proofview.V82.of_tactic (Tactics.change_concl (set [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); @@ -1689,7 +1693,7 @@ let micromega_order_changer cert env ff gl = ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl) - ) + )) gl @@ -1710,7 +1714,7 @@ let micromega_genr 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 (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in @@ -1729,8 +1733,6 @@ let micromega_genr prover gl = micromega_order_changer res' env (abstract_wrt_formula ff' ff) ]) 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 @@ -1760,7 +1762,7 @@ open Persistent_cache module Cache = PHashtable(struct type t = (provername * micromega_polys) - let equal = (=) + let equal = Pervasives.(=) let hash = Hashtbl.hash end) @@ -1954,7 +1956,7 @@ let non_linear_prover_Z str o = { module CacheZ = PHashtable(struct type t = (Mc.z Mc.pol * Mc.op1) list - let equal = (=) + let equal = Pervasives.(=) let hash = Hashtbl.hash end) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index b5c08300..b41f29c9 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* failwith "not implemented" +let canonical_sum_to_string = function s -> failwith "not implemented" let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) @@ -122,7 +119,7 @@ let real_nonlinear_prover d l = 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)) + | _ -> failwith "monoids") m (poly_const (Int 1)) , List.map snd m)) (sets_of_list neq) in let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> @@ -130,10 +127,10 @@ let real_nonlinear_prover d l = 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)) + let proofs_ideal = List.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 proofs_cone = List.map term_of_sos cert_cone in let proof_ne = let (neq , lt) = List.partition @@ -150,7 +147,7 @@ let real_nonlinear_prover d l = S (Some proof) with | Sos_lib.TooDeep -> S None - | x when x <> Sys.Break -> F (Printexc.to_string x) + | any -> F (Printexc.to_string any) (* This is somewhat buggy, over Z, strict inequality vanish... *) let pure_sos l = @@ -159,8 +156,8 @@ let pure_sos l = (* 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) + let l = List.combine l (interval 0 (List.length l -1)) in + let (lt,i) = try (List.find (fun (x,_) -> Pervasives.(=) (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) *) @@ -174,7 +171,7 @@ let pure_sos l = S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) - | x when x <> Sys.Break -> (* May be that could be refined *) S None + | any -> (* May be that could be refined *) S None diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 4270d5bb..1ac44a42 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* anomaly "Unevaluated or_var variable" + | ArgVar _ -> anomaly (Pp.str "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) ] +| [ "psatz_Z" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (out_arg i)) ] +| [ "psatz_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (-1)) ] END -TACTIC EXTEND ZOmicron -[ "xlia" ] -> [ Coq_micromega.xlia] +TACTIC EXTEND Lia +[ "xlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xlia) ] END -TACTIC EXTEND Nlia -[ "xnlia" ] -> [ Coq_micromega.xnlia] +TACTIC EXTEND Nia +[ "xnlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xnlia) ] END TACTIC EXTEND Sos_Z -| [ "sos_Z" ] -> [ Coq_micromega.sos_Z] +| [ "sos_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Z) ] END TACTIC EXTEND Sos_Q -| [ "sos_Q" ] -> [ Coq_micromega.sos_Q] +| [ "sos_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Q) ] END TACTIC EXTEND Sos_R -| [ "sos_R" ] -> [ Coq_micromega.sos_R] +| [ "sos_R" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_R) ] END - +(* TACTIC EXTEND Omicron -[ "psatzl_Z" ] -> [ Coq_micromega.psatzl_Z] +[ "psatzl_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Z) ] END +*) -TACTIC EXTEND QOmicron -[ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q] +TACTIC EXTEND LRA_Q +[ "psatzl_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Q) ] END -TACTIC EXTEND ROmicron -[ "psatzl_R" ] -> [ Coq_micromega.psatzl_R] +TACTIC EXTEND LRA_R +[ "psatzl_R" ] -> [ Proofview.V82.tactic (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) ] +TACTIC EXTEND PsatzR +| [ "psatz_R" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_R (out_arg i)) ] +| [ "psatz_R" ] -> [ Proofview.V82.tactic (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) ] +TACTIC EXTEND PsatzQ +| [ "psatz_Q" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (out_arg i)) ] +| [ "psatz_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (-1)) ] END diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 6effa4c4..88c1a783 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -3,13 +3,14 @@ module Utils = Mutils open Polynomial open Vect - 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 +let compare_float (p : float) q = Pervasives.compare p q + (** Implementation of intervals *) module Itv = struct @@ -18,10 +19,10 @@ struct 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'] + - 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. *) @@ -89,7 +90,7 @@ type vector = Vect.t {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 ISet = Set.Make(Int) module PSet = ISet @@ -116,7 +117,7 @@ and cstr_info = { } -(** A system of constraints has the form [{sys = s ; vars = v}]. +(** 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. @@ -195,7 +196,7 @@ let pp_split_cstr o (vl,v,c,_) = 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) ; + assert (Int.equal p1 p2 && Int.equal n1 n2) ; match inter i1 i2 with | None -> None (* Could directly raise a system contradiction exception *) | Some bnd -> @@ -207,7 +208,7 @@ let merge_cstr_info i1 i2 = *) let xadd_cstr vect cstr_info sys = - if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ; + if debug && Int.equal (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 @@ -235,7 +236,7 @@ let normalise_cstr vect cinfo = | (_,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 + if Int.equal (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)}) @@ -252,7 +253,7 @@ let count v = | [] -> (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 + if Int.equal sg 1 then count n (p+1) v else count (n+1) p v in count 0 0 v @@ -304,7 +305,7 @@ let add (v1,c1) (v2,c2) = let rec xadd v1 v2 = match v1 , v2 with | (x1,n1)::v1' , (x2,n2)::v2' -> - if x1 = x2 + if Int.equal x1 x2 then let n' = (n1 // c1) +/ (n2 // c2) in if n' =/ Int 0 then xadd v1' v2' @@ -352,7 +353,7 @@ let split x (vect: vector) info (l,m,r) = | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in let lb,rb = info.bound in - if sign_num vl = 1 + if Int.equal (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) @@ -437,7 +438,7 @@ let elim_var_using_eq vr vect cst prf sys = (** [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) +module IMap = Map.Make(Int) let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map () @@ -498,7 +499,7 @@ let pick_small_value bnd = then ceiling_num i (* why not *) else i -(** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)] +(** [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 @@ -556,7 +557,7 @@ struct match l1 with | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p | (vr,vl)::rl1 -> - if v = vr + if Int.equal v vr then let cons_bound lst bd = match bd with @@ -564,7 +565,7 @@ struct | Some bnd -> info.neg+info.pos::lst in let lb,rb = info.bound in - if sign_num vl = 1 + if Int.equal (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 @@ -590,7 +591,7 @@ struct (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 + List.sort (fun x y -> compare_float (snd x) (snd y) ) evals end @@ -615,7 +616,7 @@ struct let rec unroll_until v l = match l with | [] -> (false,[]) - | (i,_)::rl -> if i = v + | (i,_)::rl -> if Int.equal i v then (true,rl) else if i < v then unroll_until v rl else (false,l) @@ -632,7 +633,7 @@ struct let choose_primal_equation eqs sys_l = - (* Counts the number of equations refering to variable [v] -- + (* Counts the number of equations referring to variable [v] -- It looks like nb_cst is dead... *) let is_primal_equation_var v = @@ -646,7 +647,7 @@ struct | [] -> None | (i,_)::vect -> let nb_eq = is_primal_equation_var i in - if nb_eq = 2 + if Int.equal nb_eq 2 then Some i else find_var vect in let rec find_eq_var eqs = @@ -704,7 +705,7 @@ struct (* 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 + List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] @@ -727,9 +728,9 @@ struct | Inl (s,_) -> try Some (bound_of_variable IMap.empty fresh s.sys) - with - x when x <> Sys.Break -> - Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None + with x when Errors.noncritical x -> + Printf.printf "optimise Exception : %s" (Printexc.to_string x); + None let find_point cstrs = @@ -793,18 +794,18 @@ struct 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 + if Int.equal ((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 + 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 + 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) ; diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index 564126d2..0537cdbe 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1499,7 +1499,7 @@ module N = (** val eqb : n -> n -> bool **) - let rec eqb n0 m = + let eqb n0 m = match n0 with | N0 -> (match m with @@ -1693,7 +1693,7 @@ module N = (** val ldiff : n -> n -> n **) - let rec ldiff n0 m = + let ldiff n0 m = match n0 with | N0 -> N0 | Npos p -> @@ -2205,7 +2205,7 @@ module Z = (** val eqb : z -> z -> bool **) - let rec eqb x y = + let eqb x y = match x with | Z0 -> (match y with diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 7f0dce04..a07cbec6 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (try rst () - with any -> raise reraise + with any -> raise reraise ); raise reraise let map_option f x = @@ -72,15 +72,15 @@ 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") + | _ -> invalid_arg "map3" -let rec is_sublist l1 l2 = +let rec is_sublist f 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' + if f e e' then is_sublist f l1' l2' + else is_sublist f l1 l2' let list_try_find f = let rec try_find_f = function @@ -89,7 +89,7 @@ let list_try_find f = in try_find_f -let rec list_fold_right_elements f l = +let list_fold_right_elements f l = let rec aux = function | [] -> invalid_arg "list_fold_right_elements" | [x] -> x @@ -142,9 +142,9 @@ let rec rec_gcd_list c l = | [] -> c | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l -let rec gcd_list l = +let gcd_list l = let res = rec_gcd_list zero_big_int l in - if compare_big_int res zero_big_int = 0 + if Int.equal (compare_big_int res zero_big_int) 0 then unit_big_int else res let rats_to_ints l = @@ -192,7 +192,7 @@ let select_pos lpos l = match l with | [] -> failwith "select_pos" | e::l -> - if i = j + if Int.equal i j then e:: (xselect (i+1) rpos l) else xselect (i+1) lpos l in xselect 0 lpos l @@ -269,19 +269,19 @@ struct let rec positive n = - if n=1 then XH - else if n land 1 = 1 then XI (positive (n lsr 1)) + if Int.equal n 1 then XH + else if Int.equal (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 if Int.equal 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)) + if Int.equal n 1 then XH + else if Int.equal (n land 1) 1 then XI (index (n lsr 1)) else XO (index (n lsr 1)) @@ -289,8 +289,8 @@ struct (*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)) + if Int.equal n 1 then [] + else (Int.equal (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)) @@ -342,7 +342,7 @@ struct | [] -> 0 (* Equal *) | f::l -> let cmp = f () in - if cmp = 0 then compare_lexical l else cmp + if Int.equal cmp 0 then compare_lexical l else cmp let rec compare_list cmp l1 l2 = match l1 , l2 with @@ -351,7 +351,7 @@ struct | _ , [] -> 1 | e1::l1 , e2::l2 -> let c = cmp e1 e2 in - if c = 0 then compare_list cmp l1 l2 else c + if Int.equal c 0 then compare_list cmp l1 l2 else c (** * hash_list takes a hash function and a list, and computes an integer which @@ -393,7 +393,7 @@ struct 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 + let compare : int -> int -> int = Int.compare end @@ -403,6 +403,12 @@ end module TagSet = Set.Make(Tag) +(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *) + +let rec waitpid_non_intr pid = + try snd (Unix.waitpid [] pid) + with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid + (** * Forking routine, plumbing the appropriate pipes where needed. *) @@ -422,25 +428,33 @@ let command exe_path args vl = flush outch ; (* Wait for its completion *) - let _pid,status = Unix.waitpid [] pid in + let status = waitpid_non_intr pid in finally (* Recover the result *) (fun () -> match status with | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in - begin try Marshal.from_channel inch - with x when x <> Sys.Break -> - 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)) + let inch = Unix.in_channel_of_descr stdout_read in + begin + try Marshal.from_channel inch + with any -> + failwith + (Printf.sprintf "command \"%s\" exited %s" exe_path + (Printexc.to_string any)) + 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)) (* Cleanup *) (fun () -> - List.iter (fun x -> try Unix.close x with e when e <> Sys.Break -> ()) - [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) + List.iter (fun x -> try Unix.close x with any -> ()) + [stdin_read; stdin_write; + stdout_read; stdout_write; + stderr_read; stderr_write]) (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 2465617a..2dc0d003 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (try rst () - with any -> raise reraise + with any -> raise reraise ); raise reraise @@ -93,26 +92,52 @@ let read_key_elem inch = Some (Marshal.from_channel inch) with | End_of_file -> None - | e when e <> Sys.Break -> raise InvalidTableFormat - -(** In win32, it seems that we should unlock the exact zone - that has been locked, and not the whole file *) + | e when Errors.noncritical e -> raise InvalidTableFormat + +(** + We used to only lock/unlock regions. + Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]? + In case of locking failure, the cache is not used. +**) + +type lock_kind = Read | Write + +let lock kd fd = + let pos = lseek fd 0 SEEK_CUR in + let success = + try + ignore (lseek fd 0 SEEK_SET); + let lk = match kd with + | Read -> F_RLOCK + | Write -> F_LOCK in + lockf fd lk 1; true + with Unix.Unix_error(_,_,_) -> false in + ignore (lseek fd pos SEEK_SET) ; + success + +let unlock fd = + let pos = lseek fd 0 SEEK_CUR in + try + ignore (lseek fd 0 SEEK_SET) ; + lockf fd F_ULOCK 1 + with + Unix.Unix_error(_,_,_) -> () + (* Here, this is really bad news -- + there is a pending lock which could cause a deadlock. + Should it be an anomaly or produce a warning ? + *); + ignore (lseek fd pos SEEK_SET) -let locked_start = ref 0 -let lock fd = - locked_start := lseek fd 0 SEEK_CUR; - lockf fd F_LOCK 0 +(* We make the assumption that an acquired lock can always be released *) -let rlock fd = - locked_start := lseek fd 0 SEEK_CUR; - lockf fd F_RLOCK 0 +let do_under_lock kd fd f = + if lock kd fd + then + finally f (fun () -> unlock fd) + else f () + -let unlock fd = - let pos = lseek fd 0 SEEK_CUR in - ignore (lseek fd !locked_start SEEK_SET); - lockf fd F_ULOCK 0; - ignore (lseek fd pos SEEK_SET) let open_in f = let flags = [O_RDONLY ; O_CREAT] in @@ -128,37 +153,30 @@ let open_in f = xload () in try (* Locking of the (whole) file while reading *) - rlock finch; - finally - (fun () -> xload () ) - (fun () -> - unlock finch ; - close_in_noerr inch ; - ) ; + do_under_lock Read finch xload ; + close_in_noerr inch ; { - outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ; - status = Open ; - htbl = htbl + outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ; + status = Open ; + htbl = htbl } with InvalidTableFormat -> - (* Try to keep as many entries as possible *) - begin - let flags = [O_WRONLY; O_TRUNC;O_CREAT] in - let out = (openfile f flags 0o666) in - let outch = out_channel_of_descr out in - lock out; - (try - Table.iter - (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; - flush outch ; - with e when e <> Sys.Break -> () ) - ; - unlock out ; - { outch = outch ; - status = Open ; - htbl = htbl - } - end + (* The file is corrupted *) + begin + close_in_noerr inch ; + let flags = [O_WRONLY; O_TRUNC;O_CREAT] in + let out = (openfile f flags 0o666) in + let outch = out_channel_of_descr out in + do_under_lock Write out + (fun () -> + Table.iter + (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; + flush outch) ; + { outch = outch ; + status = Open ; + htbl = htbl + } + end let close t = @@ -172,22 +190,22 @@ let close t = let add t k e = let {outch = outch ; status = status ; htbl = tbl} = t in - if status = Closed + if status == Closed then raise UnboundTable else let fd = descr_of_out_channel outch in begin - Table.add tbl k e ; - lock fd; - ignore (lseek fd 0 SEEK_END); - Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; - flush outch ; - unlock fd + Table.add tbl k e ; + do_under_lock Write fd + (fun _ -> + Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; + flush outch + ) end let find t k = let {outch = outch ; status = status ; htbl = tbl} = t in - if status = Closed + if status == Closed then raise UnboundTable else let res = Table.find tbl k in diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 9372cb66..b8b42a3f 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let s1 = sum_degree m1 and s2 = sum_degree m2 in - if s1 = s2 then Map.compare Pervasives.compare m1 m2 - else Pervasives.compare s1 s2 + if Int.equal s1 s2 then Map.compare Int.compare m1 m2 + else Int.compare s1 s2 let is_const m = (m = Map.empty) @@ -218,7 +218,7 @@ struct let fold = P.fold - let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p true + let is_null p = fold (fun mn vl b -> b && sign_num vl = 0) p true let compare = compare compare_num @@ -241,8 +241,7 @@ module Vect = 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] *) +(** [equal v1 v2 = true] if the vectors are syntactically equal. *) let rec equal v1 v2 = match v1 , v2 with @@ -250,7 +249,7 @@ module Vect = | [] , _ -> false | _::_ , [] -> false | (i1,n1)::v1 , (i2,n2)::v2 -> - (i1 = i2) && n1 =/ n2 && equal v1 v2 + (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 let hash v = let rec hash i = function @@ -294,7 +293,7 @@ module Vect = match t with | [] -> cons i (f zero_num) [] | (k,v)::l -> - match Pervasives.compare i k with + match Int.compare i k with | 0 -> cons k (f v) l | -1 -> cons i (f zero_num) t | 1 -> (k,v) ::(update i f l) @@ -304,7 +303,7 @@ module Vect = match t with | [] -> cons i n [] | (k,v)::l -> - match Pervasives.compare i k with + match Int.compare i k with | 0 -> cons k n l | -1 -> cons i n t | 1 -> (k,v) :: (set i n l) @@ -315,7 +314,7 @@ module Vect = 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 = + let mul z t = match z with | Int 0 -> [] | Int 1 -> t @@ -346,7 +345,7 @@ module Vect = let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical [ - (fun () -> Pervasives.compare (fst x) (fst y)); + (fun () -> Int.compare (fst x) (fst y)); (fun () -> compare_num (snd x) (snd y))]) (** [tail v vect] returns @@ -359,7 +358,7 @@ module Vect = match vect with | [] -> None | (v',vl)::vect' -> - match Pervasives.compare v' v with + match Int.compare v' v with | 0 -> Some (vl,vect) (* Ok, found *) | -1 -> tail v vect' (* Might be in the tail *) | _ -> None (* Hopeless *) @@ -585,7 +584,7 @@ struct module MonT = struct module MonoMap = Map.Make(Monomial) - module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end) + module IntMap = Map.Make(Int) (** A hash table might be preferable but requires a hash function. *) let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) @@ -615,7 +614,7 @@ struct end let normalise (v,c) = - (List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) v , c) + (List.sort (fun x y -> Int.compare (fst x) (fst y)) v , c) let output_mon o (x,v) = diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 6ddc48e7..cc89e2b9 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -1,16 +1,15 @@ (* ========================================================================= *) (* - 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 *) +(* - 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 *) +(* - 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;; @@ -40,7 +39,7 @@ let decimalize = let z = pow10(-e) */ y +/ Int 1 in let k = round_num(pow10 d */ z) in (if x x =/ Int 0) (snd v1) (snd v2));; let vector_of_list l = - let n = length l in + let n = List.length l in (n,itlist2 (|->) (1--n) l undefined :vector);; (* ------------------------------------------------------------------------- *) @@ -176,9 +175,9 @@ let diagonal (v:vector) = ((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 + let m = List.length l in if m = 0 then matrix_0 (0,0) else - let n = length (hd l) in + let n = List.length (List.hd l) in (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;; (* ------------------------------------------------------------------------- *) @@ -201,11 +200,11 @@ let monomial_pow (m:monomial) k = 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;; + 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 + 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;; @@ -227,7 +226,7 @@ let eval assig (p:poly) = let poly_0 = (undefined:poly);; -let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;; +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);; @@ -283,13 +282,13 @@ let poly_variables (p:poly) = (* Order monomials for human presentation. *) (* ------------------------------------------------------------------------- *) -let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 & k1 > k2;; +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 + | 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));; @@ -302,14 +301,14 @@ 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 + let xs = List.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 + let rstr = List.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 "]");; @@ -408,7 +407,7 @@ let rec poly_of_term t = match t with let sdpa_of_vector (v:vector) = let n = dim v in - let strs = map (o (decimalize 20) (element v)) (1--n) in + let strs = List.map (o (decimalize 20) (element v)) (1--n) in end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; (* ------------------------------------------------------------------------- *) @@ -445,15 +444,15 @@ let sdpa_of_matrix k (m:matrix) = (* ------------------------------------------------------------------------- *) let sdpa_of_problem comment obj mats = - let m = length mats - 1 - and n,_ = dimensions (hd mats) in + let m = List.length mats - 1 + and n,_ = dimensions (List.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 "";; + (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) (* More parser basics. *) @@ -461,7 +460,7 @@ let sdpa_of_problem comment obj mats = let word s = end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t)) - (map a (explode s));; + (List.map a (explode s));; let token s = many (some isspace) ++ word s ++ many (some isspace) >> (fun ((_,t),_) -> t);; @@ -470,7 +469,7 @@ 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 + >> (fun s -> Num.num_of_string(implode s) // pow10 (List.length s)) in let decimalsig = decimalint ++ possibly (a "." ++ decimalfrac >> snd) >> (function (h,[x]) -> h +/ x | (h,_) -> h) in @@ -626,13 +625,13 @@ let scale_then = 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 + let mats' = List.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' + let mats'' = List.map (mapf (fun x -> x */ scal1)) mats' and obj'' = vector_cmul scal2 obj' in solver obj'' mats'';; @@ -651,7 +650,7 @@ let nice_vector n = mapa (nice_rational n);; let linear_program_basic a = let m,n = dimensions a in - let mats = map (fun j -> diagonal (column j a)) (1--n) + let mats = List.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 @@ -665,7 +664,7 @@ let linear_program_basic a = 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) + let mats = diagonal b :: List.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 @@ -679,10 +678,10 @@ let linear_program a b = (* ------------------------------------------------------------------------- *) 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 pts1 = (1::pt) :: List.map (fun x -> 1::x) pts in + let pts2 = List.map (fun p -> List.map (fun x -> -x) p @ p) pts1 in + let n = List.length pts + 1 + and v = 2 * (List.length pt + 1) in let m = v + n - 1 in let mat = (m,n), @@ -700,8 +699,8 @@ let minimal_convex_hull = | (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';; + let mons' = itlist augment (List.tl mons) [List.hd mons] in + funpow (List.length mons') augment1 mons';; (* ------------------------------------------------------------------------- *) (* Stuff for "equations" (generic A->num functions). *) @@ -743,7 +742,7 @@ let eliminate_equations = 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) + eliminate vs ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) with Failure _ -> eliminate vs dun eqs in fun one vars eqs -> let assig = eliminate vars undefined eqs in @@ -774,7 +773,7 @@ let eliminate_all_equations one = 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 + eliminate ((v |-> eq') (mapf elim dun)) (List.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 @@ -805,14 +804,14 @@ let solve_equations one eqs = 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 mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol) + and ds = List.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');; + List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in + List.map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) + vars m monomial_1) (List.rev all');; (* ------------------------------------------------------------------------- *) (* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) @@ -851,10 +850,10 @@ let deration d = 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 d' = List.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';; + (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';; (* ------------------------------------------------------------------------- *) (* Enumeration of monomials with given multidegree bound. *) @@ -865,8 +864,8 @@ let rec enumerate_monomials d vars = 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) + List.map (fun k -> let oths = enumerate_monomials (d - k) (List.tl vars) in + List.map (fun ks -> if k = 0 then ks else (List.hd vars |-> k) ks) oths) (0--d) in end_itlist (@) alts;; @@ -883,7 +882,7 @@ let rec enumerate_products d pols = | (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)) + List.map (fun (q,c) -> poly_mul p q,Product(b,c)) (enumerate_products (d - e) ps);; (* ------------------------------------------------------------------------- *) @@ -936,15 +935,15 @@ let sdpa_of_blockdiagonal k m = (* ------------------------------------------------------------------------- *) let sdpa_of_blockproblem comment nblocks blocksizes obj mats = - let m = length mats - 1 in + let m = List.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)) ^ + (end_itlist (fun s t -> s^" "^t) (List.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 "";; + (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) (* Hence run CSDP on a problem in block diagonal form. *) @@ -996,35 +995,35 @@ let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; (* ------------------------------------------------------------------------- *) let blocks blocksizes bm = - map (fun (bs,b0) -> + List.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));; + (zip blocksizes (1--List.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 vars = itlist ((o) union poly_variables) (pol::eqs @ List.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) + (List.filter (fun (p,c) -> multidegree p <= d) leqs) else enumerate_products d leqs in - let nblocks = length monoid in + let nblocks = List.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 + let nons = zip mons (1--List.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 + let nons = zip mons (1--List.length mons) in mons, itlist (fun (m1,n1) -> itlist (fun (m2,n2) a -> @@ -1035,9 +1034,9 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = (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 sqmonlist,sqs = unzip(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) + and idmonlist,ids = unzip(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in + let blocksizes = List.map List.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 @@ -1053,10 +1052,10 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = ((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) + (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, + let mats = List.map mk_matrix qvars + and obj = List.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 @@ -1071,11 +1070,11 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = (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 + vec,List.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 + else tryfind find_rounding (List.map Num.num_of_int (1--31) @ + List.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 @@ -1088,11 +1087,11 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = 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 + (1--List.length mons) undefined in + List.map mk_sq in + let sqs = List.map2 mk_sos sqmonlist ratdias + and cfs = List.map poly_of_epoly ids in + let msq = List.filter (fun (a,b) -> b <> []) (List.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 = @@ -1100,7 +1099,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = (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;; + cfs,List.map (fun (a,b) -> snd a,b) msq;; (* ------------------------------------------------------------------------- *) (* Iterative deepening. *) @@ -1138,7 +1137,7 @@ let monomial_order = else lexorder mon1 mon2;; let dest_poly p = - map (fun (m,c) -> c,dest_monomial m) + List.map (fun (m,c) -> c,dest_monomial m) (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));; (* ------------------------------------------------------------------------- *) @@ -1164,7 +1163,7 @@ let term_of_cmonomial = let term_of_poly = fun p -> if p = poly_0 then Zero else - let cms = map term_of_cmonomial + let cms = List.map term_of_cmonomial (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in end_itlist (fun t1 t2 -> Add (t1,t2)) cms;; @@ -1173,7 +1172,7 @@ let term_of_sqterm (c,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));; + else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));; (* ------------------------------------------------------------------------- *) (* Interface to HOL. *) @@ -1236,7 +1235,7 @@ let REAL_NONLINEAR_SUBST_PROVER = 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) + 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 @@ -1292,10 +1291,10 @@ let REAL_SOSFIELD = 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)) & + 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 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 @@ -1371,14 +1370,14 @@ let SOS_RULE tm = let rec allpermutations l = if l = [] then [[]] else - itlist (fun h acc -> map (fun t -> h::t) + itlist (fun h acc -> List.map (fun t -> h::t) (allpermutations (subtract l [h])) @ acc) l [];; let allvarorders l = - map (fun vlis x -> index x vlis) (allpermutations l);; + List.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;; + foldl (fun a x k -> (List.assoc x zoln |-> k) a) monomial_1 m;; let changevariables zoln pol = foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) @@ -1390,7 +1389,7 @@ let changevariables zoln pol = let sdpa_of_vector (v:vector) = let n = dim v in - let strs = map (o (decimalize 20) (element v)) (1--n) in + let strs = List.map (o (decimalize 20) (element v)) (1--n) in end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; let sdpa_of_blockdiagonal k m = @@ -1412,15 +1411,15 @@ let sdpa_of_matrix k (m:matrix) = " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; let sdpa_of_problem comment obj mats = - let m = length mats - 1 - and n,_ = dimensions (hd mats) in + let m = List.length mats - 1 + and n,_ = dimensions (List.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 "";; + (1--List.length mats) mats "";; let run_csdp dbg obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in @@ -1455,33 +1454,33 @@ let csdp obj mats = let sumofsquares_general_symmetry tool pol = let vars = poly_variables pol and lpps = newton_polytope pol in - let n = length lpps in + let n = List.length lpps in let sym_eqs = - let invariants = filter + let invariants = List.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 lpns = zip lpps (1--List.length lpps) in let lppcs = - filter (fun (m,(n1,n2)) -> n1 <= n2) + List.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' -> + (List.map (fun ((m1,m2),(n1,n2)) -> + List.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) + let clppcs_dom = setify(List.map fst clppcs) in + let clppcs_cls = List.map (fun d -> List.filter (fun (e,_) -> e = d) clppcs) clppcs_dom in - let eqvcls = map (o setify (map snd)) clppcs_cls in + let eqvcls = List.map (o setify (List.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 + | h::t -> List.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 -> @@ -1497,15 +1496,15 @@ let sumofsquares_general_symmetry tool pol = 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 + end_itlist equation_add (List.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, + let mats = List.map mk_matrix qvars + and obj = List.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 @@ -1524,12 +1523,12 @@ let sumofsquares_general_symmetry tool pol = 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 + tryfind find_rounding (List.map Num.num_of_int (1--31) @ + List.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 lins = List.map poly_of_lin dia in + let sqs = List.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;; diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli index d7314ccb..fc0b2fd4 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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;; +let cmp = Pervasives.compare (** FIXME *) + +let (=?) = fun x y -> cmp x y = 0;; +let ( cmp x y < 0;; +let (<=?) = fun x y -> cmp x y <= 0;; +let (>?) = fun x y -> cmp x y > 0;; +let (>=?) = fun x y -> cmp x y >= 0;; (* ------------------------------------------------------------------------- *) (* Combinators. *) @@ -53,7 +54,7 @@ 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 + if x =/ num_0 && y =/ num_0 then num_0 else abs_num((x */ y) // gcd_num x y);; @@ -62,7 +63,7 @@ let lcm_num x y = (* ------------------------------------------------------------------------- *) let rec el n l = - if n = 0 then hd l else el (n - 1) (tl l);; + if n = 0 then List.hd l else el (n - 1) (List.tl l);; (* ------------------------------------------------------------------------- *) @@ -141,7 +142,7 @@ let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; let rec forall p l = match l with [] -> true - | h::t -> p(h) & forall p t;; + | h::t -> p(h) && forall p t;; let rec tryfind f l = match l with @@ -162,14 +163,14 @@ let index x = let rec mem x lis = match lis with [] -> false - | (h::t) -> x =? h or mem x t;; + | (h::t) -> x =? h || 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;; +let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;; (* ------------------------------------------------------------------------- *) (* Merging and bottom-up mergesort. *) @@ -224,7 +225,7 @@ let rec sort cmp lis = match lis with [] -> [] | piv::rest -> - let r,l = partition (cmp piv) rest in + let r,l = List.partition (cmp piv) rest in (sort cmp l) @ (piv::(sort cmp r));; (* ------------------------------------------------------------------------- *) @@ -416,7 +417,7 @@ let (|=>) = fun x y -> (x |-> y) undefined;; let rec choose t = match t with Empty -> failwith "choose: completely undefined function" - | Leaf(h,l) -> hd l + | Leaf(h,l) -> List.hd l | Branch(b,p,t1,t2) -> choose t1;; (* ------------------------------------------------------------------------- *) @@ -547,7 +548,7 @@ let fix err prs input = try prs input with Noparse -> failwith (err ^ " expected");; -let rec listof prs sep err = +let listof prs sep err = prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);; let possibly prs input = @@ -583,7 +584,7 @@ let strings_of_file filename = let rec suck_lines acc = try let l = Pervasives.input_line fd in suck_lines (l::acc) - with End_of_file -> rev acc in + with End_of_file -> List.rev acc in let data = suck_lines [] in (Pervasives.close_in fd; data);; diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml index 351a3133..e9543714 100644 --- a/plugins/micromega/sos_types.ml +++ b/plugins/micromega/sos_types.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* PolZ -> R := (InitialRing.gen_phiZ ring0 ring1 add mul opp)). Definition PEevalR : list R -> PEZ -> R := - PEeval ring0 add mul sub opp + PEeval ring0 ring1 add mul sub opp (gen_phiZ ring0 ring1 add mul opp) N.to_nat pow. @@ -241,7 +241,9 @@ Fixpoint interpret3 t fv {struct t}: R := | (PEpow t1 t2) => let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) | (PEc t1) => (IZR1 t1) - | (PEX n) => List.nth (pred (Pos.to_nat n)) fv 0 + | PEO => 0 + | PEI => 1 + | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 end. diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 4bfcc436..8ff82454 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 + let c = List.map fst p in + let m = List.map snd p in + List.fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c module Hashpol = Hashtbl.Make( struct @@ -236,9 +235,8 @@ module Hashpol = Hashtbl.Make( open Format let getvar lv i = - try (nth lv i) - with e when Errors.noncritical e -> - (fold_left (fun r x -> r^" "^x) "lv= " lv) + try (List.nth lv i) + with Failure _ -> (List.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 @@ -363,8 +361,8 @@ let stringPcut p = (*Polynomesrec.nsP1:=20;*) nsP2:=10; let res = - if (length p)> !nsP2 - then (stringP [hd p])^" + "^(string_of_int (length p))^" terms" + if (List.length p)> !nsP2 + then (stringP [List.hd p])^" + "^(string_of_int (List.length p))^" terms" else stringP p in (*Polynomesrec.nsP1:= max_int;*) nsP2:= max_int; @@ -399,7 +397,7 @@ let zeroP = [] (* returns a constant polynom ial with d variables *) let polconst d c = - let m = Array.create (d+1) 0 in + let m = Array.make (d+1) 0 in let m = set_deg m in [(c,m)] @@ -432,7 +430,7 @@ 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 + let m = Array.make (d+1) 0 in m.(i) <- 1; let m = set_deg m in [((coef_of_int 1),m)] @@ -463,10 +461,10 @@ let puisP p n= match p with [] -> [] |_ -> - let d = nvar (snd (hd p)) in + let d = nvar (snd (List.hd p)) in let rec puisP n = match n with - 0 -> [coef1, Array.create (d+1) 0] + 0 -> [coef1, Array.make (d+1) 0] | 1 -> p |_ -> multP p (puisP (n-1)) in puisP n @@ -484,7 +482,7 @@ let contentPlist lp = match lp with |[] -> coef1 |p::l1 -> - fold_left + List.fold_left (fun r q -> if P.equal r coef1 || P.equal r coefm1 then r @@ -501,17 +499,17 @@ let polynom0 = {pol = ref []; num = 0; sugar = 0} let ppol p = !(p.pol) -let lm p = snd (hd (ppol p)) +let lm p = snd (List.hd (ppol p)) let nallpol = ref 0 -let allpol = ref (Array.create 1000 polynom0) +let allpol = ref (Array.make 1000 polynom0) let new_allpol p s = nallpol := !nallpol + 1; if !nallpol >= Array.length !allpol then - allpol := Array.append !allpol (Array.create !nallpol polynom0); + allpol := Array.append !allpol (Array.make !nallpol polynom0); let p = {pol = ref p; num = !nallpol; sugar = s} in !allpol.(!nallpol)<- p; p @@ -521,7 +519,7 @@ let new_allpol p s = let rec selectdiv m l = match l with [] -> polynom0 - |q::r -> let m'= snd (hd (ppol q)) in + |q::r -> let m'= snd (List.hd (ppol q)) in match (div_mon_test m m') with true -> q |false -> selectdiv m r @@ -550,7 +548,7 @@ 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 l = if nouveaux_pol_en_tete then List.rev l else l in let rec reduce p = match p with [] -> (coef1,[]) @@ -601,8 +599,8 @@ let coefpoldep_set p q c = let initcoefpoldep d lp = poldep:=lp; - poldepcontent:= map (fun p -> contentP (ppol p)) lp; - iter + poldepcontent:= List.map (fun p -> contentP (ppol p)) lp; + List.iter (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1))) lp @@ -610,7 +608,7 @@ let initcoefpoldep d lp = divides without pseudodivisions *) let reduce2_trace p l lcp = - let l = if nouveaux_pol_en_tete then rev l else l in + let l = if nouveaux_pol_en_tete then List.rev l else l in (* rend (lq,r), ou r = p + sum(lq) *) let rec reduce p = match p with @@ -646,10 +644,10 @@ let reduce2_trace p l lcp = info ((stringP x)^"\n")) lq; info "ok\n";*) - (map2 + (List.map2 (fun c0 q -> let c = - fold_left + List.fold_left (fun x (a,m,s) -> if equal (ppol s) (ppol q) then @@ -672,7 +670,7 @@ let pol_courant = ref polynom0 let sugar_flag = ref true let compute_sugar p = - fold_left (fun s (a,m) -> max s m.(0)) 0 p + List.fold_left (fun s (a,m) -> max s m.(0)) 0 p let mk_polynom p = new_allpol p (compute_sugar p) @@ -680,12 +678,12 @@ let mk_polynom 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 m = snd (List.hd p) in + let m'= snd (List.hd q) in + let a = fst (List.hd p) in + let b = fst (List.hd q) in + let p'= List.tl p in + let q'= List.tl q in let c = (pgcdpos a b) in let m''=(ppcm_mon m m') in let m1 = div_mon m'' m in @@ -709,8 +707,8 @@ let spol ps qs= let etrangers p p'= - let m = snd (hd p) in - let m'= snd (hd p') in + let m = snd (List.hd p) in + let m'= snd (List.hd p') in let d = nvar m in let res=ref true in let i=ref 1 in @@ -723,9 +721,9 @@ let etrangers p p'= (* 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 m = snd (List.hd p) in + let m'= snd (List.hd p') in + let m''= snd (List.hd p'') in let d = nvar m in let res=ref true in let i=ref 1 in @@ -766,7 +764,7 @@ let slice i a q = (* sugar strategy *) -let rec addS x l = l @ [x] (* oblige de mettre en queue sinon le certificat deconne *) +let addS x l = l @ [x] (* oblige de mettre en queue sinon le certificat deconne *) let addSsugar x l = if !sugar_flag @@ -823,10 +821,10 @@ let ordcpair ((i1,j1),m1) ((i2,j2),m2) = compare_mon m1 m2 let sortcpairs lcp = - sort ordcpair lcp + List.sort ordcpair lcp let mergecpairs l1 l2 = - merge ordcpair l1 l2 + List.merge ordcpair l1 l2 let ord i j = if i r @ (cpair p q)) [] lq) + sortcpairs (List.fold_left (fun r q -> r @ (cpair p q)) [] lq) let cpairs lp = let rec aux l = @@ -849,18 +847,18 @@ let cpairs lp = let critere2 ((i,j),m) lp lcp = - exists + List.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)) + not (List.exists (fun (c,_) -> c1 = c) lcp)) && (let c1 = ord j h.num in - not (exists (fun (c,_) -> c1 = c) lcp))) + not (List.exists (fun (c,_) -> c1 = c) lcp))) lp let critere3 ((i,j),m) lp lcp = - exists + List.exists (fun h -> h.num <> i && h.num <> j && (div_mon_test m (lm h)) @@ -881,8 +879,8 @@ let step = ref 0 let infobuch p q = if !step = 0 - then (info ("[" ^ (string_of_int (length p)) - ^ "," ^ (string_of_int (length q)) + then (info ("[" ^ (string_of_int (List.length p)) + ^ "," ^ (string_of_int (List.length q)) ^ "]")) (* in lp new polynomials are at the end *) @@ -900,13 +898,13 @@ let test_dans_ideal p lp lp0 = pol_courant:= mk_polynom r; if r=[] then (info "polynomial reduced to 0\n"; - let lcp = map (fun q -> []) !poldep in + let lcp = List.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 + List.iter2 (fun cq q -> res:=plusP (!res) (multP cq (ppol q)); ) lcq !poldep; @@ -916,22 +914,22 @@ let test_dans_ideal p lp lp0 = match lp with |[] -> [] |p::lp -> - (map + (List.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 liste_polynomes_de_depart = List.rev lp0 in let polynome_a_tester = p in let liste_des_coefficients_intermediaires = - (let lci = rev (aux (rev lp)) in + (let lci = List.rev (aux (List.rev lp)) in let lci = ref lci (* (map rev lci) *) in - iter (fun x -> lci := tl (!lci)) lp0; + List.iter (fun x -> lci := List.tl (!lci)) lp0; !lci) in let liste_des_coefficients = - map + List.map (fun cq -> emultP (coef_of_int (-1)) cq) - (rev lcq) in + (List.rev lcq) in (liste_polynomes_de_depart, polynome_a_tester, {coef = coefficient_multiplicateur; @@ -946,7 +944,7 @@ let test_dans_ideal p lp lp0 = let divide_rem_with_critical_pair = ref false let list_diff l x = - filter (fun y -> y <> x) l + List.filter (fun y -> y <> x) l let deg_hom p = match p with @@ -984,12 +982,12 @@ let pbuchf pq p lp0= (* 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)) + (List.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 -> + List.iter2 (fun c q -> coefpoldep_remove a q; coefpoldep_set a q c) lca !poldep; let a0 = a in @@ -1009,7 +1007,7 @@ 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 + List.for_all (fun (b,m') -> m'.(0)=d) p1 (* returns c @@ -1030,15 +1028,15 @@ 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); + allpol := Array.make 1000 polynom0; + homogeneous := List.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 ("lp:\n"^(List.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 lp = List.map mk_polynom lp in let p = mk_polynom p in initcoefpoldep d lp; coef_courant:=coef1; @@ -1049,7 +1047,7 @@ let in_ideal d lp p = with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in info "computed\n"; - (map ppol lp1, p1, cert) + (List.map ppol lp1, p1, cert) (* *) end diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4 index a66bd44b..b4eb57ec 100644 --- a/plugins/nsatz/nsatz.ml4 +++ b/plugins/nsatz/nsatz.ml4 @@ -1,42 +1,24 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 1 + with Failure _ -> 1 let puis = power_big_int_positive_int (* a et b positifs, résultat positif *) @@ -156,7 +138,7 @@ type term = 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 pow(p,i) = if Int.equal i 1 then p else Pow(p,i) let add = function (Zero,q) -> q | (p,Zero) -> p @@ -212,7 +194,7 @@ let rec mkt_pos n = mkt_app pxI [mkt_pos (quo_num n num_2)] let mkt_n n = - if n=num_0 + if Num.eq_num n num_0 then Lazy.force nN0 else mkt_app nNpos [mkt_pos n] @@ -232,7 +214,7 @@ let rec mkt_term t = match t with | 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 +| Pow (t1,n) -> if Int.equal 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)] @@ -331,7 +313,7 @@ let term_pol_sparse np t= match t with | Zero -> zeroP | Const r -> - if r = num_0 + if Num.eq_num r num_0 then zeroP else polconst d (Poly.Pint (Coef.of_num r)) | Var v -> @@ -385,19 +367,19 @@ let pol_sparse_to_term n2 p = if m.(k)>0 then i0:=k done; - if !i0 = 0 + if Int.equal !i0 0 then (r,d) else if !i0 > r then (!i0, m.(!i0)) - else if !i0 = r && m.(!i0)=m then () @@ -543,7 +525,7 @@ let theoremedeszeros_termes lp = let (cert,lp0,p,_lct) = theoremedeszeros lpol p in info "cert ok\n"; let lc = cert.last_comb::List.rev cert.gb_comb in - match remove_zeros (fun x -> x=zeroP) lc with + match remove_zeros (fun x -> equal x zeroP) lc with | [] -> assert false | (lq::lci) -> (* lci commence par les nouveaux polynomes *) @@ -610,7 +592,7 @@ let nsatz_compute t = return_term lpol TACTIC EXTEND nsatz_compute -| [ "nsatz_compute" constr(lt) ] -> [ nsatz_compute lt ] +| [ "nsatz_compute" constr(lt) ] -> [ Proofview.V82.tactic (nsatz_compute lt) ] END diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index 026b66c7..a9651304 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -1,14 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pint coef1; - |_->let tmp = Array.create (n+1) (Pint coef0) in + |_->let tmp = Array.make (n+1) (Pint coef0) in tmp.(n)<-(Pint coef1); Prec (v, tmp) @@ -159,28 +159,21 @@ let rec max_var_pol2 p = 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 +let 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 e when Errors.noncritical e -> false) + |(Prec(x,p1),Prec(y,q1)) -> (Int.equal x y) && Array.for_all2 equal p1 q1 | (_,_) -> false (* normalize polynomial: remove head zeros, coefficients are normalized if constant, returns the coefficient *) -let rec norm p = match p with +let norm p = match p with Pint _ -> p |Prec (x,a)-> let d = (Array.length a -1) in @@ -189,17 +182,17 @@ let rec norm p = match p with 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 + else if Int.equal !n 0 then a.(0) + else if Int.equal !n d then p + else (let b=Array.make (!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 = +let deg v p = match p with - Prec(x,p1) when x=v -> Array.length p1 -1 + Prec(x,p1) when Int.equal x v -> Array.length p1 -1 |_ -> 0 @@ -219,8 +212,8 @@ let rec copyP p = (* 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 + Prec (x,p1) when Int.equal x v -> if i<(Array.length p1) then p1.(i) else Pint coef0 + |_ -> if Int.equal i 0 then p else Pint coef0 (* addition *) @@ -243,7 +236,7 @@ let rec plusP p q = Prec (x,p2)) else (let n=max (deg x p) (deg x q) in - let r=Array.create (n+1) (Pint coef0) in + let r=Array.make (n+1) (Pint coef0) in for i=0 to n do r.(i)<- plusP (coef x i p) (coef x i q); done; @@ -275,15 +268,15 @@ let rec vars=function (* multiply p by v^n, v >= max_var p *) -let rec multx n v p = +let multx n v p = match p with - Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in + Prec (x,p1) when Int.equal x v -> let p2= Array.make ((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 equal p (Pint coef0) then (Pint coef0) - else (let p2=Array.create (n+1) (Pint coef0) in + else (let p2=Array.make (n+1) (Pint coef0) in p2.(n)<-p; Prec (v,p2)) @@ -313,14 +306,14 @@ let rec multP p q = (* derive p with variable v, v >= max_var p *) -let rec deriv v p = +let deriv v p = match p with Pint a -> Pint coef0 - | Prec(x,p1) when x=v -> + | Prec(x,p1) when Int.equal x v -> let d = Array.length p1 -1 in - if d=1 then p1.(1) + if Int.equal d 1 then p1.(1) else - (let p2 = Array.create d (Pint coef0) in + (let p2 = Array.make d (Pint coef0) in for i=0 to d-1 do p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1); done; @@ -415,7 +408,7 @@ let rec string_of_Pcut p = and s=ref "" and sp=ref "" in let st0 = string_of_Pcut t.(0) in - if st0<>"0" + if not (String.equal st0 "0") then s:=st0; let fin = ref false in for i=(Array.length t)-1 downto 1 do @@ -426,31 +419,31 @@ let rec string_of_Pcut p = else ( let si=string_of_Pcut t.(i) in sp:=""; - if i=1 + if Int.equal i 1 then ( - if si<>"0" + if not (String.equal si "0") then (nsP:=(!nsP)-1; - if si="1" + if String.equal si "1" then sp:=v else (if (String.contains si '+') then sp:="("^si^")*"^v else sp:=si^"*"^v))) else ( - if si<>"0" + if not (String.equal si "0") then (nsP:=(!nsP)-1; - if si="1" + if String.equal 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) + if not (String.is_empty !sp) && not (!fin) then (nsP:=(!nsP)-1; - if !s="" + if String.is_empty !s then s:=!sp else s:=(!s)^"+"^(!sp))); done; - if !s="" then (nsP:=(!nsP)-1; + if String.is_empty !s then (nsP:=(!nsP)-1; (s:="0")); !s @@ -473,7 +466,7 @@ let print_lpoly lp = print_tpoly (Array.of_list lp) (* return (s,r) s.t. p = s*q+r *) let rec quo_rem_pol p q x = - if x=0 + if Int.equal x 0 then (match (p,q) with |(Pint a, Pint b) -> if C.equal (C.modulo a b) coef0 @@ -519,12 +512,11 @@ let divP p q= let div_pol_rat p q= let x = max (max_var_pol p) (max_var_pol q) in - try (let s = div_pol (multP p (puisP (Pint(coef_int_tete q)) - (1+(deg x p) - (deg x q)))) - q x in - (* degueulasse, mais c 'est pour enlever un warning *) - if s==s then true else true) - with e when Errors.noncritical e -> false + try + let r = puisP (Pint(coef_int_tete q)) (1+(deg x p)-(deg x q)) in + let _ = div_pol (multP p r) q x in + true + with Failure _ -> false (*********************************************************************** 5. Pseudo-division and gcd with subresultants. @@ -538,7 +530,7 @@ let div_pol_rat p q= 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) when not (Int.equal x v) -> (cf0, q,1, p) | Prec (v,q1) -> ( (* pr "pseudo_division: c^d*p = s*q + r";*) @@ -575,13 +567,13 @@ and pgcd_pol p q x = and content_pol p x = match p with - Prec(v,p1) when v=x -> + Prec(v,p1) when Int.equal 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 -> + Prec(v,p1) when Int.equal x v -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c p1 |_ -> pgcd_pol_rec c p (x-1) @@ -593,9 +585,9 @@ and pgcd_pol_rec p q x = then q else if equal q cf0 then p - else if (deg x q) = 0 + else if Int.equal (deg x q) 0 then pgcd_coef_pol q p x - else if (deg x p) = 0 + else if Int.equal (deg x p) 0 then pgcd_coef_pol p q x else ( let a = content_pol p x in @@ -610,7 +602,7 @@ and pgcd_pol_rec p q x = res ) -(* Sub-résultants: +(* Sub-résultants: ai*Ai = Qi*Ai+1 + bi*Ai+2 @@ -655,7 +647,7 @@ and gcd_sub_res_rec p q s c d x = and lazard_power c s d x = let res = ref c in - for i=1 to d-1 do + for _i = 1 to d - 1 do res:= div_pol ((!res)@@c) s x; done; !res diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli index 0f1e0481..9d46cd99 100644 --- a/plugins/nsatz/polynom.mli +++ b/plugins/nsatz/polynom.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 e when Errors.noncritical e -> - (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 @@ -95,7 +81,7 @@ let facteurs_liste div constant lp = 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 + let res = Array.make (Array.length f) (c,[]) in Array.iteri (fun i p -> let r = ref p in let li = ref [] in diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli index 83b2ac39..1f841575 100644 --- a/plugins/nsatz/utile.mli +++ b/plugins/nsatz/utile.mli @@ -10,10 +10,6 @@ val info : string -> unit 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 : diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v index 0192528c..7400d462 100644 --- a/plugins/omega/Omega.v +++ b/plugins/omega/Omega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 +Hint Extern 10 False => abstract omega: zarith. diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v index d23e3d13..9e5c1484 100644 --- a/plugins/omega/OmegaPlugin.v +++ b/plugins/omega/OmegaPlugin.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + simplest_elim (Tacmach.New.pf_global id gl) + end +let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl let timing timer_name f arg = f arg @@ -51,20 +48,15 @@ let old_style_flag = ref false (* Should we reset all variable labels between two runs of omega ? *) -let reset_flag = ref false +let reset_flag = ref true -(* Historical version of Coq do not perform such resets, and this - implies that omega is slightly non-deterministic: successive runs of - omega on the same problem may lead to distinct proof-terms. - At the very least, these terms will differ on the inner +(* Coq < 8.5 was not performing such resets, hence omega was slightly + non-deterministic: successive runs of omega on the same problem may + lead to distinct proof-terms. + At the very least, these terms differed on the inner variable names, but they could even be non-convertible : the OmegaSolver relies on Hashtbl.iter, it can hence find a different - solution when variable indices differ. - - Starting from Coq 8.4pl4, omega may be made stable via the option - [Set Stable Omega]. In the 8.4 branch, this option is unset by default - for compatibility. In Coq >= 8.5, this option is set by default. -*) + solution when variable indices differ. *) let read f () = !f let write f x = f:=x @@ -101,19 +93,12 @@ let _ = let _ = declare_bool_option { optsync = true; - optdepr = false; + optdepr = true; optname = "Omega automatic reset of generated names"; optkey = ["Stable";"Omega"]; optread = read reset_flag; optwrite = write reset_flag } -let all_time = timing "Omega " -let solver_time = timing "Solver " -let exact_time = timing "Rewrites " -let elim_time = timing "Elim " -let simpl_time = timing "Simpl " -let generalize_time = timing "Generalize" - let intref, reset_all_references = let refs = ref [] in (fun n -> let r = ref n in refs := (r,n) :: !refs; r), @@ -121,7 +106,7 @@ let intref, reset_all_references = let new_identifier = let cpt = intref 0 in - (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) + (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s) let new_identifier_state = let cpt = intref 0 in @@ -129,7 +114,7 @@ let new_identifier_state = let new_identifier_var = let cpt = intref 0 in - (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) + (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s) let new_id = let cpt = intref 0 in fun () -> incr cpt; !cpt @@ -145,7 +130,7 @@ let display_var i = Printf.sprintf "X%d" i let intern_id,unintern_id,reset_intern_tables = let cpt = ref 0 in let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in - (fun (name : identifier) -> + (fun (name : Id.t) -> try Hashtbl.find table name with Not_found -> let idx = !cpt in Hashtbl.add table name idx; @@ -159,30 +144,33 @@ let intern_id,unintern_id,reset_intern_tables = let mk_then = tclTHENLIST -let exists_tac c = constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [c]) +let exists_tac c = constructor_tac false (Some 1) 1 (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 [Termops.all_occurrences, Lazy.force s] +let generalize_tac t = generalize t +let elim t = simplest_elim t +let exact t = Tactics.refine t +let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] let rev_assoc k = let rec loop = function - | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l + | [] -> raise Not_found + | (v,k')::_ when Int.equal k k' -> v + | _ :: l -> loop l in loop let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags = - let l = ref ([]:(identifier * int) list) in + let l = ref ([]:(Id.t * 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 Id.List.assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun () -> l := []) let hide_constr,find_constr,clear_constr_tables,dump_tables = - let l = ref ([]:(constr * (identifier * identifier * bool)) list) in + let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), - (fun h -> try list_assoc_f eq_constr h !l with Not_found -> failwith "find_contr"), + (fun h -> + try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) @@ -230,8 +218,6 @@ let coq_Zopp = lazy (zbase_constant "Z.opp") let coq_Zminus = lazy (zbase_constant "Z.sub") let coq_Zsucc = lazy (zbase_constant "Z.succ") let coq_Zpred = lazy (zbase_constant "Z.pred") -let coq_Zgt = lazy (zbase_constant "Z.gt") -let coq_Zle = lazy (zbase_constant "Z.le") let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat") let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add") let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul") @@ -318,10 +304,10 @@ 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_minus = lazy (init_constant "Nat.sub") +let coq_plus = lazy (init_constant "Nat.add") +let coq_mult = lazy (init_constant "Nat.mul") +let coq_pred = lazy (init_constant "Nat.pred") let coq_nat = lazy (init_constant "nat") let coq_S = lazy (init_constant "S") let coq_O = lazy (init_constant "O") @@ -363,11 +349,10 @@ 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) -> + | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn - | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") + | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant")) let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc) let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) @@ -378,19 +363,20 @@ let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" 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_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_eq t1 t2 = mkApp (Universes.constr_of_global (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_eq_rel t1 t2 = mkApp (Universes.constr_of_global (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 = @@ -419,7 +405,7 @@ type omega_proposition = | Kn type result = - | Kvar of identifier + | Kvar of Id.t | Kapp of omega_constant * constr list | Kimp of constr * constr | Kufo @@ -434,7 +420,7 @@ type result = let destructurate_prop t = let c, args = decompose_app t in match kind_of_term c, args with - | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args) + | _, [_;_;_] when is_global (build_coq_eq ()) c -> Kapp (Eq,args) | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) @@ -451,11 +437,11 @@ let destructurate_prop t = | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) - | Const sp, args -> + | Const (sp,_), args -> Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args) - | Construct csp , args -> + | Construct (csp,_) , args -> Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args) - | Ind isp, args -> + | Ind (isp,_), args -> Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) @@ -549,7 +535,6 @@ let context operation path (t : constr) = | ((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 @@ -570,7 +555,6 @@ let occurence path (t : constr) = | ((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 @@ -578,19 +562,19 @@ let occurence path (t : constr) = 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 + 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 + Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl -let focused_simpl path = simpl_time (focused_simpl path) +let focused_simpl path = focused_simpl path type oformula = | Oplus of oformula * oformula | Oinv of oformula | Otimes of oformula * oformula - | Oatom of identifier + | Oatom of Id.t | Oz of bigint | Oufo of constr @@ -602,7 +586,7 @@ let rec oprint = function | Otimes (t1,t2) -> print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" - | Oatom s -> print_string (string_of_id s) + | Oatom s -> print_string (Id.to_string s) | Oz i -> print_string (string_of_bigint i) | Oufo f -> print_string "?" @@ -629,11 +613,11 @@ let compile name kind = let id = new_id () in tag_hypothesis name id; {kind = kind; body = List.rev accu; constant = n; id = id} - | _ -> anomaly "compile_equation" + | _ -> anomaly (Pp.str "compile_equation") in loop [] -let rec decompile af = +let decompile af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) | [] -> Oz af.constant @@ -648,10 +632,10 @@ let clever_rewrite_base_poly typ p result theorem gl = let t = applist (mkLambda - (Name (id_of_string "P"), + (Name (Id.of_string "P"), mkArrow typ mkProp, mkLambda - (Name (id_of_string "H"), + (Name (Id.of_string "H"), applist (mkRel 1,[result]), mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), @@ -724,10 +708,10 @@ let rec shuffle p (t1,t2) = Oplus(t2,t1) else [],Oplus(t1,t2) -let rec shuffle_mult p_init k1 e1 k2 e2 = +let 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 + if Int.equal 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]; @@ -781,10 +765,10 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = in loop p_init (e1,e2) -let rec shuffle_mult_right p_init e1 k2 e2 = +let 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 + if Int.equal v1 v2 then let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1]; @@ -866,7 +850,7 @@ let rec scalar p n = function | 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 scalar_norm p_init = let rec loop p = function | [] -> [focused_simpl p_init] | (_::l) -> @@ -877,7 +861,7 @@ let rec scalar_norm p_init = in loop p_init -let rec norm_add p_init = +let norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] | _:: l -> @@ -887,7 +871,7 @@ let rec norm_add p_init = in loop p_init -let rec scalar_norm_add p_init = +let scalar_norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] | _ :: l -> @@ -1015,7 +999,7 @@ let reduce_factor p = function let rec condense p = function | Oplus(f1,(Oplus(f2,r) as t)) -> - if weight f1 = weight f2 then begin + if Int.equal (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 @@ -1031,7 +1015,7 @@ let rec condense p = function | 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 + if Int.equal (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' @@ -1059,17 +1043,17 @@ let rec clear_zero p = function | 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 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 = + let rec loop t : unit Proofview.tactic = match t with | HYP e :: l -> begin try - tclTHEN - (List.assoc (hyp_of_tag e.id) tactic_normalisation) + Tacticals.New.tclTHEN + (Id.List.assoc (hyp_of_tag e.id) tactic_normalisation) (loop l) with Not_found -> loop l end | NEGATE_CONTRADICT (e2,e1,b) :: l -> @@ -1080,16 +1064,16 @@ let replay_history tactic_normalisation = 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 + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA17, [| val_of eq1; val_of eq2; mk_integer k; mkVar id1; mkVar id2 |])]); - (mk_then tac); + Proofview.V82.tactic (mk_then tac); (intros_using [aux]); - (resolve_id aux); + Proofview.V82.tactic (resolve_id aux); reflexivity ] | CONTRADICTION (e1,e2) :: l -> @@ -1098,15 +1082,16 @@ let replay_history tactic_normalisation = 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 (), [| + let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()), + [| Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) in - tclTHENS - (tclTHENLIST [ - (unfold sp_Zle); - (simpl_in_concl); + Tacticals.New.tclTHENS + (Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (unfold sp_Zle); + Proofview.V82.tactic (simpl_in_concl); intro; (absurd not_sup_sup) ]) [ assumption ; reflexivity ] @@ -1117,7 +1102,7 @@ let replay_history tactic_normalisation = mkVar (hyp_of_tag e1.id); mkVar (hyp_of_tag e2.id) |]) in - tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le) + Proofview.tclTHEN (Proofview.V82.tactic (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) @@ -1127,34 +1112,34 @@ let replay_history tactic_normalisation = 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 + Tacticals.New.tclTHENS (cut state_eg) - [ tclTHENS - (tclTHENLIST [ + [ Tacticals.New.tclTHENS + (Tacticals.New.tclTHENLIST [ (intros_using [aux]); - (generalize_tac + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA1, [| eq1; rhs; mkVar aux; mkVar id |])]); - (clear [aux;id]); + Proofview.V82.tactic (clear [aux;id]); (intros_using [id]); (cut (mk_gt kk dd)) ]) - [ tclTHENS + [ Tacticals.New.tclTHENS (cut (mk_gt kk izero)) - [ tclTHENLIST [ + [ Tacticals.New.tclTHENLIST [ (intros_using [aux1; aux2]); - (generalize_tac + (Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, - [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); - (clear [aux1;aux2;id]); + [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])])); + Proofview.V82.tactic (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; - tclTHENLIST [ - (unfold sp_Zgt); - (simpl_in_concl); + Tacticals.New.tclTHENLIST [ + (Proofview.V82.tactic (unfold sp_Zgt)); + (Proofview.V82.tactic simpl_in_concl); reflexivity ] ]; - tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] + Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (unfold sp_Zgt); Proofview.V82.tactic simpl_in_concl; reflexivity ] ]; - tclTHEN (mk_then tac) reflexivity ] + Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in @@ -1165,27 +1150,27 @@ let replay_history tactic_normalisation = let kk = mk_integer k and dd = mk_integer d in let tac = scalar_norm_add [P_APP 2] e2.body in - tclTHENS + Tacticals.New.tclTHENS (cut (mk_gt dd izero)) - [ tclTHENS (cut (mk_gt kk dd)) - [tclTHENLIST [ + [ Tacticals.New.tclTHENS (cut (mk_gt kk dd)) + [Tacticals.New.tclTHENLIST [ (intros_using [aux2;aux1]); - (generalize_tac + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); - (clear [aux1;aux2]); - (unfold sp_not); + Proofview.V82.tactic (clear [aux1;aux2]); + Proofview.V82.tactic (unfold sp_not); (intros_using [aux]); - (resolve_id aux); - (mk_then tac); + Proofview.V82.tactic (resolve_id aux); + Proofview.V82.tactic (mk_then tac); assumption ] ; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (unfold sp_Zgt); + Proofview.V82.tactic simpl_in_concl; reflexivity ] ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (unfold sp_Zgt); + Proofview.V82.tactic simpl_in_concl; reflexivity ] ] | EXACT_DIVIDE (e1,k) :: l -> let id = hyp_of_tag e1.id in @@ -1194,38 +1179,38 @@ let replay_history tactic_normalisation = 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 + if e1.kind == DISE then let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS + Tacticals.New.tclTHENS (cut state_eq) - [tclTHENLIST [ + [Tacticals.New.tclTHENLIST [ (intros_using [aux1]); - (generalize_tac + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA18, [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); - (clear [aux1;id]); + Proofview.V82.tactic (clear [aux1;id]); (intros_using [id]); (loop l) ]; - tclTHEN (mk_then tac) reflexivity ] + Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS (cut state_eq) + Tacticals.New.tclTHENS (cut state_eq) [ - tclTHENS + Tacticals.New.tclTHENS (cut (mk_gt kk izero)) - [tclTHENLIST [ + [Tacticals.New.tclTHENLIST [ (intros_using [aux2;aux1]); - (generalize_tac + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA3, [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); - (clear [aux1;aux2;id]); + Proofview.V82.tactic (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (unfold sp_Zgt); + Proofview.V82.tactic simpl_in_concl; reflexivity ] ]; - tclTHEN (mk_then tac) reflexivity ] + Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] | (MERGE_EQ(e3,e1,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; @@ -1238,16 +1223,16 @@ let replay_history tactic_normalisation = (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: scalar_norm [P_APP 3] e1.body in - tclTHENS + Tacticals.New.tclTHENS (cut (mk_eq eq1 (mk_inv eq2))) - [tclTHENLIST [ + [Tacticals.New.tclTHENLIST [ (intros_using [aux]); - (generalize_tac [mkApp (Lazy.force coq_OMEGA8, + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); - (clear [id1;id2;aux]); + Proofview.V82.tactic (clear [id1;id2;aux]); (intros_using [id]); (loop l) ]; - tclTHEN (mk_then tac) reflexivity] + Tacticals.New.tclTHEN (Proofview.V82.tactic (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 () @@ -1271,21 +1256,21 @@ let replay_history tactic_normalisation = [[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 + Tacticals.New.tclTHENS (cut theorem) - [tclTHENLIST [ + [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (elim_id aux); - (clear [aux]); + Proofview.V82.tactic (clear [aux]); (intros_using [vid; aux]); - (generalize_tac + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); - (mk_then tac); - (clear [aux]); + Proofview.V82.tactic (mk_then tac); + Proofview.V82.tactic (clear [aux]); (intros_using [id]); (loop l) ]; - tclTHEN (exists_tac eq1) reflexivity ] + Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in @@ -1294,10 +1279,10 @@ let replay_history tactic_normalisation = 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 + Tacticals.New.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) ]] + [Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac1); (intros_using [id1]); (loop act1) ]; + Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; @@ -1305,7 +1290,7 @@ let replay_history tactic_normalisation = 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 + if k1 =? one && e2.kind == EQUA then let tac_thm = match e1.kind with | EQUA -> Lazy.force coq_OMEGA5 @@ -1314,12 +1299,12 @@ let replay_history tactic_normalisation = 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 + 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 + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); - (mk_then tac); + Proofview.V82.tactic (mk_then tac); (intros_using [id]); (loop l) ] @@ -1328,43 +1313,43 @@ let replay_history tactic_normalisation = 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 + Tacticals.New.tclTHENS (cut (mk_gt kk1 izero)) + [Tacticals.New.tclTHENS (cut (mk_gt kk2 izero)) - [tclTHENLIST [ + [Tacticals.New.tclTHENLIST [ (intros_using [aux2;aux1]); - (generalize_tac + Proofview.V82.tactic (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); + Proofview.V82.tactic (clear [aux1;aux2]); + Proofview.V82.tactic (mk_then tac); (intros_using [id]); (loop l) ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (unfold sp_Zgt); + Proofview.V82.tactic simpl_in_concl; reflexivity ] ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (unfold sp_Zgt); + Proofview.V82.tactic simpl_in_concl; reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> - tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl + Tacticals.New.tclTHEN (Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl | CONSTANT_NUL(e) :: l -> - tclTHEN (resolve_id (hyp_of_tag e)) reflexivity + Tacticals.New.tclTHEN (Proofview.V82.tactic (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); + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)]); + Proofview.V82.tactic (unfold sp_Zle); + Proofview.V82.tactic simpl_in_concl; + Proofview.V82.tactic (unfold sp_not); (intros_using [aux]); - (resolve_id aux); + Proofview.V82.tactic (resolve_id aux); reflexivity ] - | _ -> tclIDTAC + | _ -> Proofview.tclUNIT () in loop @@ -1382,21 +1367,21 @@ let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) (tclTRY (clear [id])) in - if tac <> [] then + if not (List.is_empty tac) then let id' = new_identifier () in - ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ])) + ((id',(Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (shift_left); Proofview.V82.tactic (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 + if String.equal (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,[]) -> + when begin match destructurate_type (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def @@ -1425,12 +1410,18 @@ let destructure_omega gl tac_def (id,c) = let reintroduce id = (* [id] cannot be cleared if dependent: protect it by a try *) - tclTHEN (tclTRY (clear [id])) (intro_using id) + Tacticals.New.tclTHEN (Proofview.V82.tactic (tclTRY (clear [id]))) (intro_using id) + -let coq_omega gl = +open Proofview.Notations + +let coq_omega = + Proofview.Goal.nf_enter begin fun gl -> clear_constr_tables (); + let hyps_types = Tacmach.New.pf_hyps_types gl in + let destructure_omega = Tacmach.New.of_old destructure_omega gl in let tactic_normalisation, system = - List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in + List.fold_left destructure_omega ([],[]) hyps_types in let prelude,sys = List.fold_left (fun (tac,sys) (t,(v,th,b)) -> @@ -1438,78 +1429,81 @@ let coq_omega gl = let id = new_identifier () in let i = new_id () in tag_hypothesis id i; - (tclTHENLIST [ + (Tacticals.New.tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); (intros_using [v; id]); (elim_id id); - (clear [id]); + Proofview.V82.tactic (clear [id]); (intros_using [th;id]); tac ]), {kind = INEQ; body = [{v=intern_id v; c=one}]; constant = zero; id = i} :: sys else - (tclTHENLIST [ + (Tacticals.New.tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_new_var, [t]))); (intros_using [v;th]); tac ]), sys) - (tclIDTAC,[]) (dump_tables ()) + (Proofview.tclUNIT (),[]) (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 + Proofview.tclUNIT () 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 + (Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)) 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" + Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path) + with NO_CONTRADICTION -> Proofview.tclZERO (UserError ("" , Pp.str"Omega can't solve this system")) + end end -let coq_omega = solver_time coq_omega +let coq_omega = coq_omega -let nat_inject gl = - let rec explore p t = +let nat_inject = + Proofview.Goal.nf_enter begin fun gl -> + let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in + let rec explore p t : unit Proofview.tactic = try match destructurate_term t with | Kapp(Plus,[t1;t2]) -> - tclTHENLIST [ - (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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)) + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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 + Tacticals.New.tclTHENS + (Tacticals.New.tclTHEN (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) (intros_using [id])) [ - tclTHENLIST [ - (clever_rewrite_gen p + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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])) + (Tacticals.New.tclTHEN + (Proofview.V82.tactic (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']) -> @@ -1520,37 +1514,37 @@ let nat_inject gl = | _ -> false with e when catchable_exception e -> false in - let rec loop p t = + let rec loop p t : unit Proofview.tactic = try match destructurate_term t with Kapp(S,[t]) -> - (tclTHEN - (clever_rewrite_gen p + (Tacticals.New.tclTHEN + (Proofview.V82.tactic (clever_rewrite_gen p (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[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 + if is_number t' then Proofview.V82.tactic (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])) + Tacticals.New.tclTHEN + (Proofview.V82.tactic (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 + | Kapp(O,[]) -> Proofview.V82.tactic (focused_simpl p) + | _ -> Proofview.tclUNIT () + with e when catchable_exception e -> Proofview.tclUNIT () and loop = function - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | (i,t)::lit -> begin try match destructurate_prop t with Kapp(Le,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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); @@ -1558,8 +1552,8 @@ let nat_inject gl = (loop lit) ] | Kapp(Lt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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); @@ -1567,8 +1561,8 @@ let nat_inject gl = (loop lit) ] | Kapp(Ge,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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); @@ -1576,8 +1570,8 @@ let nat_inject gl = (loop lit) ] | Kapp(Gt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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); @@ -1585,8 +1579,8 @@ let nat_inject gl = (loop lit) ] | Kapp(Neq,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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); @@ -1594,9 +1588,9 @@ let nat_inject gl = (loop lit) ] | Kapp(Eq,[typ;t1;t2]) -> - if pf_conv_x gl typ (Lazy.force coq_nat) then - tclTHENLIST [ - (generalize_tac + if is_conv typ (Lazy.force coq_nat) then + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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); @@ -1607,7 +1601,9 @@ let nat_inject gl = | _ -> loop lit with e when catchable_exception e -> loop lit end in - loop (List.rev (pf_hyps_types gl)) gl + let hyps_types = Tacmach.New.pf_hyps_types gl in + loop (List.rev hyps_types) + end let dec_binop = function | Zne -> coq_dec_Zne @@ -1675,51 +1671,57 @@ let rec decidability gl t = 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) + Tacticals.New.tclTHEN + (Proofview.V82.tactic (tclTRY (clear [id]))) + (Proofview.Goal.nf_enter begin fun gl -> + let id = Tacmach.New.of_old (fresh_id [] id) gl in + Tacticals.New.tclTHEN (introduction id) (tac id) + end) let onClearedName2 id tac = - tclTHEN - (tclTRY (clear [id])) - (fun gl -> - let id1 = fresh_id [] (add_suffix id "_left") gl in - let id2 = fresh_id [] (add_suffix id "_right") gl in - tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] 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 + Tacticals.New.tclTHEN + (Proofview.V82.tactic (tclTRY (clear [id]))) + (Proofview.Goal.nf_enter begin fun gl -> + let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in + let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in + Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] + end) + +let destructure_hyps = + Proofview.Goal.nf_enter begin fun gl -> + let type_of = Tacmach.New.pf_type_of gl in + let decidability = Tacmach.New.of_old decidability gl in + let pf_nf = Tacmach.New.of_old pf_nf gl in + let rec loop = function + | [] -> (Tacticals.New.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))) ]) + (Tacticals.New.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]) -> - tclTHEN + Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop ((i1,None,t1)::(i2,None,t2)::lit))) | Kapp(Iff,[t1;t2]) -> - tclTHEN + Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if is_Prop (pf_type_of gl t2) + if is_Prop (type_of t2) then - let d1 = decidability gl t1 in - tclTHENLIST [ - (generalize_tac [mkApp (Lazy.force coq_imp_simp, - [| t1; t2; d1; mkVar i|])]); + let d1 = decidability t1 in + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_imp_simp, + [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) ] @@ -1727,135 +1729,138 @@ let destructure_hyps gl = 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]) -> - let d1 = decidability gl t1 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_and, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> - (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) - ] - | Kapp(Iff,[t1;t2]) -> - let d1 = decidability gl t1 in - let d2 = decidability gl t2 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_iff, - [| t1; t2; d1; d2; 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) -> + Kapp(Or,[t1;t2]) -> + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (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]) -> + let d1 = decidability t1 in + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac + [mkApp (Lazy.force coq_not_and, + [| t1; t2; d1; mkVar i |])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) + ] + | Kapp(Iff,[t1;t2]) -> + let d1 = decidability t1 in + let d2 = decidability t2 in + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac + [mkApp (Lazy.force coq_not_iff, + [| t1; t2; d1; d2; 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) -> (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. For t1, being decidable implies being Prop. *) - let d1 = decidability gl t1 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_imp, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> - (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) - ] - | Kapp(Not,[t]) -> - let d = decidability gl t in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) - ] - | Kapp(op,[t1;t2]) -> - (try - let thm = not_binop op in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - with Not_found -> 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 + let d1 = decidability t1 in + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac + [mkApp (Lazy.force coq_not_imp, + [| t1; t2; d1; mkVar i |])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) + ] + | Kapp(Not,[t]) -> + let d = decidability t in + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac + [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); + (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) + ] + | Kapp(op,[t1;t2]) -> + (try + let thm = not_binop op in + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (generalize_tac + [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + with Not_found -> loop lit) + | Kapp(Eq,[typ;t1;t2]) -> + if !old_style_flag then begin + match destructurate_type (pf_nf typ) with + | Kapp(Nat,_) -> + Tacticals.New.tclTHENLIST [ + (simplest_elim + (mkApp + (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Z,_) -> + Tacticals.New.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 typ) with + | Kapp(Nat,_) -> + (Tacticals.New.tclTHEN + (convert_hyp_no_check + (i,body, + (mkApp (Lazy.force coq_neq, [| t1;t2|])))) + (loop lit)) + | Kapp(Z,_) -> + (Tacticals.New.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 - | Undecidable -> loop lit - | e when catchable_exception e -> loop lit - end - in - loop (pf_hyps gl) gl + with + | Undecidable -> loop lit + | e when catchable_exception e -> loop lit + end + in + let hyps = Proofview.Goal.hyps gl in + loop hyps + end -let destructure_goal gl = - let concl = pf_concl gl in - let rec loop t = - match destructurate_prop t with +let destructure_goal = + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let decidability = Tacmach.New.of_old decidability gl in + let rec loop t = + match destructurate_prop t with | Kapp(Not,[t]) -> - (tclTHEN - (tclTHEN (unfold sp_not) intro) + (Tacticals.New.tclTHEN + (Tacticals.New.tclTHEN (Proofview.V82.tactic (unfold sp_not)) intro) destructure_hyps) - | Kimp(a,b) -> (tclTHEN intro (loop b)) + | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> - let goal_tac = - try - let dec = decidability gl t in - tclTHEN - (Tactics.refine - (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))) - intro - with Undecidable -> Tactics.elim_type (build_coq_False ()) - in - tclTHEN goal_tac destructure_hyps - in - (loop concl) gl + let goal_tac = + try + let dec = decidability t in + Tacticals.New.tclTHEN + (Proofview.V82.tactic (Tactics.refine + (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))) + intro + with Undecidable -> Tactics.elim_type (build_coq_False ()) + in + Tacticals.New.tclTHEN goal_tac destructure_hyps + in + (loop concl) + end -let destructure_goal = all_time (destructure_goal) +let destructure_goal = destructure_goal -let omega_solver gl = +let omega_solver = + Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *) Coqlib.check_required_library ["Coq";"omega";"Omega"]; reset_all (); - let result = destructure_goal gl in - (* if !display_time_flag then begin text_time (); - flush Pervasives.stdout end; *) - result + destructure_goal diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index b2a5b5dc..46bbe2fd 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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)) + | s -> Errors.error ("No Omega knowledge base for type "^s)) + (Util.List.sort_uniquize String.compare l) in - tclTHEN - (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) - omega_solver + Tacticals.New.tclTHEN + (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs)) + (omega_solver) TACTIC EXTEND omega @@ -39,7 +40,7 @@ END TACTIC EXTEND omega' | [ "omega" "with" ne_ident_list(l) ] -> - [ omega_tactic (List.map Names.string_of_id l) ] + [ omega_tactic (List.map Names.Id.to_string l) ] | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 94ce4d50..67a1ff96 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bigint -> bool val less_than : bigint -> bigint -> bool val add : bigint -> bigint -> bigint val sub : bigint -> bigint -> bigint @@ -34,26 +33,26 @@ 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 +module MakeOmegaSolver (I:INT) = struct + +type bigint = I.bigint +let (=?) = I.equal +let (?) x y = I.less_than y x +let (>=?) x y = I.less_than y x || x = y +let (+) = I.add +let (-) = I.sub +let ( * ) = I.mult +let (/) x y = fst (I.euclid x y) +let (mod) x y = snd (I.euclid x y) +let zero = I.zero +let one = I.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 +let negone = I.neg one +let abs x = if I.less_than x zero then I.neg x else x +let string_of_bigint = I.to_string +let neg = I.neg (* To ensure that polymorphic (<) is not used mistakenly on big integers *) (* Warning: do not use (=) either on big int *) @@ -241,7 +240,7 @@ let add_event, history, clear_history = (fun () -> !accu), (fun () -> accu := []) -let nf_linear = Sort.list (fun x y -> x.v > y.v) +let nf_linear = List.sort (fun x y -> Pervasives.(-) y.v x.v) let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) @@ -303,16 +302,16 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = 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 + 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 + 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) + add_event (if eq_flag=EQUA || eq_flag = DISE then EXACT_DIVIDE(eq,gcd) else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); [new_eq] end else [eq] @@ -352,11 +351,11 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = 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 + 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 + 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 @@ -368,9 +367,9 @@ let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e, if !debug then display_system print_var (e::other); try let v,def = chop_factor_1 e.body in - (Util.list_map_append + (Util.List.map_append (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, - Util.list_map_append + 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) @@ -474,7 +473,7 @@ let select_variable system = Hashtbl.iter (fun v ({contents = c}) -> incr var_cpt; - if c add_event (HYP e)) system; - let system = Util.list_map_append normalize system in + 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 @@ -547,30 +546,30 @@ 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 + if Int.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 + if Int.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 + if Int.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 + if Int.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 + if Int.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 + if Int.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 + if Int.List.mem e relie_on then depend (e1.id::e2::relie_on) (act::accu) l else depend relie_on accu l @@ -586,15 +585,6 @@ let rec depend relie_on accu = function 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 ()))) @@ -658,7 +648,7 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = | ([],ineqs,expl_map) -> ineqs,expl_map in try - let system = Util.list_map_append normalize system in + 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 @@ -674,7 +664,7 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = 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 dc,_ = List.partition (fun (_,id,_) -> Int.List.mem id relie_on) decomp in let red = List.map (fun (x,_,_) -> x) dc in (red,relie_on,decomp,path)) sys_exploded @@ -699,14 +689,16 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = | [] -> 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 remove_int (dep,ro,dc,pa) = + (Util.List.except Int.equal id dep,ro,dc,pa) + in + let s1' = List.map remove_int s1 in + let s2' = List.map remove_int 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 + let (eq,id1,id2) = Int.List.assoc id explode_map in + [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], + eq.id :: Util.List.union Int.equal relie1 relie2 with FULL_SOLUTION (x0,x1) -> (x0,x1) in let act,relie_on = solve all_solutions in diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget index 787995ed..d8752f8b 100644 --- a/plugins/pluginsbyte.itarget +++ b/plugins/pluginsbyte.itarget @@ -1,4 +1,4 @@ -field/field_plugin.cma +btauto/btauto_plugin.cma setoid_ring/newring_plugin.cma extraction/extraction_plugin.cma decl_mode/decl_mode_plugin.cma @@ -8,9 +8,6 @@ fourier/fourier_plugin.cma romega/romega_plugin.cma omega/omega_plugin.cma micromega/micromega_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 @@ -21,3 +18,4 @@ syntax/r_syntax_plugin.cma syntax/string_syntax_plugin.cma syntax/z_syntax_plugin.cma quote/quote_plugin.cma +derive/derive_plugin.cma \ No newline at end of file diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget index bd3cec01..220e5182 100644 --- a/plugins/pluginsdyn.itarget +++ b/plugins/pluginsdyn.itarget @@ -1,3 +1,4 @@ +btauto/btauto_plugin.cmxs field/field_plugin.cmxs setoid_ring/newring_plugin.cmxs extraction/extraction_plugin.cmxs @@ -8,7 +9,6 @@ fourier/fourier_plugin.cmxs romega/romega_plugin.cmxs omega/omega_plugin.cmxs micromega/micromega_plugin.cmxs -xml/xml_plugin.cmxs subtac/subtac_plugin.cmxs ring/ring_plugin.cmxs cc/cc_plugin.cmxs @@ -21,3 +21,4 @@ syntax/r_syntax_plugin.cmxs syntax/string_syntax_plugin.cmxs syntax/z_syntax_plugin.cmxs quote/quote_plugin.cmxs +derive/derive_plugin.cmxs diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget index 5264ba37..04a1e711 100644 --- a/plugins/pluginsopt.itarget +++ b/plugins/pluginsopt.itarget @@ -1,4 +1,4 @@ -field/field_plugin.cmxa +btauto/btauto_plugin.cmxa setoid_ring/newring_plugin.cmxa extraction/extraction_plugin.cmxa decl_mode/decl_mode_plugin.cmxa @@ -8,9 +8,6 @@ fourier/fourier_plugin.cmxa romega/romega_plugin.cmxa omega/omega_plugin.cmxa micromega/micromega_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 @@ -21,3 +18,4 @@ syntax/r_syntax_plugin.cmxa syntax/string_syntax_plugin.cmxa syntax/z_syntax_plugin.cmxa quote/quote_plugin.cmxa +derive/derive_plugin.cmxa diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget index bab15ad0..a59bf29c 100644 --- a/plugins/pluginsvo.itarget +++ b/plugins/pluginsvo.itarget @@ -1,12 +1,12 @@ -field/vo.otarget +btauto/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 +derive/vo.otarget \ No newline at end of file diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v index 92e5c75c..ca1a18e8 100644 --- a/plugins/quote/Quote.v +++ b/plugins/quote/Quote.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* k)) in - let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in - let tac = <:tactic> in - Tacinterp.interp tac +DECLARE PLUGIN "quote_plugin" + +let loc = Loc.ghost +let cont = (loc, Id.of_string "cont") +let x = (loc, Id.of_string "x") + +let make_cont (k : glob_tactic_expr) (c : Constr.t) = + let c = Tacinterp.Value.of_constr c in + let tac = TacCall (loc, ArgVar cont, [Reference (ArgVar x)]) in + let tac = TacLetIn (false, [(cont, Tacexp k)], TacArg (loc, tac)) in + let ist = { lfun = Id.Map.singleton (snd x) c; extra = TacStore.empty; } in + Tacinterp.eval_tactic_ist ist tac TACTIC EXTEND quote [ "quote" ident(f) ] -> [ quote f [] ] diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 48c67089..637e0e28 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + | Ind((sp,0),u) -> let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in - mkApp (mkConstruct ((sp,0),i+1), argsi) + mkApp (mkConstructU (((sp,0),i+1),u), argsi) | _ -> i_can't_do_that () (*s This function builds the pattern from the RHS. Recursive calls are @@ -208,29 +207,29 @@ let compute_lhs typ i nargsi = let compute_rhs bodyi index_of_f = let rec aux c = match kind_of_term c with - | App (j, args) when isRel j && destRel j = index_of_f (* recursive call *) -> - let i = destRel (array_last args) in + | App (j, args) when isRel j && Int.equal (destRel j) 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) + PApp (snd (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> snd (pattern_of_constr Evd.empty c) + | _ -> snd (pattern_of_constr (Global.env())(*FIXME*) 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 e when Errors.noncritical e -> i_can't_do_that () - in - let body = Environ.constant_value (Global.env()) cst in +let compute_ivs f cs gl = + let cst = try destConst f with DestKO -> i_can't_do_that () in + let body = Environ.constant_value_in (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 + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let is_conv = Reductionops.is_conv env sigma 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) @@ -243,14 +242,13 @@ let compute_ivs gl f cs = (* 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 isRel bodyi && destRel bodyi = 1 then + if isRel bodyi && Int.equal (destRel bodyi) 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 + when isRel a3 && isRel a4 && is_conv vmf (Lazy.force coq_varmap_find)-> v_lhs := Some (compute_lhs (snd (List.hd args3)) @@ -264,7 +262,7 @@ let compute_ivs gl f cs = end) lci; - if !c_lhs = None & !v_lhs = None then i_can't_do_that (); + if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that (); (* The Cases predicate is a lambda; we assume no dependency *) let p = match kind_of_term p with @@ -299,10 +297,10 @@ binary search trees (see file \texttt{Quote.v}) *) and variables (open terms) *) let rec closed_under cset t = - (ConstrSet.mem t cset) or + (ConstrSet.mem t cset) || (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 + | 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 @@ -342,8 +340,8 @@ 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)) + if Int.equal n 1 then [] + else (Int.equal (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 @@ -361,9 +359,9 @@ let path_of_int n = (* 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 + (pf_conv_x gl t t') || (match (kind_of_term t) with - | App (f,args) -> array_exists (fun t -> subterm gl t t') args + | App (f,args) -> Array.exists (fun t -> subterm gl t t') args | Cast(t,_,_) -> (subterm gl t t') | _ -> false) @@ -393,7 +391,7 @@ module Constrhash = Hashtbl.Make [ivs : inversion_scheme]\\ [lc: constr list]\\ [gl: goal sigma]\\ *) -let quote_terms ivs lc gl = +let quote_terms ivs lc = Coqlib.check_required_library ["Coq";"quote";"Quote"]; let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) @@ -403,7 +401,7 @@ let quote_terms ivs lc gl = match l with | (lhs, rhs)::tail -> begin try - let s1 = matches rhs c in + let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty 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 @@ -414,7 +412,7 @@ let quote_terms ivs lc gl = | None -> begin match ivs.constant_lhs with | Some c_lhs -> Termops.subst_meta [1, c] c_lhs - | None -> anomaly "invalid inversion scheme for quote" + | None -> anomaly (Pp.str "invalid inversion scheme for quote") end | Some var_lhs -> begin match ivs.constant_lhs with @@ -440,36 +438,43 @@ let quote_terms ivs lc gl = 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 )) + (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 +let quote f lid = + Proofview.Goal.nf_enter begin fun gl -> + let f = Tacmach.New.pf_global f gl in + let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + let ivs = compute_ivs f cl gl in + let concl = Proofview.Goal.concl gl in + let quoted_terms = quote_terms ivs [concl] in + let (p, vm) = match quoted_terms with + | [p], vm -> (p,vm) + | _ -> assert false + in + match ivs.variable_lhs with + | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast + | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast + end + +let gen_quote cont c f lid = + Proofview.Goal.nf_enter begin fun gl -> + let f = Tacmach.New.pf_global f gl in + let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + let ivs = compute_ivs f cl gl in + let quoted_terms = quote_terms ivs [c] in + let (p, vm) = match quoted_terms 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 + | None -> cont (mkApp (f, [| p |])) + | Some _ -> cont (mkApp (f, [| vm; p |])) + end (*i diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v deleted file mode 100644 index 0d92973e..00000000 --- a/plugins/ring/LegacyArithRing.v +++ /dev/null @@ -1,88 +0,0 @@ -(************************************************************************) -(* 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) - | |- (?X1 = ?X2) => - try - let t1 := - (**) (**) - rewrite_S_to_plus_term X1 - with t2 := rewrite_S_to_plus_term X2 in - change (t1 = t2) - end. - -Ltac ring_nat := rewrite_S_to_plus; ring. diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v deleted file mode 100644 index b358251a..00000000 --- a/plugins/ring/LegacyNArithRing.v +++ /dev/null @@ -1,43 +0,0 @@ -(************************************************************************) -(* 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 N.compare_eq. - destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ]. -Qed. - -Definition NTheory : Semi_Ring_Theory N.add N.mul 1%N 0%N Neq. - split. - apply N.add_comm. - apply N.add_assoc. - apply N.mul_comm. - apply N.mul_assoc. - apply N.add_0_l. - apply N.mul_1_l. - apply N.mul_0_l. - apply N.mul_add_distr_r. - apply Neq_prop. -Qed. - -Add Legacy Semi Ring - N N.add N.mul 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 deleted file mode 100644 index 31b7cd7c..00000000 --- a/plugins/ring/LegacyRing.v +++ /dev/null @@ -1,35 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* b) eqb. -split; simpl. -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; 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 deleted file mode 100644 index 8f07ad26..00000000 --- a/plugins/ring/LegacyRing_theory.v +++ /dev/null @@ -1,374 +0,0 @@ -(************************************************************************) -(* 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 ; eauto. Qed. - -Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). -symmetry ; eauto. Qed. - -Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n. -symmetry ; eauto. Qed. - -Lemma SR_mult_one_left2 : forall n:A, n = 1 * n. -symmetry ; eauto. Qed. - -Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n. -symmetry ; eauto. Qed. - -Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. -symmetry ; 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 ; 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 ; eauto. Qed. - -Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). -symmetry ; eauto. Qed. - -Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n. -symmetry ; eauto. Qed. - -Lemma Th_mult_one_left2 : forall n:A, n = 1 * n. -symmetry ; eauto. Qed. - -Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. -symmetry ; eauto. Qed. - -Lemma Th_opp_def2 : forall n:A, 0 = n + - n. -symmetry ; 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. -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 ; 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 ; 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 ; 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 ; 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 ; 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; 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 deleted file mode 100644 index 472c91b4..00000000 --- a/plugins/ring/LegacyZArithRing.v +++ /dev/null @@ -1,35 +0,0 @@ -(************************************************************************) -(* 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 Z.compare_eq. - destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ]. -Qed. - -Definition ZTheory : Ring_Theory Z.add Z.mul 1%Z 0%Z Z.opp Zeq. - split; intros; eauto with zarith. - apply Zeq_prop; assumption. -Qed. - -(* NatConstants and NatTheory are defined in Ring_theory.v *) -Add Legacy Ring Z Z.add Z.mul 1%Z 0%Z Z.opp Zeq ZTheory - [ Zpos Zneg 0%Z xO xI 1%positive ]. diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v deleted file mode 100644 index 4aec3893..00000000 --- a/plugins/ring/Ring_abstract.v +++ /dev/null @@ -1,700 +0,0 @@ -(************************************************************************) -(* 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 eq_refl eq_sym eq_trans. -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; 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; intros. - elim (varlist_lt l v); simpl. - 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; elim (varlist_lt v v0); simpl. - repeat rewrite iacs_aux_ok. - rewrite H; simpl; auto. - - simpl in H0. - repeat rewrite iacs_aux_ok. - rewrite H0. simpl; 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; eauto. - - simpl; 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; eauto. - - destruct y as [| v0 a0]; intros. - - simpl; rewrite H; eauto. - - unfold abstract_sum_prod; fold abstract_sum_prod. - rewrite abstract_sum_merge_ok. - rewrite abstract_sum_scalar_ok. - rewrite H; simpl; auto. -Qed. - -Theorem aspolynomial_normalize_ok : - forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x). -Proof. - simple induction x; simpl; 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 eq_refl eq_sym eq_trans. -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; intros. - trivial. - reflexivity. - reflexivity. -Qed. - -Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core. - -Ltac solve1 v v0 H H0 := - simpl; elim (varlist_lt v v0); simpl; rewrite isacs_aux_ok; - [ rewrite H; simpl; 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; auto. - - simple induction y; intros. - - auto. - - solve1 v v0 H H0. - - simpl; generalize (varlist_eq_prop v v0). - elim (varlist_eq v v0); simpl. - - 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; generalize (varlist_eq_prop v v0). - elim (varlist_eq v v0); simpl. - - 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; 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; intros. - solve2 l v H. - - simpl; intros. - generalize (varlist_eq_prop l v). - elim (varlist_eq l v); simpl. - - 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; intros. - generalize (varlist_eq_prop l v). - elim (varlist_eq l v); simpl. - - 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; intros. - solve2 l v H. - - simpl; 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; intros. - - symmetry ; 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; 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; 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; intros. - - rewrite (Th_mult_zero_right T); symmetry ; apply (Th_opp_zero T). - - simpl; 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; 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; eauto 1. - - intros; simpl. - rewrite signed_sum_merge_ok. - rewrite plus_sum_scalar_ok. - repeat rewrite isacs_aux_ok. - rewrite H. - auto. - - intros; simpl. - 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; 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 deleted file mode 100644 index 6306c4a7..00000000 --- a/plugins/ring/Ring_normalize.v +++ /dev/null @@ -1,897 +0,0 @@ -(************************************************************************) -(* 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; 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 eq_refl eq_sym eq_trans. -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; 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; 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; trivial. - simple induction y. - simpl; trivial. - simpl; intros. - elim (index_lt i i0); simpl; intros. - - repeat rewrite ivl_aux_ok. - rewrite H. simpl. - 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; 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; 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. -trivial. - -simple induction y; simpl; intros. -(* monom and nil *) -eauto. - -(* monom and monom *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl; 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. -repeat rewrite ics_aux_ok. -rewrite H; simpl; rewrite ics_aux_ok; eauto. - -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; - eauto. - -(* monom and varlist *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl; 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. -repeat rewrite ics_aux_ok. -rewrite H; simpl; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; - eauto. - -simple induction y; simpl; intros. -(* varlist and nil *) -trivial. - -(* varlist and monom *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl; 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. -repeat rewrite ics_aux_ok. -rewrite H; simpl; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; - eauto. - -(* varlist and varlist *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl; 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. -repeat rewrite ics_aux_ok. -rewrite H; simpl; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; - 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; rewrite interp_m_ok; trivial. - -simpl; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl; 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; - [ 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; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl; 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; - [ 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; trivial. - -simpl; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl; 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; - [ 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; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl; 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; - [ 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; eauto. - -simpl; 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; 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; trivial. - -simpl; 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; 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; repeat rewrite (SR_mult_zero_right T); reflexivity. - -simpl; 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; 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; 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 . -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; 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; 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. -generalize (SR_eq_prop T a Aone). -elim (Aeq a Aone). -intro Heq; rewrite (Heq I). -simpl. -repeat rewrite ics_aux_ok. -rewrite interp_m_ok. -rewrite H. -rewrite (SR_mult_one_left T). -reflexivity. - -simpl. -repeat rewrite ics_aux_ok. -rewrite interp_m_ok. -rewrite H. -reflexivity. - -(* cons_varlist *) -simpl; 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. -rewrite canonical_sum_simplify_ok. -apply spolynomial_normalize_ok. -Qed. - -(* End properties. *) -End semi_rings. - -Arguments Cons_varlist : default implicits. -Arguments Cons_monom : default implicits. -Arguments SPconst : default implicits. -Arguments SPplus : default implicits. -Arguments SPmult : default implicits. - -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 eq_refl eq_sym eq_trans. -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; 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; intros). -rewrite H; rewrite H0; reflexivity. -rewrite H; rewrite H0; reflexivity. -rewrite H; simpl. -elim - (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var - (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0))); - [ reflexivity - | simpl; intros; rewrite H0; reflexivity - | simpl; 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. -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 deleted file mode 100644 index 4b484483..00000000 --- a/plugins/ring/Setoid_ring.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* n = m. -Proof. - simple induction n; simple induction m; simpl; - 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 eq_refl eq_sym eq_trans. -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; 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; 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; trivial. - simple induction y. - simpl; trivial. - simpl; intros. - elim (index_lt i i0); simpl; 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. - 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; 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. -trivial. - -simple induction y; simpl; intros. -eauto. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl. -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. -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. -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; - auto. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl. -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. -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. -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. -auto. - -simple induction y; simpl; intros. -trivial. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl. -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; 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. -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; auto. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0); intros. -rewrite (H1 I); simpl. -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. -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. -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; 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; rewrite (interp_m_ok a l); trivial. - -simpl; generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl. -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; 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. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl. -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; 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; intros. -trivial. - -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl. -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; 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. -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; 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; 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; 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; 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; 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; 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; intros. -trivial. - -generalize (SSR_eq_prop T a Azero). -elim (Aeq a Azero). -simpl. -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. -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. -rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). -rewrite H. -auto. - -simpl. -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. -rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)). -exact (setspolynomial_normalize_ok p). -Qed. - -End semi_setoid_rings. - -Arguments Cons_varlist : default implicits. -Arguments Cons_monom : default implicits. -Arguments SetSPconst : default implicits. -Arguments SetSPplus : default implicits. -Arguments SetSPmult : default implicits. - - - -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 eq_refl eq_sym eq_trans. -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; 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; intros. -rewrite H; rewrite H0; reflexivity. -rewrite H; rewrite H0; reflexivity. -rewrite H; simpl. -elim - (canonical_sum_scalar3 (Aopp Aone) Nil_var - (setspolynomial_normalize (setspolynomial_of s))); - [ reflexivity - | simpl; intros; rewrite H0; reflexivity - | simpl; 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. -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 deleted file mode 100644 index bb88f646..00000000 --- a/plugins/ring/Setoid_ring_theory.v +++ /dev/null @@ -1,425 +0,0 @@ -(************************************************************************) -(* 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; 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 deleted file mode 100644 index f2e904b1..00000000 --- a/plugins/ring/g_ring.ml4 +++ /dev/null @@ -1,134 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index db88a05c..00000000 --- a/plugins/ring/ring.ml +++ /dev/null @@ -1,928 +0,0 @@ -(************************************************************************) -(* 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 = (RefOrdered.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 = constr_ord 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 : constr * theory -> obj = - 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 e when Errors.noncritical e -> 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 - -*) - -module Constrhash = Hashtbl.Make - (struct type t = constr - let equal = eq_constr - let hash = hash_constr - end) - -let build_spolynom gl th lc = - let varhash = (Constrhash.create 17 : constr Constrhash.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 Constrhash.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; - Constrhash.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 = (Constrhash.create 17 : constr Constrhash.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 Z.sub *) - | 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 Constrhash.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; - Constrhash.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 = (Constrhash.create 17 : constr Constrhash.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 Constrhash.find varhash c - with Not_found -> - let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in - begin - incr counter; - varlist := c :: !varlist; - Constrhash.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 = (Constrhash.create 17 : constr Constrhash.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 Z.sub *) - | 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 Constrhash.find varhash c - with Not_found -> - let newvar = - mkLApp(coq_APvar, [| path_of_int !counter |]) in - begin - incr counter; - varlist := c :: !varlist; - Constrhash.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 = (Constrhash.create 17 : constr Constrhash.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 Z.sub *) - | 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 Constrhash.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; - Constrhash.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 = (Constrhash.create 17 : constr Constrhash.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 Constrhash.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; - Constrhash.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 true false c'i_eq_c''i) - (Equality.general_rewrite false - Termops.all_occurrences true 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 deleted file mode 100644 index 3c5f995f..00000000 --- a/plugins/ring/ring_plugin.mllib +++ /dev/null @@ -1,3 +0,0 @@ -Ring -G_ring -Ring_plugin_mod diff --git a/plugins/ring/vo.itarget b/plugins/ring/vo.itarget deleted file mode 100644 index da387be8..00000000 --- a/plugins/ring/vo.itarget +++ /dev/null @@ -1,10 +0,0 @@ -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/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index ab424c22..b84cf254 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -980,9 +980,9 @@ Inductive p_step : Set := | 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. +(* List of normalizations to perform : if the type [p_step] had a constructor + that indicated visiting both left and right branches, we would be able to + restrict ourselves to the case of 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. *) @@ -990,7 +990,7 @@ 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 +(* This type allows navigation 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 conjunction with possibly the right level of negations. *) @@ -1000,7 +1000,7 @@ Inductive direction : Set := | D_right : direction | D_mono : direction. -(* This type allows to extract useful components from hypothesis, either +(* This type allows extracting 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] *) @@ -1014,7 +1014,7 @@ Inductive e_step : Set := (* 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 : + Then we prove two theorem allowing elimination of such equalities : \begin{verbatim} (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. @@ -1284,7 +1284,7 @@ Qed. (* Extraire une hypothèse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. - +Unset Printing Notations. 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). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index fb45e816..21b0f78b 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -1,7 +1,7 @@ (************************************************************************* PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D + Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) @@ -19,27 +19,27 @@ let meaningful_submodule = [ "Z"; "N"; "Pos" ] let string_of_global r = let dp = Nametab.dirpath_of_global r in - let prefix = match Names.repr_dirpath dp with + let prefix = match Names.DirPath.repr dp with | [] -> "" | m::_ -> - let s = Names.string_of_id m in - if List.mem s meaningful_submodule then s^"." else "" + let s = Names.Id.to_string m in + if Util.String.List.mem s meaningful_submodule then s^"." else "" in - prefix^(Names.string_of_id (Nametab.basename_of_global r)) + prefix^(Names.Id.to_string (Nametab.basename_of_global r)) let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with - | Term.Const sp, args -> - Kapp (string_of_global (Libnames.ConstRef sp), args) - | Term.Construct csp , args -> - Kapp (string_of_global (Libnames.ConstructRef csp), args) - | Term.Ind isp, args -> - Kapp (string_of_global (Libnames.IndRef isp), args) - | Term.Var id,[] -> Kvar(Names.string_of_id id) + | Term.Const (sp,_), args -> + Kapp (string_of_global (Globnames.ConstRef sp), args) + | Term.Construct (csp,_) , args -> + Kapp (string_of_global (Globnames.ConstructRef csp), args) + | Term.Ind (isp,_), args -> + Kapp (string_of_global (Globnames.IndRef isp), args) + | Term.Var id,[] -> Kvar(Names.Id.to_string id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) | Term.Prod (Names.Name _,_,_),[] -> - Util.error "Omega: Not a quantifier-free goal" + Errors.error "Omega: Not a quantifier-free goal" | _ -> Kufo exception Destruct @@ -48,9 +48,9 @@ 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 + | Term.Const (sp,_) -> Globnames.ConstRef sp + | Term.Construct (csp,_) -> Globnames.ConstructRef csp + | Term.Ind (isp,_) -> Globnames.IndRef isp | _ -> raise Destruct in Nametab.basename_of_global ref, args @@ -71,7 +71,6 @@ let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module (* 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") @@ -211,19 +210,31 @@ let rec mk_nat = function (* Lists *) -let coq_cons = lazy (constant "cons") -let coq_nil = lazy (constant "nil") +let mkListConst c = + let r = + Coqlib.gen_reference "" ["Init";"Datatypes"] c + in + let inst = + if Global.is_polymorphic r then fun u -> Univ.Instance.of_array [|u|] + else fun _ -> Univ.Instance.empty + in + fun u -> Term.mkConstructU (Globnames.destConstructRef r, inst u) + +let coq_cons univ typ = Term.mkApp (mkListConst "cons" univ, [|typ|]) +let coq_nil univ typ = Term.mkApp (mkListConst "nil" univ, [|typ|]) -let mk_list typ l = +let mk_list univ typ l = let rec loop = function - | [] -> - Term.mkApp (Lazy.force coq_nil, [|typ|]) + | [] -> coq_nil univ typ | (step :: l) -> - Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in + Term.mkApp (coq_cons univ typ, [| step; loop l |]) in loop l -let mk_plist l = mk_list Term.mkProp l +let mk_plist = + let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in + fun l -> mk_list type1lev Term.mkProp l +let mk_list = mk_list Univ.Level.set let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l @@ -297,13 +308,13 @@ let coq_Zneg = lazy (bin_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 + match Names.Id.to_string 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 + match Names.Id.to_string f,l with "Zpos",[t] -> loop t | "Zneg",[t] -> Bigint.neg (loop t) | "Z0",[] -> Bigint.zero @@ -353,7 +364,7 @@ let parse_rel gl t = let is_scalar t = let rec aux t = match destructurate t with - | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 & aux t2 + | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 && aux t2 | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true | _ -> false in diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index b8db71e4..af50ea0f 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -1,7 +1,7 @@ (************************************************************************* PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D + Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) @@ -117,6 +117,7 @@ val do_seq : Term.constr -> Term.constr -> Term.constr val do_list : Term.constr list -> Term.constr val mk_nat : int -> Term.constr +(** Precondition: the type of the list is in Set *) 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 diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 2db86e00..0a99a26b 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -1,15 +1,16 @@ (************************************************************************* PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D + Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) +(*i camlp4deps: "grammar/grammar.cma" i*) + +DECLARE PLUGIN "romega_plugin" open Refl_omega -open Refiner let romega_tactic l = let tacs = List.map @@ -18,17 +19,17 @@ let romega_tactic l = | "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)) + | s -> Errors.error ("No ROmega knowledge base for type "^s)) + (Util.List.sort_uniquize String.compare l) in - tclTHEN - (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) - (tclTHEN + Tacticals.New.tclTHEN + (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs))) + (Tacticals.New.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) + (Tactics.intros) + (Proofview.V82.tactic total_reflexive_omega_tactic)) TACTIC EXTEND romega @@ -37,6 +38,6 @@ END TACTIC EXTEND romega' | [ "romega" "with" ne_ident_list(l) ] -> - [ romega_tactic (List.map Names.string_of_id l) ] + [ romega_tactic (List.map Names.Id.to_string l) ] | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index e57230cb..8156e841 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -1,11 +1,12 @@ (************************************************************************* PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D + Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) +open Pp open Util open Const_omega module OmegaSolver = Omega.MakeOmegaSolver (Bigint) @@ -16,7 +17,7 @@ open OmegaSolver let debug = ref false let show_goal gl = - if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl + if !debug then (); Tacticals.tclIDTAC gl let pp i = print_int i; print_newline (); flush stdout @@ -37,9 +38,13 @@ type direction = Left of int | Right of int 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} +let occ_step_eq s1 s2 = match s1, s2 with +| O_left, O_left | O_right, O_right | O_mono, O_mono -> true +| _ -> false + +(* 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.Id.t; o_path : occ_path} (* \subsection{refiable formulas} *) type oformula = @@ -58,7 +63,7 @@ type 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 +(* Type des prédicats réifiés (fragment de calcul propositionnel. Les * quantifications sont externes au langage) *) type oproposition = Pequa of Term.constr * oequation @@ -70,19 +75,19 @@ type oproposition = | Pimp of int * oproposition * oproposition | Pprop of Term.constr -(* Les équations ou proposiitions atomiques utiles du calcul *) +(* 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_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 *) + 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} @@ -101,8 +106,8 @@ type environment = { 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 *) + (* 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; @@ -110,35 +115,35 @@ type environment = { } (* \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 *) + 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 *) +(* 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 + (* 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 *) +(* 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__" +(* 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 *) +(* 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; @@ -146,29 +151,28 @@ let new_environment () = { constructors = Hashtbl.create 7; } -(* Génération d'un nom d'équation *) +(* 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 *) +(* Calcul de la branche complémentaire *) let barre = function Left x -> Right x | Right x -> Left x -(* Identifiant associé à une branche *) +(* Identifiant associé à une branche *) let indice = function Left x | Right x -> x -(* Affichage de l'environnement de réification (termes et propositions) *) +(* 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" + [] -> str " ===============================\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 - + let s = Printf.sprintf "(%c%02d)" c i in + spc () ++ str s ++ str " := " ++ Printer.pr_lconstr t ++ fnl () ++ + loop c (succ i) l + in + let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in + let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in + msg_debug (prop_info ++ fnl () ++ term_info) (* \subsection{Gestion des environnements de variable pour Omega} *) (* generation d'identifiant d'equation pour Omega *) @@ -185,75 +189,73 @@ let new_omega_var, rst_omega_var = (function () -> incr cpt; !cpt), (function () -> cpt:=0) -(* Affichage des variables d'un système *) +(* 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 +(* 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 + begin try List.assoc_f Pervasives.(=) t env.om_vars (* FIXME *) 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 *) +(* 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 *) +(* 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 + | ((t,j)::l) -> if Int.equal id j then t else loop l in loop env.om_vars -(* \subsection{Gestion des environnements de variable pour la réflexion} +(* \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 + 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_f Term.eq_constr t env.terms + try List.index0 Term.eq_constr 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 e when Errors.noncritical e -> failwith "get_reified_atom" + try List.nth env.terms with Invalid_argument _ -> 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_f Term.eq_constr t env.props + try List.index0 Term.eq_constr t env.props with Not_found -> let i = List.length env.props in env.props <- env.props @ [t]; i -(* accès a une proposition *) +(* accès a une proposition *) let get_prop v env = - try List.nth v env - with e when Errors.noncritical e -> failwith "get_prop" + try List.nth v env with Invalid_argument _ -> failwith "get_prop" -(* \subsection{Gestion du nommage des équations} *) +(* \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 *) +(* accès a une equation *) let get_equation env id = try Hashtbl.find env.equations id with Not_found as e -> - Printf.printf "Omega Equation %d non trouvée\n" id; raise e + Printf.printf "Omega Equation %d non trouvée\n" id; raise e -(* Affichage des termes réifiés *) +(* 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 @@ -287,7 +289,7 @@ let rec weight env = function | Oufo _ -> -1 | Oatom _ as c -> (intern_omega env c) -(* \section{Passage entre oformules et représentation interne de Omega} *) +(* \section{Passage entre oformules et représentation interne de Omega} *) (* \subsection{Oformula vers Omega} *) @@ -305,7 +307,7 @@ let omega_of_oformula env kind = (* \subsection{Omega vers Oformula} *) -let rec oformula_of_omega env af = +let oformula_of_omega env af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) @@ -316,7 +318,7 @@ let app f v = mkApp(Lazy.force f,v) (* \subsection{Oformula vers COQ reel} *) -let rec coq_of_formula env t = +let 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 |] @@ -330,12 +332,12 @@ let rec coq_of_formula env t = | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in loop t -(* \subsection{Oformula vers COQ reifié} *) +(* \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; + 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 @@ -388,7 +390,7 @@ let reified_of_proposition env f = try reified_of_proposition env f with reraise -> pprint stderr f; raise reraise -(* \subsection{Omega vers COQ réifié} *) +(* \subsection{Omega vers COQ réifié} *) let reified_of_omega env body constant = let coeff_constant = @@ -402,21 +404,18 @@ let reified_of_omega env body constant = List.fold_right mk_coeff body coeff_constant let reified_of_omega env body c = - try - reified_of_omega env body c - with reraise -> - display_eq display_omega_var (body,c); raise reraise + try reified_of_omega env body c + with reraise -> display_eq display_omega_var (body,c); raise reraise +(* \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. *) -(* \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 *) -(* \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 (@@) = List.merge_uniq compare let rec vars_of_formula = function | Oint _ -> [] @@ -455,7 +454,7 @@ let rec scalar n = function | 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" + Errors.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)) @@ -474,23 +473,23 @@ let rec negate = function | 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" + Errors.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) +let norm l = (List.length l) -(* \subsection{Mélange (fusion) de deux équations} *) +(* \subsection{Mélange (fusion) de deux équations} *) (* \subsubsection{Version avec coefficients} *) -let rec shuffle_path k1 e1 k2 e2 = +let 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 ( + if Int.equal v1 v2 then + if Bigint.equal (k1 * c1 + k2 * c2) zero then ( Lazy.force coq_f_cancel :: loop (l1,l2)) else ( Lazy.force coq_f_equal :: loop (l1,l2) ) @@ -532,7 +531,7 @@ let rec shuffle env (t1,t2) = do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) else do_list [],Oplus(t1,t2) -(* \subsection{Fusion avec réduction} *) +(* \subsection{Fusion avec réduction} *) let shrink_pair f1 f2 = begin match f1,f2 with @@ -546,7 +545,7 @@ let shrink_pair f1 f2 = 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" + flush Pervasives.stdout; Errors.error "shrink.1" end (* \subsection{Calcul d'une sous formule constante} *) @@ -560,15 +559,15 @@ let reduce_factor = function let rec compute = function Oint n -> n | Oplus(t1,t2) -> compute t1 + compute t2 - | _ -> Util.error "condense.1" in + | _ -> Errors.error "condense.1" in [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) - | t -> Util.error "reduce_factor.1" + | t -> Errors.error "reduce_factor.1" -(* \subsection{Réordonnancement} *) +(* \subsection{Réordonnancement} *) let rec condense env = function Oplus(f1,(Oplus(f2,r) as t)) -> - if weight env f1 = weight env f2 then begin + if Int.equal (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 @@ -582,7 +581,7 @@ let rec condense env = function 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 + if Int.equal (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' @@ -597,18 +596,18 @@ let rec condense env = function let final = Oplus(t',Oint zero) in tac @ [Lazy.force coq_c_red6], final -(* \subsection{Elimination des zéros} *) +(* \subsection{Elimination des zéros} *) let rec clear_zero = function - Oplus(Omult(Oatom v,Oint n),r) when n=zero -> + Oplus(Omult(Oatom v,Oint n),r) when Bigint.equal 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) + (if List.is_empty tac then [] else [do_right (do_list tac)]),Oplus(f,t) | t -> [],t;; -(* \subsection{Transformation des hypothèses} *) +(* \subsection{Transformation des hypothèses} *) let rec reduce env = function Oplus(t1,t2) -> @@ -643,7 +642,7 @@ let normalize_linear_term env t = 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] *) +(* 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 @@ -669,7 +668,7 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = INEQ with e when Logic.catchable_exception e -> raise e -(* \section{Compilation des hypothèses} *) +(* \section{Compilation des hypothèses} *) let rec oformula_of_constr env t = match Z.parse_term t with @@ -698,7 +697,7 @@ and binprop env (neg2,depends,origin,path) 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. *) + (* On numérote le connecteur dans l'environnement. *) c i t1' t2' and mk_equation env ctxt c connector t1 t2 = @@ -737,7 +736,7 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = (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 *) +(* Destructuration des hypothèses et de la conclusion *) let reify_gl env gl = let concl = Tacmach.pf_concl gl in @@ -751,7 +750,7 @@ let reify_gl env gl = (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); + Printf.printf " %s: " (Names.Id.to_string i); pprint stdout t'; Printf.printf "\n" end; @@ -816,13 +815,13 @@ let destructurate_hyps syst = (i,t) :: l -> let l_syst1 = destructurate_pos_hyp i [] [] t in let l_syst2 = loop l in - list_cartesian (@) l_syst1 l_syst2 + List.cartesian (@) l_syst1 l_syst2 | [] -> [[]] in loop syst -(* \subsection{Affichage d'un système d'équation} *) +(* \subsection{Affichage d'un système d'équation} *) -(* Affichage des dépendances de système *) +(* 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 @@ -845,7 +844,7 @@ let display_systems syst_list = (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) + (Names.Id.to_string oformula_eq.e_origin.o_hyp) (if oformula_eq.e_negated then "yes" else "no") in let display_system syst = @@ -853,8 +852,8 @@ let display_systems syst_list = 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 *) +(* 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 -> @@ -866,9 +865,9 @@ let rec hyps_used_in_trace = function 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 *) +(* 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 -> @@ -886,7 +885,7 @@ let rec variable_stated_in_trace = function 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 *) + 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 @@ -895,15 +894,15 @@ let add_stated_equations env tree = in loop tree in let add_env st = - (* On retransforme la définition de v en formule reifiée *) + (* 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é, + (* 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 + (* 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 *) @@ -911,18 +910,18 @@ let add_stated_equations env tree = (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 *) +(* 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 + 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) + List.union Pervasives.(=) (List.rev l) (get_eclatement env r) | [] -> [] let select_smaller l = @@ -933,10 +932,14 @@ 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 if List.mem (barre x) required then raise Exit else x :: select l - | [] -> [] in - map_succeed (function (sol,splits) -> (sol,select splits)) systems + | [] -> [] + in + List.map_filter + (function (sol, splits) -> + try Some (sol, select splits) with Exit -> None) + systems let rec equas_of_solution_tree = function Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) @@ -955,7 +958,7 @@ let really_useful_prop l_equa c = | 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 ! *) + (* 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 = @@ -1015,10 +1018,10 @@ let rec solve_with_constraints all_solutions path = 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) + | (x1::l1,x2::l2) when occ_step_eq 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' -> + CCHyp{o_hyp=id';o_path=p'} :: l when Names.Id.equal id id' -> begin match loop_path (p',p) with Some r -> i,r | None -> loop_id (succ i) l @@ -1036,7 +1039,7 @@ let mk_direction_list l = (* \section{Rejouer l'historique} *) let get_hyp env_hyp i = - try list_index0 (CCEqua i) env_hyp + try List.index0 Pervasives.(=) (CCEqua i) env_hyp with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) let replay_history env env_hyp = @@ -1163,11 +1166,11 @@ and decompose_tree_hyps trace env ctxt = function (* \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 +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. *) +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 @@ -1178,7 +1181,7 @@ let resolution env full_reified_goal systems_list = simplify_strong (new_omega_eq,new_omega_var,display_omega_var) system in - (* calcule les hypotheses utilisées pour la solution *) + (* 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 @@ -1199,17 +1202,21 @@ let resolution env full_reified_goal systems_list = display_solution_tree stdout solution_tree; print_newline() end; - (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) + (* 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 l_hyps' = List.uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in + let l_hyps = id_concl :: List.remove Names.Id.equal id_concl l_hyps' in let useful_hyps = - List.map (fun id -> List.assoc id full_reified_goal) l_hyps in + List.map + (fun id -> List.assoc_f Names.Id.equal 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 + let concl_vars = + vars_of_prop (List.assoc_f Names.Id.equal id_concl full_reified_goal) + in really_useful_vars @@ concl_vars in (* variables a introduire *) @@ -1218,8 +1225,8 @@ let resolution env full_reified_goal systems_list = 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 *) + - 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 @@ -1229,7 +1236,7 @@ let resolution env full_reified_goal systems_list = | [] -> [] 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 *) + (* 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; @@ -1258,10 +1265,10 @@ let resolution env full_reified_goal systems_list = | ((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 + let i = List.index0 Names.Id.equal 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) + if Int.equal 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 = @@ -1275,8 +1282,8 @@ let resolution env full_reified_goal systems_list = 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|]) >> + Proofview.V82.of_tactic (Tactics.change_concl reified) >> + Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> show_goal >> Tactics.normalise_vm_in_concl >> (*i Alternatives to the previous line: @@ -1285,7 +1292,7 @@ let resolution env full_reified_goal systems_list = - 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) + Proofview.V82.of_tactic (Tactics.apply (Lazy.force coq_I)) let total_reflexive_omega_tactic gl = Coqlib.check_required_library ["Coq";"romega";"ROmega"]; @@ -1297,7 +1304,7 @@ let total_reflexive_omega_tactic gl = 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" + with NO_CONTRADICTION -> Errors.error "ROmega can't solve this system" (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index fbfa1bfd..267cd472 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Proof. intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push;simpl contents. +unfold index,get,push. simpl @contents. intros i e;rewrite Tget_Tadd. rewrite (Gt_Psucc _ _ e). unfold get in IHW. @@ -209,7 +209,7 @@ 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. +unfold push,index,get;simpl @contents. intros a S. rewrite Tget_Tadd. rewrite Psucc_Gt. @@ -231,12 +231,12 @@ Proof. intros i a S F. case_eq (i ?= index S). intro e;rewrite (Pos.compare_eq _ _ e). -destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. +destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. rewrite Pos.compare_refl;reflexivity. -intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. -simpl index in H;rewrite H;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. +unfold get,push;simpl. rewrite Tget_Tadd;intro e;rewrite e. change (get i S=PNone). apply get_Full_Gt;auto. @@ -260,7 +260,7 @@ 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:=Pos.succ_not_1 (index S)). +simpl @index in one;assert (h:=Pos.succ_not_1 (index S)). congruence. Qed. diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index f823cf74..61a160b2 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ Refl_tauto.rtauto_tac ] + [ "rtauto" ] -> [ Proofview.V82.tactic (Refl_tauto.rtauto_tac) ] END diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 2ace38bd..23510117 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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) +module FOrd = struct + type t = form + let rec compare x y = + match x, y with + | Bot, Bot -> 0 + | Bot, _ -> -1 + | Atom _, Bot -> 1 + | Atom a1, Atom a2 -> Int.compare a1 a2 + | Atom _, _ -> -1 + | Arrow _, (Bot | Atom _) -> 1 + | Arrow (f1, g1), Arrow (f2, g2) -> + let cmp = compare f1 f2 in + if cmp = 0 then compare g1 g2 else cmp + | Arrow _, _ -> -1 + | Conjunct _, (Bot | Atom _ | Arrow _) -> 1 + | Conjunct (f1, g1), Conjunct (f2, g2) -> + let cmp = compare f1 f2 in + if cmp = 0 then compare g1 g2 else cmp + | Conjunct _, _ -> -1 + | Disjunct _, (Bot | Atom _ | Arrow _ | Conjunct _) -> 1 + | Disjunct (f1, g1), Disjunct (f2, g2) -> + let cmp = compare f1 f2 in + if cmp = 0 then compare g1 g2 else cmp +end +module Fmap = Map.Make(FOrd) type sequent = - {rev_hyps: form Intmap.t; - norev_hyps: form Intmap.t; + {rev_hyps: form Int.Map.t; + norev_hyps: form Int.Map.t; size:int; left:int Fmap.t; right:(int*form) list Fmap.t; @@ -131,21 +146,21 @@ let add_step s sub = | 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" + | _,_ -> anomaly ~label:"add_step" (Pp.str "wrong arity") type 'a with_deps = {dep_it:'a; dep_goal:bool; - dep_hyps:Intset.t} + dep_hyps:Int.Set.t} type slice= {proofs_done:proof list; proofs_todo:sequent with_deps list; step:rule; needs_goal:bool; - needs_hyps:Intset.t; + needs_hyps:Int.Set.t; changes_goal:bool; - creates_hyps:Intset.t} + creates_hyps:Int.Set.t} type state = Complete of proof @@ -153,7 +168,7 @@ type state = let project = function Complete prf -> prf - | Incomplete (_,_) -> anomaly "not a successful state" + | Incomplete (_,_) -> anomaly (Pp.str "not a successful state") let pop n prf = let nprf= @@ -168,27 +183,27 @@ let rec fill stack proof = | slice::super -> if !pruning && - slice.proofs_done=[] && + List.is_empty slice.proofs_done && not (slice.changes_goal && proof.dep_goal) && - not (Intset.exists - (fun i -> Intset.mem i proof.dep_hyps) + not (Int.Set.exists + (fun i -> Int.Set.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 + let created_here=Int.Set.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) + (fun sum dseq -> sum + Int.Set.cardinal dseq.dep_hyps) created_here slice.proofs_todo; - fill super (pop (Intset.cardinal slice.creates_hyps) proof) + fill super (pop (Int.Set.cardinal slice.creates_hyps) proof) end else let dep_hyps= - Intset.union slice.needs_hyps - (Intset.diff proof.dep_hyps slice.creates_hyps) in + Int.Set.union slice.needs_hyps + (Int.Set.diff proof.dep_hyps slice.creates_hyps) in let dep_goal= slice.needs_goal || ((not slice.changes_goal) && proof.dep_goal) in @@ -235,7 +250,7 @@ let append stack (step,subgoals) = let embed seq= {dep_it=seq; dep_goal=false; - dep_hyps=Intset.empty} + dep_hyps=Int.Set.empty} let change_goal seq gl= {seq with @@ -270,7 +285,7 @@ let add_hyp seqwd f= cnx=cnx} | Conjunct (_,_) | Disjunct (_,_) -> {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; + rev_hyps=Int.Map.add num f seq.rev_hyps; size=num; left=left; right=right; @@ -285,14 +300,14 @@ let add_hyp seqwd f= match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; + rev_hyps=Int.Map.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; + norev_hyps=Int.Map.add num f seq.norev_hyps; size=num; left=left; right=nright; @@ -305,13 +320,13 @@ let add_hyp seqwd f= cnx=ncnx} in {seqwd with dep_it=nseq; - dep_hyps=Intset.add num seqwd.dep_hyps} + dep_hyps=Int.Set.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; + Int.Map.iter (fun i f -> raise (Here_is (i,f))) m; raise Not_found with Here_is (i,f) -> (i,f) @@ -322,11 +337,11 @@ let search_or seq= Disjunct (f1,f2) -> [{dep_it = SI_Or_l; dep_goal = true; - dep_hyps = Intset.empty}, + dep_hyps = Int.Set.empty}, [change_goal (embed seq) f1]; {dep_it = SI_Or_r; dep_goal = true; - dep_hyps = Intset.empty}, + dep_hyps = Int.Set.empty}, [change_goal (embed seq) f2]] | _ -> [] @@ -336,19 +351,19 @@ let search_norev seq= match f with Arrow (Arrow (f1,f2),f3) -> let nseq = - {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in + {seq with norev_hyps=Int.Map.remove i seq.norev_hyps} in goals:= ({dep_it=SD_Arrow(i); dep_goal=false; - dep_hyps=Intset.singleton i}, + dep_hyps=Int.Set.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; + | _ -> anomaly ~label:"search_no_rev" (Pp.str "can't happen") in + Int.Map.iter add_one seq.norev_hyps; List.rev !goals let search_in_rev_hyps seq= @@ -357,8 +372,8 @@ let search_in_rev_hyps seq= 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 + dep_hyps=Int.Set.singleton i} in + let nseq={seq with rev_hyps=Int.Map.remove i seq.rev_hyps} in match f with Conjunct (f1,f2) -> [make_step (SE_And(i)), @@ -372,7 +387,7 @@ let search_in_rev_hyps seq= | 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" + | _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen") with Not_found -> search_norev seq @@ -383,27 +398,27 @@ let search_rev seq= match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with cnx=next; - rev_hyps=Intmap.remove j seq.rev_hyps} + rev_hyps=Int.Map.remove j seq.rev_hyps} | Arrow (_,_) -> {seq with cnx=next; - norev_hyps=Intmap.remove j seq.norev_hyps} + norev_hyps=Int.Map.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)}, + dep_hyps=Int.Set.add i (Int.Set.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}, + dep_hyps=Int.Set.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; + dep_hyps=Int.Set.empty},[change_goal (embed seq) f1; change_goal (embed seq) f2]] | _ -> search_in_rev_hyps seq @@ -412,18 +427,18 @@ let search_all seq= Some i -> [{dep_it=SE_False (i); dep_goal=false; - dep_hyps=Intset.singleton i},[]] + dep_hyps=Int.Set.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},[]] + dep_hyps=Int.Set.singleton ax},[]] with Not_found -> search_rev seq let bare_sequent = embed - {rev_hyps=Intmap.empty; - norev_hyps=Intmap.empty; + {rev_hyps=Int.Map.empty; + norev_hyps=Int.Map.empty; size=0; left=Fmap.empty; right=Fmap.empty; @@ -442,7 +457,7 @@ let success= function let branching = function Incomplete (seq,stack) -> - check_for_interrupt (); + Control.check_for_interrupt (); let successors = search_all seq in let _ = match successors with @@ -450,7 +465,7 @@ let branching = function | _::next -> s_info.nd_branching<-s_info.nd_branching+List.length next in List.map (append stack) successors - | Complete prf -> anomaly "already succeeded" + | Complete prf -> anomaly (Pp.str "already succeeded") open Pp @@ -471,11 +486,11 @@ and pp_atom= function | Atom n -> int n | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" -let pr_form f = msg (pp_form f) +let pr_form f = pp_form f let pp_intmap map = let pp=ref (str "") in - Intmap.iter (fun i obj -> pp:= (!pp ++ + Int.Map.iter (fun i obj -> pp:= (!pp ++ pp_form obj ++ cut ())) map; str "{ " ++ v 0 (!pp) ++ str " }" @@ -532,7 +547,7 @@ let pp_info () = int s_info.created_branches ++ str " created" ++ fnl () ++ str "Hypotheses : " ++ int s_info.created_hyps ++ str " created" ++ fnl () in - msgnl + msg_info ( str "Proof-search statistics :" ++ fnl () ++ count_info ++ str "Branch ends: " ++ diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index 1aaafbe6..86a2fb66 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool val pp: state -> Pp.std_ppcmds -val pr_form : form -> unit +val pr_form : form -> Pp.std_ppcmds val reset_info : unit -> unit diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 7dedb44e..4ffc1f33 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* if not (Termops.dependent (mkRel 1) b) && Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) a = InProp + (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 @@ -112,25 +104,25 @@ let rec make_form atom_env gls term = make_atom atom_env (normalize term) | Cast(a,_,_) -> make_form atom_env gls a - | Ind ind -> - if ind = Lazy.force li_False then + | Ind (ind, _) -> + if Names.eq_ind ind (fst (Lazy.force li_False)) then Bot else make_atom atom_env (normalize term) - | App(hd,argv) when Array.length argv = 2 -> + | App(hd,argv) when Int.equal (Array.length argv) 2 -> begin try - let ind = destInd hd in - if ind = Lazy.force li_and then + let ind, _ = destInd hd in + if Names.eq_ind ind (fst (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 + else if Names.eq_ind ind (fst (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) + with DestKO -> make_atom atom_env (normalize term) end | _ -> make_atom atom_env (normalize term) @@ -143,7 +135,7 @@ let rec make_hyps atom_env gls lenv = function make_hyps atom_env gls (typ::lenv) rest in if List.exists (Termops.dependent (mkVar id)) lenv || (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) typ <> InProp) + (pf_env gls) (Tacmach.project gls) typ != InProp) then hrec else @@ -151,7 +143,7 @@ let rec make_hyps atom_env gls lenv = function let rec build_pos n = if n<=1 then force node_count l_xH - else if n land 1 = 0 then + else if Int.equal (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)|]) @@ -269,22 +261,21 @@ let rtauto_tac gls= let gl=pf_concl gls in let _= if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) gl <> InProp + (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] (pf_hyps gls) 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 search_fun = match Tacinterp.get_debug() with + | Tactic_debug.DebugOn 0 -> Search.debug_depth_first + | _ -> Search.depth_first + in let _ = begin reset_info (); if !verbose then - msgnl (str "Starting proof-search ..."); + msg_info (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in let prf = @@ -294,10 +285,10 @@ let rtauto_tac gls= let search_end_time = System.get_time () in let _ = if !verbose then begin - msgnl (str "Proof tree found in " ++ + msg_info (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); pp_info (); - msgnl (str "Building proof term ... ") + msg_info (str "Building proof term ... ") end in let build_start_time=System.get_time () in let _ = step_count := 0; node_count := 0 in @@ -306,11 +297,11 @@ let rtauto_tac gls= build_form formula; build_proof [] 0 prf|]) in let term= - Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in + 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 " ++ + msg_info (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ fnl () ++ str "Proof size : " ++ int !step_count ++ @@ -322,14 +313,14 @@ let rtauto_tac gls= let tac_start_time = System.get_time () in let result= if !check then - Tactics.exact_check term gls + Proofview.V82.of_tactic (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 !check then msg_info (str "Proof term type-checking is on"); if !verbose then - msgnl (str "Internal tactic executed in " ++ + msg_info (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 index 9f7db593..45fb50dc 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Proof_type.goal Tacmach.sigma -> Term.types list -> - (Names.identifier * Term.types option * Term.types) list -> - (Names.identifier * Proof_search.form) list + (Names.Id.t * Term.types option * Term.types) list -> + (Names.Id.t * Proof_search.form) list val rtauto_tac : Proof_type.tactic diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v index 92e61583..e7d0cd8e 100644 --- a/plugins/setoid_ring/ArithRing.v +++ b/plugins/setoid_ring/ArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* change (op (@Ring_polynom.PEeval - _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) + _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) lvar e1) (@Ring_polynom.PEeval - _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) + _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) lvar e2)) end end. diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v index d2ab9e0f..4de2efe3 100644 --- a/plugins/setoid_ring/Field.v +++ b/plugins/setoid_ring/Field.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* match t with + | rO => + fun _ => constr:(@FEO C) + | rI => + fun _ => constr:(@FEI C) | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEadd e1 e2) + let e2 := mkP t2 in constr:(@FEadd C e1 e2) | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEmul e1 e2) + let e2 := mkP t2 in constr:(@FEmul C e1 e2) | (rsub ?t1 ?t2) => fun _ => let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEsub e1 e2) + let e2 := mkP t2 in constr:(@FEsub C e1 e2) | (ropp ?t1) => - fun _ => let e1 := mkP t1 in constr:(FEopp e1) + fun _ => let e1 := mkP t1 in constr:(@FEopp C e1) | (rdiv ?t1 ?t2) => fun _ => let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEdiv e1 e2) + let e2 := mkP t2 in constr:(@FEdiv C e1 e2) | (rinv ?t1) => - fun _ => let e1 := mkP t1 in constr:(FEinv e1) + fun _ => let e1 := mkP t1 in constr:(@FEinv C 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) + | ?c => fun _ => let e1 := mkP t1 in constr:(@FEpow C e1 c) end | _ => fun _ => let p := Find_at t fv in constr:(@FEX C p) end - | ?c => fun _ => constr:(FEc c) + | ?c => fun _ => constr:(@FEc C c) end in f () in mkP t. -Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := + (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) + (* the tactic could be used to discriminate occurrences of an opaque *) + (* constant phi, with (phi 0) not convertible to 0 for instance *) +Ltac FFV Cst CstPow rO rI add mul sub opp div inv pow t fv := let rec TFV t fv := match Cst t with | InitialRing.NotConstant => match t with + | rO => fv + | rI => fv | (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) @@ -83,60 +95,60 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := 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 + | context [req (@FEeval ?R ?rO ?rI ?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) + req rO rI 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => req). @@ -146,33 +158,33 @@ Ltac get_FldCarrier FLD := Ltac get_RingFV FLD := FLD ltac: - (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => - FV Cst_tac Pow_tac radd rmul rsub ropp rpow). + FV Cst_tac Pow_tac r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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). + FFV Cst_tac Pow_tac r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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). + mkPolexpr C Cst_tac Pow_tac r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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). + mkFieldexpr C Cst_tac Pow_tac r0 r1 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 + (fun Cst_tac Pow_tac pre post req r0 r1 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 + let mkPol := mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow in fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). Ltac get_FEeval FLD := @@ -180,8 +192,8 @@ Ltac get_FEeval FLD := 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) + ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] => + constr:(@FEeval R r0 r1 add mul sub opp div inv C phi Cpow powphi pow) | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)" end. @@ -201,8 +213,7 @@ Ltac fold_field_cond req := Ltac simpl_PCond FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in - try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; - clear lock_def lock); + try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req; try exact I. @@ -210,8 +221,7 @@ Ltac simpl_PCond FLD := Ltac simpl_PCond_BEURK FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in - try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; - clear lock_def lock); + (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req. @@ -544,10 +554,9 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := 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 field_ok := constr:(field_ok2 _ dd_spec) in let mk_lemma lemma := constr:(lemma _ _ _ _ _ _ _ _ _ _ set ext_r inv_m afth @@ -563,7 +572,7 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := (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" + | _ => fail 4 "field: bad coefficient division specification" end | _ => fail 3 "field: bad sign specification" end diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 75d3ad86..0f5c49b0 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1,6 +1,6 @@ (************************************************************************) (* 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 : Equivalence 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 - }. +(* Field elements : R *) + +Variable R:Type. +Bind Scope R_scope with R. +Delimit Scope R_scope with ring. +Local Open Scope R_scope. + +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 : R_scope. +Notation "1" := rI : R_scope. +Infix "+" := radd : R_scope. +Infix "-" := rsub : R_scope. +Infix "*" := rmul : R_scope. +Infix "/" := rdiv : R_scope. +Notation "- x" := (ropp x) : R_scope. +Notation "/ x" := (rinv x) : R_scope. +Infix "==" := req (at level 70, no associativity) : R_scope. + +(* Equality properties *) +Variable Rsth : Equivalence 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). +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. +Add Morphism radd : radd_ext. Proof. exact (Radd_ext Reqe). Qed. +Add Morphism rmul : rmul_ext. Proof. exact (Rmul_ext Reqe). Qed. +Add Morphism ropp : ropp_ext. Proof. exact (Ropp_ext Reqe). Qed. +Add Morphism rsub : rsub_ext. Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. +Add Morphism rinv : rinv_ext. Proof. exact SRinv_ext. Qed. - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. +Let eq_trans := Setoid.Seq_trans _ _ Rsth. +Let eq_sym := Setoid.Seq_sym _ _ Rsth. +Let eq_refl := Setoid.Seq_refl _ _ Rsth. -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). +Let radd_0_l := ARadd_0_l ARth. +Let radd_comm := ARadd_comm ARth. +Let radd_assoc := ARadd_assoc ARth. +Let rmul_1_l := ARmul_1_l ARth. +Let rmul_0_l := ARmul_0_l ARth. +Let rmul_comm := ARmul_comm ARth. +Let rmul_assoc := ARmul_assoc ARth. +Let rdistr_l := ARdistr_l ARth. +Let ropp_mul_l := ARopp_mul_l ARth. +Let ropp_add := ARopp_add ARth. +Let rsub_def := ARsub_def ARth. + +Let radd_0_r := ARadd_0_r Rsth ARth. +Let rmul_0_r := ARmul_0_r Rsth ARth. +Let rmul_1_r := ARmul_1_r Rsth ARth. +Let ropp_0 := ARopp_zero Rsth Reqe ARth. +Let rdistr_r := ARdistr_r Rsth Reqe ARth. + +(* Coefficients : C *) + +Variable C: Type. +Bind Scope C_scope with C. +Delimit Scope C_scope with coef. + +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. + +Notation "0" := cO : C_scope. +Notation "1" := cI : C_scope. +Infix "+" := cadd : C_scope. +Infix "-" := csub : C_scope. +Infix "*" := cmul : C_scope. +Notation "- x" := (copp x) : C_scope. +Infix "=?" := ceqb : C_scope. +Notation "[ x ]" := (phi x) (at level 0). + +Let phi_0 := CRmorph.(morph0). +Let phi_1 := CRmorph.(morph1). + +Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef. Proof. -intros. -generalize (fun h => X (morph_eq CRmorph c1 c2 h)). -case (ceqb c1 c2); auto. +generalize (CRmorph.(morph_eq) c c'). +destruct (c =? c')%coef; auto. Qed. +(* Power coefficients : Cpow *) - (* 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). +Variable Cpow : Type. +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. - (* Useful tactics *) - 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 rpow_pow := pow_th.(rpow_pow_N). -Let eq_trans := Setoid.Seq_trans _ _ Rsth. -Let eq_sym := Setoid.Seq_sym _ _ Rsth. -Let eq_refl := Setoid.Seq_refl _ _ Rsth. +(* Polynomial expressions : (PExpr C) *) + +Bind Scope PE_scope with PExpr. +Delimit Scope PE_scope with poly. + +Notation NPEeval := (PEeval rO rI radd rmul rsub ropp phi Cp_phi rpow). +Notation "P @ l" := (NPEeval l P) (at level 10, no associativity). + +Arguments PEc _ _%coef. + +Notation "0" := (PEc 0) : PE_scope. +Notation "1" := (PEc 1) : PE_scope. +Infix "+" := PEadd : PE_scope. +Infix "-" := PEsub : PE_scope. +Infix "*" := PEmul : PE_scope. +Notation "- e" := (PEopp e) : PE_scope. +Infix "^" := PEpow : PE_scope. + +Definition NPEequiv e e' := forall l, e@l == e'@l. +Infix "===" := NPEequiv (at level 70, no associativity) : PE_scope. -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 : Type. - 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). +Instance NPEequiv_eq : Equivalence NPEequiv. +Proof. + split; red; unfold NPEequiv; intros; [reflexivity|symmetry|etransitivity]; + eauto. +Qed. + +Instance NPEeval_ext : Proper (eq ==> NPEequiv ==> req) NPEeval. +Proof. + intros l l' <- e e' He. now rewrite (He l). +Qed. + +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). -Local Hint Extern 2 (_ == _) => f_equiv. - (* additional ring properties *) -Lemma rsub_0_l : forall r, 0 - r == - r. -intros; rewrite (ARsub_def ARth);ring. +Lemma rsub_0_l r : 0 - r == - r. +Proof. +rewrite rsub_def; ring. Qed. -Lemma rsub_0_r : forall r, r - 0 == r. -intros; rewrite (ARsub_def ARth). -rewrite (ARopp_zero Rsth Reqe ARth); ring. +Lemma rsub_0_r r : r - 0 == r. +Proof. +rewrite rsub_def, ropp_0; ring. Qed. (*************************************************************************** @@ -134,452 +190,525 @@ Qed. ***************************************************************************) -Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. +Theorem rdiv_simpl p q : ~ q == 0 -> q * (p / q) == p. Proof. -intros p q H. +intros. rewrite rdiv_def. -transitivity (/ q * q * p); [ ring | idtac ]. -rewrite rinv_l; auto. +transitivity (/ q * q * p); [ ring | ]. +now rewrite rinv_l. Qed. -Hint Resolve rdiv_simpl . -Instance SRdiv_ext: Proper (req ==> req ==> req) rdiv. +Instance rdiv_ext: Proper (req ==> req ==> req) rdiv. Proof. -intros p1 p2 Ep q1 q2 Eq. -transitivity (p1 * / q1); auto. -transitivity (p2 * / q2); auto. +intros p1 p2 Ep q1 q2 Eq. now rewrite !rdiv_def, Ep, Eq. Qed. -Hint Resolve SRdiv_ext. -Lemma rmul_reg_l : forall p q1 q2, +Lemma rmul_reg_l p q1 q2 : ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. Proof. -intros p q1 q2 H EQ. -rewrite <- (@rdiv_simpl q1 p) by trivial. -rewrite <- (@rdiv_simpl q2 p) by trivial. -rewrite !rdiv_def, !(ARmul_assoc ARth). -now rewrite EQ. +intros H EQ. +assert (H' : p * (q1 / p) == p * (q2 / p)). +{ now rewrite !rdiv_def, !rmul_assoc, EQ. } +now rewrite !rdiv_simpl in H'. Qed. -Theorem field_is_integral_domain : forall r1 r2, +Theorem field_is_integral_domain r1 r2 : ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. Proof. -intros r1 r2 H1 H2. contradict H2. -transitivity (1 * r2); auto. -transitivity (/ r1 * r1 * r2); auto. -rewrite <- (ARmul_assoc ARth). -rewrite H2. -apply ARmul_0_r with (1 := Rsth) (2 := ARth). +intros H1 H2. contradict H2. +transitivity (/r1 * r1 * r2). +- now rewrite rinv_l. +- now rewrite <- rmul_assoc, H2. Qed. -Theorem ropp_neq_0 : forall r, +Theorem ropp_neq_0 r : ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. +Proof. intros. setoid_replace (- r) with (- (1) * r). - apply field_is_integral_domain; trivial. - rewrite <- (ARopp_mul_l ARth). - rewrite (ARmul_1_l ARth). - reflexivity. +- apply field_is_integral_domain; trivial. +- now rewrite <- ropp_mul_l, rmul_1_l. Qed. -Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1. -intros. -rewrite (AFdiv_def AFth). -rewrite (ARmul_comm ARth). -apply (AFinv_l AFth). -trivial. +Theorem rdiv_r_r r : ~ r == 0 -> r / r == 1. +Proof. +intros. rewrite rdiv_def, rmul_comm. now apply rinv_l. Qed. -Theorem rdiv1: forall r, r == r / 1. -intros r; transitivity (1 * (r / 1)); auto. +Theorem rdiv1 r : r == r / 1. +Proof. +transitivity (1 * (r / 1)). +- symmetry; apply rdiv_simpl. apply rI_neq_rO. +- apply rmul_1_l. Qed. -Theorem rdiv2: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r4 == 0 -> - r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4). +Theorem rdiv2 a b c d : + ~ b == 0 -> + ~ d == 0 -> + a / b + c / d == (a * d + c * b) / (b * d). Proof. -intros r1 r2 r3 r4 H H0. -assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * r4); trivial. +intros H H0. +assert (~ b * d == 0) by now apply field_is_integral_domain. +apply rmul_reg_l with (b * d); trivial. rewrite rdiv_simpl; trivial. -rewrite (ARdistr_r Rsth Reqe ARth). -apply (Radd_ext Reqe). -- transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. -- transitivity (r2 * (r4 * (r3 / r4))); auto. - transitivity (r2 * r3); auto. +rewrite rdistr_r. +apply radd_ext. +- now rewrite <- rmul_assoc, (rmul_comm d), rmul_assoc, rdiv_simpl. +- now rewrite (rmul_comm c), <- rmul_assoc, rdiv_simpl. 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)). +Theorem rdiv2b a b c d e : + ~ (b*e) == 0 -> + ~ (d*e) == 0 -> + a / (b*e) + c / (d*e) == (a * d + c * b) / (b * (d * e)). 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) +intros H H0. +assert (~ b == 0) by (contradict H; rewrite H; ring). +assert (~ e == 0) by (contradict H; rewrite H; ring). +assert (~ d == 0) by (contradict H0; rewrite H0; ring). +assert (~ b * (d * e) == 0) by (repeat apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * (r4 * r5)); trivial. +apply rmul_reg_l with (b * (d * e)); trivial. rewrite rdiv_simpl; trivial. -rewrite (ARdistr_r Rsth Reqe ARth). -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. -Proof. -intros r1 r2. -transitivity (- (r1 * / r2)); auto. -transitivity (- r1 * / r2); auto. -Qed. -Hint Resolve rdiv5 . - -Theorem rdiv3 r1 r2 r3 r4 : - ~ r2 == 0 -> - ~ r4 == 0 -> - r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). -Proof. -intros H2 H4. -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)). -apply rdiv2; auto. -f_equiv. -transitivity (r1 * r4 + - (r3 * r2)); 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; ring. - apply rmul_reg_l with (r1 / r2); auto. - transitivity (/ (r1 / r2) * (r1 / r2)); auto. - transitivity 1; auto. - repeat rewrite rdiv_def. - transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ]. - repeat rewrite rinv_l; 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 (apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * r4); trivial. -rewrite rdiv_simpl; trivial. -transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. -repeat rewrite rdiv_simpl; trivial. +rewrite rdistr_r. +apply radd_ext. +- transitivity ((b * e) * (a / (b * e)) * d); + [ ring | now rewrite rdiv_simpl ]. +- transitivity ((d * e) * (c / (d * e)) * b); + [ ring | now rewrite rdiv_simpl ]. 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). +Theorem rdiv5 a b : - (a / b) == - a / b. 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. +now rewrite !rdiv_def, ropp_mul_l. +Qed. - apply field_is_integral_domain. - intros H1; case H; rewrite H1; ring. - intros H1; case H0; rewrite H1; ring. +Theorem rdiv3b a b c d e : + ~ (b * e) == 0 -> + ~ (d * e) == 0 -> + a / (b*e) - c / (d*e) == (a * d - c * b) / (b * (d * e)). +Proof. +intros H H0. +rewrite !rsub_def, rdiv5, ropp_mul_l. +now apply rdiv2b. Qed. +Theorem rdiv6 a b : + ~ a == 0 -> ~ b == 0 -> / (a / b) == b / a. +Proof. +intros H H0. +assert (Hk : ~ a / b == 0). +{ contradict H. + transitivity (b * (a / b)). + - now rewrite rdiv_simpl. + - rewrite H. apply rmul_0_r. } +apply rmul_reg_l with (a / b); trivial. +rewrite (rmul_comm (a / b)), rinv_l; trivial. +rewrite !rdiv_def. +transitivity (/ a * a * (/ b * b)); [ | ring ]. +now rewrite !rinv_l, rmul_1_l. +Qed. + +Theorem rdiv4 a b c d : + ~ b == 0 -> + ~ d == 0 -> + (a / b) * (c / d) == (a * c) / (b * d). +Proof. +intros H H0. +assert (~ b * d == 0) by now apply field_is_integral_domain. +apply rmul_reg_l with (b * d); trivial. +rewrite rdiv_simpl; trivial. +transitivity (b * (a / b) * (d * (c / d))); [ ring | ]. +rewrite !rdiv_simpl; trivial. +Qed. -Theorem rdiv7: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r3 == 0 -> - ~ r4 == 0 -> - (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3). +Theorem rdiv4b a b c d e f : + ~ b * e == 0 -> + ~ d * f == 0 -> + ((a * f) / (b * e)) * ((c * e) / (d * f)) == (a * c) / (b * d). +Proof. +intros H H0. +assert (~ b == 0) by (contradict H; rewrite H; ring). +assert (~ e == 0) by (contradict H; rewrite H; ring). +assert (~ d == 0) by (contradict H0; rewrite H0; ring). +assert (~ f == 0) by (contradict H0; rewrite H0; ring). +assert (~ b*d == 0) by now apply field_is_integral_domain. +assert (~ e*f == 0) by now apply field_is_integral_domain. +rewrite rdiv4; trivial. +transitivity ((e * f) * (a * c) / ((e * f) * (b * d))). +- apply rdiv_ext; ring. +- rewrite <- rdiv4, rdiv_r_r; trivial. +Qed. + +Theorem rdiv7 a b c d : + ~ b == 0 -> + ~ c == 0 -> + ~ d == 0 -> + (a / b) / (c / d) == (a * d) / (b * c). Proof. intros. -rewrite (rdiv_def (r1 / r2)). +rewrite (rdiv_def (a / b)). rewrite rdiv6; 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). +Theorem rdiv7b a b c d e f : + ~ b * f == 0 -> + ~ c * e == 0 -> + ~ d * f == 0 -> + ((a * e) / (b * f)) / ((c * e) / (d * f)) == (a * d) / (b * c). +Proof. +intros Hbf Hce Hdf. +assert (~ c==0) by (contradict Hce; rewrite Hce; ring). +assert (~ e==0) by (contradict Hce; rewrite Hce; ring). +assert (~ b==0) by (contradict Hbf; rewrite Hbf; ring). +assert (~ f==0) by (contradict Hbf; rewrite Hbf; ring). +assert (~ b*c==0) by now apply field_is_integral_domain. +assert (~ e*f==0) by now apply field_is_integral_domain. +rewrite rdiv7; trivial. +transitivity ((e * f) * (a * d) / ((e * f) * (b * c))). +- apply rdiv_ext; ring. +- now rewrite <- rdiv4, rdiv_r_r. +Qed. + +Theorem rinv_nz a : ~ a == 0 -> ~ /a == 0. +Proof. +intros H H0. apply rI_neq_rO. +rewrite <- (rdiv_r_r H), rdiv_def, H0. apply rmul_0_r. +Qed. + +Theorem rdiv8 a b : ~ b == 0 -> a == 0 -> a / b == 0. +Proof. +intros H H0. +now rewrite rdiv_def, H0, rmul_0_l. +Qed. + +Theorem cross_product_eq a b c d : + ~ b == 0 -> ~ d == 0 -> a * d == c * b -> a / b == c / d. 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. +transitivity (a / b * (d / d)). +- now rewrite rdiv_r_r, rmul_1_r. +- now rewrite rdiv4, H1, (rmul_comm b d), <- rdiv4, rdiv_r_r. Qed. +(* Results about [pow_pos] and [pow_N] *) -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. +Instance pow_ext : Proper (req ==> eq ==> req) (pow_pos rmul). +Proof. +intros x y H p p' <-. +induction p as [p IH| p IH|];simpl; trivial; now rewrite !IH, ?H. Qed. +Instance pow_N_ext : Proper (req ==> eq ==> req) (pow_N rI rmul). +Proof. +intros x y H n n' <-. destruct n; simpl; trivial. now apply pow_ext. +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; trivial. - symmetry . - apply (ARmul_1_r Rsth ARth). - rewrite rdiv4; trivial. - rewrite H1. - rewrite (ARmul_comm ARth r2 r4). - rewrite <- rdiv4; trivial. - rewrite rdiv_r_r by trivial. - apply (ARmul_1_r Rsth ARth). +Lemma pow_pos_0 p : pow_pos rmul 0 p == 0. +Proof. +induction p;simpl;trivial; now rewrite !IHp. Qed. +Lemma pow_pos_1 p : pow_pos rmul 1 p == 1. +Proof. +induction p;simpl;trivial; ring [IHp]. +Qed. + +Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. +Proof. +induction p;simpl;trivial; now rewrite !CRmorph.(morph_mul), !IHp. +Qed. + +Lemma pow_pos_mul_l x y p : + pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. +Proof. +induction p;simpl;trivial; ring [IHp]. +Qed. + +Lemma pow_pos_add_r x p1 p2 : + pow_pos rmul x (p1+p2) == pow_pos rmul x p1 * pow_pos rmul x p2. +Proof. + exact (Ring_theory.pow_pos_add Rsth rmul_ext rmul_assoc x p1 p2). +Qed. + +Lemma pow_pos_mul_r x p1 p2 : + pow_pos rmul x (p1*p2) == pow_pos rmul (pow_pos rmul x p1) p2. +Proof. +induction p1;simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r; + simpl; trivial; ring [IHp1]. +Qed. + +Lemma pow_pos_nz x p : ~x==0 -> ~pow_pos rmul x p == 0. +Proof. + intros Hx. induction p;simpl;trivial; + repeat (apply field_is_integral_domain; trivial). +Qed. + +Lemma pow_pos_div a b p : ~ b == 0 -> + pow_pos rmul (a / b) p == pow_pos rmul a p / pow_pos rmul b p. +Proof. + intros. + induction p; simpl; trivial. + - rewrite IHp. + assert (nz := pow_pos_nz p H). + rewrite !rdiv4; trivial. + apply field_is_integral_domain; trivial. + - rewrite IHp. + assert (nz := pow_pos_nz p H). + rewrite !rdiv4; trivial. +Qed. + +(* === is a morphism *) + +Instance PEadd_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEadd C). +Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. +Instance PEsub_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEsub C). +Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. +Instance PEmul_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEmul C). +Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. +Instance PEopp_ext : Proper (NPEequiv ==> NPEequiv) (@PEopp C). +Proof. intros ? ? E l. simpl. now rewrite E. Qed. +Instance PEpow_ext : Proper (NPEequiv ==> eq ==> NPEequiv) (@PEpow C). +Proof. + intros ? ? E ? ? <- l. simpl. rewrite !rpow_pow. apply pow_N_ext; trivial. +Qed. + +Lemma PE_1_l (e : PExpr C) : (1 * e === e)%poly. +Proof. + intros l. simpl. rewrite phi_1. apply rmul_1_l. +Qed. + +Lemma PE_1_r (e : PExpr C) : (e * 1 === e)%poly. +Proof. + intros l. simpl. rewrite phi_1. apply rmul_1_r. +Qed. + +Lemma PEpow_0_r (e : PExpr C) : (e ^ 0 === 1)%poly. +Proof. + intros l. simpl. now rewrite !rpow_pow. +Qed. + +Lemma PEpow_1_r (e : PExpr C) : (e ^ 1 === e)%poly. +Proof. + intros l. simpl. now rewrite !rpow_pow. +Qed. + +Lemma PEpow_1_l n : (1 ^ n === 1)%poly. +Proof. + intros l. simpl. rewrite rpow_pow. destruct n; simpl. + - now rewrite phi_1. + - now rewrite phi_1, pow_pos_1. +Qed. + +Lemma PEpow_add_r (e : PExpr C) n n' : + (e ^ (n+n') === e ^ n * e ^ n')%poly. +Proof. + intros l. simpl. rewrite !rpow_pow. + destruct n; simpl. + - rewrite rmul_1_l. trivial. + - destruct n'; simpl. + + rewrite rmul_1_r. trivial. + + apply pow_pos_add_r. +Qed. + +Lemma PEpow_mul_l (e e' : PExpr C) n : + ((e * e') ^ n === e ^ n * e' ^ n)%poly. +Proof. + intros l. simpl. rewrite !rpow_pow. destruct n; simpl; trivial. + - symmetry; apply rmul_1_l. + - apply pow_pos_mul_l. +Qed. + +Lemma PEpow_mul_r (e : PExpr C) n n' : + (e ^ (n * n') === (e ^ n) ^ n')%poly. +Proof. + intros l. simpl. rewrite !rpow_pow. + destruct n, n'; simpl; trivial. + - now rewrite pow_pos_1. + - apply pow_pos_mul_r. +Qed. + +Lemma PEpow_nz l e n : ~ e @ l == 0 -> ~ (e^n) @ l == 0. +Proof. + intros. simpl. rewrite rpow_pow. destruct n; simpl. + - apply rI_neq_rO. + - now apply pow_pos_nz. +Qed. + + (*************************************************************************** Some equality test ***************************************************************************) +Local Notation "a &&& b" := (if a then b else false) + (at level 40, left associativity). + (* 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 => Pos.eqb 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.eqb n3 n4 then PExpr_eq e3 e4 else false +Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool := + match e, e' with + | PEc c, PEc c' => ceqb c c' + | PEX _ p, PEX _ p' => Pos.eqb p p' + | e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' + | e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' + | e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' + | - e, - e' => PExpr_eq e e' + | e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e' | _, _ => 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. - -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; case Pos.eqb_spec; intros; now subst. -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; case N.eqb_spec; try discriminate; intros EQ H; subst. -repeat rewrite pow_th.(rpow_pow_N). rewrite (rec _ H);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. + end%poly. -Theorem NPEadd_correct: - forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2). +Lemma if_true (a b : bool) : a &&& b = true -> a = true /\ b = true. Proof. -intros l e1 e2. -destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c); simpl;try apply eq_refl; - try (ring [(morph0 CRmorph)]). - apply (morph_add CRmorph). + destruct a, b; split; trivial. Qed. -Definition NPEpow x n := - match n with - | N0 => PEc cI - | Npos p => - if Pos.eqb 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). +Theorem PExpr_eq_semi_ok e e' : + PExpr_eq e e' = true -> (e === e')%poly. +Proof. +revert e'; induction e; destruct e'; simpl; try discriminate. +- intros H l. now apply (morph_eq CRmorph). +- case Pos.eqb_spec; intros; now subst. +- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. +- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. +- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. +- intros H. now rewrite IHe. +- intros H. destruct (if_true _ _ H). + apply N.eqb_eq in H0. now rewrite IHe, H0. +Qed. + +Lemma PExpr_eq_spec e e' : BoolSpec (e === e')%poly True (PExpr_eq e e'). Proof. - destruct n;simpl. - rewrite pow_th.(rpow_pow_N);simpl;auto. - fold (p =? 1)%positive. - case Pos.eqb_spec; intros H; (rewrite H || clear H). - now rewrite pow_th.(rpow_pow_N). - 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]. + assert (H := PExpr_eq_semi_ok e e'). + destruct PExpr_eq; constructor; intros; trivial. now apply H. 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.eqb n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y - | _, _ => PEmul x y - end. +(** Smart constructors for polynomial expression, + with reduction of constants *) -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. +Definition NPEadd e1 e2 := + match e1, e2 with + | PEc c1, PEc c2 => PEc (c1 + c2) + | PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2 + | _, PEc c => if (c =? 0)%coef then e1 else e1 + e2 + (* Peut t'on factoriser ici ??? *) + | _, _ => (e1 + e2) + end%poly. +Infix "++" := NPEadd (at level 60, right associativity). -Theorem NPEmul_correct : forall l e1 e2, - NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). -induction e1;destruct e2; simpl;try reflexivity; - repeat apply ceqb_rect; - try (intro eq_c; rewrite eq_c); simpl; try reflexivity; - try ring [(morph0 CRmorph) (morph1 CRmorph)]. - apply (morph_mul CRmorph). -case N.eqb_spec; intros H; try rewrite <- H; clear H. -rewrite NPEpow_correct. simpl. -repeat rewrite pow_th.(rpow_pow_N). -rewrite IHe1; destruct n;simpl;try ring. -apply pow_pos_mul. -simpl;auto. +Theorem NPEadd_ok e1 e2 : (e1 ++ e2 === e1 + e2)%poly. +Proof. +intros l. +destruct e1, e2; simpl; try reflexivity; try (case ceqb_spec); +try intro H; try rewrite H; simpl; +try apply eq_refl; try (ring [phi_0]). +apply (morph_add CRmorph). 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 + | PEc c1, PEc c2 => PEc (c1 - c2) + | PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2 + | _, PEc c => if (c =? 0)%coef then e1 else e1 - e2 (* Peut-on factoriser ici *) - | _, _ => PEsub e1 e2 - end. + | _, _ => e1 - e2 + end%poly. +Infix "--" := NPEsub (at level 50, left associativity). -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; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c); simpl; - try rewrite (morph0 CRmorph); try reflexivity; +Theorem NPEsub_ok e1 e2: (e1 -- e2 === e1 - e2)%poly. +Proof. +intros l. +destruct e1, e2; simpl; try reflexivity; try case ceqb_spec; + try intro H; try rewrite H; simpl; + try rewrite phi_0; 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. + match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly. + +Theorem NPEopp_ok e : (NPEopp e === -e)%poly. +Proof. +intros l. destruct e; simpl; trivial. apply (morph_opp CRmorph). +Qed. + +Definition NPEpow x n := + match n with + | N0 => 1 + | Npos p => + if (p =? 1)%positive then x else + match x with + | PEc c => + if (c =? 1)%coef then 1 + else if (c =? 0)%coef then 0 + else PEc (pow_pos cmul c p) + | _ => x ^ n + end + end%poly. +Infix "^^" := NPEpow (at level 35, right associativity). -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). +Theorem NPEpow_ok e n : (e ^^ n === e ^ n)%poly. +Proof. + intros l. unfold NPEpow; destruct n. + - simpl; now rewrite rpow_pow. + - case Pos.eqb_spec; [intro; subst | intros _]. + + simpl. now rewrite rpow_pow. + + destruct e;simpl;trivial. + repeat case ceqb_spec; intros; rewrite ?rpow_pow, ?H; simpl. + * now rewrite phi_1, pow_pos_1. + * now rewrite phi_0, pow_pos_0. + * now rewrite pow_pos_cst. +Qed. + +Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := + match x, y with + | PEc c1, PEc c2 => PEc (c1 * c2) + | PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y + | _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y + | e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y + | _, _ => x * y + end%poly. +Infix "**" := NPEmul (at level 40, left associativity). + +Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly. +Proof. +intros l. +revert e2; induction e1;destruct e2; simpl;try reflexivity; + repeat (case ceqb_spec; intro H; try rewrite H; clear H); + simpl; try reflexivity; try ring [phi_0 phi_1]. + apply (morph_mul CRmorph). +case N.eqb_spec; [intros <- | reflexivity]. +rewrite NPEpow_ok. simpl. +rewrite !rpow_pow. rewrite IHe1. +destruct n; simpl; [ ring | apply pow_pos_mul_l ]. Qed. (* simplification *) -Fixpoint PExpr_simp (e : PExpr C) : PExpr C := +Fixpoint PEsimp (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 + | e1 + e2 => (PEsimp e1) ++ (PEsimp e2) + | e1 * e2 => (PEsimp e1) ** (PEsimp e2) + | e1 - e2 => (PEsimp e1) -- (PEsimp e2) + | - e1 => NPEopp (PEsimp e1) + | e1 ^ n1 => (PEsimp e1) ^^ n1 | _ => e - end. + end%poly. -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. +Theorem PEsimp_ok e : (PEsimp e === e)%poly. +Proof. +induction e; simpl. +- reflexivity. +- reflexivity. +- intro l; trivial. +- intro l; trivial. +- rewrite NPEadd_ok. now f_equiv. +- rewrite NPEsub_ok. now f_equiv. +- rewrite NPEmul_ok. now f_equiv. +- rewrite NPEopp_ok. now f_equiv. +- rewrite NPEpow_ok. now f_equiv. Qed. @@ -592,7 +721,9 @@ Qed. (* The input: syntax of a field expression *) Inductive FExpr : Type := - FEc: C -> FExpr + | FEO : FExpr + | FEI : FExpr + | FEc: C -> FExpr | FEX: positive -> FExpr | FEadd: FExpr -> FExpr -> FExpr | FEsub: FExpr -> FExpr -> FExpr @@ -604,6 +735,8 @@ Inductive FExpr : Type := Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := match pe with + | FEO => rO + | FEI => rI | FEc c => phi c | FEX x => BinList.nth 0 x l | FEadd x y => FEeval l x + FEeval l y @@ -633,44 +766,46 @@ Record linear : Type := mk_linear { 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 + | e1 :: nil => ~ req (e1 @ l) rO + | e1 :: l1 => ~ req (e1 @ l) 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. +Theorem PCond_cons l a l1 : + PCond l (a :: l1) <-> ~ a @ l == 0 /\ PCond l l1. +Proof. +destruct l1. +- simpl. split; [split|destruct 1]; trivial. +- reflexivity. 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. +Theorem PCond_cons_inv_l l a l1 : PCond l (a::l1) -> ~ a @ l == 0. +Proof. +rewrite PCond_cons. now destruct 1. 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. - simpl; auto. - destruct l0; simpl in *. - destruct l2; firstorder. - firstorder. +Theorem PCond_cons_inv_r l a l1 : PCond l (a :: l1) -> PCond l l1. +Proof. +rewrite PCond_cons. now destruct 1. 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 ). +Theorem PCond_app l l1 l2 : + PCond l (l1 ++ l2) <-> PCond l l1 /\ PCond l l2. +Proof. +induction l1. +- simpl. split; [split|destruct 1]; trivial. +- simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc. Qed. + (* An unsatisfiable condition: issued when a division by zero is detected *) -Definition absurd_PCond := cons (PEc cO) nil. +Definition absurd_PCond := cons 0%poly nil. Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. +Proof. unfold absurd_PCond; simpl. red; intros. apply H. -apply (morph0 CRmorph). +apply phi_0. Qed. (*************************************************************************** @@ -679,167 +814,124 @@ Qed. ***************************************************************************) -Fixpoint isIn (e1:PExpr C) (p1:positive) - (e2:PExpr C) (p2:positive) {struct e2}: option (N * PExpr C) := +Definition default_isIn e1 p1 e2 p2 := + if PExpr_eq e1 e2 then + match Z.pos_sub p1 p2 with + | Zpos p => Some (Npos p, 1%poly) + | Z0 => Some (N0, 1%poly) + | Zneg p => Some (N0, e2 ^^ Npos p) + end + else None. + +Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) := match e2 with - | PEmul e3 e4 => + | e3 * e4 => match isIn e1 p1 e3 p2 with - | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) + | Some (N0, e5) => Some (N0, e5 ** (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))) + | Some (n, e6) => Some (n, e5 ** e6) + | None => Some (Npos p, e5 ** (e4 ^^ Npos p2)) end | None => match isIn e1 p1 e4 p2 with - | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) + | Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5) | None => None end end - | PEpow e3 N0 => None - | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pos.mul p3 p2) - | _ => - if PExpr_eq e1 e2 then - match Z.pos_sub p1 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. + | e3 ^ N0 => None + | e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2) + | _ => default_isIn e1 p1 e2 p2 + end%poly. 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_add := - (Ring_theory.pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). - Lemma Z_pos_sub_gt p q : (p > q)%positive -> Z.pos_sub p q = Zpos (p - q). Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed. Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption. - Lemma isIn_correct_aux : forall l e1 e2 p1 p2, - match - (if PExpr_eq e1 e2 then - match Z.sub (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 + Lemma default_isIn_ok e1 e2 p1 p2 : + match default_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 + let n' := ZtoN (Zpos p1 - NtoZ n) in + (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly + /\ (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. + unfold default_isIn. + case PExpr_eq_spec; trivial. intros EQ. rewrite Z.pos_sub_spec. - case Pos.compare_spec;intros;simpl. - - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:reflexivity. - subst. rewrite H by trivial. ring [ (morph1 CRmorph)]. - - fold (p2 - p1 =? 1)%positive. - fold (NPEpow e2 (Npos (p2 - p1))). - rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. split. 2:reflexivity. - rewrite <- pow_pos_add. now rewrite Pos.add_comm, Pos.sub_add. - - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. - rewrite Z.pos_sub_gt by now apply Pos.sub_decr. - replace (p1 - (p1 - p2))%positive with p2; - [| rewrite Pos.sub_sub_distr, Pos.add_comm; - auto using Pos.add_sub, Pos.sub_decr ]. - split. - simpl. ring [ (morph1 CRmorph)]. - now apply Z.lt_gt, Pos.sub_decr. -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_add;simpl. -ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto. -Qed. - - -Theorem isIn_correct: forall l e1 p1 e2 p2, + case Pos.compare_spec;intros H; split; try reflexivity. + - simpl. now rewrite PE_1_r, H, EQ. + - rewrite NPEpow_ok, EQ, <- PEpow_add_r. f_equiv. + simpl. f_equiv. now rewrite Pos.add_comm, Pos.sub_add. + - simpl. rewrite PE_1_r, EQ. f_equiv. + rewrite Z.pos_sub_gt by now apply Pos.sub_decr. simpl. f_equiv. + rewrite Pos.sub_sub_distr, Pos.add_comm; trivial. + rewrite Pos.add_sub; trivial. + apply Pos.sub_decr; trivial. + - simpl. now apply Z.lt_gt, Pos.sub_decr. +Qed. + +Ltac npe_simpl := rewrite ?NPEmul_ok, ?NPEpow_ok, ?PEpow_mul_l. +Ltac npe_ring := intro l; simpl; ring. + +Theorem isIn_ok 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 + let n' := ZtoN (Zpos p1 - NtoZ n) in + (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly + /\ (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). - simpl_pos_sub. 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_add. - rewrite Pos.add_comm, Pos.sub_add by (now apply Z.gt_lt in H4). - split. symmetry;apply ARth.(ARmul_assoc). reflexivity. - repeat rewrite pow_th.(rpow_pow_N);simpl. - intros (H1,H2) (H3,H4). - simpl_pos_sub. simpl in H1, H3. - assert (Zpos p1 > Zpos p6)%Z. - apply Zgt_trans with (Zpos p4). exact H4. exact H2. - simpl_pos_sub. - 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_add. - 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 <- Z.add_assoc. rewrite (Z.add_assoc (- Zpos p4)). - simpl. rewrite Z.pos_sub_diag. simpl. reflexivity. - unfold Z.sub, Z.opp in H0. simpl in H0. - simpl_pos_sub. inversion H0; trivial. - simpl. repeat rewrite pow_th.(rpow_pow_N). - intros H1 (H2,H3). simpl_pos_sub. - 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. - simpl_pos_sub. 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. +revert p1 p2. +induction e2; intros p1 p2; + try refine (default_isIn_ok e1 _ p1 p2); simpl isIn. +- specialize (IHe2_1 p1 p2). + destruct isIn as [([|p],e)|]. + + split; [|reflexivity]. + clear IHe2_2. + destruct IHe2_1 as (IH,_). + npe_simpl. rewrite IH. npe_ring. + + specialize (IHe2_2 p p2). + destruct isIn as [([|p'],e')|]. + * destruct IHe2_1 as (IH1,GT1). + destruct IHe2_2 as (IH2,GT2). + split; [|simpl; apply Zgt_trans with (Z.pos p); trivial]. + npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. + replace (N.pos p1) with (N.pos p + N.pos (p1 - p))%N. + rewrite PEpow_add_r; npe_ring. + { simpl. f_equal. rewrite Pos.add_comm, Pos.sub_add. trivial. + now apply Pos.gt_lt. } + * destruct IHe2_1 as (IH1,GT1). + destruct IHe2_2 as (IH2,GT2). + assert (Z.pos p1 > Z.pos p')%Z by (now apply Zgt_trans with (Zpos p)). + split; [|simpl; trivial]. + npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. + replace (N.pos (p1 - p')) with (N.pos (p1 - p) + N.pos (p - p'))%N. + rewrite PEpow_add_r; npe_ring. + { simpl. f_equal. rewrite Pos.add_sub_assoc, Pos.sub_add; trivial. + now apply Pos.gt_lt. + now apply Pos.gt_lt. } + * destruct IHe2_1 as (IH,GT). split; trivial. + npe_simpl. rewrite IH. npe_ring. + + specialize (IHe2_2 p1 p2). + destruct isIn as [(n,e)|]; trivial. + destruct IHe2_2 as (IH,GT). split; trivial. + set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. + npe_simpl. rewrite IH. npe_ring. +- destruct n; trivial. + specialize (IHe2 p1 (p * p2)%positive). + destruct isIn as [(n,e)|]; trivial. + destruct IHe2 as (IH,GT). split; trivial. + set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. + now rewrite <- PEpow_mul_r. Qed. Record rsplit : Type := mk_rsplit { @@ -852,121 +944,122 @@ 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 := +Fixpoint split_aux e1 p e2 {struct e1}: rsplit := match e1 with - | PEmul e3 e4 => + | 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 (Pos.mul p3 p) e2 + mk_rsplit (left r1 ** left r2) + (common r1 ** common r2) + (right r2) + | e3 ^ N0 => mk_rsplit 1 1 e2 + | e3 ^ Npos p3 => split_aux e3 (Pos.mul 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 + match isIn e1 p e2 1 with + | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 + | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 + | None => mk_rsplit (e1 ^^ Npos p) 1 e2 end - end. + end%poly. -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. +Lemma split_aux_ok1 e1 p e2 : + (let res := match isIn e1 p e2 1 with + | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 + | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 + | None => mk_rsplit (e1 ^^ Npos p) 1 e2 + end + in + e1 ^ Npos p === left res * common res + /\ e2 === right res * common res)%poly. +Proof. 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). simpl_pos_sub. simpl in H;split;try ring [H]. - apply Z.gt_lt in Hgt. - now rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add. - 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]. + intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). + destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. + - intros (H1,H2); split; npe_simpl. + + now rewrite PE_1_l. + + rewrite PEpow_1_r in H1. rewrite H1. npe_ring. + - intros (H1,H2); split; npe_simpl. + + rewrite <- PEpow_add_r. f_equiv. simpl. f_equal. + rewrite Pos.add_comm, Pos.sub_add; trivial. + now apply Z.gt_lt in H2. + + rewrite PEpow_1_r in H1. rewrite H1. simpl_pos_sub. simpl. npe_ring. + - intros _; split; npe_simpl; now rewrite PE_1_r. +Qed. + +Theorem split_aux_ok: forall e1 p e2, + (e1 ^ Npos p === left (split_aux e1 p e2) * common (split_aux e1 p e2) + /\ e2 === right (split_aux e1 p e2) * common (split_aux e1 p e2))%poly. +Proof. +induction e1;intros k e2; try refine (split_aux_ok1 _ k e2);simpl. +destruct (IHe1_1 k e2) as (H1,H2). +destruct (IHe1_2 k (right (split_aux e1_1 k e2))) as (H3,H4). +clear IHe1_1 IHe1_2. +- npe_simpl; split. + * rewrite H1, H3. npe_ring. + * rewrite H2 at 1. rewrite H4 at 1. npe_ring. +- destruct n; simpl. + + rewrite PEpow_0_r, PEpow_1_l, !PE_1_r. now split. + + rewrite <- PEpow_mul_r. simpl. apply IHe1. 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))). +Theorem split_ok_l e1 e2 : + (e1 === left (split e1 e2) * common (split e1 e2))%poly. +Proof. +destruct (split_aux_ok e1 xH e2) as (H,_). now rewrite <- H, PEpow_1_r. +Qed. + +Theorem split_ok_r e1 e2 : + (e2 === right (split e1 e2) * common (split e1 e2))%poly. Proof. -intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl. -rewrite pow_th.(rpow_pow_N);simpl;auto. +destruct (split_aux_ok e1 xH e2) as (_,H). trivial. Qed. -Theorem split_correct_r: forall l e1 e2, - NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) - (common (split e1 e2))). +Lemma split_nz_l l e1 e2 : + ~ e1 @ l == 0 -> ~ left (split e1 e2) @ l == 0. Proof. -intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. + intros H. contradict H. rewrite (split_ok_l e1 e2); simpl. + now rewrite H, rmul_0_l. +Qed. + +Lemma split_nz_r l e1 e2 : + ~ e2 @ l == 0 -> ~ right (split e1 e2) @ l == 0. +Proof. + intros H. contradict H. rewrite (split_ok_r e1 e2); simpl. + now rewrite H, rmul_0_l. 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 + | FEO => mk_linear 0 1 nil + | FEI => mk_linear 1 1 nil + | FEc c => mk_linear (PEc c) 1 nil + | FEX x => mk_linear (PEX C x) 1 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) - + ((num x ** right s) ++ (num y ** left s)) + (left s ** (right s ** common s)) + (condition x ++ condition y)%list | 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) + ((num x ** right s) -- (num y ** left s)) + (left s ** (right s ** common s)) + (condition x ++ condition y)%list | 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) + mk_linear (left s1 ** left s2) + (right s2 ** right s1) + (condition x ++ condition y)%list | FEopp e1 => let x := Fnorm e1 in mk_linear (NPEopp (num x)) (denum x) (condition x) @@ -978,15 +1071,14 @@ Fixpoint Fnorm (e : FExpr) : linear := 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) + mk_linear (left s1 ** right s2) + (left s2 ** right s1) + (num y :: condition x ++ condition y)%list | FEpow e1 n => let x := Fnorm e1 in - mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x) + mk_linear ((num x)^^n) ((denum x)^^n) (condition x) end. - (* Example *) (* Eval compute @@ -996,93 +1088,31 @@ Eval compute (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. +Theorem Pcond_Fnorm l e : + PCond l (condition (Fnorm e)) -> ~ (denum (Fnorm e))@l == 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; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. - simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum. - rewrite NPEmul_correct. - simpl. - 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. - rewrite NPEmul_correct. - simpl. - 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. - rewrite NPEmul_correct. - simpl. - 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. - auto. - intros e1 Hrec1 Hcond. - simpl condition in Hcond. - simpl denum. - apply PCond_cons_inv_l with (1:=Hcond). - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum. - rewrite NPEmul_correct. - simpl. - 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. +induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; + simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok. +- simpl. rewrite phi_1; exact rI_neq_rO. +- simpl. rewrite phi_1; exact rI_neq_rO. +- simpl; intros. rewrite phi_1; exact rI_neq_rO. +- simpl; intros. rewrite phi_1; exact rI_neq_rO. +- rewrite <- split_ok_r. simpl. apply field_is_integral_domain. + + apply split_nz_l, IHe1, Hc1. + + apply IHe2, Hc2. +- rewrite <- split_ok_r. simpl. apply field_is_integral_domain. + + apply split_nz_l, IHe1, Hc1. + + apply IHe2, Hc2. +- simpl. apply field_is_integral_domain. + + apply split_nz_r, IHe1, Hc1. + + apply split_nz_r, IHe2, Hc2. +- now apply IHe. +- trivial. +- destruct Hc2 as (Hc2,_). simpl. apply field_is_integral_domain. + + apply split_nz_l, IHe1, Hc2. + + apply split_nz_r, Hc1. +- rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc. +Qed. (*************************************************************************** @@ -1091,154 +1121,106 @@ Hint Resolve Pcond_Fnorm. ***************************************************************************) -Theorem Fnorm_FEeval_PEeval: - forall l fe, +Ltac uneval := + repeat match goal with + | |- context [ ?x @ ?l * ?y @ ?l ] => change (x@l * y@l) with ((x*y)@l) + | |- context [ ?x @ ?l + ?y @ ?l ] => change (x@l + y@l) with ((x+y)@l) + end. + +Theorem Fnorm_FEeval_PEeval 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, + FEeval l fe == (num (Fnorm fe)) @ l / (denum (Fnorm fe)) @ l. +Proof. +induction fe; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl; + intros (Hc1,Hc2) || intros Hc; + try (specialize (IHfe1 Hc1);apply Pcond_Fnorm in Hc1); + try (specialize (IHfe2 Hc2);apply Pcond_Fnorm in Hc2); + try set (F1 := Fnorm fe1) in *; try set (F2 := Fnorm fe2) in *. + +- now rewrite phi_1, phi_0, rdiv_def. +- now rewrite phi_1; apply rdiv1. +- rewrite phi_1; apply rdiv1. +- rewrite phi_1; apply rdiv1. +- rewrite NPEadd_ok, !NPEmul_ok. simpl. + rewrite <- rdiv2b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. + now f_equiv. + +- rewrite NPEsub_ok, !NPEmul_ok. simpl. + rewrite <- rdiv3b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. + now f_equiv. + +- rewrite !NPEmul_ok. simpl. + rewrite IHfe1, IHfe2. + rewrite (split_ok_l (num F1) (denum F2) l), + (split_ok_r (num F1) (denum F2) l), + (split_ok_l (num F2) (denum F1) l), + (split_ok_r (num F2) (denum F1) l) in *. + apply rdiv4b; trivial. + +- rewrite NPEopp_ok; simpl; rewrite (IHfe Hc); apply rdiv5. + +- rewrite (IHfe Hc2); apply rdiv6; trivial; + apply Pcond_Fnorm; trivial. + +- destruct Hc2 as (Hc2,Hc3). + rewrite !NPEmul_ok. simpl. + assert (U1 := split_ok_l (num F1) (num F2) l). + assert (U2 := split_ok_r (num F1) (num F2) l). + assert (U3 := split_ok_l (denum F1) (denum F2) l). + assert (U4 := split_ok_r (denum F1) (denum F2) l). + rewrite (IHfe1 Hc2), (IHfe2 Hc3), U1, U2, U3, U4. + simpl in U2, U3, U4. apply rdiv7b; + rewrite <- ?U2, <- ?U3, <- ?U4; try apply Pcond_Fnorm; trivial. + +- rewrite !NPEpow_ok. simpl. rewrite !rpow_pow, (IHfe Hc). + destruct n; simpl. + + apply rdiv1. + + apply pow_pos_div. apply Pcond_Fnorm; trivial. +Qed. + +Theorem Fnorm_crossproduct 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)) -> + (num nfe1 * denum nfe2) @ l == (num nfe2 * denum nfe1) @ l -> 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 by - apply PCond_app_inv_l with (1 := Hcond). - rewrite Fnorm_FEeval_PEeval 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). +Proof. +simpl. rewrite PCond_app. intros Hcrossprod (Hc1,Hc2). +rewrite !Fnorm_FEeval_PEeval; trivial. +apply cross_product_eq; trivial; + apply Pcond_Fnorm; trivial. 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). +Notation Ninterp_PElist := + (interp_PElist rO rI 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: +Theorem Fnorm_ok: 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. +Proof. +intros n l lpe fe Hlpe H H1. +rewrite (Fnorm_FEeval_PEeval l fe H1). +apply rdiv8. apply Pcond_Fnorm; trivial. +transitivity (0@l); trivial. +rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe); trivial. +change (0 @ l) with (Pphi 0 radd rmul phi l (Pc cO)). +apply (Peq_ok Rsth Reqe CRmorph); trivial. Qed. +Notation ring_rw_correct := + (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). + +Notation ring_rw_pow_correct := + (ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). + +Notation ring_correct := + (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). + (* simplify a field expression into a fraction *) (* TODO: simplify when den is constant... *) Definition display_linear l num den := @@ -1247,71 +1229,54 @@ Definition display_linear l num den := Definition display_pow_linear l num den := NPphi_pow l num / NPphi_pow l den. -Theorem Field_rw_correct : - forall n lpe l, +Theorem Field_rw_correct 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)). + 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. + intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. + rewrite (Fnorm_FEeval_PEeval _ _ H). + unfold display_linear; apply rdiv_ext; + eapply ring_rw_correct; eauto. Qed. -Theorem Field_rw_pow_correct : - forall n lpe l, +Theorem Field_rw_pow_correct 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)). + 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. + intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. + rewrite (Fnorm_FEeval_PEeval _ _ H). + unfold display_pow_linear; apply rdiv_ext; + eapply ring_rw_pow_correct;eauto. Qed. -Theorem Field_correct : - forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> +Theorem Field_correct 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 -> + Peq ceqb (Nnorm n lmp (num nfe1 * denum nfe2)) + (Nnorm n lmp (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. +intros 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. +eapply ring_correct; 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 Logic.eq_refl x Logic.eq_refl); - rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec - O nil l I Logic.eq_refl y Logic.eq_refl) - end. -trivial. -Qed. + +(** This allows rewriting modulo the simplification of PEeval on PMul *) +Declare Equivalent Keys PEeval rmul. Theorem Field_simplify_eq_correct : forall n l lpe fe1 fe2, @@ -1320,37 +1285,23 @@ Theorem Field_simplify_eq_correct : 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))) -> + NPphi_dev l (Nnorm n lmp (num nfe1 * right den)) == + NPphi_dev l (Nnorm n lmp (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. +intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. +apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. simpl. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))). -rewrite NPEmul_correct. -rewrite NPEmul_correct. +rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. +rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. simpl. -repeat rewrite (ARmul_assoc ARth). -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 Logic.eq_refl - x Logic.eq_refl) 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 Logic.eq_refl - x Logic.eq_refl) in Hcrossprod. -simpl in Hcrossprod. -rewrite Hcrossprod. -reflexivity. +rewrite !rmul_assoc. +apply rmul_ext; trivial. +rewrite (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), + (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). +rewrite Hlmp. +apply Hcrossprod. Qed. Theorem Field_simplify_eq_pow_correct : @@ -1360,37 +1311,55 @@ Theorem Field_simplify_eq_pow_correct : 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))) -> + NPphi_pow l (Nnorm n lmp (num nfe1 * right den)) == + NPphi_pow l (Nnorm n lmp (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. +intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. +apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. simpl. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))). -rewrite NPEmul_correct. -rewrite NPEmul_correct. +rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. +rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. simpl. -repeat rewrite (ARmul_assoc ARth). -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 Logic.eq_refl - x Logic.eq_refl) 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 Logic.eq_refl - x Logic.eq_refl) in Hcrossprod. -simpl in Hcrossprod. -rewrite Hcrossprod. -reflexivity. +rewrite !rmul_assoc. +apply rmul_ext; trivial. +rewrite + (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), + (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). +rewrite Hlmp. +apply Hcrossprod. +Qed. + +Theorem Field_simplify_aux_ok l fe1 fe2 den : + FEeval l fe1 == FEeval l fe2 -> + split (denum (Fnorm fe1)) (denum (Fnorm fe2)) = den -> + PCond l (condition (Fnorm fe1) ++ condition (Fnorm fe2)) -> + (num (Fnorm fe1) * right den) @ l == (num (Fnorm fe2) * left den) @ l. +Proof. + rewrite PCond_app; intros Hfe Hden (Hc1,Hc2); simpl. + assert (Hc1' := Pcond_Fnorm _ _ Hc1). + assert (Hc2' := Pcond_Fnorm _ _ Hc2). + set (N1 := num (Fnorm fe1)) in *. set (N2 := num (Fnorm fe2)) in *. + set (D1 := denum (Fnorm fe1)) in *. set (D2 := denum (Fnorm fe2)) in *. + assert (~ (common den) @ l == 0). + { intro H. apply Hc1'. + rewrite (split_ok_l D1 D2 l). + rewrite Hden. simpl. ring [H]. } + apply (@rmul_reg_l ((common den) @ l)); trivial. + rewrite !(rmul_comm ((common den) @ l)), <- !rmul_assoc. + change + (N1@l * (right den * common den) @ l == + N2@l * (left den * common den) @ l). + rewrite <- Hden, <- split_ok_l, <- split_ok_r. + apply (@rmul_reg_l (/ D2@l)). { apply rinv_nz; trivial. } + rewrite (rmul_comm (/ D2 @ l)), <- !rmul_assoc. + rewrite <- rdiv_def, rdiv_r_r, rmul_1_r by trivial. + apply (@rmul_reg_l (/ (D1@l))). { apply rinv_nz; trivial. } + rewrite !(rmul_comm (/ D1@l)), <- !rmul_assoc. + rewrite <- !rdiv_def, rdiv_r_r, rmul_1_r by trivial. + rewrite (rmul_comm (/ D2@l)), <- rdiv_def. + unfold N1,N2,D1,D2; rewrite <- !Fnorm_FEeval_PEeval; trivial. Qed. Theorem Field_simplify_eq_pow_in_correct : @@ -1400,47 +1369,17 @@ Theorem Field_simplify_eq_pow_in_correct : 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 -> + forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> + forall np2, Nnorm n lmp (num nfe2 * left den) = np2 -> FEeval l fe1 == FEeval l fe2 -> - PCond l (condition nfe1 ++ condition nfe2) -> + 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). + 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. apply Field_simplify_aux_ok; trivial. Qed. Theorem Field_simplify_eq_in_correct : @@ -1450,47 +1389,16 @@ forall n l lpe fe1 fe2, 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 -> + forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> + forall np2, Nnorm n lmp (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. + 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). + rewrite !(Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). + repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). + apply Field_simplify_aux_ok; trivial. Qed. @@ -1499,7 +1407,7 @@ 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. + PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := match l with @@ -1507,15 +1415,15 @@ Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := | cons a l1 => Fcons a (Fapp l1 m) end. - Lemma fcons_correct : forall l l1, +Lemma fcons_ok : forall l l1, (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1. - Proof. - intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1. - induction l1; simpl; intros. - trivial. - elim PCond_fcons_inv with (1 := H); intros. - destruct l1; trivial. split; trivial. apply IHl1; trivial. - Qed. +Proof. +intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1. +induction l1; simpl; intros. + trivial. + elim PCond_fcons_inv with (1 := H); intros. + destruct l1; trivial. split; trivial. apply IHl1; trivial. +Qed. End Fcons_impl. @@ -1531,21 +1439,15 @@ Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := 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. + forall l a l1, PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. +Proof. +induction l1 as [|e l1]; simpl Fcons. +- simpl; now split. +- case PExpr_eq_spec; intros H; rewrite !PCond_cons; intros (H1,H2); + repeat split; trivial. + + now rewrite H. + + now apply IHl1. + + now apply IHl1. Qed. (* equality of normal forms rather than syntactic equality *) @@ -1558,23 +1460,16 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := 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. + forall l a l1, PCond l (Fcons0 a l1) -> ~ a @ l == 0 /\ PCond l l1. +Proof. +induction l1 as [|e l1]; simpl Fcons0. +- simpl; now split. +- generalize (ring_correct O l nil a e). lazy zeta; simpl Peq. + case Peq; intros H; rewrite !PCond_cons; intros (H1,H2); + repeat split; trivial. + + now rewrite H. + + now apply IHl1. + + now apply IHl1. Qed. (* split factorized denominators *) @@ -1586,95 +1481,83 @@ Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := 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. - 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. + forall l a l1, PCond l (Fcons00 a l1) -> ~ a @ l == 0 /\ PCond l l1. +Proof. +intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). +- intros p H p0 H0 l1 H1. + simpl in H1. + destruct (H _ H1) as (H2,H3). + destruct (H0 _ H3) as (H4,H5). split; trivial. + simpl. + apply field_is_integral_domain; trivial. +- intros. destruct (H _ H0). split; trivial. + apply PEpow_nz; trivial. Qed. Definition Pcond_simpl_gen := - fcons_correct _ PFcons00_fcons_inv. + fcons_ok _ 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. +Hypothesis ceqb_complete : forall c1 c2, [c1] == [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). +Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2). 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; intro. -absurd (false = true); auto; discriminate. +assert (H := morph_eq CRmorph c1 c2). +assert (H' := @ceqb_complete c1 c2). +destruct (ceqb c1 c2); constructor. +- now apply H. +- intro E. specialize (H' E). 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) + | 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 + | PEopp e => if (-(1) =? 0)%coef then absurd_PCond else Fcons1 e l + | PEc c => if (c =? 0)%coef 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; intros c l1. - apply ceqb_rect_complete; intros. - elim (@absurd_PCond_bottom l H0). - split; trivial. - rewrite <- (morph0 CRmorph); 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. - apply field_is_integral_domain; trivial. - simpl; intros p H l1. - apply ceqb_rect_complete; intros. - elim (@absurd_PCond_bottom l H1). - destruct (H _ H1). + forall l a l1, PCond l (Fcons1 a l1) -> ~ a @ l == 0 /\ PCond l l1. +Proof. +intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). +- simpl; intros c l1. + case ceqb_spec'; intros H H0. + + elim (@absurd_PCond_bottom l H0). + + split; trivial. rewrite <- phi_0; trivial. +- intros p H p0 H0 l1 H1. simpl in H1. + destruct (H _ H1) as (H2,H3). + destruct (H0 _ H3) as (H4,H5). + split; trivial. simpl. apply field_is_integral_domain; trivial. +- simpl; intros p H l1. + case ceqb_spec'; intros H0 H1. + + 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. + rewrite (morph_opp CRmorph), phi_0, phi_1 in H0. trivial. +- intros. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial. Qed. -Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. +Definition Fcons2 e l := Fcons1 (PEsimp e) l. Theorem PFcons2_fcons_inv: - forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. + forall l a l1, PCond l (Fcons2 a l1) -> ~ a @ l == 0 /\ PCond l l1. +Proof. unfold Fcons2; intros l a l1 H; split; - case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto. + case (PFcons1_fcons_inv l (PEsimp a) l1); trivial. intros H1 H2 H3; case H1. -transitivity (NPEeval l a); trivial. -apply PExpr_simp_correct. +transitivity (a@l); trivial. +apply PEsimp_ok. Qed. Definition Pcond_simpl_complete := - fcons_correct _ PFcons2_fcons_inv. + fcons_ok _ PFcons2_fcons_inv. End Fcons_simpl. @@ -1742,22 +1625,22 @@ 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, +Lemma add_inj_r p x y : gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. -intros p x y. +Proof. elim p using Pos.peano_ind; simpl; intros. apply S_inj; trivial. apply H. apply S_inj. - repeat rewrite (ARadd_assoc ARth). + rewrite !(ARadd_assoc ARth). rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial. Qed. -Lemma gen_phiPOS_inj : forall x y, +Lemma gen_phiPOS_inj 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). +Proof. +rewrite <- !(same_gen Rsth Reqe ARth). case (Pos.compare_spec x y). intros. trivial. @@ -1777,9 +1660,10 @@ case (Pos.compare_spec x y). Qed. -Lemma gen_phiN_inj : forall x y, +Lemma gen_phiN_inj x y : gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> x = y. +Proof. destruct x; destruct y; simpl; intros; trivial. elim gen_phiPOS_not_0 with p. symmetry . @@ -1789,7 +1673,7 @@ destruct x; destruct y; simpl; intros; trivial. rewrite gen_phiPOS_inj with (1 := H); trivial. Qed. -Lemma gen_phiN_complete : forall x y, +Lemma gen_phiN_complete x y : gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> N.eqb x y = true. Proof. @@ -1808,31 +1692,22 @@ Section Field. 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. +Lemma ring_S_inj x y : 1+x==1+y -> x==y. +Proof. intros. -transitivity (x + (1 + - (1))). - rewrite (Ropp_def Rth). - symmetry . - apply (ARadd_0_r Rsth ARth). - transitivity (y + (1 + - (1))). - repeat rewrite <- (ARplus_assoc ARth). - repeat rewrite (ARadd_assoc ARth). - apply (Radd_ext Reqe). - repeat rewrite <- (ARadd_comm ARth 1). - trivial. - reflexivity. - rewrite (Ropp_def Rth). - apply (ARadd_0_r Rsth ARth). +rewrite <- (ARadd_0_l ARth x), <- (ARadd_0_l ARth y). +rewrite <- (Ropp_def Rth 1), (ARadd_comm ARth 1). +rewrite <- !(ARadd_assoc ARth). now apply (Radd_ext Reqe). Qed. - - Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. +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, +Lemma gen_phiPOS_discr_sgn x y : ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. +Proof. red; intros. apply gen_phiPOS_not_0 with (y + x)%positive. rewrite (ARgen_phiPOS_add Rsth Reqe ARth). @@ -1845,9 +1720,10 @@ transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). apply (Ropp_def Rth). Qed. -Lemma gen_phiZ_inj : forall x y, +Lemma gen_phiZ_inj x y : gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> x = y. +Proof. destruct x; destruct y; simpl; intros. trivial. elim gen_phiPOS_not_0 with p. @@ -1878,9 +1754,10 @@ destruct x; destruct y; simpl; intros. reflexivity. Qed. -Lemma gen_phiZ_complete : forall x y, +Lemma gen_phiZ_complete x y : gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> Zeq_bool x y = true. +Proof. intros. replace y with x. unfold Zeq_bool. @@ -1891,3 +1768,6 @@ Qed. End Field. End Complete. + +Arguments FEO [C]. +Arguments FEI [C]. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index e106d5b5..b92b847b 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* f arth ext_r morph lemma1 lemma2 | _ => fail 4 "ring: bad sign specification" end - | _ => fail 3 "ring: bad coefficiant division specification" + | _ => fail 3 "ring: bad coefficient division specification" end | _ => fail 2 "ring: bad power specification" end diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v index cfd00521..a10eeecc 100644 --- a/plugins/setoid_ring/NArithRing.v +++ b/plugins/setoid_ring/NArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [x] == [y]. Proof. intros;subst;reflexivity. Qed. +Declare Equivalent Keys bracket gen_phiZ. (*proof that [.] satisfies morphism specifications*) Global Instance gen_phiZ_morph : (@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*) diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v index eefc9428..5845b629 100644 --- a/plugins/setoid_ring/Ncring_polynom.v +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 + | PEI => 1 | PEc c => [c] - | PEX j => nth 0 j l + | 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) @@ -500,8 +503,10 @@ Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) := Fixpoint norm_aux (pe:PExpr C) : Pol := match pe with + | PEO => Pc cO + | PEI => Pc cI | PEc c => Pc c - | PEX j => mk_X j + | PEX _ j => mk_X j | PEadd pe1 (PEopp pe2) => Psub (norm_aux pe1) (norm_aux pe2) | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) @@ -520,28 +525,30 @@ Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) := Proof. intros. induction pe. -Esimpl3. Esimpl3. simpl. - rewrite IHpe1;rewrite IHpe2. - destruct pe2; Esimpl3. -unfold Psub. -destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity. -simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2. -destruct pe1. destruct pe2; rewrite Padd_ok; rewrite Popp_ok; try reflexivity. -Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. - Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. -simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity. -simpl. rewrite IHpe; Esimpl3. -simpl. - rewrite Ppow_N_ok; (intros;try reflexivity). - rewrite rpow_pow_N. Esimpl3. - induction n;simpl. Esimpl3. induction p; simpl. - try rewrite IHp;try rewrite IHpe; - repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;reflexivity. -rewrite Pmul_ok. try rewrite IHp;try rewrite IHpe; - repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;reflexivity. trivial. -exact pow_th. + - now simpl; rewrite <- ring_morphism0. + - now simpl; rewrite <- ring_morphism1. + - Esimpl3. + - Esimpl3. + - simpl. + rewrite IHpe1;rewrite IHpe2. + destruct pe2; Esimpl3. + unfold Psub. + destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity. + - simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2. + now destruct pe1; + [destruct pe2; rewrite Padd_ok; rewrite Popp_ok; Esimpl3 | Esimpl3..]. + - simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity. + - now simpl; rewrite IHpe; Esimpl3. + - simpl. + rewrite Ppow_N_ok; (intros;try reflexivity). + rewrite rpow_pow_N; [| now apply pow_th]. + induction n;simpl; [now Esimpl3|]. + induction p; simpl; trivial. + + try rewrite IHp;try rewrite IHpe; + repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity. + + rewrite Pmul_ok. + try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;reflexivity. Qed. Lemma norm_subst_spec : diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v index 4fb02909..31c9e54d 100644 --- a/plugins/setoid_ring/Ncring_tac.v +++ b/plugins/setoid_ring/Ncring_tac.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr:(t1::t2::nil) @@ -138,6 +137,7 @@ Ltac lterm_goal g := Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y. intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. + Ltac reify_goal lvar lexpr lterm:= (*idtac lvar; idtac lexpr; idtac lterm;*) match lexpr with diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v index 98150d35..b2417db6 100644 --- a/plugins/setoid_ring/Ring.v +++ b/plugins/setoid_ring/Ring.v @@ -1,6 +1,6 @@ (************************************************************************) (* 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 index 21d3099c..2d2756b1 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -1,17 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 **) (** A monomial is X1^k1...Xi^ki. Its representation @@ -511,6 +502,29 @@ Section MakeRingPol. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). + Definition Pequiv (P Q : Pol) := forall l, P@l == Q@l. + Infix "===" := Pequiv (at level 70, no associativity). + + Instance Pequiv_eq : Equivalence Pequiv. + Proof. + unfold Pequiv; split; red; intros; [reflexivity|now symmetry|now etransitivity]. + Qed. + + Instance Pphi_ext : Proper (eq ==> Pequiv ==> req) Pphi. + Proof. + now intros l l' <- P Q H. + Qed. + + Instance Pinj_ext : Proper (eq ==> Pequiv ==> Pequiv) Pinj. + Proof. + intros i j <- P P' HP l. simpl. now rewrite HP. + Qed. + + Instance PX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) PX. + Proof. + intros P P' HP p p' <- Q Q' HQ l. simpl. now rewrite HP, HQ. + Qed. + (** Evaluation of a monomial towards R *) Fixpoint Mphi(l:list R) (M: Mon) : R := @@ -532,8 +546,9 @@ Section MakeRingPol. Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l). Proof. rewrite Pos.add_comm. apply jump_add. Qed. - Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. + Lemma Peq_ok P P' : (P ?== P') = true -> P === P'. Proof. + unfold Pequiv. revert P';induction P;destruct P';simpl; intros H l; try easy. - now apply (morph_eq CRmorph). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. @@ -545,8 +560,7 @@ Section MakeRingPol. now rewrite IHP1, IHP2. Qed. - Lemma Peq_spec P P' : - BoolSpec (forall l, P@l == P'@l) True (P ?== P'). + Lemma Peq_spec P P' : BoolSpec (P === P') True (P ?== P'). Proof. generalize (Peq_ok P P'). destruct (P ?== P'); auto. Qed. @@ -567,6 +581,11 @@ Section MakeRingPol. now rewrite jump_add'. Qed. + Instance mkPinj_ext : Proper (eq ==> Pequiv ==> Pequiv) mkPinj. + Proof. + intros i j <- P Q H l. now rewrite !mkPinj_ok. + Qed. + Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. @@ -590,6 +609,11 @@ Section MakeRingPol. rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. Qed. + Instance mkPX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) mkPX. + Proof. + intros P P' HP i i' <- Q Q' HQ l. now rewrite !mkPX_ok, HP, HQ. + Qed. + Hint Rewrite Pphi0 Pphi1 @@ -656,7 +680,7 @@ Section MakeRingPol. - add_permut. - destruct p; simpl; rewrite ?jump_pred_double; add_permut. - - destr_pos_sub; intros ->;Esimpl. + - destr_pos_sub; intros ->; Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. @@ -689,47 +713,23 @@ Section MakeRingPol. rewrite IHP'2, pow_pos_add; rsimpl. add_permut. Qed. - Lemma PsubX_ok P' P k l : - (forall P l, (P--P')@l == P@l - P'@l) -> - (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. + Lemma Psub_opp P' P : P -- P' === P ++ (--P'). Proof. - intros IHP'. - revert k l. induction P;simpl;intros. - - rewrite Popp_ok;rsimpl; add_permut. - - destruct p; simpl; - rewrite Popp_ok;rsimpl; - rewrite ?jump_pred_double; add_permut. - - destr_pos_sub; intros ->; Esimpl. - + rewrite IHP';rsimpl. add_permut. - + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. - + rewrite IHP1, pow_pos_add;rsimpl. add_permut. + revert P; induction P'; simpl; intros. + - intro l; Esimpl. + - revert p; induction P; simpl; intros; try reflexivity. + + destr_pos_sub; intros ->; now apply mkPinj_ext. + + destruct p0; now apply PX_ext. + - destruct P; simpl; try reflexivity. + + destruct p0; now apply PX_ext. + + destr_pos_sub; intros ->; apply mkPX_ext; auto. + revert p1. induction P2; simpl; intros; try reflexivity. + destr_pos_sub; intros ->; now apply mkPX_ext. Qed. Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. - revert P l; induction P';simpl;intros;Esimpl. - - revert p l; induction P;simpl;intros. - + Esimpl; add_permut. - + destr_pos_sub; intros ->;Esimpl. - * rewrite IHP';rsimpl. - * rewrite IHP';Esimpl. now rewrite jump_add'. - * rewrite IHP. now rewrite jump_add'. - + destruct p0;simpl. - * rewrite IHP2;simpl. rsimpl. - * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. - * rewrite IHP'. rsimpl. - - destruct P;simpl. - + Esimpl; add_permut. - + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. - * rsimpl. add_permut. - * rewrite jump_pred_double. rsimpl. add_permut. - * rsimpl. add_permut. - + destr_pos_sub; intros ->; Esimpl. - * rewrite IHP'1, IHP'2;rsimpl. add_permut. - * rewrite IHP'1, IHP'2;simpl;Esimpl. - rewrite pow_pos_add;rsimpl. add_permut. - * rewrite PsubX_ok by trivial;rsimpl. - rewrite IHP'2, pow_pos_add;rsimpl. add_permut. + rewrite Psub_opp, Padd_ok, Popp_ok. rsimpl. Qed. Lemma PmulI_ok P' : @@ -764,15 +764,6 @@ Section MakeRingPol. add_permut; f_equiv; mul_permut. Qed. - Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. - Proof. - revert l;induction P;simpl;intros;Esimpl. - - apply IHP. - - rewrite Padd_ok, Pmul_ok;Esimpl. - rewrite IHP1, IHP2. - mul_push ((hd l)^p). now mul_push (P2@l). - Qed. - Lemma mkZmon_ok M j l : (mkZmon j M) @@ l == (zmon j M) @@ l. Proof. @@ -807,9 +798,9 @@ Section MakeRingPol. P@l == Q@l + [c] * R@l. Proof. revert l. - induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). - destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. + induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. + - assert (H := div_th.(div_eucl_th) c0 c). + destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. Qed. @@ -818,11 +809,12 @@ Section MakeRingPol. let (c,M) := cM in let (Q,R) := MFactor P c M in P@l == Q@l + [c] * M@@l * R@l. - Proof. + Proof. destruct cM as (c,M). revert M l. - induction P; destruct M; intros l; simpl; auto; + induction P; destruct M; intros l; simpl; auto; try (case ceqb_spec; intro He); - try (case Pos.compare_spec; intros He); rewrite ?He; + try (case Pos.compare_spec; intros He); + rewrite ?He; destr_factor; simpl; Esimpl. - assert (H := div_th.(div_eucl_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. @@ -880,9 +872,9 @@ Section MakeRingPol. Lemma PSubstL1_ok n LM1 P1 l : MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. Proof. - revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - - reflexivity. - - rewrite <- IH by intuition. now apply PNSubst1_ok. + revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. + - reflexivity. + - rewrite <- IH by intuition; now apply PNSubst1_ok. Qed. Lemma PSubstL_ok n LM1 P1 P2 l : @@ -907,6 +899,8 @@ Section MakeRingPol. (** Definition of polynomial expressions *) Inductive PExpr : Type := + | PEO : PExpr + | PEI : PExpr | PEc : C -> PExpr | PEX : positive -> PExpr | PEadd : PExpr -> PExpr -> PExpr @@ -915,6 +909,7 @@ Section MakeRingPol. | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. + (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. @@ -922,6 +917,8 @@ Section MakeRingPol. Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := match pe with + | PEO => rO + | PEI => rI | PEc c => phi c | PEX j => nth 0 j l | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) @@ -985,11 +982,13 @@ Section POWER. 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 Pmul_subst P1 P2 := subst_l (P1 ** P2). Let Ppow_subst := Ppow_N subst_l. Fixpoint norm_aux (pe:PExpr) : Pol := match pe with + | PEO => Pc cO + | PEI => Pc cI | PEc c => Pc c | PEX j => mk_X j | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1) @@ -1021,7 +1020,7 @@ Section POWER. end. Proof. simpl (norm_aux (PEadd _ _)). - destruct pe1; [ | | | | | reflexivity | ]; + destruct pe1; [ | | | | | | | reflexivity | ]; destruct pe2; simpl get_PEopp; reflexivity. Qed. @@ -1034,22 +1033,26 @@ Section POWER. now destruct pe. Qed. + Arguments norm_aux !pe : simpl nomatch. + Lemma norm_aux_spec l pe : PEeval l pe == (norm_aux pe)@l. Proof. intros. - induction pe. + induction pe; cbn. + - now rewrite (morph0 CRmorph). + - now rewrite (morph1 CRmorph). - reflexivity. - apply mkX_ok. - - simpl PEeval. rewrite IHpe1, IHpe2. + - rewrite IHpe1, IHpe2. assert (H1 := norm_aux_PEopp pe1). assert (H2 := norm_aux_PEopp pe2). rewrite norm_aux_PEadd. do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - - simpl. rewrite IHpe1, IHpe2. Esimpl. - - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - - simpl. rewrite IHpe. Esimpl. - - simpl. rewrite Ppow_N_ok by reflexivity. + - rewrite IHpe1, IHpe2. Esimpl. + - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. + - rewrite IHpe. Esimpl. + - rewrite Ppow_N_ok by reflexivity. rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. @@ -1483,3 +1486,6 @@ Qed. Qed. End MakeRingPol. + +Arguments PEO [C]. +Arguments PEI [C]. diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index 7a7ffcfd..77863edc 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -196,12 +196,17 @@ Ltac get_MonPol lemma := (********************************************************) (* Building the atom list of a ring expression *) -Ltac FV Cst CstPow add mul sub opp pow t fv := +(* We do not assume that Cst recognizes the rO and rI terms as constants, as *) +(* the tactic could be used to discriminate occurrences of an opaque *) +(* constant phi, with (phi 0) not convertible to 0 for instance *) +Ltac FV Cst CstPow rO rI add mul sub opp pow t fv := let rec TFV t fv := let f := match Cst t with | NotConstant => match t with + | rO => fun _ => fv + | rI => fun _ => fv | (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) @@ -219,32 +224,39 @@ Ltac FV Cst CstPow add mul sub opp pow t fv := in TFV t fv. (* syntaxification of ring expressions *) -Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := + (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) + (* the tactic could be used to discriminate occurrences of an opaque *) + (* constant phi, with (phi 0) not convertible to 0 for instance *) +Ltac mkPolexpr C Cst CstPow rO rI radd rmul rsub ropp rpow t fv := let rec mkP t := let f := match Cst t with | InitialRing.NotConstant => match t with + | rO => + fun _ => constr:(@PEO C) + | rI => + fun _ => constr:(@PEI C) | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEadd e1 e2) + let e2 := mkP t2 in constr:(@PEadd C e1 e2) | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEmul e1 e2) + let e2 := mkP t2 in constr:(@PEmul C e1 e2) | (rsub ?t1 ?t2) => fun _ => let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEsub e1 e2) + let e2 := mkP t2 in constr:(@PEsub C e1 e2) | (ropp ?t1) => fun _ => - let e1 := mkP t1 in constr:(PEopp e1) + let e1 := mkP t1 in constr:(@PEopp C 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) + | ?c => fun _ => let e1 := mkP t1 in constr:(@PEpow C e1 c) end | _ => fun _ => let p := Find_at t fv in constr:(PEX C p) @@ -260,58 +272,58 @@ 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 _ _] => + [@PEeval ?R ?r0 ?r1 ?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) + R req r0 r1 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 req r0 r1 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 => + R req r0 r1 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 => + R req r0 r1 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 => + R req r0 r1 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 => + R req r0 r1 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 => + R req r0 r1 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). + R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => + FV cst_tac pow_tac r0 r1 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). + R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => + mkPolexpr C cst_tac pow_tac r0 r1 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 + R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => + let mkPol := mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow in fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). (* ring tactics *) @@ -338,8 +350,8 @@ Ltac Ring RNG lemma lH := (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") + || idtac "can not automatically prove hypothesis :"; + [> idtac " maybe a left member of a hypothesis is not a monomial"..]) | vm_compute; (exact (eq_refl true) || fail "not a valid ring equation")]). diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index af43b0ab..4f05f0d4 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* f i c + | (i,[|c|]) -> f (Evar.repr i) c | _ -> assert false type protect_flag = Eval|Prot|Rec @@ -48,10 +51,19 @@ 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 + | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c + +let global_head_of_constr c = + let f, args = decompose_app c in + try global_of_constr f + with Not_found -> anomaly (str "global_head_of_constr") + +let global_of_constr_nofail c = + try global_of_constr c + with Not_found -> VarRef (Id.of_string "dummy") let rec mk_clos_but f_map subs t = - match f_map t with + match f_map (global_of_constr_nofail t) with | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t | None -> (match kind_of_term t with @@ -62,9 +74,9 @@ let rec mk_clos_but f_map subs 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 fargs, args' = Array.chop n args in let f' = mkApp(f,fargs) in - match f_map f' with + match f_map (global_of_constr_nofail f') with Some map -> mk_clos_deep (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s')) @@ -72,24 +84,13 @@ and mk_clos_app_but f_map subs f args n = (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_f eq_constr t l) with Not_found -> None + try Some(List.assoc_f eq_gr 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 protect_maps = ref String.Map.empty +let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = - try Stringmap.find map !protect_maps + try String.Map.find map !protect_maps with Not_found -> errorlabstrm"lookup_map"(str"map "++qs map++str"not found") @@ -101,112 +102,120 @@ 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, Termops.InHyp));; + Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));; TACTIC EXTEND protect_fv [ "protect_fv" string(map) "in" ident(id) ] -> - [ protect_tac_in map id ] + [ Proofview.V82.tactic (protect_tac_in map id) ] | [ "protect_fv" string(map) ] -> - [ protect_tac map ] + [ Proofview.V82.tactic (protect_tac map) ] END;; (****************************************************************************) let closed_term t l = - let l = List.map constr_of_global l in + let l = List.map Universes.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 ] + [ Proofview.V82.tactic (closed_term t l) ] END ;; -TACTIC EXTEND echo +(* TACTIC EXTEND echo | [ "echo" constr(t) ] -> [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] -END;; +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]))) + TacFun([Some(Id.of_string"t")], + TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term", + [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t")); + Genarg.in_gen (Genarg.wit_list Constrarg.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 (GVar(dummy_loc,id_of_string"t"),None); - Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l]))) + let tacname = { + mltac_plugin = "newring_plugin"; + mltac_tactic = "closed_term"; + } in + let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in + TacFun([Some(Id.of_string"t")], + TacML(Loc.ghost,tacname, + [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None); + Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l])) (* -let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term" +let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) (****************************************************************************) let ic c = let env = Global.env() and sigma = Evd.empty in - Constrintern.interp_constr sigma env c + Constrintern.interp_open_constr env sigma c + +let ic_unsafe c = (*FIXME remove *) + let env = Global.env() and sigma = Evd.empty in + fst (Constrintern.interp_constr env sigma 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_secctx = None; - const_entry_type = None; - const_entry_opaque = true }, - IsProof Lemma)) +let decl_constant na ctx c = + let vars = Universes.universes_of_constr c in + let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in + mkConst(declare_constant (Id.of_string na) + (DefinitionEntry (definition_entry ~opaque:true + ~univs:(Univ.ContextSet.to_context ctx) c), + IsProof Lemma)) (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = - TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) + TacArg(Loc.ghost,TacCall(Loc.ghost, ArgArg(Loc.ghost, Lazy.force tac),args)) (* Calling a locally bound tactic *) let ltac_lcall tac args = - TacArg(dummy_loc,TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) + TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args)) let ltac_letin (x, e1) e2 = - TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2) + TacLetIn(false,[(Loc.ghost,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) + TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds) -let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) +let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c) -let dummy_goal env = +let dummy_goal env sigma = let (gl,_,sigma) = - Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in - {Evd.it = gl; - Evd.sigma = sigma} + Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in + {Evd.it = gl; Evd.sigma = sigma} -let exec_tactic env n f args = - let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in +let constr_of v = match Value.to_constr v with + | Some c -> c + | None -> failwith "Ring.exec_tactic: anomaly" + +let exec_tactic env evd n f args = + let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let res = ref [||] in let get_res ist = - let l = List.map (fun id -> List.assoc id ist.lfun) lid in + let l = List.map (fun id -> Id.Map.find 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" + Tacintern.glob_tactic(tacticIn get_res))) in + let gl = dummy_goal env evd in + let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in + let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in + Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -217,16 +226,23 @@ let stdlib_modules = let coq_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) +let coq_reference c = + lazy (Coqlib.gen_reference_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_None = coq_reference "None" +let coq_Some = coq_reference "Some" let coq_eq = coq_constant "eq" +let coq_cons = coq_reference "cons" +let coq_nil = coq_reference "nil" + let lapp f args = mkApp(Lazy.force f,args) +let plapp evd f args = + let fc = Evarutil.e_new_global evd (Lazy.force f) in + mkApp(fc,args) + let dest_rel0 t = match kind_of_term t with | App(f,args) when Array.length args >= 2 -> @@ -255,17 +271,19 @@ let plugin_modules = let my_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) +let my_reference c = + lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) let new_ring_path = - make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"]) + DirPath.make (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)) + lazy(make_kn (MPfile new_ring_path) DirPath.empty (Label.make s)) let znew_ring_path = - make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"]) + DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = - lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) + lazy(make_kn (MPfile znew_ring_path) DirPath.empty (Label.make s)) -let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; +let mk_cst l s = lazy (Coqlib.gen_reference "newring" l s);; let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; (* Ring theory *) @@ -274,9 +292,9 @@ let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; 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" +let coq_eq_setoid = my_reference "Eqsth" +let coq_eq_morph = my_reference "Eq_ext" +let coq_eq_smorph = my_reference "Eq_s_ext" (* ring -> almost_ring utilities *) let coq_ring_theory = my_constant "ring_theory" @@ -303,16 +321,19 @@ 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" +let coq_mkhypo = my_reference "mkhypo" +let coq_hypo = my_reference "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)):: + ((global_head_of_constr req,(function -1->Prot|_->Rec)):: List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) +let map_without_eq arg_map _ = + interp_map (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); @@ -343,15 +364,12 @@ type ring_info = ring_pre_tac : glob_tactic_expr; ring_post_tac : glob_tactic_expr } -module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) +module Cmap = Map.Make(Constr) -let from_carrier = ref Cmap.empty -let from_relation = ref Cmap.empty -let from_name = ref Spmap.empty +let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" +let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table" 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 @@ -370,32 +388,9 @@ let find_ring_structure env sigma l = (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 @@ -408,10 +403,10 @@ let subst_th (subst,th) = 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 + let tac'= Tacsubst.subst_tactic subst th.ring_cst_tac in + let pow_tac'= Tacsubst.subst_tactic subst th.ring_pow_tac in + let pretac'= Tacsubst.subst_tactic subst th.ring_pre_tac in + let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && eq' == th.ring_req && eq_constr set' th.ring_setoid && @@ -443,20 +438,20 @@ let theory_to_obj : ring_info -> obj = 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); + open_function = (fun i o -> if Int.equal 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 +let setoid_of_relation env evd a r = 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 |] + let evm = !evd in + let evm, refl = Rewrite.get_reflexive_proof env evm a r in + let evm, sym = Rewrite.get_symmetric_proof env evm a r in + let evm, trans = Rewrite.get_transitive_proof env evm a r in + evd := evm; + lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> error "cannot find setoid relation" @@ -469,7 +464,7 @@ let op_smorph 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 ? *\) *) +(* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *) (* | _ -> false in *) (* match default_relation_for_carrier ~filter:is_setoid r with *) (* Leibniz _ -> *) @@ -484,7 +479,7 @@ let op_smorph r add mul req m1 m2 = (* let is_endomorphism = function *) (* { args=args } -> List.for_all *) (* (function (var,Relation rel) -> *) -(* var=None && eq_constr req rel *) +(* var=None && eq_constr_nounivs req rel *) (* | _ -> false) args in *) (* let add_m = *) (* try default_morphism ~filter:is_endomorphism add *) @@ -519,17 +514,19 @@ let op_smorph r add mul req m1 m2 = (* op_smorph r add mul req add_m.lem mul_m.lem) in *) (* (setoid,op_morph) *) -let ring_equality (r,add,mul,opp,req) = +let ring_equality env evd (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 + | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + let setoid = plapp evd 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 + Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] + | None -> plapp evd coq_eq_smorph [|r;add;mul|] in + let setoid = Typing.solve_evars env evd setoid in + let op_morph = Typing.solve_evars env evd op_morph in (setoid,op_morph) | _ -> - let setoid = setoid_of_relation (Global.env ()) r req in + let setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add @@ -549,7 +546,7 @@ let ring_equality (r,add,mul,opp,req) = let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose - msgnl + msg_info (str"Using setoid \""++pr_constr req++str"\""++spc()++ str"and morphisms \""++pr_constr add_m_lem ++ str"\","++spc()++ str"\""++pr_constr mul_m_lem++ @@ -558,7 +555,7 @@ let ring_equality (r,add,mul,opp,req) = op_morph) | None -> (Flags.if_verbose - msgnl + msg_info (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ str"and morphisms \""++pr_constr add_m_lem ++ str"\""++spc()++str"and \""++ @@ -566,22 +563,22 @@ let ring_equality (r,add,mul,opp,req) = 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 = +let build_setoid_params env evd r add mul opp req eqth = match eqth with Some th -> th - | None -> ring_equality (r,add,mul,opp,req) + | None -> ring_equality env evd (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 eq_constr f (Lazy.force coq_almost_ring_theory) -> + when eq_constr_nounivs 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 eq_constr f (Lazy.force coq_semi_ring_theory) -> + when eq_constr_nounivs 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 eq_constr f (Lazy.force coq_ring_theory) -> + when eq_constr_nounivs f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" @@ -591,18 +588,18 @@ let dest_morph env sigma m_spec = 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 eq_constr f (Lazy.force coq_ring_morph) -> + when eq_constr_nounivs 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 eq_constr f (Lazy.force coq_semi_morph) -> + when eq_constr_nounivs 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 *) +type 'constr coeff_spec = + Computational of 'constr (* equality test *) | Abstract (* coeffs = Z *) - | Morphism of constr (* general morphism *) + | Morphism of 'constr (* general morphism *) let reflect_coeff rkind = @@ -618,101 +615,89 @@ type cst_tac_spec = 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 (CstTac t) -> Tacintern.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(dummy_loc,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(dummy_loc,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 - (dummy_loc,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 - (dummy_loc,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 - (dummy_loc,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 + let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in + TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])) + +let make_hyp env evd c = + let t = Retyping.get_type_of env !evd c in + plapp evd coq_mkhypo [|t;c|] + +let make_hyp_list env evd lH = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in + let l = + List.fold_right + (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH + (plapp evd coq_nil [|carrier|]) + in + let l' = Typing.solve_evars env evd l in + Evarutil.nf_evars_universes !evd l' + +let interp_power env evd pow = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match pow with | None -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in - (TacArg(dummy_loc,TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) + let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in + (TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])), plapp evd coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with - | CstTac t -> Tacinterp.glob_tactic t + | CstTac t -> Tacintern.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 spec = make_hyp env evd (ic_unsafe spec) in + (tac, plapp evd coq_Some [|carrier; spec|]) -let interp_sign env sign = - let carrier = Lazy.force coq_hypo in +let interp_sign env evd sign = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match sign with - | None -> lapp coq_None [|carrier|] + | None -> plapp evd coq_None [|carrier|] | Some spec -> - let spec = make_hyp env (ic spec) in - lapp coq_Some [|carrier;spec|] + let spec = make_hyp env evd (ic_unsafe spec) in + plapp evd coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env div = - let carrier = Lazy.force coq_hypo in +let interp_div env evd div = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match div with - | None -> lapp coq_None [|carrier|] + | None -> plapp evd coq_None [|carrier|] | Some spec -> - let spec = make_hyp env (ic spec) in - lapp coq_Some [|carrier;spec|] + let spec = make_hyp env evd (ic_unsafe spec) in + plapp evd coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = +let add_theory name (sigma,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 evd = ref sigma in + let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in + let (pow_tac, pspec) = interp_power env evd power in + let sspec = interp_sign env evd sign in + let dspec = interp_div env evd div in let rk = reflect_coeff morphth in - let params = - exec_tactic env 5 (zltac "ring_lemmas") + let params,ctx = + exec_tactic env !evd 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 = params.(3) in + let lemma2 = 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 lemma1 = + decl_constant (Id.to_string name^"_ring_lemma1") ctx lemma1 in + let lemma2 = + decl_constant (Id.to_string name^"_ring_lemma2") ctx 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 + Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let posttac = match post with - Some t -> Tacinterp.glob_tactic t + Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let _ = Lib.add_leaf name @@ -720,9 +705,9 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = { 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_ext = params.(1); + ring_morph = params.(2); + ring_th = params.(0); ring_cst_tac = cst_tac; ring_pow_tac = pow_tac; ring_lemma1 = lemma1; @@ -731,22 +716,28 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = ring_post_tac = posttac }) in () -type ring_mod = - Ring_kind of coeff_spec +type 'constr ring_mod = + Ring_kind of 'constr 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 + | Setoid of Constrexpr.constr_expr * Constrexpr.constr_expr + | Pow_spec of cst_tac_spec * Constrexpr.constr_expr (* Syntaxification tactic , correctness lemma *) - | Sign_spec of Topconstr.constr_expr - | Div_spec of Topconstr.constr_expr + | Sign_spec of Constrexpr.constr_expr + | Div_spec of Constrexpr.constr_expr + + +let ic_coeff_spec = function + | Computational t -> Computational (ic_unsafe t) + | Morphism t -> Morphism (ic_unsafe t) + | Abstract -> Abstract VERNAC ARGUMENT EXTEND ring_mod - | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ] + | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ] | [ "abstract" ] -> [ Ring_kind Abstract ] - | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ] + | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism 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 ] @@ -761,7 +752,7 @@ VERNAC ARGUMENT EXTEND ring_mod END let set_once s r v = - if !r = None then r := Some v else error (s^" cannot be set twice") + if Option.is_empty !r then r := Some v else error (s^" cannot be set twice") let process_ring_mods l = let kind = ref None in @@ -773,21 +764,29 @@ let process_ring_mods l = let power = ref None in let div = ref None in List.iter(function - Ring_kind k -> set_once "ring kind" kind k + Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec 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) + | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe 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 +VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "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] + | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ + msg_notice (strbrk "The following ring structures have been declared:"); + Spmap.iter (fun fn fi -> + msg_notice (hov 2 + (Ppconstr.pr_id (Libnames.basename fn)++spc()++ + str"with carrier "++ pr_constr fi.ring_carrier++spc()++ + str"and equivalence relation "++ pr_constr fi.ring_req)) + ) !from_name ] END (*****************************************************************************) @@ -799,10 +798,11 @@ let make_args_list rl t = | [] -> 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 make_term_list env evd carrier rl = + let l = List.fold_right + (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl + (plapp evd coq_nil [|carrier|]) + in Typing.solve_evars env evd l let ltac_ring_structure e = let req = carg e.ring_req in @@ -819,19 +819,24 @@ let ltac_ring_structure e = [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 +let ring_lookup (f:glob_tactic_expr) lH rl t = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + try (* find_ring_strucure can raise an exception *) + let evdref = ref sigma in + let rl = make_args_list rl t in + let e = find_ring_structure env sigma rl in + let rl = carg (make_term_list env evdref e.ring_carrier rl) in + let lH = carg (make_hyp_list env evdref lH) in + let ring = ltac_ring_structure e in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + end 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 f lH lr t] + [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t] END @@ -839,10 +844,10 @@ END (***********************************************************************) let new_field_path = - make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"]) + DirPath.make (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)) + lazy(make_kn (MPfile new_field_path) DirPath.empty (Label.make s)) let _ = add_map "field" @@ -851,9 +856,9 @@ let _ = add_map "field" 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", + my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); - my_constant "display_pow_linear", + my_reference "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 *) @@ -865,16 +870,16 @@ let _ = add_map "field" 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)]);; + my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; let _ = add_map "field_cond" - (map_with_eq + (map_without_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)]);;*) + my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; +(* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*) let _ = Redexpr.declare_reduction "simpl_field_expr" @@ -882,29 +887,29 @@ let _ = Redexpr.declare_reduction "simpl_field_expr" -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 +let afield_theory = my_reference "almost_field_theory" +let field_theory = my_reference "field_theory" +let sfield_theory = my_reference "semi_field_theory" +let af_ar = my_reference"AF_AR" +let f_r = my_reference"F_R" +let sf_sr = my_reference"SF_SR" +let dest_field env evd th_spec = + let th_typ = Retyping.get_type_of env !evd th_spec in match kind_of_term th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when eq_constr f (Lazy.force afield_theory) -> - let rth = lapp af_ar + when is_global (Lazy.force afield_theory) f -> + let rth = plapp evd 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 eq_constr f (Lazy.force field_theory) -> + when is_global (Lazy.force field_theory) f -> let rth = - lapp f_r + plapp evd 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 eq_constr f (Lazy.force sfield_theory) -> - let rth = lapp sf_sr + when is_global (Lazy.force sfield_theory) f -> + let rth = plapp evd 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" @@ -922,13 +927,10 @@ type field_info = 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_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table" +let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table" 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"]); @@ -948,35 +950,9 @@ let find_field_structure env sigma l = (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) = @@ -987,10 +963,10 @@ let subst_th (subst,th) = 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 + let tac'= Tacsubst.subst_tactic subst th.field_cst_tac in + let pow_tac' = Tacsubst.subst_tactic subst th.field_pow_tac in + let pretac'= Tacsubst.subst_tactic subst th.field_pre_tac in + let posttac'= Tacsubst.subst_tactic subst th.field_post_tac in if c' == th.field_carrier && eq' == th.field_req && thm1' == th.field_ok && @@ -1019,17 +995,17 @@ let ftheory_to_obj : field_info -> obj = 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); + open_function = (fun i o -> if Int.equal 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 = +let field_equality evd 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|]) + | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) | _ -> - let _setoid = setoid_of_relation (Global.env ()) r req in + let _setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv @@ -1037,45 +1013,50 @@ let field_equality r inv req = 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 = +let add_field_theory name (sigma,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 evd = ref sigma 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 + dest_field env evd fth in + let (sth,ext) = build_setoid_params env evd 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 _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in + let (pow_tac, pspec) = interp_power env evd power in + let sspec = interp_sign env evd sign in + let dspec = interp_div env evd odiv in + let inv_m = field_equality evd r inv req in let rk = reflect_coeff morphth in - let params = - exec_tactic env 9 (field_ltac"field_lemmas") + let params,ctx = + exec_tactic env !evd 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 lemma1 = params.(3) in + let lemma2 = params.(4) in + let lemma3 = params.(5) in + let lemma4 = 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 + | Some thm -> mkApp(params.(8),[|thm|]) + | None -> params.(7) in + let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") + ctx lemma1 in + let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") + ctx lemma2 in + let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") + ctx lemma3 in + let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") + ctx lemma4 in + let cond_lemma = decl_constant (Id.to_string name^"_lemma5") + ctx 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 + Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let posttac = match post with - Some t -> Tacinterp.glob_tactic t + Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let _ = Lib.add_leaf name @@ -1092,9 +1073,9 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odi field_pre_tac = pretac; field_post_tac = posttac }) in () -type field_mod = - Ring_mod of ring_mod - | Inject of Topconstr.constr_expr +type 'constr field_mod = + Ring_mod of 'constr ring_mod + | Inject of Constrexpr.constr_expr VERNAC ARGUMENT EXTEND field_mod | [ ring_mod(m) ] -> [ Ring_mod m ] @@ -1112,23 +1093,31 @@ let process_field_mods l = 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(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec 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(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe 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; + | Inject i -> set_once "infinite property" inj (ic_unsafe 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 +VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "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] +| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ + msg_notice (strbrk "The following field structures have been declared:"); + Spmap.iter (fun fn fi -> + msg_notice (hov 2 + (Ppconstr.pr_id (Libnames.basename fn)++spc()++ + str"with carrier "++ pr_constr fi.field_carrier++spc()++ + str"and equivalence relation "++ pr_constr fi.field_req)) + ) !field_from_name ] END @@ -1146,18 +1135,23 @@ let ltac_field_structure e = [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 +let field_lookup (f:glob_tactic_expr) lH rl t = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + try + let evdref = ref sigma in + let rl = make_args_list rl t in + let e = find_field_structure env sigma rl in + let rl = carg (make_term_list env evdref e.field_carrier rl) in + let lH = carg (make_hyp_list env evdref lH) in + let field = ltac_field_structure e in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + end 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 f lH l t ] + [ let (t,l) = List.sep_last lt in field_lookup f lH l t ] END diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget index 580df9b5..595ba55e 100644 --- a/plugins/setoid_ring/vo.itarget +++ b/plugins/setoid_ring/vo.itarget @@ -7,7 +7,6 @@ InitialRing.vo NArithRing.vo RealField.vo Ring_base.vo -Ring_equiv.vo Ring_polynom.vo Ring_tac.vo Ring_theory.vo diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml deleted file mode 100644 index f4d8b769..00000000 --- a/plugins/subtac/eterm.ml +++ /dev/null @@ -1,259 +0,0 @@ -(** - - 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_src: hole_kind located; - ev_typ: types; - ev_tac: tactic option; - ev_deps: Intset.t } - -(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *) -open Store.Field -let evar_tactic = Store.field () - -(** 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 evars_of_evar_info evi = - Intset.union (Evarutil.evars_of_term evi.evar_concl) - (Intset.union - (match evi.evar_body with - | Evar_empty -> Intset.empty - | Evar_defined b -> Evarutil.evars_of_term b) - (Evarutil.evars_of_named_context (evar_filtered_context evi))) - -let evar_dependencies evm oev = - let one_step deps = - Intset.fold (fun ev s -> - let evi = Evd.find evm ev in - let deps' = evars_of_evar_info evi in - if Intset.mem oev deps' then - raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev)) - else Intset.union deps' 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 oev) - -let move_after (id, ev, deps as obl) l = - let rec aux restdeps = function - | (id', _, _) as obl' :: tl -> - let restdeps' = Intset.remove id' restdeps in - if Intset.is_empty restdeps' then - obl' :: obl :: tl - else obl' :: aux restdeps' tl - | [] -> [obl] - in aux (Intset.remove id deps) l - -let sort_dependencies evl = - let rec aux l found list = - match l with - | (id, ev, deps) as obl :: tl -> - let found' = Intset.union found (Intset.singleton id) in - if Intset.subset deps found' then - aux tl found' (obl :: list) - else aux (move_after obl tl) found list - | [] -> List.rev list - in aux evl Intset.empty [] - -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 evar_tactic.get 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_src = loc, k; 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_src = src; 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, src, 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 deleted file mode 100644 index 35744b71..00000000 --- a/plugins/subtac/eterm.mli +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* 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 * hole_kind located * 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 deleted file mode 100644 index c89d135f..00000000 --- a/plugins/subtac/g_subtac.ml4 +++ /dev/null @@ -1,167 +0,0 @@ -(************************************************************************) -(* 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 = gec "subtac_gallina_loc" - - let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.entry = gec "subtac_withtac" -end - -open Glob_term -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 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.closed_binder: - [[ "("; 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)] - ] ]; - - 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 None "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 None "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 when Errors.noncritical exn -> - errorlabstrm "Program" (Errors.print 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 - -open Pp - -VERNAC COMMAND EXTEND Subtac_Show_Solver -| [ "Show" "Obligation" "Tactic" ] -> [ - msgnl (str"Program obligation tactic is " ++ Subtac_obligations.print_default_tactic ()) ] -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 deleted file mode 100644 index 89d9050c..00000000 --- a/plugins/subtac/subtac.ml +++ /dev/null @@ -1,226 +0,0 @@ -(************************************************************************) -(* 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 ~is_type:true 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 start_proof_and_print env isevars idopt k t hook = - start_proof_com env isevars idopt k t hook; - Vernacentries.print_subgoals () - -let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (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) -> - 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 -> - 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) - - | 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 -> - if Dumpglob.dump () then - List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; - ignore(Subtac_command.build_corecursive l) - - (*| 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 -> raise e - - | Type_errors.TypeError (env, exn) as e -> raise e - - | Pretype_errors.PretypeError (env, _, exn) as e -> raise e - - | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) | - Loc.Exc_located (loc, e') as e) -> raise e - - | reraise -> - (* msg_warning (str "Uncaught exception: " ++ Errors.print e); *) - raise reraise diff --git a/plugins/subtac/subtac.mli b/plugins/subtac/subtac.mli deleted file mode 100644 index b51150aa..00000000 --- a/plugins/subtac/subtac.mli +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 index 9ff8ba50..00000000 --- a/plugins/subtac/subtac_cases.ml +++ /dev/null @@ -1,2023 +0,0 @@ -(************************************************************************) -(* 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 : glob_constr; - } - -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 glob_pattern_of_partial_history args2 = function - | Continuation (n, args1, h) -> - let args3 = make_anonymous_patvars (n - (List.length args2)) in - build_glob_pattern (List.rev_append args1 (args2@args3)) h - | Result pl -> pl - -and build_glob_pattern args = function - | Top -> args - | MakeAlias (AliasLeaf, rh) -> - assert (args = []); - glob_pattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh - | MakeAlias (AliasConstructor pci, rh) -> - glob_pattern_of_partial_history - [PatCstr (dummy_loc, pci, args, Anonymous)] rh - -let complete_history = glob_pattern_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 -> glob_constr -> 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 e when Errors.noncritical e -> 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_glob_constr 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_glob_constr 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 true 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_glob_constr 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 isRel t && destRel t = 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 e when Errors.noncritical e -> 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 true 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 (delayed_force eq_ind, [| typ; x ; y |]) -let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |]) -let mk_JMeq typ x typ' y = - mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) -let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |]) - -let hole = GHole (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 (substl args (liftn (List.length sign) (succ (List.length args)) 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, - (GApp (dummy_loc, - (GRef (dummy_loc, delayed_force refl_ref)), [hole; GVar (dummy_loc, prev)])) :: vars - | _ -> - match na with - Anonymous -> raise (Invalid_argument "vars_of_ctx") - | Name n -> n, GVar (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 (delayed_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 ("program_branch_" ^ (string_of_int !i)) in - let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in - let branch = - let bref = GVar (dummy_loc, branch_name) in - match vars_of_ctx rhs_rels with - [] -> bref - | l -> GApp (dummy_loc, bref, l) - in - let branch = match ineqs with - Some _ -> GApp (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 (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, neqs, [], [], 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 deleted file mode 100644 index 5ef42b13..00000000 --- a/plugins/subtac/subtac_cases.mli +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* 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 in bl - -let interp_type_evars_impls ~evdref ?(impls=empty_internalization_env) env c = - let c = intern_gen true ~impls !evdref env c in - let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in - SPretyping.understand_tcc_evars ~fail_evar:false evdref env IsType c, imps - -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 ~filter:Subtac_utils.no_goals_or_obligations ~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 - evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; - let ctx = Evarutil.nf_rel_context_evar !evars ctx - and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in - let env' = push_rel_context ctx env in - let sigma = !evars in - let subst = List.map (Evarutil.nf_evar sigma) subst in - let props = - match props with - | Some (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 - | Some p -> Inr p - | None -> Inl [] - in - let subst = - match props with - | Inr term -> - let c = interp_casted_constr_evars evars env' term cty in - Inr c - | 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 - List.iter - (fun (n, _, x) -> - if n = Name mid then - Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) - 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; - evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; - evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !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 (Option.get app) (ctx' @ ctx) in - term, termtype - | Inr def -> - 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 - Impargs.declare_manual_implicits false gr ~enriching:false [imps]; - Typeclasses.declare_instance pri (not global) (ConstRef cst) - 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,Instance) ~hook obls diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli deleted file mode 100644 index bd3fe484..00000000 --- a/plugins/subtac/subtac_classes.mli +++ /dev/null @@ -1,39 +0,0 @@ -(************************************************************************) -(* 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 option -> - ?generalize:bool -> - int option -> - identifier * Subtac_obligations.progress diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml deleted file mode 100644 index 4fe29ac8..00000000 --- a/plugins/subtac/subtac_coercion.ml +++ /dev/null @@ -1,510 +0,0 @@ -(************************************************************************) -(* 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_ = delayed_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 (delayed_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 (delayed_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 hnf_nodelta env evars c = whd_betaiota evars 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 rec aux v = - let v = hnf env !isevars v in - match disc_subset v with - Some (u, p) -> - let f, ct = aux u in - let p = hnf env !isevars p in - (Some (fun x -> - app_opt env isevars - f (mkApp ((delayed_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 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 :: List.map (lift 1) tele) in - let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in - let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in - let evar = make_existential loc env isevars eq in - let eq_app x = mkApp (delayed_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 env' isevars 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 env' isevars 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 = delayed_force existS in - let prod = delayed_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 env !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 env' isevars c1 (mkApp (existS.proj1, - [| a; pb; x |])), - app_opt env' isevars 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 env isevars c1 (mkApp (prod.proj1, - [| a; b; x |])), - app_opt env isevars 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 env isevars c (mkApp ((delayed_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 env isevars c x in - let evar = make_existential loc env isevars (mkApp (p, [| cx |])) - in - (mkApp - ((delayed_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 - let t = Option.map (app_opt env evars coercion) v in - !evars, t - - (* 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 e when Errors.noncritical e -> anomaly "apply_coercion" - - let inh_app_fun _ env isevars j = - let isevars = ref isevars in - let t = hnf 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 - let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in - (!isevars, res) - 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 = hnf 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 isevars = ref isevars in - let typ = hnf env !isevars j.uj_type in - let ct, typ' = mu env isevars typ in - let res = - { uj_val = app_opt env isevars ct j.uj_val; - uj_type = typ' } - in !isevars, res - - let inh_coerce_to_prod loc env isevars t = - let isevars = ref isevars in - let typ = hnf 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 cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type } - and t = hnf_nodelta env evd t in - let (evd', val') = - try - inh_conv_coerce_to_fail loc env evd rigidonly - (Some cj.uj_val) cj.uj_type t - with NoCoercion -> - (try - coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t - with NoSubtacCoercion -> - error_actual_type_loc loc env evd 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 -> - error_cannot_coerce env' isevars (t, t')) - else isevars - with e when Errors.noncritical e -> isevars -end diff --git a/plugins/subtac/subtac_coercion.mli b/plugins/subtac/subtac_coercion.mli deleted file mode 100644 index 5678c10e..00000000 --- a/plugins/subtac/subtac_coercion.mli +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 index 537a8301..00000000 --- a/plugins/subtac/subtac_command.ml +++ /dev/null @@ -1,544 +0,0 @@ -open Closure -open RedFlags -open Declarations -open Entries -open Libobject -open Pattern -open Matching -open Pp -open Glob_term -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 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=Constrintern.empty_internalization_env) ?(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=Constrintern.empty_internalization_env) c = - interp_gen IsType isevars env ~impls c - -let interp_casted_constr isevars env ?(impls=Constrintern.empty_internalization_env) c typ = - interp_gen (OfType (Some typ)) isevars env ~impls c - -let interp_casted_constr_evars isevars env ?(impls=Constrintern.empty_internalization_env) 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 - | GHole _ -> - (try match na with - | Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id) - | Anonymous -> raise Not_found - with Not_found -> GHole (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_glob_constr t) na t) - -let interp_context_evars evdref env params = - let int_env, bl = Constrintern.intern_context false !evdref env Constrintern.empty_internalization_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_glob_constr 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 (Termops.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_ndecls = [|2|]; - ci_pp_info = { ind_nargs = 0; style = LetStyle } - } - -let rec 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 - - | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in - ty, ((n, Some b, t) :: subst), lift 1 term - -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 = - 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 error () = - user_err_loc (constr_loc r, - "Subtac_command.build_wellfounded", - my_print_constr env rel ++ str " is not an homogeneous binary relation.") - in - try - 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 - | _, _ -> error () - with e when Errors.noncritical e -> error () - 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 (delayed_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 (delayed_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 = (delayed_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 ((delayed_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 = Idmap.singleton recname - (r, l, impls @ [(Some (id_of_string "recproof", Impargs.Manual, (true, false)))], - scopes @ [None]) 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 (delayed_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_secctx = None; - const_entry_type = Some ty; - const_entry_opaque = 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 find_annot loc id ctx = - try rel_index id ctx - with Not_found -> - user_err_loc(loc,"", - str "No parameter named " ++ Nameops.pr_id id ++ str".") - -let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = - match n with - | Some (loc, id) -> [find_annot loc id 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 = - 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 (delayed_force Subtac_utils.fix_proto, [|sort; t|]) - with e when Errors.noncritical 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_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 - ~filter:Typeclasses.no_goals ~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 = - 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) - - | [(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) - - | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> - let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) -> - ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n; - Command.fix_body = def; Command.fix_type = typ},ntn)) l - in interp_recursive (IsFixpoint g) fixl - | _, _ -> - errorlabstrm "Subtac_command.build_recursive" - (str "Well-founded fixpoints not allowed in mutually recursive blocks") - -let build_corecursive l = - let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> - ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None; - Command.fix_body = def; Command.fix_type = typ},ntn)) - l in - interp_recursive IsCoFixpoint fixl diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli deleted file mode 100644 index 72549a01..00000000 --- a/plugins/subtac/subtac_command.mli +++ /dev/null @@ -1,60 +0,0 @@ -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: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:internalization_env -> - constr_expr -> constr -val interp_casted_constr_evars : - evar_map ref -> - env -> - ?impls: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 * Term.types 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 -> Subtac_obligations.progress - -val build_recursive : - (fixpoint_expr * decl_notation list) list -> unit - -val build_corecursive : - (cofixpoint_expr * decl_notation list) list -> unit diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml deleted file mode 100644 index 067da150..00000000 --- a/plugins/subtac/subtac_errors.ml +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index 8d75b9c0..00000000 --- a/plugins/subtac/subtac_errors.mli +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100644 index 7a4916fa..00000000 --- a/plugins/subtac/subtac_obligations.ml +++ /dev/null @@ -1,699 +0,0 @@ -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 -open Compat - -let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) -let pperror cmd = Util.errorlabstrm "Program" cmd -let error s = pperror (str s) - -let reduce c = - Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c - -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 * hole_kind located * - obligation_definition_status * Intset.t * tactic option) array - -type obligation = - { obl_name : identifier; - obl_type : types; - obl_location : hole_kind located; - 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_reduce : constr -> constr; - prg_hook : Tacexpr.declaration_hook; -} - -let assumption_message id = - Flags.if_verbose message ((string_of_id id) ^ " is assumed") - -let (set_default_tactic, get_default_tactic, print_default_tactic) = - Tactic_option.declare_tactic_option "Program tactic" - -(* 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; - optdepr = false; - optname = "transparency of Program obligations"; - optkey = ["Transparent";"Obligations"]; - optread = get_proofs_transparency; - optwrite = set_proofs_transparency; } - -(* true = hide obligations *) -let hide_obligations = ref false - -let set_hide_obligations = (:=) hide_obligations -let get_hide_obligations () = !hide_obligations - -open Goptions - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "Hidding of Program obligations"; - optkey = ["Hide";"Obligations"]; - optread = get_hide_obligations; - optwrite = set_hide_obligations; } - -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 obl_substitution expand obls deps = - Intset.fold - (fun x acc -> - let xobl = obls.(x) in - let oblb = - try get_obligation_body expand xobl - with e when Errors.noncritical e -> assert(false) - in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) - deps [] - -let subst_deps expand obls deps t = - let subst = obl_substitution expand obls deps in - Term.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t - -let rec prod_app t n = - match kind_of_term (strip_outer_cast t) with - | Prod (_,_,b) -> subst1 n b - | LetIn (_, b, t, b') -> prod_app (subst1 b b') n - | _ -> - errorlabstrm "prod_app" - (str"Needed a product, but didn't find one" ++ fnl ()) - - -(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) -let prod_applist t nL = List.fold_left prod_app t nL - -let replace_appvars subst = - let rec aux c = - let f, l = decompose_app c in - if isVar f then - try - let c' = List.map (map_constr aux) l in - let (t, b) = List.assoc (destVar f) subst in - mkApp (delayed_force hide_obligation, - [| prod_applist t c'; applistc b c' |]) - with Not_found -> map_constr aux c - else map_constr aux c - in map_constr aux - -let subst_prog expand obls ints prg = - let subst = obl_substitution expand obls ints in - if get_hide_obligations () then - (replace_appvars subst prg.prg_body, - replace_appvars subst (Termops.refresh_universes prg.prg_type)) - else - let subst' = List.map (fun (n, (_, b)) -> n, b) subst in - (Term.replace_vars subst' prg.prg_body, - Term.replace_vars subst' (Termops.refresh_universes prg.prg_type)) - -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 -let unfreeze v = from_prg := v -let init () = from_prg := ProgMap.empty - -(** 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 close sec = - if not (ProgMap.is_empty !from_prg) then - let keys = map_keys !from_prg in - errorlabstrm "Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ - prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ - (str (if List.length keys = 1 then " has " else "have ") ++ - str "unsolved obligations")) - -let input : program_info ProgMap.t -> obj = - declare_object - { (default_object "Program state") with - cache_function = (fun (na, pi) -> from_prg := pi); - load_function = (fun _ (_, pi) -> from_prg := pi); - discharge_function = (fun _ -> close "section"; None); - classify_function = (fun _ -> close "module"; Dispose) } - -open Evd - -let progmap_remove prg = - Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg)) - -let progmap_add n prg = - Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg)) - -let progmap_replace prg' = - Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !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_prog expand obls ints prg - -let declare_definition prg = - let body, typ = subst_body true prg in - let (local, kind) = prg.prg_kind in - let ce = - { const_entry_body = body; - const_entry_secctx = None; - const_entry_type = Some typ; - const_entry_opaque = false } - 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 (snd 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 - x.prg_reduce term, x.prg_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,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 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 = prg.prg_reduce body in - let ty = prg.prg_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_secctx = None; - const_entry_type = Some ty; - const_entry_opaque = opaque } - 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 init_prog_info n b t deps fixkind notations obls impls kind reduce 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, InternalHole; 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 = reduce t; obl_status = o; - obl_deps = d; obl_tac = tac }) - obls, b - in - { prg_name = n ; prg_body = b; prg_type = reduce t; prg_obligations = (obls', Array.length obls'); - prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; - prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; 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 - progmap_replace 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 dependencies obls n = - let res = ref Intset.empty in - Array.iteri - (fun i obl -> - if i <> n && Intset.mem n obl.obl_deps then - res := Intset.add i !res) - 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 when Errors.noncritical e -> - pperror (Errors.print (Cerrors.process_vernac_interp_error e)) - in - match res with - | Remain n when n > 0 -> - let deps = dependencies obls num in - if deps <> Intset.empty then - ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps) - | _ -> ()); - trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ - Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); - Pfedit.by (snd (get_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 -> snd (get_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 - | Loc.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) - | Loc.Exc_located(_, Refiner.FailError (_, s)) - | Refiner.FailError (_, s) -> - user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) - | Util.Anomaly _ as e -> raise e - | e when Errors.noncritical e -> false - -and solve_prg_obligations prg ?oblset tac = - let obls, rem = prg.prg_obligations in - let rem = ref rem in - let obls' = Array.copy obls in - let set = ref Intset.empty in - let p = match oblset with - | None -> (fun _ -> true) - | Some s -> set := s; - (fun i -> Intset.mem i !set) - in - let _ = - Array.iteri (fun i x -> - if p i && solve_obligation_by_tac prg obls' i tac then - let deps = dependencies obls i in - (set := Intset.union !set deps; - 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 ?oblset tac : progress = - Flags.if_verbose msgnl (str "Solving obligations automatically..."); - try solve_prg_obligations (get_prog_err n) ?oblset 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,Definition) ?tactic - ?(reduce=reduce) ?(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 reduce 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 - progmap_add n 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,Definition) ?(reduce=reduce) - ?(hook=fun _ _ -> ()) notations fixkind = - let deps = List.map (fun (n, b, t, imps, obls) -> n) l in - List.iter - (fun (n, b, t, imps, obls) -> - let prg = init_prog_info n (Some b) t deps (Some fixkind) - notations obls imps kind reduce hook - in progmap_add n prg) l; - 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 - let obls = Array.copy obls 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 (None, x.obl_type,None), 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 diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli deleted file mode 100644 index c1d665aa..00000000 --- a/plugins/subtac/subtac_obligations.mli +++ /dev/null @@ -1,72 +0,0 @@ -open Names -open Util -open Libnames -open Evd -open Proof_type -open Vernacexpr - -type obligation_info = - (identifier * Term.types * hole_kind located * - 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 get_default_tactic : unit -> locality_flag * Proof_type.tactic -val print_default_tactic : unit -> Pp.std_ppcmds - -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 -> - ?reduce:(Term.constr -> Term.constr) -> - ?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 -> - ?reduce:(Term.constr -> Term.constr) -> - ?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 deleted file mode 100644 index a4b9d67e..00000000 --- a/plugins/subtac/subtac_plugin.mllib +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index 68636574..00000000 --- a/plugins/subtac/subtac_pretyping.ml +++ /dev/null @@ -1,138 +0,0 @@ -(************************************************************************) -(* 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_glob_constr env c) ++ *) -(* str " and tycon "++ my_print_tycon env tycon ++ *) -(* str " in environment: " ++ my_print_env env); *) - -let interp env isevars c tycon = - let j = pretype true 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 ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in - let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~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 -> Glob_term.glob_constr = - Constrintern.intern_constr evd env -let coqintern_type evd env : Topconstr.constr_expr -> Glob_term.glob_constr = - 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 ?(is_type=false) env isevars id bl c tycon = - let c = Topconstr.abstract_constr_expr c bl in - let tycon, imps = - match tycon with - None -> empty_tycon, None - | Some t -> - let t = Topconstr.prod_constr_expr t bl in - let t = coqintern_type !isevars env t in - let imps = Implicit_quantifiers.implicits_of_glob_constr t in - let coqt, ttyp = interp env isevars t empty_tycon in - mk_tycon coqt, Some imps - in - let c = coqintern_constr !isevars env c in - let imps = match imps with - | Some i -> i - | None -> Implicit_quantifiers.implicits_of_glob_constr ~with_products:is_type 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 deleted file mode 100644 index fa767790..00000000 --- a/plugins/subtac/subtac_pretyping.mli +++ /dev/null @@ -1,23 +0,0 @@ -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 -> - Glob_term.glob_constr -> - Evarutil.type_constraint -> Term.constr * Term.constr - -val subtac_process : ?is_type:bool -> 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 deleted file mode 100644 index 3fc35c81..00000000 --- a/plugins/subtac/subtac_pretyping_F.ml +++ /dev/null @@ -1,662 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* j - | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc 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 mind (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 (Termops.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) = Termops.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=Termops.it_mkLambda ccl' sign; uj_type=Termops.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 evdref = function - | GProp c -> judge_of_prop_contents c - | GType _ -> evd_comb0 judge_of_new_Type evdref - - let split_tycon_lam loc env evd tycon = - let rec real_split evd c = - let t = whd_betadeltaiota env evd c in - match kind_of_term t with - | Prod (na,dom,rng) -> evd, (na, dom, rng) - | Evar ev when not (Evd.is_defined_evar evd ev) -> - let (evd',prod) = define_evar_as_product evd ev in - let (_,dom,rng) = destProd prod in - evd',(Anonymous, dom, rng) - | _ -> error_not_product_loc loc env evd c - in - match tycon with - | None -> evd,(Anonymous,None,None) - | Some (abs, c) -> - (match abs with - | None -> - let evd', (n, dom, rng) = real_split evd c in - evd', (n, mk_tycon dom, mk_tycon rng) - | Some (init, cur) -> - evd, (Anonymous, None, Some (Some (init, succ cur), c))) - - - (* [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 resolve_tc (tycon : type_constraint) env evdref lvar c = -(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_glob_constr env c ++ *) -(* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) -(* with _ -> () *) -(* in *) - let pretype = pretype resolve_tc in - let pretype_type = pretype_type resolve_tc in - let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in - match c with - | GRef (loc,ref) -> - inh_conv_coerce_to_tycon loc env evdref - (pretype_ref evdref env ref) - tycon - - | GVar (loc, id) -> - inh_conv_coerce_to_tycon loc env evdref - (pretype_id loc env !evdref lvar id) - tycon - - | GEvar (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 - - | GPatVar (loc,(someta,n)) -> - anomaly "Found a pattern variable in a glob_constr to type" - - | GHole (loc,k) -> - let ty = - match tycon with - | Some (None, ty) -> ty - | None | Some _ -> - e_new_evar evdref env ~src:(loc, InternalHole) (Termops.new_Type ()) in - { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } - - | GRec (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 (delayed_force Subtac_utils.fix_proto, [| sort; ty |])) - ftys - in - push_rec_types (names,marked_ftys,[||]) env - in - let fixi = match fixkind with GFix (vn, i) -> i | GCoFix 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 - | GFix (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) - | GCoFix i -> - let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix - with e when Errors.noncritical e -> Loc.raise loc e); - make_judge (mkCoFix cofix) ftys.(i) in - inh_conv_coerce_to_tycon loc env evdref fixj tycon - - | GSort (loc,s) -> - let s' = pretype_sort evdref s in - inh_conv_coerce_to_tycon loc env evdref s' tycon - - | GApp (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) -> - if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty - else None - | _ -> None - in - let fj = pretype ftycon env evdref lvar f in - let floc = loc_of_glob_constr f in - let rec apply_rec env n resj tycon = function - | [] -> resj - | c::rest -> - let argloc = loc_of_glob_constr c in - let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc 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 c1) env evdref lvar c in - let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in - apply_rec env (n+1) - { uj_val = value; - uj_type = typ } - (Option.map (fun (abs, c) -> abs, 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 = apply_rec env 1 fj ftycon args in - let resj = - match kind_of_term (whd_evar !evdref 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 - - | GLambda(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_lam 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 - - | GProd(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' = Termops.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 -> Loc.raise loc e in - inh_conv_coerce_to_tycon loc env evdref resj tycon - - | GLetIn(loc,name,c1,c2) -> - let j = pretype empty_tycon env evdref lvar c1 in - let t = Termops.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 } - - | GLetTuple (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_glob_constr 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 }) - - | GIf (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_glob_constr 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) (Termops.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 - let f cs b = - let n = rel_context_length cs.cs_args in - let pi = lift n pred in - 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 - 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 } - - | GCases (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) - - | GCast (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 - 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 - - (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) - and pretype_type resolve_tc valcon env evdref lvar = function - | GHole 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 = Termops.new_Type_sort () in - { utj_val = e_new_evar evdref env ~src:loc (mkSort s); - utj_type = s}) - | c -> - let j = pretype resolve_tc empty_tycon env evdref lvar c in - let loc = loc_of_glob_constr 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_glob_constr 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 resolve_classes tycon env evdref lvar c).uj_val - | IsType -> - (pretype_type resolve_classes empty_valcon env evdref lvar c).utj_val - in - if resolve_classes then - (try - evdref := Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations - ~split:true ~fail:true env !evdref; - evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars - ~split:true ~fail:false env !evdref - with e when Errors.noncritical e -> - if fail_evar then raise e else ()); - evdref := consider_remaining_unif_problems 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 true 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 true 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 ?(resolve_classes=false) expand_evar sigma env lvar kind c = - ise_pretype_gen expand_evar false resolve_classes 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 deleted file mode 100644 index e32bb9e0..00000000 --- a/plugins/subtac/subtac_utils.ml +++ /dev/null @@ -1,476 +0,0 @@ -(** -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) - -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 fixsub_module = subtac_dir @ ["Wf"] -let utils_module = subtac_dir @ ["Utils"] -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 safe_init_constant md name () = - check_required_library ("Coq"::md); - init_constant md name () - -let ex_pi1 = init_constant utils_module "ex_pi1" -let ex_pi2 = init_constant utils_module "ex_pi2" - -let make_ref l s = 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_ = build_sig - -let fix_proto = safe_init_constant tactics_module "fix_proto" - -let hide_obligation = safe_init_constant tactics_module "obligation" - -let eq_ind = init_constant ["Init"; "Logic"] "eq" -let eq_rec = init_constant ["Init"; "Logic"] "eq_rec" -let eq_rect = init_constant ["Init"; "Logic"] "eq_rect" -let eq_refl = init_constant ["Init"; "Logic"] "refl_equal" -let eq_ind_ref = init_reference ["Init"; "Logic"] "eq" -let refl_equal_ref = init_reference ["Init"; "Logic"] "refl_equal" - -let not_ref = init_constant ["Init"; "Logic"] "not" - -let and_typ = Coqlib.build_coq_and - -let eqdep_ind = init_constant [ "Logic";"Eqdep"] "eq_dep" -let eqdep_rec = init_constant ["Logic";"Eqdep"] "eq_dep_rec" -let eqdep_ind_ref = init_reference [ "Logic";"Eqdep"] "eq_dep" -let eqdep_intro_ref = init_reference [ "Logic";"Eqdep"] "eq_dep_intro" - -let jmeq_ind = - safe_init_constant ["Logic";"JMeq"] "JMeq" - -let jmeq_rec = - init_constant ["Logic";"JMeq"] "JMeq_rec" - -let jmeq_refl = - init_constant ["Logic";"JMeq"] "JMeq_refl" - -let ex_ind = init_constant ["Init"; "Logic"] "ex" -let ex_intro = init_reference ["Init"; "Logic"] "ex_intro" - -let proj1 = init_constant ["Init"; "Logic"] "proj1" -let proj2 = init_constant ["Init"; "Logic"] "proj2" - -let existS = build_sigma_type - -let prod = build_prod - - -(* orders *) -let well_founded = init_constant ["Init"; "Wf"] "well_founded" -let fix = init_constant ["Init"; "Wf"] "Fix" -let acc = init_constant ["Init"; "Wf"] "Acc" -let acc_inv = 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_glob_constr = Printer.pr_glob_constr_env -let my_print_evardefs = Evd.pr_evar_map None - -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" ()) - (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 = - Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c - -let no_goals_or_obligations = function - | GoalEvar | QuestionMark _ -> false - | _ -> true - -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 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 e when Errors.noncritical e -> ()); - let tac = assert_tac (Name n) hyptype in - let conttac = - (fun cont -> - conttac - (tclTHENS tac - ([intros; - (tclTHENSEQ - [constructor_tac false (Some 1) 1 - (Glob_term.ImplicitBindings [mkVar n]); - cont]); - ]))) - in - let conttype = - (fun typ -> - let tex = mkLambda (Name n, t, typ) in - conttype - (mkApp (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 [] identity identity (List.rev l) - -open Proof_type -open Tacexpr - -let mkProj1 a b c = - mkApp (delayed_force proj1, [| a; b; c |]) - -let mkProj2 a b c = - mkApp (delayed_force proj2, [| a; b; c |]) - -let mk_ex_pi1 a b c = - mkApp (delayed_force ex_pi1, [| a; b; c |]) - -let mk_ex_pi2 a b c = - mkApp (delayed_force ex_pi2, [| a; b; c |]) - -let mkSubset name typ prop = - mkApp ((delayed_force sig_).typ, - [| typ; mkLambda (name, typ, prop) |]) - -let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |]) -let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |]) -let mk_JMeq typ x typ' y = mkApp (delayed_force jmeq_ind, [| typ; x ; typ'; y |]) -let mk_JMeq_refl typ x = mkApp (delayed_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 = delayed_force and_typ in - unsafe_fold_right - (fun c conj -> - mkApp (conj_typ, [| c ; conj |])) - l - -let mk_not c = - let notc = delayed_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 (delayed_force ex_ind) && Array.length args = 2 -> - let (dom, rng) = - try (args.(0), args.(1)) - with e when Errors.noncritical e -> 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 Glob_term - -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 reraise -> - Pfedit.delete_current_proof(); - raise reraise - -(* 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 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 " : " ++ - Termops.print_constr b.rebus ++ fnl ()) - | (mv,Clval(na,b,_)) -> - hov 0 - (pr_meta mv ++ pr_name na ++ str " := " ++ - Termops.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 = Termops.print_constr evi.evar_concl in - let pb = - match evi.evar_body with - | Evar_empty -> mt () - | Evar_defined c -> spc() ++ str"=> " ++ Termops.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) -> - Termops.print_constr t1 ++ spc() ++ - str (match pbty with - | Reduction.CONV -> "==" - | Reduction.CUMUL -> "<=") ++ - spc() ++ Termops.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(dummy_loc,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 deleted file mode 100644 index 112b1795..00000000 --- a/plugins/subtac/subtac_utils.mli +++ /dev/null @@ -1,131 +0,0 @@ -open Term -open Libnames -open Coqlib -open Environ -open Pp -open Evd -open Decl_kinds -open Topconstr -open Glob_term -open Util -open Evarutil -open Names -open Sign - -val ($) : ('a -> 'b) -> 'a -> 'b -val contrib_name : string -val subtac_dir : string list -val fixsub_module : string list -val init_constant : string list -> string -> constr delayed -val init_reference : string list -> string -> global_reference delayed -val well_founded_ref : global_reference delayed -val acc_ref : global_reference delayed -val acc_inv_ref : global_reference delayed -val fix_sub_ref : global_reference delayed -val measure_on_R_ref : global_reference delayed -val fix_measure_sub_ref : global_reference delayed -val refl_ref : global_reference delayed -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 delayed - -val fix_proto : constr delayed - -val hide_obligation : constr delayed - -val eq_ind : constr delayed -val eq_rec : constr delayed -val eq_rect : constr delayed -val eq_refl : constr delayed - -val not_ref : constr delayed -val and_typ : constr delayed - -val eqdep_ind : constr delayed -val eqdep_rec : constr delayed - -val jmeq_ind : constr delayed -val jmeq_rec : constr delayed -val jmeq_refl : constr delayed - -val existS : coq_sigma_data delayed -val prod : coq_sigma_data delayed - -val well_founded : constr delayed -val fix : constr delayed -val acc : constr delayed -val acc_inv : constr delayed -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_glob_constr : env -> glob_constr -> 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 delayed) 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 no_goals_or_obligations : Typeclasses.evar_filter -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 deleted file mode 100644 index e3dbd127..00000000 --- a/plugins/subtac/test/ListDep.v +++ /dev/null @@ -1,49 +0,0 @@ -(* -*- 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 deleted file mode 100644 index 2cea0841..00000000 --- a/plugins/subtac/test/ListsTest.v +++ /dev/null @@ -1,99 +0,0 @@ -(* -*- 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 deleted file mode 100644 index 01e2d75f..00000000 --- a/plugins/subtac/test/Mutind.v +++ /dev/null @@ -1,20 +0,0 @@ -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 deleted file mode 100644 index 7e0755d5..00000000 --- a/plugins/subtac/test/Test1.v +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 index 97c3d941..00000000 --- a/plugins/subtac/test/euclid.v +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index 9ae11088..00000000 --- a/plugins/subtac/test/id.v +++ /dev/null @@ -1,46 +0,0 @@ -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 deleted file mode 100644 index 4f938f4f..00000000 --- a/plugins/subtac/test/measure.v +++ /dev/null @@ -1,20 +0,0 @@ -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 deleted file mode 100644 index aaefd8cc..00000000 --- a/plugins/subtac/test/rec.v +++ /dev/null @@ -1,65 +0,0 @@ -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 deleted file mode 100644 index 90ae8bae..00000000 --- a/plugins/subtac/test/take.v +++ /dev/null @@ -1,34 +0,0 @@ -(* -*- 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 deleted file mode 100644 index 5ccc154a..00000000 --- a/plugins/subtac/test/wf.v +++ /dev/null @@ -1,48 +0,0 @@ -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 index bd2285bb..67c9dd0a 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -7,20 +7,18 @@ (***********************************************************************) open Pp +open Errors open Util open Names -open Pcoq open Glob_term -open Topconstr -open Libnames +open Globnames open Coqlib -open Bigint exception Non_closed_ascii -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) -let make_kn dir id = Libnames.encode_mind (make_dir dir) (id_of_string id) -let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) +let make_dir l = DirPath.make (List.rev_map Id.of_string l) +let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let ascii_module = ["Coq";"Strings";"Ascii"] @@ -37,17 +35,17 @@ open Lazy let interp_ascii dloc p = let rec aux n p = - if n = 0 then [] else + if Int.equal n 0 then [] else let mp = p mod 2 in - GRef (dloc,if mp = 0 then glob_false else glob_true) + GRef (dloc,(if Int.equal mp 0 then glob_false else glob_true),None) :: (aux (n-1) (p/2)) in - GApp (dloc,GRef(dloc,force glob_Ascii), aux 8 p) + GApp (dloc,GRef(dloc,force glob_Ascii,None), aux 8 p) let interp_ascii_string dloc s = let p = - if String.length s = 1 then int_of_char s.[0] + if Int.equal (String.length s) 1 then int_of_char s.[0] else - if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2] + if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] then int_of_string s else user_err_loc (dloc,"interp_ascii_string", @@ -56,13 +54,13 @@ let interp_ascii_string dloc s = let uninterp_ascii r = let rec uninterp_bool_list n = function - | [] when n = 0 -> 0 - | GRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | GRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) + | [] when Int.equal n 0 -> 0 + | GRef (_,k,_)::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | GRef (_,k,_)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try - let rec aux = function - | GApp (_,GRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l + let aux = function + | GApp (_,GRef (_,k,_),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with @@ -78,4 +76,4 @@ let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string - ([GRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true) + ([GRef (Loc.ghost,static_glob_Ascii,None)], uninterp_ascii_string, true) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 2899f17f..0f280aad 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* zero then mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n) @@ -58,8 +50,8 @@ let nat_of_int dloc n = exception Non_closed_number let rec int_of_nat = function - | GApp (_,GRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) - | GRef (_,z) when z = glob_O -> zero + | GApp (_,GRef (_,s,_),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) + | GRef (_,z,_) when Globnames.eq_gr z glob_O -> zero | _ -> raise Non_closed_number let uninterp_nat p = @@ -73,6 +65,6 @@ let uninterp_nat p = let _ = Notation.declare_numeral_interpreter "nat_scope" - (nat_path,["Coq";"Init";"Datatypes"]) + (nat_path,datatypes_module_name) nat_of_int - ([GRef (dummy_loc,glob_S); GRef (dummy_loc,glob_O)], uninterp_nat, true) + ([GRef (Loc.ghost,glob_S,None); GRef (Loc.ghost,glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 5d43b353..b990c0d2 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* cur - | (GRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) - | (GRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | (GRef (_,b,_))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) + | (GRef (_,b,_))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in function - | GApp (_, GRef (_, c), args) when c=int31_construct -> args_parsing args zero + | GApp (_, GRef (_, c, _), args) when eq_gr c int31_construct -> args_parsing args zero | _ -> raise Non_closed let uninterp_int31 i = @@ -127,7 +128,7 @@ let uninterp_int31 i = let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 - ([GRef (Util.dummy_loc, int31_construct)], + ([GRef (Loc.ghost, int31_construct, None)], uninterp_int31, true) @@ -158,16 +159,16 @@ let height bi = (* n must be a non-negative integer (from bigint.ml) *) let word_of_pos_bigint dloc hght n = - let ref_W0 = GRef (dloc, zn2z_W0) in - let ref_WW = GRef (dloc, zn2z_WW) in + let ref_W0 = GRef (dloc, zn2z_W0, None) in + let ref_WW = GRef (dloc, zn2z_WW, None) in let rec decomp hgt n = if hgt <= 0 then int31_of_pos_bigint dloc n else if equal n zero then - GApp (dloc, ref_W0, [GHole (dloc, Evd.InternalHole)]) + GApp (dloc, ref_W0, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)]) else let (h,l) = split_at hgt n in - GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole); + GApp (dloc, ref_WW, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None); decomp (hgt-1) h; decomp (hgt-1) l]) in @@ -175,7 +176,7 @@ let word_of_pos_bigint dloc hght n = let bigN_of_pos_bigint dloc n = let h = height n in - let ref_constructor = GRef (dloc, bigN_constructor h) in + let ref_constructor = GRef (dloc, bigN_constructor h, None) in let word = word_of_pos_bigint dloc h n in let args = if h < n_inlined then [word] @@ -184,7 +185,7 @@ let bigN_of_pos_bigint dloc n = GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = - Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") + Errors.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 @@ -198,14 +199,14 @@ let interp_bigN dloc n = let bigint_of_word = let rec get_height rc = match rc with - | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW -> + | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW -> 1+max (get_height lft) (get_height rght) | _ -> 0 in let rec transform hght rc = match rc with - | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero - | GApp (_,GRef(_,c), [_;lft;rght]) when c=zn2z_WW-> + | GApp (_,GRef(_,c,_),_) when eq_gr c zn2z_W0-> zero + | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW-> let new_hght = hght-1 in add (mult (rank new_hght) (transform new_hght lft)) @@ -235,7 +236,7 @@ let uninterp_bigN rc = let bigN_list_of_constructors = let rec build i = if i < n_inlined+1 then - GRef (Util.dummy_loc, bigN_constructor i)::(build (i+1)) + GRef (Loc.ghost, bigN_constructor i,None)::(build (i+1)) else [] in @@ -252,8 +253,8 @@ let _ = Notation.declare_numeral_interpreter bigN_scope (*** Parsing for bigZ in digital notation ***) let interp_bigZ dloc n = - let ref_pos = GRef (dloc, bigZ_pos) in - let ref_neg = GRef (dloc, bigZ_neg) in + let ref_pos = GRef (dloc, bigZ_pos, None) in + let ref_neg = GRef (dloc, bigZ_neg, None) in if is_pos_or_zero n then GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) else @@ -261,8 +262,8 @@ let interp_bigZ dloc n = (* pretty printing functions for bigZ *) let bigint_of_bigZ = function - | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg - | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_neg -> + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_neg -> let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed @@ -281,19 +282,19 @@ let uninterp_bigZ rc = let _ = Notation.declare_numeral_interpreter bigZ_scope (bigZ_path, bigZ_module) interp_bigZ - ([GRef (Util.dummy_loc, bigZ_pos); - GRef (Util.dummy_loc, bigZ_neg)], + ([GRef (Loc.ghost, bigZ_pos, None); + GRef (Loc.ghost, bigZ_neg, None)], uninterp_bigZ, true) (*** Parsing for bigQ in digital notation ***) let interp_bigQ dloc n = - let ref_z = GRef (dloc, bigQ_z) in + let ref_z = GRef (dloc, bigQ_z, None) in GApp (dloc, ref_z, [interp_bigZ dloc n]) let uninterp_bigQ rc = try match rc with - | GApp (_, GRef(_,c), [one_arg]) when c = bigQ_z -> + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigQ_z -> Some (bigint_of_bigZ one_arg) | _ -> None (* we don't pretty-print yet fractions *) with Non_closed -> None @@ -302,5 +303,5 @@ let uninterp_bigQ rc = let _ = Notation.declare_numeral_interpreter bigQ_scope (bigQ_path, bigQ_module) interp_bigQ - ([GRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ, + ([GRef (Loc.ghost, bigQ_z, None)], uninterp_bigQ, true) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 79a4d8e6..2c195755 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -1,17 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* zero then r_of_pos n else GRef(dloc,glob_R0) + let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in + if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in + if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None) let r_of_int dloc z = if is_strictly_neg z then - GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)]) else r_of_posint dloc z @@ -75,35 +71,35 @@ let bignat_of_r = (* for numbers > 1 *) let rec bignat_of_pos = function (* 1+1 *) - | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)]) - when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two + | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) + when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two (* 1+(1+1) *) - | GApp (_,GRef (_,p1), [GRef (_,o1); - GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])]) - when p1 = glob_Rplus & p2 = glob_Rplus & - o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three + | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); + GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) + when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && + Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three (* (1+1)*b *) - | GApp (_,GRef (_,p), [a; b]) when p = glob_Rmult -> - if bignat_of_pos a <> two then raise Non_closed_number; + | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> + if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) - | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])]) - when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> - if bignat_of_pos a <> two then raise Non_closed_number; + | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) + when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> + if not (Bigint.equal (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 - | GRef (_,a) when a = glob_R0 -> zero - | GRef (_,a) when a = glob_R1 -> one + | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero + | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one | r -> bignat_of_pos r in bignat_of_r let bigint_of_r = function - | GApp (_,GRef (_,o), [a]) when o = glob_Ropp -> + | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> let n = bignat_of_r a in - if n = zero then raise Non_closed_number; + if Bigint.equal n zero then raise Non_closed_number; neg n | a -> bignat_of_r a @@ -113,11 +109,12 @@ let uninterp_r p = with Non_closed_number -> None +let mkGRef gr = GRef (Loc.ghost,gr,None) + let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - ([GRef(dummy_loc,glob_Ropp);GRef(dummy_loc,glob_R0); - GRef(dummy_loc,glob_Rplus);GRef(dummy_loc,glob_Rmult); - GRef(dummy_loc,glob_R1)], + (List.map mkGRef + [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], uninterp_r, false) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index d670f602..2e696f39 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -6,12 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -open Pp -open Util -open Names -open Pcoq -open Libnames -open Topconstr +open Globnames open Ascii_syntax open Glob_term open Coqlib @@ -37,8 +32,8 @@ open Lazy let interp_string dloc s = let le = String.length s in let rec aux n = - if n = le then GRef (dloc, force glob_EmptyString) else - GApp (dloc,GRef (dloc, force glob_String), + if n = le then GRef (dloc, force glob_EmptyString, None) else + GApp (dloc,GRef (dloc, force glob_String, None), [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) in aux 0 @@ -46,11 +41,11 @@ let uninterp_string r = try let b = Buffer.create 16 in let rec aux = function - | GApp (_,GRef (_,k),[a;s]) when k = force glob_String -> + | GApp (_,GRef (_,k,_),[a;s]) when eq_gr k (force glob_String) -> (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | GRef (_,z) when z = force glob_EmptyString -> + | GRef (_,z,_) when eq_gr z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -62,6 +57,6 @@ let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([GRef (dummy_loc,static_glob_String); - GRef (dummy_loc,static_glob_EmptyString)], + ([GRef (Loc.ghost,static_glob_String,None); + GRef (Loc.ghost,static_glob_EmptyString,None)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 4025893d..e3721362 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -1,17 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* GApp (dloc, ref_xO,[pos_of q]) - | (q,true) when q <> zero -> GApp (dloc,ref_xI,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x @@ -67,9 +65,9 @@ let interp_positive dloc n = (**********************************************************************) let rec bignat_of_pos = function - | GApp (_, GRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) - | GApp (_, GRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (_, a) when a = glob_xH -> Bigint.one + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number let uninterp_positive p = @@ -85,9 +83,9 @@ let uninterp_positive p = let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive - ([GRef (dummy_loc, glob_xI); - GRef (dummy_loc, glob_xO); - GRef (dummy_loc, glob_xH)], + ([GRef (Loc.ghost, glob_xI, None); + GRef (Loc.ghost, glob_xO, None); + GRef (Loc.ghost, glob_xH, None)], uninterp_positive, true) @@ -95,7 +93,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope" (* Parsing N via scopes *) (**********************************************************************) -let n_kn = make_kn (make_dir binnums) (id_of_string "N") +let n_kn = make_kn (make_dir binnums) (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) @@ -105,10 +103,10 @@ let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnums "N" let n_of_binnat dloc pos_or_neg n = - if n <> zero then - GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n]) + if not (Bigint.equal n zero) then + GApp(dloc, GRef (dloc,glob_Npos,None), [pos_of_bignat dloc n]) else - GRef (dloc, glob_N0) + GRef (dloc, glob_N0, None) let error_negative dloc = user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") @@ -122,8 +120,8 @@ let n_of_int dloc n = (**********************************************************************) let bignat_of_n = function - | GApp (_, GRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a - | GRef (_, a) when a = glob_N0 -> Bigint.zero + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a + | GRef (_, a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number let uninterp_n p = @@ -136,8 +134,8 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int - ([GRef (dummy_loc, glob_N0); - GRef (dummy_loc, glob_Npos)], + ([GRef (Loc.ghost, glob_N0, None); + GRef (Loc.ghost, glob_Npos, None)], uninterp_n, true) @@ -146,7 +144,7 @@ let _ = Notation.declare_numeral_interpreter "N_scope" (**********************************************************************) let z_path = make_path binnums "Z" -let z_kn = make_kn (make_dir binnums) (id_of_string "Z") +let z_kn = make_kn (make_dir binnums) (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) @@ -156,21 +154,21 @@ let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG let z_of_int dloc n = - if n <> zero then + if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n]) + GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) else - GRef (dloc, glob_ZERO) + GRef (dloc, glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function - | GApp (_, GRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a - | GApp (_, GRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (_, a) when a = glob_ZERO -> Bigint.zero + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number let uninterp_z p = @@ -184,8 +182,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int - ([GRef (dummy_loc, glob_ZERO); - GRef (dummy_loc, glob_POS); - GRef (dummy_loc, glob_NEG)], + ([GRef (Loc.ghost, glob_ZERO, None); + GRef (Loc.ghost, glob_POS, None); + GRef (Loc.ghost, glob_NEG, None)], uninterp_z, true) diff --git a/plugins/xml/COPYRIGHT b/plugins/xml/COPYRIGHT deleted file mode 100644 index c8d231fd..00000000 --- a/plugins/xml/COPYRIGHT +++ /dev/null @@ -1,25 +0,0 @@ -(******************************************************************************) -(* 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 index a45dd31a..e3bcdaf0 100644 --- a/plugins/xml/README +++ b/plugins/xml/README @@ -1,254 +1,15 @@ -(******************************************************************************) -(* 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. +The xml export plugin for Coq has been discontinued for lack of users: +it was most certainly broken while imposing a non-negligible cost on +Coq development. Its purpose was to give export Coq's kernel objects +in xml form for treatment by external tools. + +If you are looking for such a tool, you may want to look at commit +7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9 responsible for the deletion +of this plugin (for instance, git checkout +7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9^ including the "^", will lead +you to the last commit before the xml plugin was deleted). + +Bear in mind, however, that the plugin was not working properly at the +time. You may want instead to write to the original author of the +plugin, Claudio Sacerdoti-Coen at sacerdot@cs.unibo.it. He has a +stable version of the plugin for an old version of Coq. diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml deleted file mode 100644 index 653c2b7b..00000000 --- a/plugins/xml/acic.ml +++ /dev/null @@ -1,108 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index c8035cab..00000000 --- a/plugins/xml/cic.dtd +++ /dev/null @@ -1,259 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml deleted file mode 100644 index 981503a6..00000000 --- a/plugins/xml/cic2Xml.ml +++ /dev/null @@ -1,17 +0,0 @@ -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 deleted file mode 100644 index 165bf83d..00000000 --- a/plugins/xml/cic2acic.ml +++ /dev/null @@ -1,942 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Libnames.is_dirpath_prefix_of modul dirpath) modules - with - [] -> - Pp.msg_warn ("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 e when e <> Sys.Break -> -(*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 deleted file mode 100644 index c22c16f0..00000000 --- a/plugins/xml/doubleTypeInference.ml +++ /dev/null @@ -1,273 +0,0 @@ -(************************************************************************) -(* 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 e when e <> Sys.Break -> - (* 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 deleted file mode 100644 index 5c00bdc6..00000000 --- a/plugins/xml/doubleTypeInference.mli +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 76364541..00000000 --- a/plugins/xml/dumptree.ml4 +++ /dev/null @@ -1,136 +0,0 @@ -(************************************************************************) -(* 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 - end ++ fnl () - ++ pr subtree - ) ++ fnl () ++ str "" - | Daimon -> str "" - | Decl_proof _ -> 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 sigma g = - let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in - if Decl_mode.try_get_info sigma g = None then - (hov 2 (str "" ++ fnl () ++ str "" ++ - (pr_context_xml env)) ++ - fnl () ++ str "") - else - (hov 2 (str "" ++ - (pr_context_xml env)) ++ - fnl () ++ str "") -;; - -let print_proof_xml () = - Util.anomaly "Dump Tree command not supported in this version." - - -VERNAC COMMAND EXTEND DumpTree - [ "Dump" "Tree" ] -> [ print_proof_xml () ] -END diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml deleted file mode 100644 index 2d16190b..00000000 --- a/plugins/xml/proof2aproof.ml +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* 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 -;; - -module ProofTreeHash = - Hashtbl.Make - (struct - type t = Proof_type.proof_tree - let equal = (==) - let hash = Hashtbl.hash - end) -;; - - -let extract_open_proof sigma pf = - (* Deactivated and candidate for removal. (Apr. 2010) *) - () - -let extract_open_pftreestate pts = - (* Deactivated and candidate for removal. (Apr. 2010) *) - () diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4 deleted file mode 100644 index 2f5eb6ac..00000000 --- a/plugins/xml/proofTree2Xml.ml4 +++ /dev/null @@ -1,205 +0,0 @@ -(************************************************************************) -(* 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 = Pp.string_of_ppcmds (prtac tactic_expr) in - let tacname= first_word tac in - let of_attribute = ("name",tacname)::("script",tac)::of_attribute in - - (****** le but *) - - let concl = Goal.V82.concl sigma goal in - let hyps = Goal.V82.hyps sigma 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.Daimon,_)} -> - X.xml_empty "Hidden_open_goal" of_attribute - - | {PT.ref=None;PT.goal=goal} -> - X.xml_empty "Open_goal" of_attribute - | {PT.ref=Some(PT.Decl_proof _, _)} -> failwith "TODO: xml and decl_proof" - 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 deleted file mode 100644 index 953fe009..00000000 --- a/plugins/xml/theoryobject.dtd +++ /dev/null @@ -1,62 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml deleted file mode 100644 index c854427d..00000000 --- a/plugins/xml/unshare.ml +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index cace2de6..00000000 --- a/plugins/xml/unshare.mli +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool) -> 'a -> 'a diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4 deleted file mode 100644 index 8a4eb39a..00000000 --- a/plugins/xml/xml.ml4 +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 0b6d5198..00000000 --- a/plugins/xml/xml.mli +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 90797e8d..00000000 --- a/plugins/xml/xml_plugin.mllib +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index 59ade01e..00000000 --- a/plugins/xml/xmlcommand.ml +++ /dev/null @@ -1,691 +0,0 @@ -(************************************************************************) -(* 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 e when e <> Sys.Break -> () (* 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.msg_warn "Conjecture not supported in dtd (used Declaration instead)"; - "AXIOM","Declaration" - | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" - | DK.IsDefinition DK.Example -> - Pp.msg_warn "Example not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Coercion -> - Pp.msg_warn "Coercion not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.SubClass -> - Pp.msg_warn "SubClass not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.CanonicalStructure -> - Pp.msg_warn "CanonicalStructure not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Fixpoint -> - Pp.msg_warn "Fixpoint not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.CoFixpoint -> - Pp.msg_warn "CoFixpoint not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Scheme -> - Pp.msg_warn "Scheme not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.StructureComponent -> - Pp.msg_warn "StructureComponent not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.IdentityCoercion -> - Pp.msg_warn "IdentityCoercion not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Instance -> - Pp.msg_warn "Instance not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Method -> - Pp.msg_warn "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.msg_warn "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 cb = G.lookup_constant kn in - let val0 = D.body_of_constant cb in - let typ = cb.D.const_type in - let hyps = cb.D.const_hyps 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 = - if true then - Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version." - -let show fn = - let pftst = Pfedit.get_pftreestate () in - let (id,kind,_,_) = Pfedit.current_proof_statement () in - show_pftreestate false 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 deleted file mode 100644 index ec50d623..00000000 --- a/plugins/xml/xmlcommand.mli +++ /dev/null @@ -1,39 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index d65a1bd3..00000000 --- a/plugins/xml/xmlentries.ml4 +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* 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