diff options
105 files changed, 3378 insertions, 3300 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index b7418f54bd..56bd34f6fd 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -160,7 +160,7 @@ /plugins/nsatz/ @coq/nsatz-maintainers /theories/nsatz/ @coq/nsatz-maintainers -/plugins/setoid_ring/ @coq/ring-maintainers +/plugins/ring/ @coq/ring-maintainers /theories/setoid_ring/ @coq/ring-maintainers /plugins/ssrmatching/ @coq/ssreflect-maintainers @@ -46,7 +46,7 @@ plugins/omega developed by Pierre Crégut (France Telecom R&D, 1996) plugins/rtauto developed by Pierre Corbineau (LRI, 2005) -plugins/setoid_ring +plugins/ring developed by Benjamin Grégoire (INRIA-Everest, 2005-2006), Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006) and Bruno Barras (INRIA LogiCal, 2005-2006), diff --git a/META.coq.in b/META.coq.in index a6747c614b..29b3ecbcb3 100644 --- a/META.coq.in +++ b/META.coq.in @@ -352,19 +352,19 @@ package "plugins" ( plugin(native) = "zify_plugin.cmxs" ) - package "setoid_ring" ( + package "ring" ( - description = "Coq newring plugin" + description = "Coq ring plugin" version = "8.13" requires = "" - directory = "setoid_ring" + directory = "ring" - archive(byte) = "newring_plugin.cmo" - archive(native) = "newring_plugin.cmx" + archive(byte) = "ring_plugin.cmo" + archive(native) = "ring_plugin.cmx" - plugin(byte) = "newring_plugin.cmo" - plugin(native) = "newring_plugin.cmxs" + plugin(byte) = "ring_plugin.cmo" + plugin(native) = "ring_plugin.cmxs" ) package "extraction" ( diff --git a/Makefile.common b/Makefile.common index 8f880e93fb..a482b9b963 100644 --- a/Makefile.common +++ b/Makefile.common @@ -103,7 +103,7 @@ CORESRCDIRS:=\ PLUGINDIRS:=\ omega micromega \ - setoid_ring extraction \ + ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ ssrmatching ltac ssr ssrsearch @@ -140,7 +140,7 @@ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/l OMEGACMO:=plugins/omega/omega_plugin.cmo MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo -RINGCMO:=plugins/setoid_ring/newring_plugin.cmo +RINGCMO:=plugins/ring/ring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo EXTRACTIONCMO:=plugins/extraction/extraction_plugin.cmo FUNINDCMO:=plugins/funind/recdef_plugin.cmo diff --git a/Makefile.dev b/Makefile.dev index f48a6f0d8f..5825a884c2 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -154,7 +154,7 @@ LTACVO:=$(filter theories/ltac/%, $(THEORIESVO)) omega: $(OMEGAVO) $(OMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) -setoid_ring: $(RINGVO) $(RINGCMO) +ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) extraction: $(EXTRACTIONCMO) $(EXTRACTIONVO) funind: $(FUNINDCMO) $(FUNINDVO) @@ -163,7 +163,7 @@ rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) ltac: $(LTACVO) $(LTACCMO) -.PHONY: omega micromega setoid_ring nsatz extraction +.PHONY: omega micromega ring nsatz extraction .PHONY: funind cc rtauto btauto ltac # For emacs: diff --git a/clib/cUnix.ml b/clib/cUnix.ml index 75ed73540e..3a10e33369 100644 --- a/clib/cUnix.ml +++ b/clib/cUnix.ml @@ -69,7 +69,7 @@ let canonical_path_name p = p' with Sys_error _ -> (* We give up to find a canonical name and just simplify it... *) - strip_path p + current ^ dirsep ^ strip_path p let make_suffix name suffix = if Filename.check_suffix name suffix then name else (name ^ suffix) diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 741cb89eed..7863af842a 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -131,7 +131,8 @@ stdenv.mkDerivation { name = "shell-for-${project}-in-${branch}"; buildInputs = - optional withCoq coq + [ python ] + ++ optional withCoq coq ++ (prj.buildInputs or []) ++ optionals withCoq (prj.coqBuildInputs or []) ; diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 91cb6168e1..534f20f85b 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -30,7 +30,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/interface -I $COQTOP/plugins/micromega \ -I $COQTOP/plugins/omega -I $COQTOP/plugins/quote \ -I $COQTOP/plugins/ring \ - -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ + -I $COQTOP/plugins/rtauto \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ -I $COQTOP/ide \ diff --git a/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst b/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst new file mode 100644 index 0000000000..95a9093272 --- /dev/null +++ b/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Undetected collision between a lonely notation and a notation in + scope at printing time + (`#12946 <https://github.com/coq/coq/pull/12946>`_, + fixes the first part of `#12908 <https://github.com/coq/coq/issues/12908>`_, + by Hugo Herbelin). diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 479fa674f5..cda8a1b679 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -387,8 +387,8 @@ The syntax for adding a new ring is interpretation via ``Cp_phi`` (the evaluation function of power coefficient) is the original term, or returns ``InitialRing.NotConstant`` if not a constant coefficient (i.e. |L_tac| is the inverse function of - ``Cp_phi``). See files ``plugins/setoid_ring/ZArithRing.v`` - and ``plugins/setoid_ring/RealField.v`` for examples. By default the tactic + ``Cp_phi``). See files ``plugins/ring/ZArithRing.v`` + and ``plugins/ring/RealField.v`` for examples. By default the tactic does not recognize power expressions as ring expressions. :n:`sign @one_term` @@ -396,7 +396,7 @@ The syntax for adding a new ring is outputting its normal form, i.e writing ``x − y`` instead of ``x + (− y)``. The term :token:`term` is a proof that a given sign function indicates expressions that are signed (:token:`term` has to be a proof of ``Ring_theory.get_sign``). See - ``plugins/setoid_ring/InitialRing.v`` for examples of sign function. + ``plugins/ring/InitialRing.v`` for examples of sign function. :n:`div @one_term` allows :tacn:`ring` and :tacn:`ring_simplify` to use monomials with @@ -405,7 +405,7 @@ The syntax for adding a new ring is euclidean division function (:n:`@one_term` has to be a proof of ``Ring_theory.div_theory``). For example, this function is called when trying to rewrite :math:`7x` by :math:`2x = z` to tell that :math:`7 = 3 \times 2 + 1`. See - ``plugins/setoid_ring/InitialRing.v`` for examples of div function. + ``plugins/ring/InitialRing.v`` for examples of div function. :n:`closed [ {+ @qualid } ]` to be documented @@ -538,7 +538,7 @@ Dealing with fields The tactic must be loaded by ``Require Import Field``. New field structures can be declared to the system with the ``Add Field`` command (see below). The field of real numbers is defined in module ``RealField`` - (in ``plugins/setoid_ring``). It is exported by module ``Rbase``, so + (in ``plugins/ring``). It is exported by module ``Rbase``, so that requiring ``Rbase`` or ``Reals`` is enough to use the field tactics on real numbers. Rational numbers in canonical form are also declared as a field in the module ``Qcanon``. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 11162ec96b..d533470f22 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -298,7 +298,7 @@ Summary of the commands .. cmd:: Class @inductive_definition {* with @inductive_definition } The :cmd:`Class` command is used to declare a typeclass with parameters - :token:`binders` and fields the declared record fields. + :n:`{* @binder }` and fields the declared record fields. Like any command declaring a record, this command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, @@ -337,7 +337,7 @@ Summary of the commands fields defined by :token:`field_def`, where each field must be a declared field of the class. - An arbitrary context of :token:`binders` can be put after the name of the + An arbitrary context of :n:`{* @binder }` can be put after the name of the instance and before the colon to declare a parameterized instance. An optional priority can be declared, 0 being the highest priority as for :tacn:`auto` hints. If the priority :token:`natural` is not specified, it defaults to the number diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index ee8784fc02..a8a574c861 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,11 +183,8 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ - 'binders', 'collection', - 'modpath', 'tactic', - 'destruction_arg', 'bindings', 'induction_clause', 'conversion', diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 768c83150e..f1ed64e52a 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -274,7 +274,7 @@ following rules. .. inference:: Prod-Type \WTEG{T}{s} - s \in \{\SProp, \Type{i}\} + s \in \{\SProp, \Type(i)\} \WTE{\Gamma::(x:T)}{U}{\Type(i)} -------------------------------- \WTEG{∀ x:T,~U}{\Type(i)} diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 765373619f..485dfd964d 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -677,7 +677,7 @@ fixpoint equation can be proved. .. index:: single: Fix_F (term) - single: fix_eq (term) + single: Fix_eq (term) single: Fix_F_inv (term) single: Fix_F_eq (term) @@ -696,7 +696,7 @@ fixpoint equation can be proved. forall (x:A) (r:Acc x), F x (fun (y:A) (p:R y x) => Fix_F y (Acc_inv x r y p)) = Fix_F x r. Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F x r = Fix_F x s. - Lemma fix_eq : forall x:A, Fix x = F x (fun (y:A) (p:R y x) => Fix y). + Lemma Fix_eq : forall x:A, Fix x = F x (fun (y:A) (p:R y x) => Fix y). End FixPoint. End Well_founded. diff --git a/doc/sphinx/language/core/primitive.rst b/doc/sphinx/language/core/primitive.rst index 727177b23a..48647deeff 100644 --- a/doc/sphinx/language/core/primitive.rst +++ b/doc/sphinx/language/core/primitive.rst @@ -133,7 +133,7 @@ follows: Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. -The complete set of such operators can be obtained looking at the :g:`PArray` module. +The rest of these operators can be found in the :g:`PArray` module. These primitive declarations are regular axioms. As such, they must be trusted and are listed by the :g:`Print Assumptions` command. @@ -150,7 +150,16 @@ extraction. Instead, it has to be provided by the user (if they want to compile or execute the extracted code). For instance, an implementation of this module can be taken from the kernel of Coq (see ``kernel/parray.ml``). -Primitive arrays expose a functional interface, but they are internally -implemented using a persistent data structure :cite:`ConchonFilliatre07wml`. -Update and access to an element in the most recent copy of an array are -constant time operations. +Coq's primitive arrays are persistent data structures. Semantically, a set operation +``t.[i <- a]`` represents a new array that has the same values as ``t``, except +at position ``i`` where its value is ``a``. The array ``t`` still exists, can +still be used and its values were not modified. Operationally, the implementation +of Coq's primitive arrays is optimized so that the new array ``t.[i <- a]`` does not +copy all of ``t``. The details are in section 2.3 of :cite:`ConchonFilliatre07wml`. +In short, the implementation keeps one version of ``t`` as an OCaml native array and +other versions as lists of modifications to ``t``. Accesses to the native array +version are constant time operations. However, accesses to versions where all the cells of +the array are modified have O(n) access time, the same as a list. The version that is kept as the native array +changes dynamically upon each get and set call: the current list of modifications +is applied to the native array and the lists of modifications of the other versions +are updated so that they still represent the same values. diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index ca69072cb9..f8375e93ce 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -217,7 +217,7 @@ usual implicit arguments disambiguation syntax. The syntax is also supported in internal binders. For instance, in the following kinds of expressions, the type of each declaration present -in :token:`binders` can be bracketed to mark the declaration as +in :n:`{* @binder }` can be bracketed to mark the declaration as implicit: * :n:`fun (@ident:forall {* @binder }, @type) => @term`, * :n:`forall (@ident:forall {* @binder }, @type), @type`, diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index e276a0edcb..4b1f312105 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -4726,7 +4726,7 @@ Automating .. seealso:: - File plugins/setoid_ring/RealField.v for an example of instantiation, + File plugins/ring/RealField.v for an example of instantiation, theory theories/Reals for many examples of use of field. Non-logical tactics diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index e05be7c2c2..8e23e61018 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -203,7 +203,7 @@ Generation of inversion principles with ``Derive`` ``Inversion`` This command generates an inversion principle for the :tacn:`inversion ... using ...` tactic. The first :token:`ident` is the name of the generated principle. The second :token:`ident` should be an inductive - predicate, and :token:`binders` the variables occurring in the term + predicate, and :n:`{* @binder }` the variables occurring in the term :token:`term`. This command generates the inversion lemma for the sort :token:`sort` corresponding to the instance :n:`forall {* @binder }, @ident @term`. When applied, it is equivalent to having inverted the instance with the diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index ba07e6df0d..2a7b283f55 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -24,7 +24,7 @@ (glob_files %{project_root}/plugins/nsatz/*.mlg) (glob_files %{project_root}/plugins/omega/*.mlg) (glob_files %{project_root}/plugins/rtauto/*.mlg) - (glob_files %{project_root}/plugins/setoid_ring/*.mlg) + (glob_files %{project_root}/plugins/ring/*.mlg) (glob_files %{project_root}/plugins/syntax/*.mlg) (glob_files %{project_root}/user-contrib/Ltac2/*.mlg) ; Sphinx files diff --git a/ide/coqide/coq_lex.mll b/ide/coqide/coq_lex.mll index a65954d566..5d5e5f0e14 100644 --- a/ide/coqide/coq_lex.mll +++ b/ide/coqide/coq_lex.mll @@ -50,52 +50,40 @@ and comment = parse | utf8_extra_byte { incr utf8_adjust; comment lexbuf } | _ { comment lexbuf } -and quotation o c n l = parse +and quotation n l = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n l lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = o then quotation_nesting o c n l 1 lexbuf - else if x = c then - if n = 1 && l = 1 then () - else quotation_closing o c n l 1 lexbuf - else quotation o c n l lexbuf -} +| utf8_extra_byte { incr utf8_adjust; quotation n l lexbuf } +| "{" { quotation_nesting n l 1 lexbuf } +| "}" { quotation_closing n l 1 lexbuf } +| _ { quotation n l lexbuf } -and quotation_nesting o c n l v = parse +and quotation_nesting n l v = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n l lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = o then - if n = v+1 then quotation o c n (l+1) lexbuf - else quotation_nesting o c n l (v+1) lexbuf - else if x = c then quotation_closing o c n l 1 lexbuf - else quotation o c n l lexbuf +| utf8_extra_byte { incr utf8_adjust; quotation n l lexbuf } +| "{" { + if n = v+1 then quotation n (l+1) lexbuf + else quotation_nesting n l (v+1) lexbuf } +| "}" { quotation_closing n l 1 lexbuf } +| _ { quotation n l lexbuf } -and quotation_closing o c n l v = parse +and quotation_closing n l v = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n l lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = c then - if n = v+1 then - if l = 1 then () - else quotation o c n (l-1) lexbuf - else quotation_closing o c n l (v+1) lexbuf - else if x = o then quotation_nesting o c n l 1 lexbuf - else quotation o c n l lexbuf +| utf8_extra_byte { incr utf8_adjust; quotation n l lexbuf } +| "}" { + if n = v+1 then + if l = 1 then () + else quotation n (l-1) lexbuf + else quotation_closing n l (v+1) lexbuf } +| "{" { quotation_nesting n l 1 lexbuf } +| _ { quotation n l lexbuf } -and quotation_start o c n = parse +and quotation_start n = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n 1 lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = o then quotation_start o c (n+1) lexbuf - else quotation o c n 1 lexbuf -} +| utf8_extra_byte { incr utf8_adjust; quotation n 1 lexbuf } +| "{" { quotation_start (n+1) lexbuf } +| _ { quotation n 1 lexbuf } (** NB : [mkiter] should be called on increasing offsets *) @@ -130,16 +118,8 @@ and sentence initial stamp = parse if initial then stamp (utf8_lexeme_start lexbuf + String.length (Lexing.lexeme lexbuf) - 1) Tags.Script.sentence; sentence initial stamp lexbuf } - | ['a'-'z' 'A'-'Z'] ":{" { - quotation_start "{" "}" 1 lexbuf; - sentence false stamp lexbuf - } - | ['a'-'z' 'A'-'Z'] ":[" { - quotation_start "[" "]" 1 lexbuf; - sentence false stamp lexbuf - } - | ['a'-'z' 'A'-'Z'] ":(" { - quotation_start "(" ")" 1 lexbuf; + | ['a'-'z' 'A'-'Z'] ":{{" { + quotation_start 2 lexbuf; sentence false stamp lexbuf } | space+ { diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 1d3b1bbb24..48fb4a4a5d 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2530,12 +2530,12 @@ let intern_context env impl_env binders = binder_block_names = Some (Some AbsPi,ids)}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) -let interp_glob_context_evars ?(program_mode=false) env sigma k bl = +let interp_glob_context_evars ?(program_mode=false) env sigma bl = let open EConstr in let flags = { Pretyping.all_no_fail_flags with program_mode } in - let env, sigma, par, _, impls = + let env, sigma, par, impls = List.fold_left - (fun (env,sigma,params,n,impls) (na, k, b, t) -> + (fun (env,sigma,params,impls) (na, k, b, t) -> let t' = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t @@ -2551,16 +2551,17 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = | MaxImplicit -> CAst.make (Some (na,true)) :: impls | Explicit -> CAst.make None :: impls in - (push_rel d env, sigma, d::params, succ n, impls) + (push_rel d env, sigma, d::params, impls) | Some b -> let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in let r = Retyping.relevance_of_type env sigma t in let d = LocalDef (make_annot na r, c, t) in - (push_rel d env, sigma, d::params, n, impls)) - (env,sigma,[],k+1,[]) (List.rev bl) - in sigma, ((env, par), List.rev impls) + (push_rel d env, sigma, d::params, impls)) + (env,sigma,[],[]) (List.rev bl) + in + sigma, ((env, par), List.rev impls) -let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = +let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) env sigma params = let int_env,bl = intern_context env impl_env params in - let sigma, x = interp_glob_context_evars ?program_mode env sigma shift bl in + let sigma, x = interp_glob_context_evars ?program_mode env sigma bl in sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 2eb96aad56..898a3e09c8 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -156,7 +156,7 @@ val interp_binder_evars : env -> evar_map -> Name.t -> constr_expr -> evar_map * (** Interpret contexts: returns extended env and context *) val interp_context_evars : - ?program_mode:bool -> ?impl_env:internalization_env -> ?shift:int -> + ?program_mode:bool -> ?impl_env:internalization_env -> env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) diff --git a/interp/notation.ml b/interp/notation.ml index 17ae045187..7e90e15b72 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1198,10 +1198,25 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function find_without_delimiters find (ntn_scope,ntn) scopes end | LonelyNotationItem ntn' :: scopes -> - begin match ntn_scope, ntn with - | LastLonelyNotation, Some ntn when notation_eq ntn ntn' -> - Some (None, None) + begin match ntn with + | Some ntn'' when notation_eq ntn' ntn'' -> + begin match ntn_scope with + | LastLonelyNotation -> + (* If the first notation with same string in the visibility stack + is the one we want to print, then it can be used without + risking a collision *) + Some (None, None) + | NotationInScope _ -> + (* A lonely notation is liable to hide the scoped notation + to print, we check if the lonely notation is active to + know if the delimiter of the scoped notationis needed *) + if find default_scope then + find_with_delimiters ntn_scope + else + find_without_delimiters find (ntn_scope,ntn) scopes + end | _ -> + (* A lonely notation which does not interfere with the notation to use *) find_without_delimiters find (ntn_scope,ntn) scopes end | [] -> diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index ada0fc9780..3e8916673d 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -159,7 +159,7 @@ val inject : constr -> fconstr (** mk_atom: prevents a term from being evaluated *) val mk_atom : constr -> fconstr -(** mk_red: makes a reducible term (used in newring) *) +(** mk_red: makes a reducible term (used in ring) *) val mk_red : fterm -> fconstr val fterm_of : fconstr -> fterm diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index a98cf3b7de..f485970eec 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -512,6 +512,12 @@ and progress_utf8 loc last nj n c tt cs = and progress_from_byte loc last nj tt cs c = progress_utf8 loc last nj (utf8_char_size loc cs c) c tt cs +let blank_or_eof cs = + match Stream.peek cs with + | None -> true + | Some (' ' | '\t' | '\n' |'\r') -> true + | _ -> false + type marker = Delimited of int * char list * char list | ImmediateAsciiIdent let peek_marker_len b e s = @@ -542,6 +548,11 @@ let parse_quotation loc bp s = in get_buff len, set_loc_pos loc bp (Stream.count s) | Delimited (lenmarker, bmarker, emarker) -> + let dot_gobbling = + (* only quotations starting with two curly braces can gobble sentences *) + match bmarker with + | '{' :: '{' :: _ -> true + | _ -> false in let b = Buffer.create 80 in let commit1 c = Buffer.add_char b c; Stream.junk s in let commit l = List.iter commit1 l in @@ -557,6 +568,10 @@ let parse_quotation loc bp s = commit1 '\n'; let loc = bump_loc_line_last loc (Stream.count s) in quotation loc depth + | '.' :: _ -> + commit1 '.'; + if not dot_gobbling && blank_or_eof s then raise Stream.Failure; + quotation loc depth | c :: cs -> commit1 c; quotation loc depth @@ -565,8 +580,26 @@ let parse_quotation loc bp s = let loc = quotation loc 0 in Buffer.contents b, set_loc_pos loc bp (Stream.count s) +let peek_string v s = + let l = String.length v in + let rec aux i = + if Int.equal i l then true + else + let l' = Stream.npeek (i + 1) s in + match List.nth l' i with + | c -> Char.equal c v.[i] && aux (i + 1) + | exception _ -> false (* EOF *) in + aux 0 let find_keyword loc id bp s = + if peek_string ":{{" s then + begin + (* "xxx:{{" always starts a sentence-gobbling quotation, whether registered or not *) + Stream.junk s; + let txt, loc = parse_quotation loc bp s in + QUOTATION (id ^ ":", txt), loc + end + else let tt = ttree_find !token_tree id in match progress_further loc tt.node 0 tt s with | None -> raise Not_found @@ -645,12 +678,6 @@ let parse_after_qmark ~diff_mode loc bp s = | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars ~diff_mode loc bp '?' s) -let blank_or_eof cs = - match Stream.peek cs with - | None -> true - | Some (' ' | '\t' | '\n' |'\r') -> true - | _ -> false - (* Parse a token in a char stream *) let rec next_token ~diff_mode loc s = diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 72e6006b7e..e50c6087bb 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Printer open CErrors open Util @@ -8,9 +18,7 @@ open Vars open Namegen open Names open Pp -open Tacmach open Termops -open Tacticals open Tactics open Indfun_common open Libnames @@ -27,7 +35,7 @@ let make_refl_eq constructor type_of_t t = mkApp (constructor, [|type_of_t; t|]) type pte_info = - {proving_tac : Id.t list -> Tacmach.tactic; is_valid : constr -> bool} + {proving_tac : Id.t list -> unit Proofview.tactic; is_valid : constr -> bool} type ptes_info = pte_info Id.Map.t @@ -36,16 +44,12 @@ type 'a dynamic_info = type body_info = constr dynamic_info -let observe_tac s = observe_tac (fun _ _ -> Pp.str s) - -let finish_proof dynamic_infos g = - observe_tac "finish" (Proofview.V82.of_tactic assumption) g +let observe_tac s = + New.observe_tac ~header:(str "observation") (fun _ _ -> Pp.str s) -let refine c = - Proofview.V82.of_tactic - (Logic.refiner ~check:true EConstr.Unsafe.(to_constr c)) - -let thin l = Proofview.V82.of_tactic (Tactics.clear l) +let finish_proof dynamic_infos = observe_tac "finish" assumption +let refine c = Logic.refiner ~check:true EConstr.Unsafe.(to_constr c) +let thin = clear let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v let is_trivial_eq sigma t = @@ -83,37 +87,42 @@ let is_incompatible_eq env sigma t = if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res -let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) 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 " *) - Proofview.V82.of_tactic (rename_hyp [(prov_id, hyp_id)]) ] ] - g +let pf_get_new_id id env = + next_ident_away id (Id.Set.of_list (Termops.ids_of_named_context env)) + +let change_hyp_with_using msg hyp_id t tac = + Proofview.Goal.enter (fun gl -> + let prov_id = pf_get_new_id hyp_id (Proofview.Goal.hyps gl) in + Tacticals.New.tclTHENS + ((* observe_tac msg *) + assert_by (Name prov_id) t + (Tacticals.New.tclCOMPLETE tac)) + [ Tacticals.New.tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) + Tactics.clear [hyp_id] + ; (* observe_tac "change_hyp_with_using rename " *) + rename_hyp [(prov_id, hyp_id)] ] ]) exception TOREMOVE let prove_trivial_eq h_id context (constructor, type_of_term, term) = let nb_intros = List.length context in - tclTHENLIST - [ tclDO nb_intros (Proofview.V82.of_tactic intro) + Tacticals.New.tclTHENLIST + [ Tacticals.New.tclDO nb_intros intro ; (* introducing context *) - (fun g -> - let context_hyps = - fst - (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - mkApp (constructor, [|type_of_term; term|]) - :: List.map mkVar context_hyps - in - let to_refine = applist (mkVar h_id, List.rev context_hyps') in - refine to_refine g) ] + Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps = + fst + (list_chop ~msg:"prove_trivial_eq : " nb_intros + (ids_of_named_context hyps)) + in + let context_hyps' = + mkApp (constructor, [|type_of_term; term|]) + :: List.map mkVar context_hyps + in + let to_refine = applist (mkVar h_id, List.rev context_hyps') in + refine to_refine) ] let find_rectype env sigma c = let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta env sigma c) in @@ -255,13 +264,11 @@ let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = Typing.type_of (Proofview.Goal.env g) (Proofview.Goal.sigma g) to_refine in - tclTHEN - (Proofview.Unsafe.tclEVARS evm) - (Proofview.V82.tactic (refine to_refine)))) + tclTHEN (Proofview.Unsafe.tclEVARS evm) (refine to_refine))) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp - (Proofview.V82.of_tactic prove_new_hyp) + prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) (* str "removing an equation " ++ fnl ()++ *) @@ -294,30 +301,30 @@ let isLetIn sigma t = match EConstr.kind sigma t with LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) - cl) + reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) cl -let rewrite_until_var arg_num eq_ids : tactic = +let rewrite_until_var arg_num eq_ids : unit Proofview.tactic = + let open Tacticals.New in (* tests if the declares recursive argument is neither a Constructor nor an applied Constructor since such a form for the recursive argument will break the Guard when trying to save the Lemma. *) let test_var g = - let sigma = project g in - let _, args = destApp sigma (pf_concl g) in + let sigma = Proofview.Goal.sigma g in + let _, args = destApp sigma (Proofview.Goal.concl g) in not (isConstruct sigma args.(arg_num) || isAppConstruct sigma args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g then tclIDTAC g - else - match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.") - | eq_id :: eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) g + let rec do_rewrite eq_ids = + Proofview.Goal.enter (fun g -> + if test_var g then Proofview.tclUNIT () + else + match eq_ids with + | [] -> + anomaly (Pp.str "Cannot find a way to prove recursive property.") + | eq_id :: eq_ids -> + tclTHEN + (tclTRY (Equality.rewriteRL (mkVar eq_id))) + (do_rewrite eq_ids)) in do_rewrite eq_ids @@ -336,7 +343,8 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in - let rec scan_type context type_of_hyp : tactic = + let open Tacticals.New in + let rec scan_type context type_of_hyp : unit Proofview.tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = @@ -362,28 +370,27 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST - [ tclDO context_length (Proofview.V82.of_tactic intro) - ; (fun g -> - let context_hyps_ids = - fst - (list_chop ~msg:"rec hyp : context_hyps" context_length - (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist - ( mkVar hyp_id - , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) - in - (* observe_tac "rec hyp " *) - (tclTHENS - (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" *) - refine to_refine ]) - g) ] + [ tclDO context_length intro + ; Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps_ids = + fst + (list_chop ~msg:"rec hyp : context_hyps" context_length + (ids_of_named_context hyps)) + in + let rec_pte_id = pf_get_new_id rec_pte_id hyps in + let to_refine = + applist + ( mkVar hyp_id + , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) + in + (* observe_tac "rec hyp " *) + tclTHENS + (assert_before (Name rec_pte_id) t_x) + [ (* observe_tac "prove rec hyp" *) + prove_rec_hyp eq_hyps + ; (* observe_tac "prove rec hyp" *) + refine to_refine ]) ] in tclTHENLIST [ (* observe_tac "hyp rec" *) @@ -408,19 +415,20 @@ 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 (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)) - in - let to_refine = - applist - ( mkVar hyp_id - , List.rev (coq_I :: List.map mkVar context_hyps) ) - in - refine to_refine g) ] + [ tclDO nb_intro intro + ; Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps = + fst + (list_chop ~msg:"removing True : context_hyps " nb_intro + (ids_of_named_context hyps)) + in + let to_refine = + applist + ( mkVar hyp_id + , List.rev (coq_I :: List.map mkVar context_hyps) ) + in + refine to_refine) ] in tclTHENLIST [ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp @@ -455,103 +463,103 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = try (scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id]) with TOREMOVE -> (thin [hyp_id], []) -let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) g = - let env = pf_env g and sigma = project g in - let tac, new_hyps = - List.fold_left - (fun (hyps_tac, new_hyps) hyp_id -> - let hyp_tac, new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma - in - (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) - (tclIDTAC, []) dyn_infos.rec_hyps - in - let new_infos = - {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} - in - tclTHENLIST - [tac; (* observe_tac "clean_hyp_with_heq continue" *) continue_tac new_infos] - g +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + let tac, new_hyps = + List.fold_left + (fun (hyps_tac, new_hyps) hyp_id -> + let hyp_tac, new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) + (tclIDTAC, []) dyn_infos.rec_hyps + in + let new_infos = + {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} + in + tclTHENLIST + [ tac + ; (* observe_tac "clean_hyp_with_heq continue" *) + continue_tac new_infos ]) let heq_id = Id.of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ (* We first introduce the variables *) - tclDO nb_first_intro - (Proofview.V82.of_tactic - (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) - ; (* Then the equation itself *) - Proofview.V82.of_tactic - (intro_using_then heq_id - (* we get the fresh name with onLastHypId *) - (fun _ -> Proofview.tclUNIT ())) - ; onLastHypId (fun heq_id -> - tclTHENLIST - [ (* Then the new hypothesis *) - tclMAP - (fun id -> Proofview.V82.of_tactic (introduction id)) - dyn_infos.rec_hyps - ; observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_get_hyp_typ g' heq_id in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App (f, [|_; _; args2|]) -> args2 - | _ -> - observe - ( str "cannot compute new term value : " - ++ pr_gls g' ++ fnl () ++ str "last hyp is" - ++ pr_leconstr_env (pf_env g') (project g') - new_term_value_eq ); - anomaly (Pp.str "cannot compute new term value.") - in - let g', termtyp = tac_type_of g' term in - let fun_body = - mkLambda - ( make_annot Anonymous Sorts.Relevant - , termtyp - , Termops.replace_term (project g') term (mkRel 1) - dyn_infos.info ) - in - let new_body = - pf_nf_betaiota g' (mkApp (fun_body, [|new_term_value|])) - in - let new_infos = - { dyn_infos with - info = new_body - ; eq_hyps = heq_id :: dyn_infos.eq_hyps } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g') ]) - ] - g - -let my_orelse tac1 tac2 g = - try tac1 g - with e when CErrors.noncritical e -> - (* observe (str "using snd tac since : " ++ CErrors.print e); *) - tac2 g +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ (* We first introduce the variables *) + tclDO nb_first_intro + (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps)) + ; (* Then the equation itself *) + intro_using_then heq_id + (* we get the fresh name with onLastHypId *) + (fun _ -> Proofview.tclUNIT ()) + ; onLastHypId (fun heq_id -> + tclTHENLIST + [ (* Then the new hypothesis *) + tclMAP introduction dyn_infos.rec_hyps + ; observe_tac "after_introduction" + (Proofview.Goal.enter (fun g' -> + let env = Proofview.Goal.env g' in + let sigma = Proofview.Goal.sigma g' in + (* We get infos on the equations introduced*) + let new_term_value_eq = + Tacmach.New.pf_get_hyp_typ heq_id g' + in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind sigma new_term_value_eq with + | App (f, [|_; _; args2|]) -> args2 + | _ -> + observe + ( str "cannot compute new term value : " + ++ Tacmach.New.pr_gls g' ++ fnl () + ++ str "last hyp is" + ++ pr_leconstr_env env sigma new_term_value_eq ); + anomaly (Pp.str "cannot compute new term value.") + in + tclTYPEOFTHEN term (fun sigma termtyp -> + let fun_body = + mkLambda + ( make_annot Anonymous Sorts.Relevant + , termtyp + , Termops.replace_term sigma term (mkRel 1) + dyn_infos.info ) + in + let new_body = + Reductionops.nf_betaiota env sigma + (mkApp (fun_body, [|new_term_value|])) + in + let new_infos = + { dyn_infos with + info = new_body + ; eq_hyps = heq_id :: dyn_infos.eq_hyps } + in + clean_goal_with_heq ptes_infos continue_tac + new_infos))) ]) ]) -let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = +let instantiate_hyps_with_args (do_prove : Id.t list -> unit Proofview.tactic) + hyps args_id = let args = Array.of_list (List.map mkVar args_id) in + let open Tacticals.New in let instantiate_one_hyp hid = - my_orelse - (fun (* we instantiate the hyp if possible *) - g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp (mkVar hid, args) in - let evm, _ = pf_apply Typing.type_of g c in - let open Tacticals.New in - Proofview.V82.of_tactic - (tclTHENLIST - [ Proofview.Unsafe.tclEVARS evm - ; pose_proof (Name prov_hid) c - ; clear [hid] - ; rename_hyp [(prov_hid, hid)] ]) - g) - (fun (* + tclORELSE0 + (* we instantiate the hyp if possible *) + (Proofview.Goal.enter (fun g -> + let prov_hid = Tacmach.New.pf_get_new_id hid g in + let c = mkApp (mkVar hid, args) in + (* Check typing *) + tclTYPEOFTHEN c (fun _ _ -> + tclTHENLIST + [ pose_proof (Name prov_hid) c + ; thin [hid] + ; rename_hyp [(prov_hid, hid)] ]))) + (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. @@ -559,9 +567,8 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = principle so that we can trash it *) - g -> - (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g) + (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + (thin [hid]) in if List.is_empty args_id then tclTHENLIST @@ -571,172 +578,178 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps ; tclMAP instantiate_one_hyp hyps - ; (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g) ] + ; Proofview.Goal.enter (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add + (Tacmach.New.pf_ids_of_hyps g) + Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps) ] let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos - dyn_infos : tactic = - let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> - let env = pf_env g in - let sigma = project g in - (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case (ci, ct, iv, t, cb) -> - let do_finalize_t dyn_info' g = - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let g, type_of_term = tac_type_of g t in - let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in - tclTHENLIST - [ Proofview.V82.of_tactic - (generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps)) - ; thin dyn_infos.rec_hyps - ; Proofview.V82.of_tactic - (pattern_option [(Locus.AllOccurrencesBut [1], t)] None) - ; (fun g -> - observe_tac "toto" - (tclTHENLIST - [ Proofview.V82.of_tactic (Simple.case t) - ; (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case ptes_infos nb_instantiate_partial - (build_proof do_finalize) t dyn_infos) - g') ]) - g) ] - g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda (n, t, b) -> ( - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> - let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' (mkApp (dyn_infos.info, [|mkVar id|])) + dyn_infos : unit Proofview.tactic = + let open Tacticals.New in + let rec build_proof_aux do_finalize dyn_infos : unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match EConstr.kind sigma dyn_infos.info with + | Case (ci, ct, iv, t, cb) -> + let do_finalize_t dyn_info' = + Proofview.Goal.enter (fun g -> + let t = dyn_info'.info in + let dyn_infos = + {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} + in + let g_nb_prod = + nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) + in + tclTYPEOFTHEN t (fun _ type_of_term -> + let term_eq = + make_refl_eq (Lazy.force refl_equal) type_of_term t + in + tclTHENLIST + [ generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps) + ; thin dyn_infos.rec_hyps + ; pattern_option [(Locus.AllOccurrencesBut [1], t)] None + ; observe_tac "toto" + (tclTHENLIST + [ Simple.case t + ; Proofview.Goal.enter (fun g' -> + let g'_nb_prod = + nb_prod (Proofview.Goal.sigma g') + (Proofview.Goal.concl g') + in + let nb_instantiate_partial = + g'_nb_prod - g_nb_prod + in + observe_tac "treat_new_case" + (treat_new_case ptes_infos + nb_instantiate_partial + (build_proof do_finalize) t dyn_infos)) + ]) ])) + in + build_proof do_finalize_t {dyn_infos with info = t} + | Lambda (n, t, b) -> ( + match EConstr.kind sigma (Proofview.Goal.concl g) with + | Prod _ -> + tclTHEN intro + (Proofview.Goal.enter (fun g' -> + let open Context.Named.Declaration in + let id = Tacmach.New.pf_last_hyp g' |> get_id in + let new_term = + Reductionops.nf_betaiota (Proofview.Goal.env g') + (Proofview.Goal.sigma g') + (mkApp (dyn_infos.info, [|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = + build_proof do_finalize + { new_infos with + rec_hyps = new_hyps + ; nb_rec_hyps = List.length new_hyps } + in + (* observe_tac "Lambda" *) + instantiate_hyps_with_args do_prove new_infos.rec_hyps [id] + (* build_proof do_finalize new_infos g' *))) + | _ -> do_finalize dyn_infos ) + | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ + |Int _ | Float _ -> + do_finalize dyn_infos + | App (_, _) -> ( + let f, args = decompose_app sigma dyn_infos.info in + match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") + | Array _ -> user_err Pp.(str "array cannot be applied") + | 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 info = (f, args)} in + build_proof_args env sigma do_finalize new_infos + | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = {dyn_infos with info = (f, args)} in + (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args env sigma do_finalize new_infos + | Const _ -> do_finalize dyn_infos + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - { new_infos with - rec_hyps = new_hyps - ; nb_rec_hyps = List.length new_hyps } + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in + build_proof_args env sigma do_finalize new_infos in - (* observe_tac "Lambda" *) - (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *)) - g - | _ -> do_finalize dyn_infos g ) - | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ - |Float _ -> - do_finalize dyn_infos g - | App (_, _) -> ( - let f, args = decompose_app sigma dyn_infos.info in - match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") - | Float _ -> user_err Pp.(str "float cannot be applied") - | Array _ -> user_err Pp.(str "array cannot be applied") - | 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 info = (f, args)} in - build_proof_args env sigma do_finalize new_infos g - | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = {dyn_infos with info = (f, args)} in - (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args env sigma do_finalize new_infos g - | Const _ -> do_finalize dyn_infos g - | Lambda _ -> - let new_term = Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - tclTHENLIST - [ tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps - ; h_reduce_with_zeta Locusops.onConcl - ; build_proof do_finalize new_infos ] - g - | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in - build_proof_args env sigma do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f} g ) - | Fix _ | CoFix _ -> - user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - tclTHENLIST - [ tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps - ; h_reduce_with_zeta Locusops.onConcl - ; build_proof do_finalize new_infos ] - g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Array _ -> CErrors.user_err Pp.(str "Arrays not handled yet") - and build_proof do_finalize dyn_infos g = + build_proof new_finalize {dyn_infos with info = f} ) + | Fix _ | CoFix _ -> + user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } + in + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Array _ -> CErrors.user_err Pp.(str "Arrays not handled yet")) + and build_proof do_finalize dyn_infos = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - Indfun_common.observe_tac + Indfun_common.New.observe_tac ~header:(str "observation") (fun env sigma -> str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info) (build_proof_aux do_finalize dyn_infos) - g - and build_proof_args env sigma do_finalize dyn_infos : tactic = - (* f_args' args *) - fun g -> - let f_args', args = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> do_finalize {dyn_infos with info = f_args'} g - | arg :: args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - build_proof_args env sigma do_finalize - {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + and build_proof_args env sigma do_finalize dyn_infos : unit Proofview.tactic = + (* f_args' args *) + Proofview.Goal.enter (fun g -> + let f_args', args = dyn_infos.info in + let tac = + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} + | arg :: args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + build_proof_args env sigma do_finalize + {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + in + build_proof do_finalize {dyn_infos with info = arg} in - build_proof do_finalize {dyn_infos with info = arg} g - in - (* observe_tac "build_proof_args" *) tac g + (* observe_tac "build_proof_args" *) tac) in let do_finish_proof dyn_infos = (* tclTRYD *) clean_goal_with_heq ptes_infos finish_proof dyn_infos in (* observe_tac "build_proof" *) - fun g -> - build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g + build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos (* Proof of principles from structural functions *) @@ -750,52 +763,59 @@ type static_fix_info = ; num_in_block : int } let prove_rec_hyp_for_struct fix_info eq_hyps = - tclTHEN (rewrite_until_var fix_info.idx eq_hyps) (fun g -> - let _, pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp (mkVar fix_info.name, array_get_start pte_args) - in - refine rec_hyp_proof g) + let open Tacticals.New in + tclTHEN + (rewrite_until_var fix_info.idx eq_hyps) + (Proofview.Goal.enter (fun g -> + let _, pte_args = + destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g) + in + let rec_hyp_proof = + mkApp (mkVar fix_info.name, array_get_start pte_args) + in + refine rec_hyp_proof)) let prove_rec_hyp fix_info = {proving_tac = prove_rec_hyp_for_struct fix_info; is_valid = (fun _ -> true)} -let generalize_non_dep hyp g = - (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) - let hyps = [hyp] in - let env = Global.env () in - let hyp_typ = pf_get_hyp_typ g hyp in - let to_revert, _ = - let open Context.Named.Declaration in - Environ.fold_named_context_reverse - (fun (clear, keep) decl -> - let decl = map_named_decl EConstr.of_constr decl in - let hyp = get_id decl in - if - Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) 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" *) Proofview.V82.of_tactic - (generalize (List.map mkVar to_revert))) - ((* observe_tac "thin" *) thin to_revert) - g +let generalize_non_dep hyp = + Proofview.Goal.enter (fun g -> + (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + let hyps = [hyp] in + let env = Global.env () in + let sigma = Proofview.Goal.sigma g in + let hyp_typ = Tacmach.New.pf_get_hyp_typ hyp g in + let to_revert, _ = + let open Context.Named.Declaration in + Environ.fold_named_context_reverse + (fun (clear, keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = get_id decl in + if + Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env sigma hyp) keep + || Termops.occur_var env sigma hyp hyp_typ + || Termops.is_section_variable hyp + (* should be dangerous *) + then (clear, decl :: keep) + else (hyp :: clear, keep)) + ~init:([], []) (Proofview.Goal.env g) + in + (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + Tacticals.New.tclTHEN + ((* observe_tac "h_generalize" *) + generalize (List.map mkVar to_revert)) + ((* observe_tac "thin" *) clear to_revert)) let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar let revert idl = - tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) + Tacticals.New.tclTHEN (generalize (List.map mkVar idl)) (clear idl) let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = + let open Tacticals.New in (* 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) )); *) @@ -843,16 +863,14 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = tclTHENLIST - [ 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 - tclTHENLIST - [ observe_tac "generalize_non_dep in generate_equation_lemma" - (generalize_non_dep rec_id) - ; observe_tac "h_case" - (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))) - ; Proofview.V82.of_tactic intros_reflexivity ] - g) ] + [ tclDO (nb_params + rec_args_num + 1) intro + ; observe_tac "" + (onNthHypId 1 (fun rec_id -> + tclTHENLIST + [ observe_tac "generalize_non_dep in generate_equation_lemma" + (generalize_non_dep rec_id) + ; observe_tac "h_case" (simplest_case (mkVar rec_id)) + ; intros_reflexivity ])) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) @@ -863,9 +881,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num Declare.CInfo.make ~name:(mk_equation_id f_id) ~typ:lemma_type () in let lemma = Declare.Proof.start ~cinfo ~info evd in - let lemma, _ = - Declare.Proof.by (Proofview.V82.tactic prove_replacement) lemma - in + let lemma, _ = Declare.Proof.by prove_replacement lemma in let (_ : _ list) = Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None @@ -873,377 +889,398 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num evd let do_replace (evd : Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num - all_funs g = - let equation_lemma = - try - let finfos = - match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with - | None -> raise Not_found - | Some finfos -> finfos - in - mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone) as e -> - let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in - (*i The next call to mk_equation_id is valid since we will construct the lemma - Ensures by: obvious - i*) - let equation_lemma_id = mk_equation_id f_id in - evd := - generate_equation_lemma !evd all_funs f fun_num (List.length params) - (List.length rev_args_id) rec_arg_num; - let _ = - match e with - | Option.IsNone -> + all_funs = + Proofview.Goal.enter (fun g -> + let equation_lemma = + try let finfos = - match find_Function_infos (fst (destConst !evd f)) with + match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with | None -> raise Not_found | Some finfos -> finfos in - update_Function - { finfos with - equation_lemma = - Some - ( match Nametab.locate (qualid_of_ident equation_lemma_id) with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } - | _ -> () + mkConst (Option.get finfos.equation_lemma) + with (Not_found | Option.IsNone) as e -> + let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in + (*i The next call to mk_equation_id is valid since we will construct the lemma + Ensures by: obvious + i*) + let equation_lemma_id = mk_equation_id f_id in + evd := + generate_equation_lemma !evd all_funs f fun_num (List.length params) + (List.length rev_args_id) rec_arg_num; + let _ = + match e with + | Option.IsNone -> + let finfos = + match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + { finfos with + equation_lemma = + Some + ( match + Nametab.locate (qualid_of_ident equation_lemma_id) + with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } + | _ -> () + in + (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) + let evd', res = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference + (qualid_of_ident equation_lemma_id)) + in + evd := evd'; + let sigma, _ = + Typing.type_of ~refresh:true (Global.env ()) !evd res + in + evd := sigma; + res in - (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) - let evd', res = - Evd.fresh_global (Global.env ()) !evd - (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) + let nb_intro_to_do = + nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) in - evd := evd'; - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in - evd := sigma; - res - in - let nb_intro_to_do = nb_prod (project g) (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) - (fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in + let open Tacticals.New in tclTHEN - (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) - g') - g + (tclDO nb_intro_to_do intro) + (Proofview.Goal.enter (fun g' -> + let just_introduced = Tacticals.New.nLastDecls g' nb_intro_to_do in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in + tclTHEN + (* Hack to synchronize the goal with the global env *) + (Proofview.V82.tactic + (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma))) + (revert just_introduced_id)))) let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num - fnames all_funs _nparams : tactic = - fun g -> - let princ_type = pf_concl g in - (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) - (* Pp.msgnl (str "all_funs "); *) - (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig (project g) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + fnames all_funs _nparams : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let princ_type = Proofview.Goal.concl g in + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) + (* Pp.msgnl (str "all_funs "); *) + (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) + let princ_info = compute_elim_sig sigma princ_type in + let fresh_id = + let avoid = ref (Tacmach.New.pf_ids_of_hyps g) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id in - avoid := new_id :: !avoid; - Name new_id - in - let fresh_decl = RelDecl.map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params - ; predicates = List.map fresh_decl princ_info.predicates - ; branches = List.map fresh_decl princ_info.branches - ; args = List.map fresh_decl princ_info.args } - in - let get_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env sigma (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt, f_body = decompose_lam (project g) fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params, princ_params, fbody_with_full_params = - if diff_params > 0 then - let princ_params, full_params = list_chop diff_params princ_info.params in - ( full_params - , (* real params *) - princ_params - , (* the params of the principle which are not params of the function *) - substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body ) - else - let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - ( princ_info.params - , (* real params *) - [] - , (* all params are full params *) - substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body ) - in - observe - ( str "full_params := " - ++ prlist_with_sep spc - (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params ); - observe - ( str "princ_params := " - ++ prlist_with_sep spc - (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params ); - observe - ( str "fbody_with_full_params := " - ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); - let all_funs_with_full_params = - Array.map - (fun f -> applist (f, List.rev_map var_of_decl full_params)) - all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix, infos = - match EConstr.kind (project g) fbody_with_full_params with - | Fix ((idxs, i), (names, typess, bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( substl - (List.rev (Array.to_list all_funs_with_full_params)) - body - , List.rev_map var_of_decl princ_params ))) - bodies + let fresh_decl = RelDecl.map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } in - let info_array = - Array.mapi - (fun i types -> - let types = - prod_applist (project g) types - (List.rev_map var_of_decl princ_params) - in - { idx = idxs.(i) - fix_offset - ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) - ; types - ; offset = fix_offset - ; nb_realargs = - List.length (fst (decompose_lam (project g) bodies.(i))) - - fix_offset - ; body_with_param = bodies_with_all_params.(i) - ; num_in_block = i }) - typess + let get_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + env sigma (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in - let pte_to_fix, rev_info = - List.fold_left_i - (fun i (acc_map, acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args, _ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = - applist - (mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) - in - let first_args = Array.init nargs (fun i -> mkRel (nargs - i)) in - let app_f = mkApp (f, first_args) in - let pte_args = Array.to_list first_args @ [app_f] in - let app_pte = applist (mkVar (Nameops.Name.get_id pte), pte_args) in - let body_with_param, num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist (body, List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with - | Fix ((_, num), (_, _, bs)) -> - ( Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( substl - (List.rev (Array.to_list all_funs_with_full_params)) - bs.(num) - , List.rev_map var_of_decl princ_params )) - , num ) - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - { infos with - types = compose_prod type_args app_pte - ; body_with_param - ; num_in_block = num } - in - (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) - (* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map, info :: acc_info)) - 0 (Id.Map.empty, []) - (List.rev princ_info.predicates) + let fbody = get_body fnames.(fun_num) in + let f_ctxt, f_body = decompose_lam sigma fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params, princ_params, fbody_with_full_params = + if diff_params > 0 then + let princ_params, full_params = + list_chop diff_params princ_info.params + in + ( full_params + , (* real params *) + princ_params + , (* the params of the principle which are not params of the function *) + substl (* function instantiated with real params *) + (List.map var_of_decl full_params) + f_body ) + else + let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + ( princ_info.params + , (* real params *) + [] + , (* all params are full params *) + substl (* function instantiated with real params *) + (List.map var_of_decl princ_info.params) + f_body ) in - (pte_to_fix, List.rev rev_info) - | _ -> (Id.Map.empty, []) - in - let mk_fixes : tactic = - let pre_info, infos = list_chop fun_num infos in - match (pre_info, infos) with - | _, [] -> tclIDTAC - | _, this_fix_info :: others_infos -> - let other_fix_infos = - List.map - (fun fi -> (fi.name, fi.idx + 1, fi.types)) - (pre_info @ others_infos) + observe + ( str "full_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params ); + observe + ( str "princ_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params ); + observe + ( str "fbody_with_full_params := " + ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); + let all_funs_with_full_params = + Array.map + (fun f -> applist (f, List.rev_map var_of_decl full_params)) + all_funs in - if List.is_empty other_fix_infos then - if this_fix_info.idx + 1 = 0 then tclIDTAC - (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else - Indfun_common.observe_tac - (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) - (Proofview.V82.of_tactic - (fix this_fix_info.name (this_fix_info.idx + 1))) - else - Proofview.V82.of_tactic - (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) - in - let first_tac : tactic = - (* every operations until fix creations *) - (* names are already refreshed *) - tclTHENLIST - [ observe_tac "introducing params" - (Proofview.V82.of_tactic - (intros_mustbe_force (List.rev_map id_of_decl princ_info.params))) - ; observe_tac "introducing predictes" - (Proofview.V82.of_tactic - (intros_mustbe_force - (List.rev_map id_of_decl princ_info.predicates))) - ; observe_tac "introducing branches" - (Proofview.V82.of_tactic - (intros_mustbe_force (List.rev_map id_of_decl princ_info.branches))) - ; observe_tac "building fixes" mk_fixes ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt, pte_app = decompose_prod_assum (project gl) (pf_concl gl) in - let pte, pte_args = decompose_app (project gl) pte_app in - try - let pte = - try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable.") + let fix_offset = List.length princ_params in + let ptes_to_fix, infos = + match EConstr.kind sigma fbody_with_full_params with + | Fix ((idxs, i), (names, typess, bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota env sigma + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + body + , List.rev_map var_of_decl princ_params ))) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = + prod_applist sigma types + (List.rev_map var_of_decl princ_params) + in + { idx = idxs.(i) - fix_offset + ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) + ; types + ; offset = fix_offset + ; nb_realargs = + List.length (fst (decompose_lam sigma bodies.(i))) + - fix_offset + ; body_with_param = bodies_with_all_params.(i) + ; num_in_block = i }) + typess + in + let pte_to_fix, rev_info = + List.fold_left_i + (fun i (acc_map, acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args, _ = decompose_prod sigma infos.types in + let nargs = List.length type_args in + let f = + applist + ( mkConst fnames.(i) + , List.rev_map var_of_decl princ_info.params ) + in + let first_args = + Array.init nargs (fun i -> mkRel (nargs - i)) + in + let app_f = mkApp (f, first_args) in + let pte_args = Array.to_list first_args @ [app_f] in + let app_pte = + applist (mkVar (Nameops.Name.get_id pte), pte_args) + in + let body_with_param, num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota env sigma + (applist (body, List.rev_map var_of_decl full_params)) + in + match EConstr.kind sigma body_with_full_params with + | Fix ((_, num), (_, _, bs)) -> + ( Reductionops.nf_betaiota env sigma + (applist + ( substl + (List.rev + (Array.to_list all_funs_with_full_params)) + bs.(num) + , List.rev_map var_of_decl princ_params )) + , num ) + | _ -> user_err Pp.(str "Not a mutual block") + in + let info = + { infos with + types = compose_prod type_args app_pte + ; body_with_param + ; num_in_block = num } + in + (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) + (* str " to " ++ Ppconstr.pr_id info.name); *) + ( Id.Map.add (Nameops.Name.get_id pte) info acc_map + , info :: acc_info )) + 0 (Id.Map.empty, []) + (List.rev princ_info.predicates) + in + (pte_to_fix, List.rev rev_info) + | _ -> (Id.Map.empty, []) in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ (* 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 - (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { nb_rec_hyps = -100 - ; rec_hyps = [] - ; info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist (fix_body, List.rev_map mkVar args_id)) - ; eq_hyps = [] } - in - tclTHENLIST - [ observe_tac "do_replace" - (do_replace evd full_params - (fix_info.idx + List.length princ_params) - ( args_id - @ List.map - (RelDecl.get_name %> Nameops.Name.get_id) - princ_params ) - all_funs.(fix_info.num_in_block) - fix_info.num_in_block all_funs) - ; (let do_prove = - build_proof interactive_proof (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - { dyn_infos with - rec_hyps = branches - ; nb_rec_hyps = List.length branches } - in - observe_tac "cleaning" - (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove dyn_infos) - in - (* observe (str "branches := " ++ *) - (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) - (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + let mk_fixes : unit Proofview.tactic = + let pre_info, infos = list_chop fun_num infos in + match (pre_info, infos) with + | _, [] -> Proofview.tclUNIT () + | _, this_fix_info :: others_infos -> + let other_fix_infos = + List.map + (fun fi -> (fi.name, fi.idx + 1, fi.types)) + (pre_info @ others_infos) + in + if List.is_empty other_fix_infos then + if this_fix_info.idx + 1 = 0 then Proofview.tclUNIT () + (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else + Indfun_common.New.observe_tac ~header:(str "observation") + (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) + (fix this_fix_info.name (this_fix_info.idx + 1)) + else + Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0 + in + let first_tac : unit Proofview.tactic = + (* every operations until fix creations *) + (* names are already refreshed *) + tclTHENLIST + [ observe_tac "introducing params" + (intros_mustbe_force (List.rev_map id_of_decl princ_info.params)) + ; observe_tac "introducing predicates" + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.predicates)) + ; observe_tac "introducing branches" + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.branches)) + ; observe_tac "building fixes" mk_fixes ] + in + let intros_after_fixes : unit Proofview.tactic = + Proofview.Goal.enter (fun gl -> + let sigma = Proofview.Goal.sigma gl in + let ccl = Proofview.Goal.concl gl in + let ctxt, pte_app = decompose_prod_assum sigma ccl in + let pte, pte_args = decompose_app sigma pte_app in + try + let pte = + try destVar sigma pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") + in + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in + tclTHENLIST + [ (* observe_tac ("introducing args") *) + tclDO nb_args intro + ; Proofview.Goal.enter (fun g -> + (* replacement of the function by its body *) + let args = Tacticals.New.nLastDecls g nb_args in + let fix_body = fix_info.body_with_param in + (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (Proofview.Goal.env g) + (Proofview.Goal.sigma g) + (applist (fix_body, List.rev_map mkVar args_id)) + ; eq_hyps = [] } + in + tclTHENLIST + [ observe_tac "do_replace" + (do_replace evd full_params + (fix_info.idx + List.length princ_params) + ( args_id + @ List.map + (RelDecl.get_name %> Nameops.Name.get_id) + princ_params ) + all_funs.(fix_info.num_in_block) + fix_info.num_in_block all_funs) + ; (let do_prove = + build_proof interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + observe_tac "cleaning" + (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) + in + (* observe (str "branches := " ++ *) + (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) + (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - (* ); *) - (* observe_tac "instancing" *) - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) ] - g) ] - gl - with Not_found -> - let nb_args = min princ_info.nargs (List.length ctxt) in - tclTHENLIST - [ 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 open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { nb_rec_hyps = -100 - ; rec_hyps = [] - ; info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( fbody_with_full_params - , List.rev_map var_of_decl princ_params - @ List.rev_map mkVar args_id )) - ; eq_hyps = [] } - in - let fname = - destConst (project g) - (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) - in - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]) - ; (let do_prove = - build_proof interactive_proof (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - { dyn_infos with - rec_hyps = branches - ; nb_rec_hyps = List.length branches } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove dyn_infos - in - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) ] - g) ] - gl - in - tclTHEN first_tac intros_after_fixes g + (* ); *) + (* observe_tac "instancing" *) + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ]) ] + with Not_found -> + let nb_args = min princ_info.nargs (List.length ctxt) in + tclTHENLIST + [ tclDO nb_args intro + ; Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* replacement of the function by its body *) + let args = Tacticals.New.nLastDecls g nb_args in + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota env sigma + (applist + ( fbody_with_full_params + , List.rev_map var_of_decl princ_params + @ List.rev_map mkVar args_id )) + ; eq_hyps = [] } + in + let fname = + destConst sigma + (fst + (decompose_app sigma (List.hd (List.rev pte_args)))) + in + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef (fst fname) ) ] + ; (let do_prove = + build_proof interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos + in + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ]) ]) + in + tclTHEN first_tac intros_after_fixes) (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) @@ -1254,97 +1291,95 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) -let prove_with_tcc tcc_lemma_constr eqs : tactic = +let prove_with_tcc tcc_lemma_constr eqs : unit Proofview.tactic = + let open Tacticals.New in match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> - (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) - (* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ (* generalize [lemma]; *) - (* h_intro hid; *) - (* Elim.h_decompose_and (mkVar hid); *) - tclTRY (list_rewrite true eqs) - ; (* (fun g -> *) - (* let ids' = pf_ids_of_hyps g in *) - (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) - (* rewrite *) - (* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false, 5) [] (Some [])) ] - gls - | Not_needed -> tclIDTAC + (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) + (* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ (* generalize [lemma]; *) + (* h_intro hid; *) + (* Elim.h_decompose_and (mkVar hid); *) + tclTRY (list_rewrite true eqs) + ; (* (fun g -> *) + (* let ids' = pf_ids_of_hyps g in *) + (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) + (* rewrite *) + (* ) *) + Eauto.gen_eauto (false, 5) [] (Some []) ] + | Not_needed -> Proofview.tclUNIT () -let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST - (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs) - in - let _, hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in - let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in - let f = fst (destApp (project gls) f_app) in - let rec backtrack : tactic = - fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App (f', _) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls +let backtrack_eqs_until_hrec hrec eqs : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun gls -> + let sigma = Proofview.Goal.sigma gls in + let eqs = List.map mkVar eqs in + let rewrite = tclFIRST (List.map Equality.rewriteRL eqs) in + let _, hrec_concl = + decompose_prod sigma (Tacmach.New.pf_get_hyp_typ hrec gls) + in + let f_app = Array.last (snd (destApp sigma hrec_concl)) in + let f = fst (destApp sigma f_app) in + let rec backtrack () : unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma gls in + let f_app = + Array.last (snd (destApp sigma (Proofview.Goal.concl g))) + in + match EConstr.kind sigma f_app with + | App (f', _) when eq_constr sigma f' f -> Proofview.tclUNIT () + | _ -> tclTHEN rewrite (backtrack ())) + in + backtrack ()) let rec rewrite_eqs_in_eqs eqs = + let open Tacticals.New in match eqs with - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | eq :: eqs -> tclTHEN (tclMAP - (fun id gl -> + (fun id -> observe_tac (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) + (Equality.general_rewrite_in true Locus.AllOccurrences true + (* dep proofs also: *) true id (mkVar eq) false))) eqs) (rewrite_eqs_in_eqs eqs) -let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENLIST - [ backtrack_eqs_until_hrec hrec eqs - ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ Proofview.V82.of_tactic (keep (tcc_hyps @ eqs)) - ; Proofview.V82.of_tactic (apply (Lazy.force acc_inv)) - ; (fun g -> - if is_mes then - Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , evaluable_of_global_reference - (delayed_force ltof_ref) ) ]) - g - else tclIDTAC g) - ; observe_tac "rew_and_finish" - (tclTHENLIST - [ 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" - (tclCOMPLETE - ( Proofview.V82.of_tactic - @@ Eauto.eauto_with_bases (true, 5) - [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [ Hints.Hint_db.empty TransparentState.empty - false ] )) ]) ] ] ]) - gls +let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : unit Proofview.tactic + = + let open Tacticals.New in + tclTHENLIST + [ backtrack_eqs_until_hrec hrec eqs + ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + tclTHENS (* We must have exactly ONE subgoal !*) + (apply (mkVar hrec)) + [ tclTHENLIST + [ keep (tcc_hyps @ eqs) + ; apply (Lazy.force acc_inv) + ; ( if is_mes then + unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference (delayed_force ltof_ref) ) + ] + else Proofview.tclUNIT () ) + ; observe_tac "rew_and_finish" + (tclTHENLIST + [ 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" + (tclCOMPLETE + (Eauto.eauto_with_bases (true, 5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false])) + ]) ] ] ] let is_valid_hypothesis sigma predicates_name = let predicates_name = @@ -1367,199 +1402,204 @@ let is_valid_hypothesis sigma predicates_name = is_valid_hypothesis let prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes - rec_arg_num rec_arg_type relation gl = - let princ_type = pf_concl gl in - let princ_info = compute_elim_sig (project gl) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps gl) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + rec_arg_num rec_arg_type relation = + Proofview.Goal.enter (fun gl -> + let sigma = Proofview.Goal.sigma gl in + let princ_type = Proofview.Goal.concl gl in + let princ_info = compute_elim_sig sigma princ_type in + let fresh_id = + let avoid = ref (Tacmach.New.pf_ids_of_hyps gl) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id in - avoid := new_id :: !avoid; - Name new_id - in - let fresh_decl = map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params - ; predicates = List.map fresh_decl princ_info.predicates - ; branches = List.map fresh_decl princ_info.branches - ; args = List.map fresh_decl princ_info.args } - in - let wf_tac = - if is_mes then fun b -> - Proofview.V82.of_tactic - @@ Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None - else fun _ -> prove_with_tcc tcc_lemma_ref [] - in - let real_rec_arg_num = rec_arg_num - princ_info.nparams in - let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in - (* observe ( *) - (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) - (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + let fresh_decl = map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } + in + let wf_tac = + if is_mes then fun b -> + Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None + else fun _ -> prove_with_tcc tcc_lemma_ref [] + in + let real_rec_arg_num = rec_arg_num - princ_info.nparams in + let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in + (* observe ( *) + (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) + (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) - (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) - (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) - (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let post_rec_arg, pre_rec_arg = - Util.List.chop npost_rec_arg princ_info.args - in - let rec_arg_id = - match List.rev post_rec_arg with - | ( LocalAssum ({binder_name = Name id}, _) - | LocalDef ({binder_name = Name id}, _, _) ) - :: _ -> - id - | _ -> assert false - in - (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = - List.map - (get_name %> Nameops.Name.get_id %> mkVar) - (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.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in - let acc_rec_arg_id = - Nameops.Name.get_id - (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) - in - let revert l = - tclTHEN - (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) - (Proofview.V82.of_tactic (clear l)) - in - let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in - let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) + (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) + (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) + (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let post_rec_arg, pre_rec_arg = + Util.List.chop npost_rec_arg princ_info.args + in + let rec_arg_id = + match List.rev post_rec_arg with + | ( LocalAssum ({binder_name = Name id}, _) + | LocalDef ({binder_name = Name id}, _, _) ) + :: _ -> + id + | _ -> assert false + in + (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = + List.map + (get_name %> Nameops.Name.get_id %> mkVar) + (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.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) + in + let acc_rec_arg_id = + Nameops.Name.get_id + (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) + in + let open Tacticals.New in + let revert l = + tclTHEN (Tactics.generalize (List.map mkVar l)) (clear l) + in + let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in + let prove_rec_arg_acc = + (* observe_tac "prove_rec_arg_acc" *) + tclCOMPLETE + (tclTHEN (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded, [|input_type; relation|])) - (Proofview.V82.tactic (fun g -> - (* observe_tac "prove wf" *) - (tclCOMPLETE (wf_tac is_mes)) g)))) - ((* observe_tac *) - (* "apply wf_thm" *) - Proofview.V82.of_tactic - (Tactics.Simple.apply - (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))))) - g - in - let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in - let lemma = - match !tcc_lemma_ref with - | Undefined -> user_err Pp.(str "No tcc proof !!") - | Value lemma -> EConstr.of_constr lemma - | Not_needed -> - EConstr.of_constr - (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") - in - (* let rec list_diff del_list check_list = *) - (* match del_list with *) - (* [] -> *) - (* [] *) - (* | f::r -> *) - (* if List.mem f check_list then *) - (* list_diff r check_list *) - (* else *) - (* f::(list_diff r check_list) *) - (* in *) - let tcc_list = ref [] in - let start_tac gls = - let hyps = pf_ids_of_hyps gls in - let hid = - next_ident_away_in_goal (Id.of_string "prov") (Id.Set.of_list hyps) - in - tclTHENLIST - [ Proofview.V82.of_tactic (generalize [lemma]) - ; 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 Id.equal new_hyps (hid :: hyps)); - if List.is_empty !tcc_list then begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g) ] - gls - in - tclTHENLIST - [ observe_tac "start_tac" start_tac - ; h_intros - (List.rev_map - (get_name %> Nameops.Name.get_id) - ( princ_info.args @ princ_info.branches @ princ_info.predicates - @ princ_info.params )) - ; Proofview.V82.of_tactic - (assert_by (Name acc_rec_arg_id) - (mkApp - (delayed_force acc_rel, [|input_type; relation; mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc)) - ; revert (List.rev (acc_rec_arg_id :: args_ids)) - ; Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1)) - ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) - ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)) - ; (fun gl' -> - let body = - let _, args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { nb_rec_hyps = List.length rec_hyps - ; rec_hyps - ; eq_hyps = [] - ; info = body } - in - let acc_inv = - lazy + (* observe_tac "prove wf" *) + (tclCOMPLETE (wf_tac is_mes))) + ((* observe_tac *) + (* "apply wf_thm" *) + Tactics.Simple.apply + (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))) + in + let args_ids = + List.map (get_name %> Nameops.Name.get_id) princ_info.args + in + let lemma = + match !tcc_lemma_ref with + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> + EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.True.I" ) + in + (* let rec list_diff del_list check_list = *) + (* match del_list with *) + (* [] -> *) + (* [] *) + (* | f::r -> *) + (* if List.mem f check_list then *) + (* list_diff r check_list *) + (* else *) + (* f::(list_diff r check_list) *) + (* in *) + let tcc_list = ref [] in + let start_tac = + Proofview.Goal.enter (fun gls -> + let hyps = Tacmach.New.pf_ids_of_hyps gls in + let hid = + next_ident_away_in_goal (Id.of_string "prov") + (Id.Set.of_list hyps) + in + tclTHENLIST + [ generalize [lemma] + ; Simple.intro hid + ; Elim.h_decompose_and (mkVar hid) + ; Proofview.Goal.enter (fun g -> + let new_hyps = Tacmach.New.pf_ids_of_hyps g in + tcc_list := + List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); + if List.is_empty !tcc_list then begin + tcc_list := [hid]; + Proofview.tclUNIT () + end + else clear [hid]) ]) + in + tclTHENLIST + [ observe_tac "start_tac" start_tac + ; h_intros + (List.rev_map + (get_name %> Nameops.Name.get_id) + ( princ_info.args @ princ_info.branches @ princ_info.predicates + @ princ_info.params )) + ; assert_by (Name acc_rec_arg_id) (mkApp - ( delayed_force acc_inv_id + ( delayed_force acc_rel , [|input_type; relation; mkVar rec_arg_id|] )) - in - let acc_inv = - lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) - in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> - (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) - (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) - (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) - (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) - (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + prove_rec_arg_acc + ; revert (List.rev (acc_rec_arg_id :: args_ids)) + ; fix fix_id (List.length args_ids + 1) + ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) + ; Equality.rewriteLR (mkConst eq_ref) + ; Proofview.Goal.enter (fun gl' -> + let body = + let _, args = + destApp (Proofview.Goal.sigma gl') (Proofview.Goal.concl gl') + in + Array.last args + in + let body_info rec_hyps = + { nb_rec_hyps = List.length rec_hyps + ; rec_hyps + ; eq_hyps = [] + ; info = body } + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + let acc_inv = + lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) + in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) + (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) + (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) + (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) + (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - (* observe_tac "new_prove_with_tcc" *) - new_prove_with_tcc is_mes acc_inv fix_id - ( !tcc_list - @ List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args @ princ_info.params) - @ [acc_rec_arg_id] ) - eqs) - ; is_valid = is_valid_hypothesis (project gl') predicates_names } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> Id.Map.add pte_id pte_info map) - Id.Map.empty predicates_names - in - let make_proof rec_hyps = - build_proof false [f_ref] ptes_info (body_info rec_hyps) - in - (* observe_tac "instantiate_hyps_with_args" *) - (instantiate_hyps_with_args make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids)) - gl') ] - gl + (* observe_tac "new_prove_with_tcc" *) + new_prove_with_tcc is_mes acc_inv fix_id + ( !tcc_list + @ List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args @ princ_info.params) + @ [acc_rec_arg_id] ) + eqs) + ; is_valid = + is_valid_hypothesis (Proofview.Goal.sigma gl') + predicates_names } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> Id.Map.add pte_id pte_info map) + Id.Map.empty predicates_names + in + let make_proof rec_hyps = + build_proof false [f_ref] ptes_info (body_info rec_hyps) + in + (* observe_tac "instantiate_hyps_with_args" *) + instantiate_hyps_with_args make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids)) ]) diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 52089ca7fb..096ea5fed5 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Names val prove_princ_for_struct : @@ -7,7 +17,7 @@ val prove_princ_for_struct : -> Constant.t array -> EConstr.constr array -> int - -> Tacmach.tactic + -> unit Proofview.tactic val prove_principle_for_gen : Constant.t * Constant.t * Constant.t @@ -22,6 +32,6 @@ val prove_principle_for_gen : -> (* the type of the recursive argument *) EConstr.constr -> (* the wf relation used to prove the function *) - Tacmach.tactic + unit Proofview.tactic (* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 45b1713441..1ea803f561 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -13,7 +13,8 @@ open Names open Indfun_common module RelDecl = Context.Rel.Declaration -let observe_tac s = observe_tac (fun _ _ -> Pp.str s) +let observe_tac s = + New.observe_tac ~header:(Pp.str "observation") (fun _ _ -> Pp.str s) (* Construct a fixpoint as a Glob_term @@ -210,9 +211,7 @@ let build_functional_principle (sigma : Evd.evar_map) old_princ_type sorts funs (EConstr.of_constr new_principle_type) in let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let ftac = - Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams) - in + let ftac = proof_tac (Array.map map funs) mutr_nparams in let env = Global.env () in let uctx = Evd.evar_universe_context sigma in let typ = EConstr.of_constr new_principle_type in @@ -335,7 +334,7 @@ let generate_principle (evd : Evd.evar_map ref) pconstants on_error is_general -> Names.Constant.t array -> EConstr.constr array -> int - -> Tacmach.tactic) : unit = + -> unit Proofview.tactic) : unit = let names = List.map (function {Vernacexpr.fname = {CAst.v = name}} -> name) fix_rec_l in @@ -442,7 +441,7 @@ let register_struct is_rec fixpoint_exprl = let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation (_ : int) (_ : Names.Constant.t array) (_ : EConstr.constr array) (_ : int) : - Tacmach.tactic = + unit Proofview.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation @@ -593,250 +592,241 @@ let rec generate_fresh_id x avoid i = id :: generate_fresh_id x (id :: avoid) (pred i) let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : - Tacmach.tactic = + unit Proofview.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - 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 evd 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 = Reductionops.nf_zeta (Global.env ()) evd princ_type in - let princ_infos = Tactics.compute_elim_sig evd princ_type in - (* The number of args of the function is then easily computable *) - let nb_fun_args = Termops.nb_prod (project g) (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 functional principle is defined in the - environment 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") - (Id.Set.of_list ids) - in - let ids = principle_id :: ids in - (* We get the branches of the principle *) - let branches = List.rev princ_infos.Tactics.branches in - (* and built the intro pattern for each of them *) - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> - CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids - (List.length - (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) - branches - in - (* before building the full intro pattern for the principle *) - let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd evd 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 pre_args = - List.fold_right - (fun {CAst.v = pat} acc -> - match pat with - | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc - | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) - (List.nth intro_pats (pred i)) - [] + let open Tacticals.New in + Proofview.Goal.enter (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 evd 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 = Reductionops.nf_zeta (Global.env ()) evd princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in + (* The number of args of the function is then easily computable *) + let nb_fun_args = + Termops.nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.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 functional principle is defined in the + environment 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") + (Id.Set.of_list ids) + in + let ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.Tactics.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> + CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids + (List.length + (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) + branches in - (* and get the real args of the branch by unfolding the defined constant *) - (* + (* before building the full intro pattern for the principle *) + let eq_ind = make_eq () in + let eq_construct = mkConstructUi (destInd evd 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_branch i pat = + (* We get the identifiers of this branch *) + let pre_args = + List.fold_right + (fun {CAst.v = pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) + pat [] + 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_get_hyp_typ g hid in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod (_, _, t') -> ( - match EConstr.kind sigma t' with - | Prod (_, t'', t''') -> ( - match (EConstr.kind sigma t'', EConstr.kind sigma t''') with - | App (eq, args), App (graph', _) - when EConstr.eq_constr sigma eq eq_ind - && Array.exists - (EConstr.eq_constr_nounivs sigma graph') - graphs_constr -> - args.(2) - :: mkApp - ( mkVar hid - , [| args.(2) - ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) - :: acc + let constructor_args g = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_get_hyp_typ hid g in + let sigma = Proofview.Goal.sigma g in + match EConstr.kind sigma type_of_hid with + | Prod (_, _, t') -> ( + match EConstr.kind sigma t' with + | Prod (_, t'', t''') -> ( + match (EConstr.kind sigma t'', EConstr.kind sigma t''') with + | App (eq, args), App (graph', _) + when EConstr.eq_constr sigma eq eq_ind + && Array.exists + (EConstr.eq_constr_nounivs sigma graph') + graphs_constr -> + args.(2) + :: mkApp + ( mkVar hid + , [| args.(2) + ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) + :: acc + | _ -> mkVar hid :: acc ) | _ -> mkVar hid :: acc ) - | _ -> mkVar hid :: acc ) - | _ -> 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.Tactics.nparams args_names) + | _ -> mkVar hid :: acc) + pre_args [] 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 fact we must also add the parameters to the constructor args *) + let constructor_args g = + let params_id = + fst (List.chop princ_infos.Tactics.nparams args_names) + in + List.map mkVar params_id @ constructor_args g in - if constructor_num <= length then ((kn, !ind_number), constructor_num) - 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 (mkConstructU (constructor, u), constructor_args g) + (* 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 ((kn, !ind_number), constructor_num) + 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 (mkConstructU (constructor, u), 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); *) + tclTHENLIST + [ observe_tac "h_intro_patterns " + (match pat with [] -> tclIDTAC | _ -> intro_patterns false pat) + ; (* 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 " (Proofview.tclUNIT ()) + ; (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP Simple.intro [res; hres]) + ; (* replacing [res] with its value *) + observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)) + ; (* Conclusion *) + observe_tac "exact" + (Proofview.Goal.enter (fun g -> exact_check (app_constructor 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 + (* end of branche proof *) + let lemmas = + Array.map + (fun (_, (ctxt, concl)) -> + match ctxt with + | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") + | hres :: res :: decl :: ctxt -> + let res = + EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres; res]) + ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) + :: ctxt ) + in + res) + lemmas_types_infos in - (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - (tclTHENLIST - [ observe_tac "h_intro_patterns " - (let l = List.nth intro_pats (pred i) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)) - ; (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false - ; Genredexpr.rConst = [] }) - Locusops.onConcl) - ; observe_tac "toto " tclIDTAC - ; (* introducing 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 - | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") - | hres :: res :: decl :: ctxt -> - let res = - EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres; res]) - ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) - :: ctxt ) - in - res) - 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) decl p -> - let id = - Namegen.next_ident_away - (Nameops.Name.get_id (RelDecl.get_name decl)) - (Id.Set.of_list avoid) - in - (p :: bindings, id :: avoid)) - ([], pf_ids_of_hyps g) - princ_infos.params (List.rev params) + 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 - let lemmas_bindings = - List.rev - (fst - (List.fold_left2 - (fun (bindings, avoid) decl p -> - let id = - Namegen.next_ident_away - (Nameops.Name.get_id (RelDecl.get_name decl)) - (Id.Set.of_list avoid) - in - ( Reductionops.nf_zeta (pf_env g) (project g) p :: bindings - , id :: avoid )) - ([], avoid) princ_infos.predicates lemmas)) + (* 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) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + (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) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + ( Reductionops.nf_zeta (Proofview.Goal.env g) + (Proofview.Goal.sigma g) p + :: bindings + , id :: avoid )) + ([], avoid) princ_infos.predicates lemmas)) + in + params_bindings @ lemmas_bindings in - params_bindings @ lemmas_bindings - in - tclTHENLIST - [ 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.type_of ~refresh:true) 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 + tclTHENLIST + [ observe_tac "principle" + (assert_by (Name principle_id) princ_type (exact_check f_principle)) + ; observe_tac "intro args_names" (tclMAP Simple.intro 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 + ; tclTHENS + (observe_tac "functional_induction" + (Proofview.Goal.enter (fun gl -> + let term = + mkApp (mkVar principle_id, Array.of_list bindings) + in + tclTYPEOFTHEN ~refresh:true term (fun _ _ -> apply term)))) + (List.map_i + (fun i pat -> + observe_tac + ("proving branch " ^ string_of_int i) + (prove_branch i pat)) + 1 intro_pats) ]) (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] is the tactic used to prove completeness lemma. @@ -865,7 +855,7 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : *) -let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl +let thin = Tactics.clear (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) @@ -882,347 +872,343 @@ let tauto = (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] *) -let generalize_dependent_of x hyp g = +let generalize_dependent_of x hyp = let open Context.Named.Declaration in - let open Tacmach in - let open Tacticals in - tclMAP - (function - | LocalAssum ({Context.binder_name = id}, t) - when (not (Id.equal id hyp)) - && Termops.occur_var (pf_env g) (project g) x t -> - tclTHEN - (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) - (thin [id]) - | _ -> tclIDTAC) - (pf_hyps g) g - -let rec intros_with_rewrite g = - observe_tac "intros_with_rewrite" intros_with_rewrite_aux g - -and intros_with_rewrite_aux : Tacmach.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + tclMAP + (function + | LocalAssum ({Context.binder_name = id}, t) + when (not (Id.equal id hyp)) + && Termops.occur_var (Proofview.Goal.env g) + (Proofview.Goal.sigma g) x t -> + tclTHEN (Tactics.generalize [EConstr.mkVar id]) (thin [id]) + | _ -> Proofview.tclUNIT ()) + (Proofview.Goal.hyps g)) + +let rec intros_with_rewrite () = + observe_tac "intros_with_rewrite" (intros_with_rewrite_aux ()) + +and intros_with_rewrite_aux () : unit Proofview.tactic = let open Constr in let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - let eq_ind = make_eq () in - let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | Prod (_, t, t') -> ( - match EConstr.kind sigma t with - | App (eq, args) when EConstr.eq_constr sigma 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 - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; thin [id] - ; intros_with_rewrite ] - g - else if - isVar sigma args.(1) - && Environ.evaluable_named (destVar sigma args.(1)) (pf_env g) - then - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ]) - ; tclMAP - (fun id -> - tclTRY - (Proofview.V82.of_tactic - (unfold_in_hyp - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] - (destVar sigma args.(1), Locus.InHyp)))) - (pf_ids_of_hyps g) - ; intros_with_rewrite ] - g - else if - isVar sigma args.(2) - && Environ.evaluable_named (destVar sigma args.(2)) (pf_env g) - then - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ]) - ; tclMAP - (fun id -> - tclTRY - (Proofview.V82.of_tactic - (unfold_in_hyp - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] - (destVar sigma args.(2), Locus.InHyp)))) - (pf_ids_of_hyps g) - ; intros_with_rewrite ] - g - else if isVar sigma args.(1) then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; generalize_dependent_of (destVar sigma args.(1)) id - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) - ; intros_with_rewrite ] - g - else if isVar sigma args.(2) then - let id = pf_get_new_id (Id.of_string "y") g in + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let eq_ind = make_eq () in + let sigma = Proofview.Goal.sigma g in + match EConstr.kind sigma (Proofview.Goal.concl g) with + | Prod (_, t, t') -> ( + match EConstr.kind sigma t with + | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> + if + Reductionops.is_conv (Proofview.Goal.env g) (Proofview.Goal.sigma g) + args.(1) args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [Simple.intro id; thin [id]; intros_with_rewrite ()] + else if + isVar sigma args.(1) + && Environ.evaluable_named + (destVar sigma args.(1)) + (Proofview.Goal.env g) + then + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + ; tclMAP + (fun id -> + tclTRY + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + (destVar sigma args.(1), Locus.InHyp))) + (pf_ids_of_hyps g) + ; intros_with_rewrite () ] + else if + isVar sigma args.(2) + && Environ.evaluable_named + (destVar sigma args.(2)) + (Proofview.Goal.env g) + then + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + ; tclMAP + (fun id -> + tclTRY + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + (destVar sigma args.(2), Locus.InHyp))) + (pf_ids_of_hyps g) + ; intros_with_rewrite () ] + else if isVar sigma args.(1) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; generalize_dependent_of (destVar sigma args.(1)) id + ; tclTRY (Equality.rewriteLR (mkVar id)) + ; intros_with_rewrite () ] + else if isVar sigma args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; generalize_dependent_of (destVar sigma args.(2)) id + ; tclTRY (Equality.rewriteRL (mkVar id)) + ; intros_with_rewrite () ] + else + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; tclTRY (Equality.rewriteLR (mkVar id)) + ; intros_with_rewrite () ] + | Ind _ + when EConstr.eq_constr sigma t + (EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.False.type" )) -> + tauto + | Case (_, _, _, v, _) -> + tclTHENLIST [simplest_case v; intros_with_rewrite ()] + | LetIn _ -> tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; generalize_dependent_of (destVar sigma args.(2)) id - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))) - ; intros_with_rewrite ] - g - else + [ reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; intros_with_rewrite () ] + | _ -> let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) - ; intros_with_rewrite ] - g - | Ind _ - when EConstr.eq_constr sigma t - (EConstr.of_constr - ( UnivGen.constr_of_monomorphic_global - @@ Coqlib.lib_ref "core.False.type" )) -> - Proofview.V82.of_tactic tauto g - | Case (_, _, _, v, _) -> - tclTHENLIST - [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] - g + tclTHENLIST [Simple.intro id; intros_with_rewrite ()] ) | LetIn _ -> tclTHENLIST - [ Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; intros_with_rewrite ] - g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [Proofview.V82.of_tactic (Simple.intro id); intros_with_rewrite] - g ) - | LetIn _ -> - tclTHENLIST - [ Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; intros_with_rewrite ] - g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = + [ reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; intros_with_rewrite () ] + | _ -> Proofview.tclUNIT ()) + +let rec reflexivity_with_destruct_cases () = let open Constr in let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - let destruct_case () = - try - match - EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) - with - | Case (_, _, _, v, _) -> - tclTHENLIST - [ Proofview.V82.of_tactic (simplest_case v) - ; Proofview.V82.of_tactic intros - ; observe_tac "reflexivity_with_destruct_cases" - reflexivity_with_destruct_cases ] - | _ -> Proofview.V82.of_tactic reflexivity - with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity - in - let eq_ind = make_eq () in - let my_inj_flags = - Some - { Equality.keep_proof_equalities = false - ; injection_in_context = false - ; (* for compatibility, necessary *) - injection_pattern_l2r_order = - false (* probably does not matter; except maybe with dependent hyps *) - } - in - let discr_inject = - Tacticals.onAllHypsAndConcl (fun sc g -> - match sc with - | None -> tclIDTAC g - | Some id -> ( - match EConstr.kind (project g) (pf_get_hyp_typ g id) with - | App (eq, [|_; t1; t2|]) when EConstr.eq_constr (project g) eq eq_ind - -> - if Equality.discriminable (pf_env g) (project g) t1 t2 then - Proofview.V82.of_tactic (Equality.discrHyp id) g - else if - Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then - tclTHENLIST - [ Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id) - ; thin [id] - ; intros_with_rewrite ] - g - else tclIDTAC g - | _ -> tclIDTAC g )) - in - (tclFIRST - [ 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 - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing - *) - observe_tac "reflexivity_with_destruct_cases : others" - (tclTHEN (tclPROGRESS discr_inject) reflexivity_with_destruct_cases) ]) - g + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let destruct_case () = + try + match + EConstr.kind (Proofview.Goal.sigma g) + (snd (destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g))).( + 2) + with + | Case (_, _, _, v, _) -> + tclTHENLIST + [ simplest_case v + ; intros + ; observe_tac "reflexivity_with_destruct_cases" + (reflexivity_with_destruct_cases ()) ] + | _ -> reflexivity + with e when CErrors.noncritical e -> reflexivity + in + let eq_ind = make_eq () in + let my_inj_flags = + Some + { Equality.keep_proof_equalities = false + ; injection_in_context = false + ; (* for compatibility, necessary *) + injection_pattern_l2r_order = + false + (* probably does not matter; except maybe with dependent hyps *) + } + in + let discr_inject = + onAllHypsAndConcl (fun sc -> + match sc with + | None -> Proofview.tclUNIT () + | Some id -> + Proofview.Goal.enter (fun g -> + match + EConstr.kind (Proofview.Goal.sigma g) (pf_get_hyp_typ id g) + with + | App (eq, [|_; t1; t2|]) + when EConstr.eq_constr (Proofview.Goal.sigma g) eq eq_ind -> + if + Equality.discriminable (Proofview.Goal.env g) + (Proofview.Goal.sigma g) t1 t2 + then Equality.discrHyp id + else if + Equality.injectable (Proofview.Goal.env g) + (Proofview.Goal.sigma g) ~keep_proofs:None t1 t2 + then + tclTHENLIST + [ Equality.injHyp my_inj_flags None id + ; thin [id] + ; intros_with_rewrite () ] + else Proofview.tclUNIT () + | _ -> Proofview.tclUNIT ())) + in + tclFIRST + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" 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 + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing + *) + observe_tac "reflexivity_with_destruct_cases : others" + (tclTHEN (tclPROGRESS discr_inject) + (reflexivity_with_destruct_cases ())) ]) let prove_fun_complete funcs graphs schemes lemmas_types_infos i : - Tacmach.tactic = + unit Proofview.tactic = let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - (* We compute the types of the different mutually recursive lemmas - in $\zeta$ normal form - *) - let lemmas = - Array.map - (fun (_, (ctxt, concl)) -> - Reductionops.nf_zeta (pf_env g) (project g) - (EConstr.it_mkLambda_or_LetIn concl ctxt)) - lemmas_types_infos - in - (* We get the constant and the principle corresponding to this lemma *) - let f = funcs.(i) in - let graph_principle = - Reductionops.nf_zeta (pf_env g) (project g) - (EConstr.of_constr schemes.(i)) - in - let g, princ_type = tac_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig (project g) princ_type in - (* Then we get the number of argument of the function - and compute a fresh name for each of them - *) - let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names @ pf_ids_of_hyps g in - (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res, hres, graph_principle_id = - match generate_fresh_id (Id.of_string "z") ids 3 with - | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) - | _ -> assert false - in - let ids = res :: hres :: graph_principle_id :: ids in - (* we also compute fresh names for each hyptohesis of each branch - of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids - (Termops.nb_prod (project g) (RelDecl.get_type decl)))) - branches - in - (* We will need to change the function by its body - using [f_equation] if it is recursive (that is the graph is infinite - or unfold if the graph is finite - *) - let rewrite_tac j ids : Tacmach.tactic = - let graph_def = graphs.(j) in - let infos = - match find_Function_infos (fst (destConst (project g) funcs.(j))) with - | None -> CErrors.user_err Pp.(str "No graph found") - | Some infos -> infos + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + (* We compute the types of the different mutually recursive lemmas + in $\zeta$ normal form + *) + let lemmas = + Array.map + (fun (_, (ctxt, concl)) -> + Reductionops.nf_zeta (Proofview.Goal.env g) (Proofview.Goal.sigma g) + (EConstr.it_mkLambda_or_LetIn concl ctxt)) + lemmas_types_infos in - if - infos.is_general - || Rtree.is_infinite Declareops.eq_recarg - graph_def.Declarations.mind_recargs - then - let eq_lemma = - try Option.get infos.equation_lemma - with Option.IsNone -> - CErrors.anomaly (Pp.str "Cannot find equation lemma.") - in - tclTHENLIST - [ 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 *) - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)) - ; thin ids ] - else - Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalConstRef (fst (destConst (project g) f)) ) ]) - in - (* The proof of each branche itself *) - let ind_number = ref 0 in - let min_constr_number = ref 0 in - let prove_branche i g = - (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = - Array.length graphs.(!ind_number).Declarations.mind_consnames - in - if constructor_num <= length then !ind_number - else begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + (* We get the constant and the principle corresponding to this lemma *) + let f = funcs.(i) in + let graph_principle = + Reductionops.nf_zeta (Proofview.Goal.env g) (Proofview.Goal.sigma g) + (EConstr.of_constr schemes.(i)) in - let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST - [ (* 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 (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 open EConstr in - let params = List.map mkVar params_names in - tclTHENLIST - [ tclMAP - (fun id -> Proofview.V82.of_tactic (Simple.intro id)) - (args_names @ [res; hres]) - ; observe_tac "h_generalize" - (Proofview.V82.of_tactic - (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" - (Proofview.V82.of_tactic - (elim false None - (mkVar hres, Tactypes.NoBindings) - (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g)) ] - g + tclTYPEOFTHEN graph_principle (fun sigma princ_type -> + let princ_infos = Tactics.compute_elim_sig sigma princ_type in + (* Then we get the number of argument of the function + and compute a fresh name for each of them + *) + let nb_fun_args = + Termops.nb_prod sigma (Proofview.Goal.concl g) - 2 + in + let args_names = + generate_fresh_id (Id.of_string "x") [] nb_fun_args + in + let ids = args_names @ pf_ids_of_hyps g in + (* and fresh names for res H and the principle (cf bug bug #1174) *) + let res, hres, graph_principle_id = + match generate_fresh_id (Id.of_string "z") ids 3 with + | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) + | _ -> assert false + in + let ids = res :: hres :: graph_principle_id :: ids in + (* we also compute fresh names for each hyptohesis of each branch + of the principle *) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids + (Termops.nb_prod (Proofview.Goal.sigma g) + (RelDecl.get_type decl)))) + branches + in + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite + *) + let rewrite_tac j ids : unit Proofview.tactic = + let graph_def = graphs.(j) in + let infos = + match + find_Function_infos + (fst (destConst (Proofview.Goal.sigma g) funcs.(j))) + with + | None -> CErrors.user_err Pp.(str "No graph found") + | Some infos -> infos + in + if + infos.is_general + || Rtree.is_infinite Declareops.eq_recarg + graph_def.Declarations.mind_recargs + then + let eq_lemma = + try Option.get infos.equation_lemma + with Option.IsNone -> + CErrors.anomaly (Pp.str "Cannot find equation lemma.") + in + tclTHENLIST + [ tclMAP Simple.intro ids + ; 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}) + Locusops.onConcl + ; generalize (List.map mkVar ids) + ; thin ids ] + else + unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef + (fst (destConst (Proofview.Goal.sigma g) f)) ) ] + in + (* The proof of each branche itself *) + let ind_number = ref 0 in + let min_constr_number = ref 0 in + let prove_branch i this_branche_ids = + (* we fist compute the inductive corresponding to the branch *) + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = + Array.length graphs.(!ind_number).Declarations.mind_consnames + in + if constructor_num <= length then !ind_number + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end + in + tclTHENLIST + [ (* 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 (all)" (intros_with_rewrite ()) + ; (* The proof is (almost) complete *) + observe_tac "reflexivity" (reflexivity_with_destruct_cases ()) + ] + in + let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in + let params = List.map mkVar params_names in + tclTHENLIST + [ tclMAP Simple.intro (args_names @ [res; hres]) + ; observe_tac "h_generalize" + (generalize + [ mkApp + ( applist (graph_principle, params) + , Array.map (fun c -> applist (c, params)) lemmas ) ]) + ; Simple.intro graph_principle_id + ; observe_tac "" + (tclTHENS + (observe_tac "elim" + (elim false None + (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings)))) + (List.map_i + (fun i pat -> + observe_tac "prove_branch" (prove_branch i pat)) + 1 intro_pats)) ])) exception No_graph_found @@ -1523,9 +1509,7 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) let info = Declare.Info.make () in let cinfo = Declare.CInfo.make ~name:lem_id ~typ () in let lemma = Declare.Proof.start ~cinfo ~info !evd in - let lemma = - fst @@ Declare.Proof.by (Proofview.V82.tactic (proving_tac i)) lemma - in + let lemma = fst @@ Declare.Proof.by (proving_tac i) lemma in let (_ : _ list) = Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None @@ -1592,10 +1576,9 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) let lemma = fst (Declare.Proof.by - (Proofview.V82.tactic - (observe_tac - ("prove completeness (" ^ Id.to_string f_id ^ ")") - (proving_tac i))) + (observe_tac + ("prove completeness (" ^ Id.to_string f_id ^ ")") + (proving_tac i)) lemma) in let (_ : _ list) = diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index af53f16e1f..0179215d6a 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -394,10 +394,7 @@ let jmeq_refl () = @@ Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) -let h_intros l = - Proofview.V82.of_tactic - (Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l) - +let h_intros l = Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" @@ -428,13 +425,12 @@ let evaluable_of_global_reference r = | _ -> assert false let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = - let open Tacticals in + let open Tacticals.New in (tclREPEAT (List.fold_right (fun (eq, b) i -> tclORELSE - (Proofview.V82.of_tactic - ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq) i) (if rev then List.rev eqs else eqs) (tclFAIL 0 (mt ()))) [@ocaml.warning "-3"]) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 396db55458..7b7044fdaf 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -90,7 +90,7 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool -val h_intros : Names.Id.t list -> Tacmach.tactic +val h_intros : Names.Id.t list -> unit Proofview.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t val acc_inv_id : EConstr.constr Util.delayed @@ -102,7 +102,7 @@ val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference -val list_rewrite : bool -> (EConstr.constr * bool) list -> Tacmach.tactic +val list_rewrite : bool -> (EConstr.constr * bool) list -> unit Proofview.tactic val decompose_lam_n : Evd.evar_map diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 066ade07d2..33076a876b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -23,8 +23,7 @@ open Nameops open CErrors open Util open UnivGen -open Tacticals -open Tacmach +open Tacticals.New open Tactics open Nametab open Tacred @@ -94,7 +93,7 @@ let const_of_ref = function (* Generic values *) let pf_get_new_ids idl g = - let ids = pf_ids_of_hyps g in + let ids = Tacmach.New.pf_ids_of_hyps g in let ids = Id.Set.of_list ids in List.fold_right (fun id acc -> @@ -105,8 +104,9 @@ let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) let compute_renamed_type gls id = - rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty - (*no rels*) [] (pf_get_hyp_typ gls id) + rename_bound_vars_as_displayed (Proofview.Goal.sigma gls) + (*no avoid*) Id.Set.empty (*no rels*) [] + (Tacmach.New.pf_get_hyp_typ id gls) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -218,20 +218,6 @@ let (declare_f : fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref) -let observe_tclTHENLIST s tacl = - if do_observe () then - let rec aux n = function - | [] -> tclIDTAC - | [tac] -> - observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac :: tacl -> - observe_tac - (fun env sigma -> s env sigma ++ spc () ++ int n) - (tclTHEN tac (aux (succ n) tacl)) - in - aux 0 tacl - else tclTHENLIST tacl - module New = struct open Tacticals.New @@ -364,11 +350,11 @@ type ('a, 'b) journey_info_tac = -> (* the arguments of the constructor *) 'b infos -> (* infos of the caller *) - ('b infos -> tactic) + ('b infos -> unit Proofview.tactic) -> (* the continuation tactic of the caller *) 'b infos -> (* argument of the tactic *) - tactic + unit Proofview.tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) @@ -376,7 +362,9 @@ 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) + ( (constr infos -> unit Proofview.tactic) + -> constr infos + -> unit Proofview.tactic) -> ( case_info * constr * (constr, EInstance.t) case_invert @@ -397,133 +385,131 @@ let add_vars sigma forbidden e = in aux 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 (project g) nb_lam e in - let ids = - List.fold_left - (fun acc (na, _) -> - let pre_id = - match na.binder_name 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 - observe_tclTHENLIST - (fun _ _ -> str "treat_case1") - [ h_intros (List.rev rev_ids) - ; Proofview.V82.of_tactic - (intro_using_then teq_id (fun _ -> Proofview.tclUNIT ())) - ; onLastHypId (fun heq -> - observe_tclTHENLIST - (fun _ _ -> str "treat_case2") - [ Proofview.V82.of_tactic (clear to_intros) - ; h_intros to_intros - ; (fun g' -> - let ty_teq = pf_get_hyp_typ g' heq in - let teq_lhs, teq_rhs = - let _, args = - try destApp (project g') ty_teq - with DestKO -> assert false - in - (args.(1), args.(2)) - in - let new_b' = - Termops.replace_term (project g') 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 (project g') 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) g = - let sigma = project g in - let env = pf_env g in - match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> - user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") - | Array _ -> user_err Pp.(str "Function cannot treat arrays") - | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn (na, b, t, e) -> - let new_continuation_tac = - jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac - in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final = false} - g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> ( - try - check_not_nested env sigma - (expr_info.f_id :: expr_info.forbidden_ids) - expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str " can not contain a recursive call to " - ++ Id.print expr_info.f_id ) ) - | Lambda (n, t, b) -> ( - try - check_not_nested env sigma - (expr_info.f_id :: expr_info.forbidden_ids) - expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str " can not contain a recursive call to " - ++ Id.print expr_info.f_id ) ) - | Case (ci, t, iv, a, l) -> - let continuation_tac_a = - jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac - in - travel jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; is_final = false} - g - | App _ -> ( - let f, args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f expr_info.f_constr then - jinfo.app_reC (f, args) expr_info continuation_tac expr_info g - else - match EConstr.kind sigma 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 treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : + unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let rev_context, b = decompose_lam_n (Proofview.Goal.sigma g) nb_lam e in + let ids = + List.fold_left + (fun acc (na, _) -> + let pre_id = + match na.binder_name 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 + New.observe_tclTHENLIST + (fun _ _ -> str "treat_case1") + [ h_intros (List.rev rev_ids) + ; intro_using_then teq_id (fun _ -> Proofview.tclUNIT ()) + ; Tacticals.New.onLastHypId (fun heq -> + New.observe_tclTHENLIST + (fun _ _ -> str "treat_case2") + [ clear to_intros + ; h_intros to_intros + ; Proofview.Goal.enter (fun g' -> + let sigma = Proofview.Goal.sigma g' in + let ty_teq = Tacmach.New.pf_get_hyp_typ heq g' in + let teq_lhs, teq_rhs = + let _, args = + try destApp sigma ty_teq with DestKO -> assert false + in + (args.(1), args.(2)) + in + let new_b' = + Termops.replace_term sigma 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 sigma infos.forbidden_ids new_b' + else infos.forbidden_ids ) } + in + finalize_tac new_infos) ]) ]) + +let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + match EConstr.kind sigma expr_info.info with + | CoFix _ | Fix _ -> + user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Array _ -> user_err Pp.(str "Function cannot treat arrays") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") + | LetIn (na, b, t, e) -> let new_continuation_tac = - jinfo.apP (f, args) expr_info continuation_tac + jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final = false} + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Prod _ -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Lambda (n, t, b) -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Case (ci, t, iv, a, l) -> + let continuation_tac_a = + jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in - travel_args jinfo expr_info.is_main_branch new_continuation_tac - new_infos g - | Case _ -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma 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_leconstr_env env sigma expr_info.info - ++ Pp.str "." ) ) - | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ - |Float _ -> - let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info g + travel jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; is_final = false} + | App _ -> ( + let f, args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f expr_info.f_constr then + jinfo.app_reC (f, args) expr_info continuation_tac expr_info + else + match EConstr.kind sigma 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 _ -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma 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_leconstr_env env sigma expr_info.info + ++ Pp.str "." ) ) + | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ + |Int _ | Float _ -> + 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 @@ -538,139 +524,131 @@ and travel_args jinfo is_final continuation_tac infos = travel jinfo new_continuation_tac {infos with info = arg; is_final = false} and travel jinfo continuation_tac expr_info = - observe_tac + New.observe_tac (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) -let rec prove_lt hyple g = - let sigma = project g in - begin - try - let varx, varz = - match decompose_app sigma (pf_concl g) with - | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) - | _ -> assert false - in - let h = - List.find - (fun id -> - match decompose_app sigma (pf_get_hyp_typ g id) with - | _, t :: _ -> EConstr.eq_constr sigma t varx - | _ -> false) - hyple - in - let y = - List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) - in - observe_tclTHENLIST - (fun _ _ -> str "prove_lt1") - [ Proofview.V82.of_tactic - (apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|]))) - ; observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] - with Not_found -> - observe_tclTHENLIST - (fun _ _ -> str "prove_lt2") - [ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)) - ; observe_tac - (fun _ _ -> 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 - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux1") - [ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])) - ; Proofview.V82.of_tactic - (intro_then (fun id -> - Proofview.V82.tactic - (observe_tac - (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS - (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ observe_tclTHENLIST - (fun _ _ -> str "") - [ Proofview.V82.of_tactic - (intro_using_then h_id - (* We don't care about the refreshed name, - accessed only through auto? *) - (fun _ -> Proofview.tclUNIT ())) - ; Proofview.V82.of_tactic - (simplest_elim - (mkApp (delayed_force lt_n_O, [|s_max|]))) - ; Proofview.V82.of_tactic default_full_auto ] - ; observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux2") - [ observe_tac - (fun _ _ -> str "clearing k ") - (Proofview.V82.of_tactic (clear [id])) - ; h_intros [k; h'; def] - ; observe_tac - (fun _ _ -> str "simple_iter") - (Proofview.V82.of_tactic - (simpl_iter Locusops.onConcl)) - ; observe_tac - (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.OnlyOccurrences [1] - , evaluable_of_global_reference - infos.func ) ])) - ; observe_tclTHENLIST - (fun _ _ -> str "test") - [ 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 - (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic - intros_reflexivity) - (observe_tac - (fun _ _ -> str "calling prove_lt") - (prove_lt hyple))) ] ] ])))) ] - g - | (_, v_bound) :: l -> - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux3") - [ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)) - ; Proofview.V82.of_tactic (clear [v_bound]) - ; tclDO 2 (Proofview.V82.of_tactic intro) - ; onNthHypId 1 (fun p_hyp -> - onNthHypId 2 (fun p -> - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux4") - [ 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 rec prove_lt hyple = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + try + let varx, varz = + match decompose_app sigma (Proofview.Goal.concl g) with + | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) + | _ -> assert false + in + let h = + List.find + (fun id -> + match decompose_app sigma (Tacmach.New.pf_get_hyp_typ id g) with + | _, t :: _ -> EConstr.eq_constr sigma t varx + | _ -> false) + hyple + in + let y = + List.hd + (List.tl + (snd (decompose_app sigma (Tacmach.New.pf_get_hyp_typ h g)))) + in + New.observe_tclTHENLIST + (fun _ _ -> str "prove_lt1") + [ apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|])) + ; New.observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] + with Not_found -> + New.observe_tclTHENLIST + (fun _ _ -> str "prove_lt2") + [ apply (delayed_force lt_S_n) + ; New.observe_tac + (fun _ _ -> + str "assumption: " + ++ Printer.pr_goal Evd.{it = Proofview.Goal.goal g; sigma}) + assumption ]) + +let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + match lbounds with + | [] -> + let ids = Tacmach.New.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 + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux1") + [ split (ImplicitBindings [s_max]) + ; intro_then (fun id -> + New.observe_tac + (fun _ _ -> str "destruct_bounds_aux") + (tclTHENS + (simplest_case (mkVar id)) + [ New.observe_tclTHENLIST + (fun _ _ -> str "") + [ intro_using_then h_id + (* We don't care about the refreshed name, + accessed only through auto? *) + (fun _ -> Proofview.tclUNIT ()) + ; simplest_elim + (mkApp (delayed_force lt_n_O, [|s_max|])) + ; default_full_auto ] + ; New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux2") + [ New.observe_tac + (fun _ _ -> str "clearing k ") + (clear [id]) + ; h_intros [k; h'; def] + ; New.observe_tac + (fun _ _ -> str "simple_iter") + (simpl_iter Locusops.onConcl) + ; New.observe_tac + (fun _ _ -> str "unfold functional") + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference infos.func ) + ]) + ; New.observe_tclTHENLIST + (fun _ _ -> str "test") + [ 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) *) + (* ; *) + New.observe_tac + (fun _ _ -> str "finishing") + (tclORELSE intros_reflexivity + (New.observe_tac + (fun _ _ -> str "calling prove_lt") + (prove_lt hyple))) ] ] ])) ] + | (_, v_bound) :: l -> + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux3") + [ simplest_elim (mkVar v_bound) + ; clear [v_bound] + ; tclDO 2 intro + ; onNthHypId 1 (fun p_hyp -> + onNthHypId 2 (fun p -> + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux4") + [ simplest_elim + (mkApp (delayed_force max_constr, [|bound; mkVar p|])) + ; tclDO 3 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) ])) ]) let destruct_bounds infos = destruct_bounds_aux infos @@ -679,47 +657,51 @@ let destruct_bounds infos = let terminate_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "terminate_app1") [ continuation_tac infos - ; observe_tac + ; New.observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) - ; observe_tac + (split (ImplicitBindings [infos.info])) + ; New.observe_tac (fun _ _ -> 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 - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "terminate_others") [ continuation_tac infos - ; observe_tac + ; New.observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) - ; observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) - ] + (split (ImplicitBindings [infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds") + (destruct_bounds infos) ] else continuation_tac infos -let terminate_letin (na, b, t, e) expr_info continuation_tac info g = - let sigma = project g in - let env = pf_env g in - let new_e = subst1 info.info e in - let new_forbidden = - let forbid = - try - check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) b; - true - with e when CErrors.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} g +let terminate_letin (na, b, t, e) expr_info continuation_tac info = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + let new_e = subst1 info.info e in + let new_forbidden = + let forbid = + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + b; + true + with e when CErrors.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 = let open Tacticals.New in @@ -729,9 +711,6 @@ let pf_type c tac = let evars, ty = Typing.type_of env sigma c in tclTHEN (Proofview.Unsafe.tclEVARS evars) (tac ty)) -let pf_type c tac = - Proofview.V82.of_tactic (pf_type c (fun ty -> Proofview.V82.tactic (tac ty))) - let pf_typel l tac = let rec aux tys l = match l with @@ -745,8 +724,8 @@ let pf_typel l tac = modified hypotheses are generalized in the process and should be introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) -let mkDestructEq not_on_hyp expr g = - let hyps = pf_hyps g in +let mkDestructEq not_on_hyp env sigma expr = + let hyps = EConstr.named_context env in let to_revert = Util.List.map_filter (fun decl -> @@ -754,173 +733,169 @@ let mkDestructEq not_on_hyp expr g = let id = get_id decl in if Id.List.mem id not_on_hyp - || not (Termops.dependent (project g) expr (get_type decl)) + || not (Termops.dependent sigma expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let g, type_of_expr = tac_type_of g expr in + let sigma, type_of_expr = Typing.type_of env sigma expr in let new_hyps = mkApp (Lazy.force refl_equal, [|type_of_expr; expr|]) :: to_revert_constr in let tac = pf_typel new_hyps (fun _ -> - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") - [ Proofview.V82.of_tactic (generalize new_hyps) - ; (fun g2 -> - let changefun patvars env sigma = - pattern_occs - [(Locus.AllOccurrencesBut [1], expr)] - (pf_env g2) sigma (pf_concl g2) - in - Proofview.V82.of_tactic - (change_in_concl ~check:true None changefun) - g2) - ; Proofview.V82.of_tactic (simplest_case expr) ]) + [ generalize new_hyps + ; Proofview.Goal.enter (fun g2 -> + let changefun patvars env sigma = + pattern_occs + [(Locus.AllOccurrencesBut [1], expr)] + (Proofview.Goal.env g2) sigma (Proofview.Goal.concl g2) + in + change_in_concl ~check:true None changefun) + ; simplest_case expr ]) in - (g, tac, to_revert) + (sigma, tac, to_revert) let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos - g = - let sigma = project g in - let env = pf_env g in - let f_is_present = - try - check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) a; - false - with e when CErrors.noncritical e -> true - in - let a' = infos.info in - let new_info = - { infos with - info = mkCase (ci, t, iv, a', l) - ; is_main_branch = expr_info.is_main_branch - ; is_final = expr_info.is_final } - in - let g, 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 - (fun _ _ -> - str "treating cases (" - ++ int (Array.length l) - ++ str ")" ++ spc () - ++ Printer.pr_leconstr_env (pf_env g) sigma a') - ( try - tclTHENS destruct_tac - (List.map_i - (fun i e -> - observe_tac - (fun _ _ -> str "do treat case") - (treat_case f_is_present to_thin_intro - (next_step continuation_tac) - ci.ci_cstr_ndecls.(i) e new_info)) - 0 (Array.to_list l)) - with - | UserError (Some "Refiner.thensn_tac3", _) - |UserError (Some "Refiner.tclFAIL_s", _) - -> - observe_tac - (fun _ _ -> - str "is computable " - ++ Printer.pr_leconstr_env env sigma new_info.info) - (next_step continuation_tac - { new_info with - info = - Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info }) - ) - g - -let terminate_app_rec (f, args) expr_info continuation_tac _ g = - let sigma = project g in - let env = pf_env g in - List.iter - (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) - args; - try - let v = - List.assoc_f - (List.equal (EConstr.eq_constr sigma)) - args expr_info.args_assoc - in - let new_infos = {expr_info with info = v} in - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec") - [ continuation_tac new_infos - ; ( if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec1") - [ observe_tac - (fun _ _ -> str "first split") - (Proofview.V82.of_tactic - (split (ImplicitBindings [new_infos.info]))) - ; observe_tac - (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) ] - else tclIDTAC ) ] - g - with Not_found -> - observe_tac - (fun _ _ -> str "terminate_app_rec not found") - (tclTHENS - (Proofview.V82.of_tactic - (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) - [ observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec2") - [ Proofview.V82.of_tactic - (intro_using_then rec_res_id - (* refreshed name gotten from onNthHypId *) - (fun _ -> Proofview.tclUNIT ())) - ; 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 - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec3") - [ continuation_tac new_infos - ; ( if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec4") - [ observe_tac - (fun _ _ -> str "first split") - (Proofview.V82.of_tactic - (split - (ImplicitBindings [new_infos.info]))) - ; observe_tac - (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) ] - else tclIDTAC ) ])) ] - ; observe_tac - (fun _ _ -> str "proving decreasing") - (tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ observe_tac - (fun _ _ -> str "assumption") - (Proofview.V82.of_tactic assumption) - ; observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec5") - [ tclTRY - (list_rewrite true - (List.map (fun e -> (mkVar e, true)) expr_info.eqs)) - ; Proofview.V82.of_tactic - @@ 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) )) - ] ]) ]) - g + = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + let f_is_present = + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + a; + false + with e when CErrors.noncritical e -> true + in + let a' = infos.info in + let new_info = + { infos with + info = mkCase (ci, t, iv, a', l) + ; is_main_branch = expr_info.is_main_branch + ; is_final = expr_info.is_final } + in + let sigma, destruct_tac, rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] env sigma a' + in + let to_thin_intro = List.rev rev_to_thin_intro in + New.observe_tac + (fun _ _ -> + str "treating cases (" + ++ int (Array.length l) + ++ str ")" ++ spc () + ++ Printer.pr_leconstr_env env sigma a') + ( try + tclTHENS destruct_tac + (List.map_i + (fun i e -> + New.observe_tac + (fun _ _ -> str "do treat case") + (treat_case f_is_present to_thin_intro + (next_step continuation_tac) + ci.ci_cstr_ndecls.(i) e new_info)) + 0 (Array.to_list l)) + with + | UserError (Some "Refiner.thensn_tac3", _) + |UserError (Some "Refiner.tclFAIL_s", _) + -> + New.observe_tac + (fun _ _ -> + str "is computable " + ++ Printer.pr_leconstr_env env sigma new_info.info) + (next_step continuation_tac + { new_info with + info = Reductionops.nf_betaiotazeta env sigma new_info.info + }) )) + +let terminate_app_rec (f, args) expr_info continuation_tac _ = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + List.iter + (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) + args; + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch then + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec1") + [ New.observe_tac + (fun _ _ -> str "first split") + (split (ImplicitBindings [new_infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds (3)") + (destruct_bounds new_infos) ] + else Proofview.tclUNIT () ) ] + with Not_found -> + New.observe_tac + (fun _ _ -> str "terminate_app_rec not found") + (tclTHENS + (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args))) + [ New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec2") + [ intro_using_then rec_res_id + (* refreshed name gotten from onNthHypId *) + (fun _ -> Proofview.tclUNIT ()) + ; 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 + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec3") + [ continuation_tac new_infos + ; ( if + expr_info.is_final && expr_info.is_main_branch + then + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec4") + [ New.observe_tac + (fun _ _ -> str "first split") + (split + (ImplicitBindings [new_infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds (2)") + (destruct_bounds new_infos) ] + else Proofview.tclUNIT () ) ])) ] + ; New.observe_tac + (fun _ _ -> str "proving decreasing") + (tclTHENS (* proof of args < formal args *) + (apply (Lazy.force expr_info.acc_inv)) + [ New.observe_tac (fun _ _ -> str "assumption") assumption + ; New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec5") + [ 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) )) + ] ]) ])) let terminate_info = { message = "prove_terminate with term " @@ -936,194 +911,197 @@ let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step case expr_info continuation_tac infos = - observe_tac + New.observe_tac (fun _ _ -> str "equation case") (terminate_case next_step case expr_info continuation_tac infos) -let rec prove_le g = - let sigma = project g in - let x, z = - let _, args = decompose_app sigma (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 c = - match EConstr.kind sigma c with - | App (c, [|x0; _|]) -> - EConstr.isVar sigma x0 - && Id.equal (destVar sigma x0) (destVar sigma x) - && EConstr.isRefX sigma (le ()) c - | _ -> false - in - let h, t = - List.find (fun (_, t) -> matching_fun t) (pf_hyps_types g) - in - let h = h.binder_name in - let y = - let _, args = decompose_app sigma t in - List.hd (List.tl args) - in - observe_tclTHENLIST - (fun _ _ -> str "prove_le") - [ Proofview.V82.of_tactic - (apply (mkApp (le_trans (), [|x; y; z; mkVar h|]))) - ; observe_tac (fun _ _ -> str "prove_le (rec)") prove_le ] - with Not_found -> tclFAIL 0 (mt ()) - end ] - g +let rec prove_le () = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let x, z = + let _, args = decompose_app sigma (Proofview.Goal.concl g) in + (List.hd args, List.hd (List.tl args)) + in + tclFIRST + [ assumption + ; apply (delayed_force le_n) + ; begin + try + let matching_fun c = + match EConstr.kind sigma c with + | App (c, [|x0; _|]) -> + EConstr.isVar sigma x0 + && Id.equal (destVar sigma x0) (destVar sigma x) + && EConstr.isRefX sigma (le ()) c + | _ -> false + in + let h, t = + List.find + (fun (_, t) -> matching_fun t) + (Tacmach.New.pf_hyps_types g) + in + let y = + let _, args = decompose_app sigma t in + List.hd (List.tl args) + in + New.observe_tclTHENLIST + (fun _ _ -> str "prove_le") + [ apply (mkApp (le_trans (), [|x; y; z; mkVar h|])) + ; New.observe_tac + (fun _ _ -> str "prove_le (rec)") + (prove_le ()) ] + with Not_found -> Tacticals.New.tclFAIL 0 (mt ()) + end ]) let rec make_rewrite_list expr_info max = function - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | (_, p, hp) :: l -> - observe_tac + let open Tacticals.New in + New.observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS - (observe_tac + (New.observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p) - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k, def = - let k_na, _, t = destProd sigma t_eq in - let _, _, t = destProd sigma t in - let def_na, _, _ = destProd sigma t in - ( Nameops.Name.get_id k_na.binder_name - , Nameops.Name.get_id def_na.binder_name ) - in - Proofview.V82.of_tactic - (general_rewrite_bindings false Locus.AllOccurrences true + (Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true ( mkVar hp , ExplicitBindings [ CAst.make @@ (NamedHyp def, expr_info.f_constr) ; CAst.make @@ (NamedHyp k, f_S max) ] ) - false) - g)) + false))) [ make_rewrite_list expr_info max l - ; observe_tclTHENLIST + ; New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list") [ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)) - ; observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ]) + apply (delayed_force le_lt_n_Sm) + ; New.observe_tac (fun _ _ -> str "prove_le(2)") (prove_le ()) ] ]) let make_rewrite expr_info l hp max = + let open Tacticals.New in tclTHENFIRST - (observe_tac + (New.observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac + (New.observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k, def = - let k_na, _, t = destProd sigma t_eq in - let _, _, t = destProd sigma t in - let def_na, _, _ = destProd sigma t in - ( Nameops.Name.get_id k_na.binder_name - , Nameops.Name.get_id def_na.binder_name ) - in - observe_tac - (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic + (Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + New.observe_tac + (fun _ _ -> str "general_rewrite_bindings") (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true ( mkVar hp , ExplicitBindings [ CAst.make @@ (NamedHyp def, expr_info.f_constr) ; CAst.make @@ (NamedHyp k, f_S (f_S max)) ] ) - false)) - g) - [ observe_tac + false))) + [ New.observe_tac (fun _ _ -> str "make_rewrite finalize") ((* tclORELSE( h_reflexivity) *) - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite") - [ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl) - ; observe_tac + [ simpl_iter Locusops.onConcl + ; New.observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.OnlyOccurrences [1] - , evaluable_of_global_reference expr_info.func ) ])) + (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 + ; New.observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) ]) - ; observe_tclTHENLIST + intros_reflexivity ]) + ; New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite1") [ (* x < S (S max) proof *) - Proofview.V82.of_tactic - (apply (EConstr.of_constr (delayed_force le_lt_SS))) - ; observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ])) + apply (EConstr.of_constr (delayed_force le_lt_SS)) + ; New.observe_tac (fun _ _ -> str "prove_le (3)") (prove_le ()) ] + ])) let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_, p, _) :: l -> - observe_tclTHENLIST + let open Tacticals.New in + New.observe_tclTHENLIST (fun _ _ -> str "compute_max") - [ Proofview.V82.of_tactic - (simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|]))) - ; tclDO 3 (Proofview.V82.of_tactic intro) + [ simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|])) + ; tclDO 3 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 = + let open Tacticals.New in match l with | [] -> ( match List.rev acc with - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | (_, p, hp) :: tl -> - observe_tac + New.observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) ) | (v, hex) :: l -> - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "destruct_hex") - [ Proofview.V82.of_tactic (simplest_case (mkVar hex)) - ; Proofview.V82.of_tactic (clear [hex]) - ; tclDO 2 (Proofview.V82.of_tactic intro) + [ simplest_case (mkVar hex) + ; clear [hex] + ; tclDO 2 intro ; onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> - observe_tac + New.observe_tac (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) (destruct_hex expr_info ((v, p, hp) :: acc) l))) ] let rec intros_values_eq expr_info acc = + let open Tacticals.New in tclORELSE - (observe_tclTHENLIST + (New.observe_tclTHENLIST (fun _ _ -> str "intros_values_eq") - [ tclDO 2 (Proofview.V82.of_tactic intro) + [ tclDO 2 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 = + let open Tacticals.New in if expr_info.is_final && expr_info.is_main_branch then - observe_tac + New.observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac + (New.observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) else - observe_tac + New.observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) @@ -1131,47 +1109,46 @@ let equation_others _ expr_info 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 - observe_tac + New.observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []) else continuation_tac infos -let equation_app_rec (f, args) expr_info continuation_tac info g = - let sigma = project g in - try - let v = - List.assoc_f - (List.equal (EConstr.eq_constr sigma)) - args expr_info.args_assoc - in - let new_infos = {expr_info with info = v} in - observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g - with Not_found -> - if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST - (fun _ _ -> str "equation_app_rec") - [ 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 - (fun _ _ -> str "app_rec intros_values_eq") - (intros_values_eq expr_info []) ] - g - else - observe_tclTHENLIST - (fun _ _ -> str "equation_app_rec1") - [ Proofview.V82.of_tactic - (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) - ; observe_tac - (fun _ _ -> str "app_rec not_found") - (continuation_tac - { expr_info with - args_assoc = - (args, delayed_force coq_O) :: expr_info.args_assoc }) ] - g +let equation_app_rec (f, args) expr_info continuation_tac info = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + New.observe_tac + (fun _ _ -> str "app_rec found") + (continuation_tac new_infos) + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch then + New.observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec") + [ 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 } + ; New.observe_tac + (fun _ _ -> str "app_rec intros_values_eq") + (intros_values_eq expr_info []) ] + else + New.observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec1") + [ simplest_case (mkApp (expr_info.f_terminate, Array.of_list args)) + ; New.observe_tac + (fun _ _ -> str "app_rec not_found") + (continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc }) ]) let equation_info = { message = "prove_equation with term " @@ -1231,73 +1208,68 @@ let compute_terminate_type nb_args func = compose_prod rev_args value let termination_proof_header is_mes input_type ids args_id relation rec_arg_num - rec_arg_id tac wf_tac : tactic = - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in - let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) - (wf_thm :: ids) - in - let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) in - let acc_inv = - lazy - (mkApp - (delayed_force acc_inv_id, [|input_type; relation; mkVar rec_arg_id|])) - in - tclTHEN (h_intros args_id) - (tclTHENS - (observe_tac - (fun _ _ -> 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 - (fun _ _ -> 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 - (fun _ _ -> str "wf_tac") - (wf_tac is_mes (Some args_id)) - ; (* this gives the accessibility argument *) - observe_tac - (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic - (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|])))) - ] - ; (* rest of the proof *) - observe_tclTHENLIST - (fun _ _ -> str "rest of proof") - [ observe_tac - (fun _ _ -> str "generalize") - (onNLastHypsId (nargs + 1) - (tclMAP (fun id -> - tclTHEN - (Proofview.V82.of_tactic - (Tactics.generalize [mkVar id])) - (Proofview.V82.of_tactic (clear [id]))))) - ; observe_tac - (fun _ _ -> str "fix") - (Proofview.V82.of_tactic (fix hrec (nargs + 1))) - ; h_intros args_id - ; Proofview.V82.of_tactic (Simple.intro wf_rec_arg) - ; observe_tac - (fun _ _ -> str "tac") - (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ]) - g + rec_arg_id tac wf_tac : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in + let wf_rec_arg = + next_ident_away_in_goal + (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) + (wf_thm :: ids) + in + let hrec = + next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + tclTHEN (h_intros args_id) + (tclTHENS + (New.observe_tac + (fun _ _ -> str "first assert") + (assert_before (Name wf_rec_arg) + (mkApp + ( delayed_force acc_rel + , [|input_type; relation; mkVar rec_arg_id|] )))) + [ (* accesibility proof *) + tclTHENS + (New.observe_tac + (fun _ _ -> str "second assert") + (assert_before (Name wf_thm) + (mkApp + (delayed_force well_founded, [|input_type; relation|])))) + [ (* interactive proof that the relation is well_founded *) + New.observe_tac + (fun _ _ -> str "wf_tac") + (wf_tac is_mes (Some args_id)) + ; (* this gives the accessibility argument *) + New.observe_tac + (fun _ _ -> str "apply wf_thm") + (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|]))) + ] + ; (* rest of the proof *) + New.observe_tclTHENLIST + (fun _ _ -> str "rest of proof") + [ New.observe_tac + (fun _ _ -> str "generalize") + (onNLastHypsId (nargs + 1) + (tclMAP (fun id -> + tclTHEN (Tactics.generalize [mkVar id]) (clear [id])))) + ; New.observe_tac (fun _ _ -> str "fix") (fix hrec (nargs + 1)) + ; h_intros args_id + ; Simple.intro wf_rec_arg + ; New.observe_tac + (fun _ _ -> str "tac") + (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ])) let rec instantiate_lambda sigma t l = match l with @@ -1307,62 +1279,61 @@ let rec instantiate_lambda sigma t l = instantiate_lambda sigma (subst1 a body) l let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : - tactic = - fun g -> - let sigma = project g in - let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = def_of_const (constr_of_monomorphic_global func) in - let func_body = EConstr.of_constr func_body in - let f_name, _, body1 = destLambda sigma func_body in - let f_id = - match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") - in - let n_names_types, _ = decompose_lam_n sigma nb_args body1 in - let n_ids, ids = - List.fold_left - (fun (n_ids, ids) (n_name, _) -> - match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - (n_id :: n_ids, n_id :: ids) - | _ -> anomaly (Pp.str "anonymous argument.")) - ([], f_id :: ids) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = - instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) - in - termination_proof_header is_mes input_type ids n_ids relation rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_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 - ; rec_arg_id - ; is_mes - ; ih = hrec - ; f_id - ; f_constr = mkVar f_id - ; func - ; info = expr - ; acc_inv - ; acc_id - ; values_and_bounds = [] - ; eqs = [] - ; forbidden_ids = [] - ; args_assoc = [] }) - g) - (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) - g + unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let hyps = Proofview.Goal.hyps g in + let ids = Termops.ids_of_named_context hyps in + let func_body = def_of_const (constr_of_monomorphic_global func) in + let func_body = EConstr.of_constr func_body in + let f_name, _, body1 = destLambda sigma func_body in + let f_id = + match f_name.binder_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") + in + let n_names_types, _ = decompose_lam_n sigma nb_args body1 in + let n_ids, ids = + List.fold_left + (fun (n_ids, ids) (n_name, _) -> + match n_name.binder_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + (n_id :: n_ids, n_id :: ids) + | _ -> anomaly (Pp.str "anonymous argument.")) + ([], f_id :: ids) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = + instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) + in + termination_proof_header is_mes input_type ids n_ids relation rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv -> + prove_terminate + (fun infos -> Proofview.tclUNIT ()) + { 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 + ; rec_arg_id + ; is_mes + ; ih = hrec + ; f_id + ; f_constr = mkVar f_id + ; func + ; info = expr + ; acc_inv + ; acc_id + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; args_assoc = [] }) + (fun b ids -> tclUSER_if_not_mes concl_tac b ids)) let get_current_subgoals_types pstate = let p = Declare.Proof.get pstate in @@ -1397,9 +1368,7 @@ let build_and_l sigma l = let c, tac, nb = f pl in ( mk_and p1 c , tclTHENS - (Proofview.V82.of_tactic - (apply - (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) + (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr))) [tclIDTAC; tac] , nb + 1 ) in @@ -1521,29 +1490,23 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name let lemma = Declare.Proof.start ~cinfo ~info sigma in let lemma = if Indfun_common.is_strict_tcc () then - fst @@ Declare.Proof.by (Proofview.V82.tactic tclIDTAC) lemma + fst @@ Declare.Proof.by tclIDTAC lemma else fst @@ Declare.Proof.by - (Proofview.V82.tactic (fun g -> - tclTHEN decompose_and_tac - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic - (Tacticals.New.tclTHENLIST - [ intros - ; Simple.apply - (fst - (interp_constr (Global.env ()) - Evd.empty c)) - (*FIXME*) - ; Tacticals.New.tclCOMPLETE Auto.default_auto - ])) - using_lemmas)) - tclIDTAC) - g)) + (tclTHEN decompose_and_tac + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Tacticals.New.tclTHENLIST + [ intros + ; Simple.apply + (fst (interp_constr (Global.env ()) Evd.empty c)) + (*FIXME*) + ; Tacticals.New.tclCOMPLETE Auto.default_auto ]) + using_lemmas)) + tclIDTAC)) lemma in if Declare.Proof.get_open_goals lemma = 0 then (defined lemma; None) @@ -1568,11 +1531,10 @@ let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes in fst @@ Declare.Proof.by - (Proofview.V82.tactic - (observe_tac - (fun _ _ -> str "whole_start") - (whole_start tac_end nb_args is_mes fonctional_ref input_type - relation rec_arg_num))) + (New.observe_tac + (fun _ _ -> str "whole_start") + (whole_start tac_end nb_args is_mes fonctional_ref input_type + relation rec_arg_num)) lemma in let lemma = @@ -1591,31 +1553,28 @@ let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes if interactive_proof then Some lemma else (defined lemma; None) let start_equation (f : GlobRef.t) (term_f : GlobRef.t) - (cont_tactic : Id.t list -> tactic) g = - let sigma = project g in - let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_monomorphic_global term_f in - let terminate_constr = EConstr.of_constr terminate_constr in - let nargs = - nb_prod (project g) - (EConstr.of_constr (type_of_const sigma terminate_constr)) - in - let x = n_x_id ids nargs in - observe_tac - (fun _ _ -> str "start_equation") - (observe_tclTHENLIST - (fun _ _ -> str "start_equation") - [ h_intros x - ; Proofview.V82.of_tactic - (unfold_in_concl - [(Locus.AllOccurrences, evaluable_of_global_reference f)]) - ; observe_tac - (fun _ _ -> str "simplest_case") - (Proofview.V82.of_tactic - (simplest_case - (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))) - ; observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ]) - g + (cont_tactic : Id.t list -> unit Proofview.tactic) = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let ids = Tacmach.New.pf_ids_of_hyps g in + let terminate_constr = constr_of_monomorphic_global term_f in + let terminate_constr = EConstr.of_constr terminate_constr in + let nargs = + nb_prod sigma (EConstr.of_constr (type_of_const sigma terminate_constr)) + in + let x = n_x_id ids nargs in + New.observe_tac + (fun _ _ -> str "start_equation") + (New.observe_tclTHENLIST + (fun _ _ -> str "start_equation") + [ h_intros x + ; unfold_in_concl + [(Locus.AllOccurrences, evaluable_of_global_reference f)] + ; New.observe_tac + (fun _ _ -> str "simplest_case") + (simplest_case + (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))) + ; New.observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ])) let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = @@ -1638,35 +1597,34 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref let lemma = fst @@ Declare.Proof.by - (Proofview.V82.tactic - (start_equation f_ref terminate_ref (fun x -> - prove_eq - (fun _ -> tclIDTAC) - { nb_arg - ; f_terminate = - EConstr.of_constr - (constr_of_monomorphic_global terminate_ref) - ; f_constr = EConstr.of_constr f_constr - ; concl_tac = Tacticals.New.tclIDTAC - ; func = functional_ref - ; info = - instantiate_lambda Evd.empty - (EConstr.of_constr - (def_of_const - (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr 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 "______" }))) + (start_equation f_ref terminate_ref (fun x -> + prove_eq + (fun _ -> Proofview.tclUNIT ()) + { nb_arg + ; f_terminate = + EConstr.of_constr + (constr_of_monomorphic_global terminate_ref) + ; f_constr = EConstr.of_constr f_constr + ; concl_tac = Tacticals.New.tclIDTAC + ; func = functional_ref + ; info = + instantiate_lambda Evd.empty + (EConstr.of_constr + (def_of_const + (constr_of_monomorphic_global functional_ref))) + (EConstr.of_constr 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 "______" })) lemma in let _ = diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index a1dbf9a439..8de6cbc0a6 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -181,7 +181,7 @@ end) = struct fun env sigma -> class_info env sigma (Lazy.force r) let proper_proj env sigma = - mkConst (Option.get (pi3 (List.hd (proper_class env sigma).cl_projs))) + mkConst (Option.get (List.hd (proper_class env sigma).cl_projs).meth_const) let proper_type env (sigma,cstrs) = let l = (proper_class env sigma).cl_impl in diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index f3021f4ee6..c24bafc761 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -127,14 +127,14 @@ let mul = function let gen_constant n = lazy (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n)) -let tpexpr = gen_constant "plugins.setoid_ring.pexpr" -let ttconst = gen_constant "plugins.setoid_ring.const" -let ttvar = gen_constant "plugins.setoid_ring.var" -let ttadd = gen_constant "plugins.setoid_ring.add" -let ttsub = gen_constant "plugins.setoid_ring.sub" -let ttmul = gen_constant "plugins.setoid_ring.mul" -let ttopp = gen_constant "plugins.setoid_ring.opp" -let ttpow = gen_constant "plugins.setoid_ring.pow" +let tpexpr = gen_constant "plugins.ring.pexpr" +let ttconst = gen_constant "plugins.ring.const" +let ttvar = gen_constant "plugins.ring.var" +let ttadd = gen_constant "plugins.ring.add" +let ttsub = gen_constant "plugins.ring.sub" +let ttmul = gen_constant "plugins.ring.mul" +let ttopp = gen_constant "plugins.ring.opp" +let ttpow = gen_constant "plugins.ring.pow" let tlist = gen_constant "core.list.type" let lnil = gen_constant "core.list.nil" diff --git a/plugins/ring/dune b/plugins/ring/dune new file mode 100644 index 0000000000..080d8c672e --- /dev/null +++ b/plugins/ring/dune @@ -0,0 +1,7 @@ +(library + (name ring_plugin) + (public_name coq.plugins.ring) + (synopsis "Coq's ring plugin") + (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ring)) diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/ring/g_ring.mlg index eb7710bbc2..3c800987ac 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/ring/g_ring.mlg @@ -13,8 +13,8 @@ open Ltac_plugin open Pp open Util -open Newring_ast -open Newring +open Ring_ast +open Ring open Stdarg open Tacarg open Pcoq.Constr @@ -22,7 +22,7 @@ open Pltac } -DECLARE PLUGIN "newring_plugin" +DECLARE PLUGIN "ring_plugin" TACTIC EXTEND protect_fv | [ "protect_fv" string(map) "in" ident(id) ] -> diff --git a/plugins/setoid_ring/newring.ml b/plugins/ring/ring.ml index 5f5a974b6a..9c75175889 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/ring/ring.ml @@ -28,7 +28,7 @@ open Libobject open Printer open Declare open Entries -open Newring_ast +open Ring_ast open Proofview.Notations let error msg = CErrors.user_err Pp.(str msg) @@ -115,7 +115,7 @@ let closed_term args _ = match args with let closed_term_ast = let tacname = { - mltac_plugin = "newring_plugin"; + mltac_plugin = "ring_plugin"; mltac_tactic = "closed_term"; } in let () = Tacenv.register_ml_tactic tacname [|closed_term|] in @@ -178,7 +178,7 @@ let tactic_res = ref [||] let get_res = let open Tacexpr in - let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in + let name = { mltac_plugin = "ring_plugin"; mltac_tactic = "get_res"; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac args ist = let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in @@ -212,7 +212,7 @@ let exec_tactic env evd n f args = let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n))) let gen_reference n = lazy (Coqlib.lib_ref n) -let coq_mk_Setoid = gen_constant "plugins.setoid_ring.Build_Setoid_Theory" +let coq_mk_Setoid = gen_constant "plugins.ring.Build_Setoid_Theory" let coq_None = gen_reference "core.option.None" let coq_Some = gen_reference "core.option.Some" let coq_eq = gen_constant "core.eq.type" @@ -265,7 +265,7 @@ let znew_ring_path = let zltac s = lazy(KerName.make (ModPath.MPfile znew_ring_path) (Label.make s)) -let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s) [@@ocaml.warning "-3"] +let mk_cst l s = lazy (Coqlib.coq_reference "ring" l s) [@@ocaml.warning "-3"] let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s (* Ring theory *) diff --git a/plugins/setoid_ring/newring.mli b/plugins/ring/ring.mli index 73d6d91434..6d24ae84d7 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/ring/ring.mli @@ -11,7 +11,7 @@ open Names open EConstr open Constrexpr -open Newring_ast +open Ring_ast val protect_tac_in : string -> Id.t -> unit Proofview.tactic diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/ring/ring_ast.ml index 8b82783db9..8b82783db9 100644 --- a/plugins/setoid_ring/newring_ast.ml +++ b/plugins/ring/ring_ast.ml diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/ring/ring_ast.mli index 8b82783db9..8b82783db9 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/ring/ring_ast.mli diff --git a/plugins/ring/ring_plugin.mlpack b/plugins/ring/ring_plugin.mlpack new file mode 100644 index 0000000000..91d7199f9b --- /dev/null +++ b/plugins/ring/ring_plugin.mlpack @@ -0,0 +1,3 @@ +Ring_ast +Ring +G_ring diff --git a/plugins/setoid_ring/dune b/plugins/setoid_ring/dune deleted file mode 100644 index 60522cd3f5..0000000000 --- a/plugins/setoid_ring/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name newring_plugin) - (public_name coq.plugins.setoid_ring) - (synopsis "Coq's setoid ring plugin") - (libraries coq.plugins.ltac)) - -(coq.pp (modules g_newring)) diff --git a/plugins/setoid_ring/newring_plugin.mlpack b/plugins/setoid_ring/newring_plugin.mlpack deleted file mode 100644 index 5aa79b5868..0000000000 --- a/plugins/setoid_ring/newring_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Newring_ast -Newring -G_newring diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4d5715a391..715b80f428 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1196,8 +1196,8 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = let filter_compatible_candidates unify flags env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match unify flags TermUnification env evd Reduction.CONV rhs c' with - | Success evd -> Some (c,evd) - | UnifFailure _ -> None + | Success evd -> Inl (c,evd) + | UnifFailure _ -> Inr c' (* [restrict_candidates ... filter ev1 ev2] restricts the candidates of ev1, removing those not compatible with the filter, as well as @@ -1218,8 +1218,8 @@ let restrict_candidates unify flags env evd filter1 (evk1,argsv1) (evk2,argsv2) let filter c2 = let compatibility = filter_compatible_candidates unify flags env evd evi2 argsv2 c1' c2 in match compatibility with - | None -> false - | Some _ -> true + | Inl _ -> true + | Inr _ -> false in let filtered = List.filter filter l2 in match filtered with [] -> false | _ -> true) l1 in @@ -1440,29 +1440,33 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = in advance, we check which of them apply *) exception NoCandidates -exception IncompatibleCandidates +exception IncompatibleCandidates of EConstr.t let solve_candidates unify flags env evd (evk,argsv) rhs = let evi = Evd.find evd evk in match evi.evar_candidates with | None -> raise NoCandidates | Some l -> - let l' = - List.map_filter - (fun c -> filter_compatible_candidates unify flags env evd evi argsv rhs c) l in - match l' with - | [] -> raise IncompatibleCandidates - | [c,evd] -> + let rec aux = function + | [] -> [], [] + | c::l -> + let compatl, disjointl = aux l in + match filter_compatible_candidates unify flags env evd evi argsv rhs c with + | Inl c -> c::compatl, disjointl + | Inr c -> compatl, c::disjointl in + match aux l with + | [], c::_ -> raise (IncompatibleCandidates c) + | [c,evd], _ -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in check_evar_instance unify flags env evd' evk c else evd - | l when List.length l < List.length l' -> + | l, _::_ (* At least one discarded candidate *) -> let candidates = List.map fst l in restrict_evar evd evk None (UpdateWith candidates) - | l -> evd + | l, [] -> evd let occur_evar_upto_types sigma n c = let c = EConstr.Unsafe.to_constr c in @@ -1794,6 +1798,6 @@ let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true) UnifFailure (evd,MetaOccurInBody evk1) | IllTypedInstance (env,t,u) -> UnifFailure (evd,InstanceNotSameType (evk1,env,t,u)) - | IncompatibleCandidates -> - UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2)) + | IncompatibleCandidates t -> + UnifFailure (evd,IncompatibleInstances (env,ev1,t,t2)) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 207ffc7b86..1e8441dd8a 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -20,6 +20,7 @@ type unification_error = | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr (* Non convertible closed terms *) + | IncompatibleInstances of env * existential * constr * constr | MetaOccurInBody of Evar.t | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 70f218d617..45997e9a66 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -23,6 +23,7 @@ type unification_error = | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr + | IncompatibleInstances of env * existential * constr * constr | MetaOccurInBody of Evar.t | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index adb9c5299f..fc71254a46 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -11,7 +11,6 @@ (*i*) open Names open Globnames -open Term open Constr open Vars open Evd @@ -42,7 +41,11 @@ let get_solve_one_instance, solve_one_instance_hook = Hook.make () let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t = Hook.get get_solve_one_instance env evm t unique -type direction = Forward | Backward +type class_method = { + meth_name : Name.t; + meth_info : hint_info option; + meth_const : Constant.t option; +} (* This module defines type-classes *) type typeclass = { @@ -59,8 +62,7 @@ type typeclass = { cl_props : Constr.rel_context; (* The method implementations as projections. *) - cl_projs : (Name.t * (direction * hint_info) option - * Constant.t option) list; + cl_projs : class_method list; cl_strict : bool; @@ -156,66 +158,6 @@ let load_class cl = (** Build the subinstances hints. *) -let check_instance env sigma c = - try - let (evd, c) = resolve_one_typeclass env sigma - (Retyping.get_type_of env sigma c) in - not (Evd.has_undefined evd) - with e when CErrors.noncritical e -> false - -let build_subclasses ~check env sigma glob { hint_priority = pri } = - let _id = Nametab.basename_of_global glob in - let _next_id = - let i = ref (-1) in - (fun () -> incr i; - Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) - in - let ty, ctx = Typeops.type_of_global_in_context env glob in - let inst, ctx = UnivGen.fresh_instance_from ctx None in - let ty = Vars.subst_instance_constr inst ty in - let ty = EConstr.of_constr ty in - let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in - let rec aux pri c ty path = - match class_of_constr env sigma ty with - | None -> [] - | Some (rels, ((tc,u), args)) -> - let instapp = - Reductionops.whd_beta env sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) - in - let instapp = EConstr.Unsafe.to_constr instapp in - let projargs = Array.of_list (args @ [instapp]) in - let projs = List.map_filter - (fun (n, b, proj) -> - match b with - | None -> None - | Some (Backward, _) -> None - | Some (Forward, info) -> - let proj = Option.get proj in - let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in - let u = EConstr.EInstance.kind sigma u in - let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in - if check && check_instance env sigma (EConstr.of_constr body) then None - else - let newpri = - match pri, info.hint_priority with - | Some p, Some p' -> Some (p + p') - | Some p, None -> Some (p + 1) - | _, _ -> None - in - Some (GlobRef.ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs - in - let declare_proj hints (cref, info, body) = - let path' = cref :: path in - let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in - let rest = aux pri body ty path' in - hints @ (path', info, body) :: rest - in List.fold_left declare_proj [] projs - in - let term = Constr.mkRef (glob, inst) in - (*FIXME subclasses should now get substituted for each particular instance of - the polymorphic superclass *) - aux pri term ty [glob] - (* * interface functions *) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 9de8083276..3f84d08a7e 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -13,8 +13,6 @@ open Constr open Evd open Environ -type direction = Forward | Backward - (* Core typeclasses hints *) type 'a hint_info_gen = { hint_priority : int option; @@ -22,6 +20,12 @@ type 'a hint_info_gen = type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen +type class_method = { + meth_name : Name.t; + meth_info : hint_info option; + meth_const : Constant.t option; +} + (** This module defines type-classes *) type typeclass = { cl_univs : Univ.AUContext.t; @@ -39,7 +43,7 @@ type typeclass = { cl_props : Constr.rel_context; (** Context of definitions and properties on defs, will not be shared *) - cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; + cl_projs : class_method list; (** The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has @@ -127,11 +131,3 @@ val classes_transparent_state : unit -> TransparentState.t val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t - -(** Build the subinstances hints for a given typeclass object. - check tells if we should check for existence of the - subinstances and add only the missing ones. *) - -val build_subclasses : check:bool -> env -> evar_map -> GlobRef.t -> - hint_info -> - (GlobRef.t list * hint_info * constr) list diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index ecdbfa5118..1207e0e599 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -99,7 +99,7 @@ let db_pr_goal sigma g = str" " ++ pc) ++ fnl () let pr_gls gls = - hov 0 (pr_evar_map (Some 2) (pf_env gls) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) + hov 0 (pr_evar_map (Some 2) (pf_env gls) (project gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) (* Variants of [Tacmach] functions built with the new proof engine *) module New = struct @@ -183,6 +183,9 @@ module New = struct let pf_unsafe_type_of gl t = pf_apply (unsafe_type_of[@warning "-3"]) gl t + let pr_gls gl = + hov 0 (pr_evar_map (Some 2) (pf_env gl) (project gl) ++ fnl () ++ db_pr_goal (project gl) (Proofview.Goal.goal gl)) + end (* deprecated *) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index d8f7b7eed8..08f88d46c1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -126,4 +126,5 @@ module New : sig val pf_nf_evar : Proofview.Goal.t -> constr -> constr + val pr_gls : Proofview.Goal.t -> Pp.t end diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index b4d7e7d7f0..ed92a85a12 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -483,17 +483,7 @@ let make_resolve_hyp env sigma st only_classes pri decl = if keep then let id = GlobRef.VarRef id in let name = PathHints [id] in - let hints = - if is_class then - let hints = build_subclasses ~check:false env sigma id empty_hint_info in - (List.map_append - (fun (path,info,c) -> - let h = IsConstr (EConstr.of_constr c, None) [@ocaml.warning "-3"] in - make_resolves env sigma ~name:(PathHints path) info ~check:true h) - hints) - else [] - in - (hints @ make_resolves env sigma pri ~name ~check:false (IsGlobRef id)) + (make_resolves env sigma pri ~name ~check:false (IsGlobRef id)) else [] let make_hints g (modes,st) only_classes sign = diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index c0fad0026f..24aa178ed2 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -797,6 +797,9 @@ module New = struct end let onLastDecl = onNthDecl 1 + let nLastHypsId gl n = List.map (NamedDecl.get_id) (nLastDecls gl n) + let nLastHyps gl n = List.map mkVar (nLastHypsId gl n) + let ifOnHyp pred tac1 tac2 id = Proofview.Goal.enter begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in @@ -808,6 +811,10 @@ module New = struct let onHyps find tac = Proofview.Goal.enter begin fun gl -> tac (find gl) end + let onNLastDecls n tac = onHyps (fun gl -> nLastDecls gl n) tac + let onNLastHypsId n tac = onHyps (fun gl -> nLastHypsId gl n) tac + let onNLastHyps n tac = onHyps (fun gl -> nLastHyps gl n) tac + let afterHyp id tac = Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps gl in @@ -835,6 +842,16 @@ module New = struct tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl) end + let fullGoal gl = None :: List.map Option.make (Tacmach.New.pf_ids_of_hyps gl) + let onAllHyps tac = + Proofview.Goal.enter begin fun gl -> + tclMAP tac (Tacmach.New.pf_ids_of_hyps gl) + end + let onAllHypsAndConcl tac = + Proofview.Goal.enter begin fun gl -> + tclMAP tac (fullGoal gl) + end + let elimination_sort_of_goal gl = (* Retyping will expand evars anyway. *) let c = Proofview.Goal.concl gl in @@ -855,4 +872,11 @@ module New = struct let (sigma, c) = Evd.fresh_global env sigma ref in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT c + let tclTYPEOFTHEN ?refresh c tac = + Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (sigma, t) = Typing.type_of ?refresh env sigma c in + Proofview.Unsafe.tclEVARS sigma <*> tac sigma t) + end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index bfead34b3b..e97c5f3c1f 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -224,6 +224,10 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic + val onNLastHypsId : int -> (Id.t list -> unit tactic) -> unit tactic + val onNLastHyps : int -> (constr list -> unit tactic) -> unit tactic + val onNLastDecls : int -> (named_context -> unit tactic) -> unit tactic + val onHyps : (Proofview.Goal.t -> named_context) -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic @@ -232,9 +236,14 @@ module New : sig val tryAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic val onClause : (Id.t option -> unit tactic) -> clause -> unit tactic + val onAllHyps : (Id.t -> unit tactic) -> unit tactic + val onAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic + val elimination_sort_of_goal : Proofview.Goal.t -> Sorts.family val elimination_sort_of_hyp : Id.t -> Proofview.Goal.t -> Sorts.family val elimination_sort_of_clause : Id.t option -> Proofview.Goal.t -> Sorts.family val pf_constr_of_global : GlobRef.t -> constr Proofview.tactic + + val tclTYPEOFTHEN : ?refresh:bool -> constr -> (evar_map -> types -> unit Proofview.tactic) -> unit Proofview.tactic end diff --git a/test-suite/bugs/closed/bug_13059.v b/test-suite/bugs/closed/bug_13059.v new file mode 100644 index 0000000000..2416e3ad13 --- /dev/null +++ b/test-suite/bugs/closed/bug_13059.v @@ -0,0 +1,31 @@ +Set Uniform Inductive Parameters. +Inductive test (X : Set) : Prop := +with test2 (X : Set) : X -> Prop := + | C (x : X) : test2 x. + +Require Import List. +Import ListNotations. + +Set Suggest Proof Using. +Set Primitive Projections. + + +Section Grammar. +Variable A : Type. + +Record grammar : Type := Grammar { + gm_nonterm :> Type ; + gm_rules :> list (gm_nonterm * list (A + gm_nonterm)) ; +}. + +Set Uniform Inductive Parameters. +Inductive lang (gm : grammar) : gm -> list A -> Prop := +| lang_rule S ps ws : In (S, ps) gm -> lmatch ps ws -> lang S (concat ws) +with lmatch (gm : grammar) : list (A + gm) -> list (list A) -> Prop := +| lmatch_nil : lmatch [] [] +| lmatch_consL ps ws a : lmatch ps ws -> lmatch (inl a :: ps) ([a] :: ws) +| lmatch_consR ps ws S w : + lang S w -> lmatch ps ws -> lmatch (inr S :: ps) (w :: ws) +. + +End Grammar. diff --git a/test-suite/bugs/closed/bug_13109.v b/test-suite/bugs/closed/bug_13109.v new file mode 100644 index 0000000000..76511a44c5 --- /dev/null +++ b/test-suite/bugs/closed/bug_13109.v @@ -0,0 +1,24 @@ +Require Import Coq.Program.Tactics. + +Set Universe Polymorphism. +Obligation Tactic := idtac. + +Program Definition foo : Type := _. +Program Definition bar : Type := _. +Admit Obligations. +(* Error: Anomaly "Uncaught exception AcyclicGraph.Make(Point).AlreadyDeclared." +Please report at http://coq.inria.fr/bugs/. + *) +Print foo. +Print foo_obligation_1. +Print bar. +Print bar_obligation_1. + +Program Definition baz : Type := _. +Admit Obligations of baz. +Print baz. +Print baz_obligation_1. + +Admit Obligations. + +Fail Admit Obligations of nobody. diff --git a/test-suite/bugs/closed/bug_2928.v b/test-suite/bugs/closed/bug_2928.v deleted file mode 100644 index 21e92ae20c..0000000000 --- a/test-suite/bugs/closed/bug_2928.v +++ /dev/null @@ -1,11 +0,0 @@ -Class Equiv A := equiv: A -> A -> Prop. -Infix "=" := equiv : type_scope. - -Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. - -Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. - -Class SemiLattice A op `{Equiv A} := - { semilattice_sg :>> SemiGroup A op - ; redundant : Associative op - }. diff --git a/test-suite/misc/coq_makefile_destination_of.sh b/test-suite/misc/coq_makefile_destination_of.sh new file mode 100755 index 0000000000..fc8e089ccf --- /dev/null +++ b/test-suite/misc/coq_makefile_destination_of.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +TMP=`mktemp -d` +cd $TMP + +function assert_eq() { + if [ "$1" != "$2" ]; then + echo "coq_makefile generates destination" $1 "!=" $2 + cd / + rm -rf $TMP + exit 1 + fi +} + +assert_eq `coq_makefile -destination-of src/Y/Z/Test.v -Q src X` "X//Y/Z" +mkdir src +assert_eq `coq_makefile -destination-of src/Y/Z/Test.v -Q src X` "X//Y/Z" +mkdir -p src/Y/Z +touch src/Y/Z/Test.v +assert_eq `coq_makefile -destination-of src/Y/Z/Test.v -Q src X` "X//Y/Z" +cd / +rm -rf $TMP +exit 0 diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 163ed15606..d8d3f696b7 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -67,9 +67,9 @@ mono The command has indeed failed with message: Universe u already exists. bobmorane = -let tt := Type@{UnivBinders.33} in -let ff := Type@{UnivBinders.35} in tt -> ff - : Type@{max(UnivBinders.32,UnivBinders.34)} +let tt := Type@{UnivBinders.32} in +let ff := Type@{UnivBinders.34} in tt -> ff + : Type@{max(UnivBinders.31,UnivBinders.33)} The command has indeed failed with message: Universe u already bound. foo@{E M N} = diff --git a/test-suite/output/bug_12908.out b/test-suite/output/bug_12908.out new file mode 100644 index 0000000000..fca6dde704 --- /dev/null +++ b/test-suite/output/bug_12908.out @@ -0,0 +1,2 @@ +forall m n : nat, m * n = (2 * m * n)%nat + : Prop diff --git a/test-suite/output/bug_12908.v b/test-suite/output/bug_12908.v new file mode 100644 index 0000000000..558c9f9f6a --- /dev/null +++ b/test-suite/output/bug_12908.v @@ -0,0 +1,6 @@ +Definition mult' m n := 2 * m * n. +Module A. +(* Test hiding of a scoped notation by a lonely notation *) +Infix "*" := mult'. +Check forall m n, mult' m n = Nat.mul (Nat.mul 2 m) n. +End A. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 1db3f87cac..74d1e391c4 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -110,7 +110,7 @@ Section Between. Lemma between_in_int : forall k l, between k l -> forall r, in_int k l r -> P r. Proof. - induction 1; intros. + intro k; induction 1 as [|l]; intros r ?. - absurd (k < k). { auto with arith. } eapply in_int_lt; eassumption. - destruct (in_int_p_Sq k l r) as [| ->]; auto with arith. @@ -125,7 +125,7 @@ Section Between. Lemma exists_in_int : forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. Proof. - induction 1 as [* ? (p, ?, ?)|]. + induction 1 as [* ? (p, ?, ?)|l]. - exists p; auto with arith. - exists l; auto with arith. Qed. @@ -154,7 +154,7 @@ Section Between. between k l -> (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l. Proof. - induction 1; red; intros. + intro k; induction 1 as [|l]; red; intros. - absurd (k < k); auto with arith. - absurd (Q l). { auto with arith. } destruct (exists_in_int k (S l)) as (l',[],?). diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 341dd7de5d..1afc49b7ff 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -21,7 +21,7 @@ Defined. Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}. Proof. - induction n in m |- *; destruct m; auto with arith. + induction n as [|n IHn] in m |- *; destruct m as [|m]; auto with arith. destruct (IHn m) as [H|H]; auto with arith. destruct H; auto with arith. Defined. @@ -33,9 +33,9 @@ Defined. Definition le_lt_dec n m : {n <= m} + {m < n}. Proof. - induction n in m |- *. + induction n as [|n IHn] in m |- *. - left; auto with arith. - - destruct m. + - destruct m as [|m]. + right; auto with arith. + elim (IHn m); [left|right]; auto with arith. Defined. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 62a0f0a0ae..593d8c5934 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -34,7 +34,7 @@ Hint Resolve eq_nat_refl: arith. Theorem eq_nat_is_eq n m : eq_nat n m <-> n = m. Proof. split. - - revert m; induction n; destruct m; simpl; contradiction || auto. + - revert m; induction n; intro m; destruct m; simpl; contradiction || auto. - intros <-; apply eq_nat_refl. Qed. @@ -53,12 +53,12 @@ Hint Immediate eq_eq_nat eq_nat_eq: arith. Theorem eq_nat_elim : forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m. Proof. - intros; replace m with n; auto with arith. + intros n P ? m ?; replace m with n; auto with arith. Qed. Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}. Proof. - induction n; destruct m; simpl. + intro n; induction n as [|n IHn]; intro m; destruct m; simpl. - left; trivial. - right; intro; trivial. - right; intro; trivial. @@ -96,7 +96,7 @@ Qed. Definition beq_nat_eq : forall n m, true = (n =? m) -> n = m. Proof. - induction n; destruct m; simpl. + intro n; induction n as [|n IHn]; intro m; destruct m; simpl. - reflexivity. - discriminate. - discriminate. diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 0871c4af67..f87d7e810a 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -33,7 +33,7 @@ Qed. Lemma fact_le n m : n <= m -> fact n <= fact m. Proof. - induction 1. + induction 1 as [|m ?]. - apply le_n. - simpl. transitivity (fact m). trivial. apply Nat.le_add_r. Qed. diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 4f17a7a8d3..4e71465452 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -80,7 +80,7 @@ Lemma le_elim_rel : (forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) -> forall n m, n <= m -> P n m. Proof. - intros P H0 HS. + intros P H0 HS n. induction n; trivial. intros m Le. elim Le; auto with arith. Qed. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 507d956e81..d7f703e6e4 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -158,7 +158,7 @@ Fixpoint mult_acc (s:nat) m n : nat := Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n. Proof. - induction n as [| n IHn]; simpl; auto. + intro n; induction n as [| n IHn]; simpl; auto. intros. rewrite Nat.add_assoc, IHn. f_equal. rewrite Nat.add_comm. apply plus_tail_plus. Qed. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index 6f5339227a..37704704a0 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -75,7 +75,9 @@ Theorem recursion_succ : Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)). Proof. -unfold Proper, respectful in *; induction n; simpl; auto. +unfold Proper, respectful in *. +intros A Aeq a f ? ? n. +induction n; simpl; auto. Qed. (** ** Remaining constants not defined in Coq.Init.Nat *) @@ -126,7 +128,7 @@ Qed. Lemma sub_succ_r n m : n - (S m) = pred (n - m). Proof. -revert m. induction n; destruct m; simpl; auto. apply sub_0_r. +revert m. induction n; intro m; destruct m; simpl; auto. apply sub_0_r. Qed. Lemma mul_0_l n : 0 * n = 0. @@ -136,9 +138,9 @@ Qed. Lemma mul_succ_l n m : S n * m = n * m + m. Proof. -assert (succ_r : forall x y, x+S y = S(x+y)) by now induction x. +assert (succ_r : forall x y, x+S y = S(x+y)) by now intro x; induction x. assert (comm : forall x y, x+y = y+x). -{ induction x; simpl; auto. intros; rewrite succ_r; now f_equal. } +{ intro x; induction x; simpl; auto. intros; rewrite succ_r; now f_equal. } now rewrite comm. Qed. @@ -152,7 +154,7 @@ Qed. Lemma eqb_eq n m : eqb n m = true <-> n = m. Proof. revert m. - induction n; destruct m; simpl; rewrite ?IHn; split; try easy. + induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn; split; try easy. - now intros ->. - now injection 1. Qed. @@ -160,7 +162,7 @@ Qed. Lemma leb_le n m : (n <=? m) = true <-> n <= m. Proof. revert m. - induction n; destruct m; simpl. + induction n as [|n IHn]; intro m; destruct m; simpl. - now split. - split; trivial. intros; apply Peano.le_0_n. - now split. @@ -178,7 +180,7 @@ Qed. Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}. Proof. - induction n; destruct m. + intro n; induction n as [|n IHn]; intro m; destruct m as [|m]. - now left. - now right. - now right. @@ -193,12 +195,14 @@ Defined. Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m. Proof. - revert m; induction n; destruct m; simpl; rewrite ?IHn; split; auto; easy. + revert m; induction n as [|n IHn]; intro m; destruct m; + simpl; rewrite ?IHn; split; auto; easy. Qed. Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m. Proof. - revert m; induction n; destruct m; simpl; rewrite ?IHn; split; try easy. + revert m; induction n as [|n IHn]; intro m; destruct m; + simpl; rewrite ?IHn; split; try easy. - intros _. apply Peano.le_n_S, Peano.le_0_n. - apply Peano.le_n_S. - apply Peano.le_S_n. @@ -206,7 +210,7 @@ Qed. Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. Proof. - revert m; induction n; destruct m; simpl; rewrite ?IHn. + revert m; induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn. - now split. - split; intros. apply Peano.le_0_n. easy. - split. now destruct 1. inversion 1. @@ -215,7 +219,7 @@ Qed. Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m). Proof. - revert m; induction n; destruct m; simpl; trivial. + revert m; induction n; intro m; destruct m; simpl; trivial. Qed. Lemma compare_succ n m : (S n ?= S m) = (n ?= m). @@ -292,7 +296,7 @@ Lemma Even_2 n : Even n <-> Even (S (S n)). Proof. split; intros (m,H). - exists (S m). rewrite H. simpl. now rewrite plus_n_Sm. - - destruct m; try discriminate. + - destruct m as [|m]; try discriminate. exists m. simpl in H. rewrite <- plus_n_Sm in H. now inversion H. Qed. @@ -305,7 +309,7 @@ Lemma Odd_2 n : Odd n <-> Odd (S (S n)). Proof. split; intros (m,H). - exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m). - - destruct m; try discriminate. + - destruct m as [|m]; try discriminate. exists m. simpl in H. rewrite <- plus_n_Sm in H. inversion H. simpl. now rewrite <- !plus_n_Sm, <- !plus_n_O. Qed. @@ -316,7 +320,7 @@ Import Private_Parity. Lemma even_spec : forall n, even n = true <-> Even n. Proof. fix even_spec 1. - destruct n as [|[|n]]; simpl. + intro n; destruct n as [|[|n]]; simpl. - split; [ now exists 0 | trivial ]. - split; [ discriminate | intro H; elim (Even_1 H) ]. - rewrite even_spec. apply Even_2. @@ -326,7 +330,7 @@ Lemma odd_spec : forall n, odd n = true <-> Odd n. Proof. unfold odd. fix odd_spec 1. - destruct n as [|[|n]]; simpl. + intro n; destruct n as [|[|n]]; simpl. - split; [ discriminate | intro H; elim (Odd_0 H) ]. - split; [ now exists 0 | trivial ]. - rewrite odd_spec. apply Odd_2. @@ -338,9 +342,9 @@ Lemma divmod_spec : forall x y q u, u <= y -> let (q',u') := divmod x y q u in x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y. Proof. - induction x. + intro x; induction x as [|x IHx]. - simpl; intuition. - - intros y q u H. destruct u; simpl divmod. + - intros y q u H. destruct u as [|u]; simpl divmod. + generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u'). intros (EQ,LE); split; trivial. rewrite <- EQ, sub_0_r, sub_diag, add_0_r. @@ -356,7 +360,7 @@ Qed. Lemma div_mod x y : y<>0 -> x = y*(x/y) + x mod y. Proof. intros Hy. - destruct y; [ now elim Hy | clear Hy ]. + destruct y as [|y]; [ now elim Hy | clear Hy ]. unfold div, modulo. generalize (divmod_spec x y 0 y (le_n y)). destruct divmod as (q,u). @@ -380,7 +384,7 @@ Lemma sqrt_iter_spec : forall k p q r, let s := sqrt_iter k p q r in s*s <= k + p*p + (q - r) < (S s)*(S s). Proof. - induction k. + intro k; induction k as [|k IHk]. - (* k = 0 *) simpl; intros p q r Hq Hr. split. @@ -391,7 +395,7 @@ Proof. apply add_le_mono_l. rewrite <- Hq. apply le_sub_l. - (* k = S k' *) - destruct r. + intros p q r; destruct r as [|r]. + (* r = 0 *) intros Hq _. replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). @@ -427,7 +431,7 @@ Lemma log2_iter_spec : forall k p q r, let s := log2_iter k p q r in 2^s <= k + q < 2^(S s). Proof. - induction k. + intro k; induction k as [|k IHk]. - (* k = 0 *) intros p q r EQ LT. simpl log2_iter. cbv zeta. split. @@ -438,7 +442,7 @@ Proof. + rewrite EQ, add_comm. apply add_lt_mono_l. apply lt_succ_r, le_0_l. - (* k = S k' *) - intros p q r EQ LT. destruct r. + intros p q r EQ LT. destruct r as [|r]. + (* r = 0 *) rewrite add_succ_r, add_0_r in EQ. rewrite add_succ_l, <- add_succ_r. apply IHk. @@ -537,7 +541,7 @@ Lemma le_div2 n : div2 (S n) <= n. Proof. revert n. fix le_div2 1. - destruct n; simpl; trivial. apply lt_succ_r. + intro n; destruct n as [|n]; simpl; trivial. apply lt_succ_r. destruct n; [simpl|]; trivial. now constructor. Qed. @@ -550,7 +554,7 @@ Qed. Lemma div2_decr a n : a <= S n -> div2 a <= n. Proof. - destruct a; intros H. + destruct a as [|a]; intros H. - simpl. apply le_0_l. - apply succ_le_mono in H. apply le_trans with a; [ apply le_div2 | trivial ]. @@ -563,7 +567,7 @@ Qed. Lemma testbit_0_l : forall n, testbit 0 n = false. Proof. - now induction n. + now intro n; induction n. Qed. Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. @@ -592,7 +596,7 @@ Qed. Lemma shiftr_specif : forall a n m, testbit (shiftr a n) m = testbit a (m+n). Proof. - induction n; intros m. trivial. + intros a n; induction n as [|n IHn]; intros m. trivial. now rewrite add_0_r. now rewrite add_succ_r, <- add_succ_l, <- IHn. Qed. @@ -600,7 +604,7 @@ Qed. Lemma shiftl_specif_high : forall a n m, n<=m -> testbit (shiftl a n) m = testbit a (m-n). Proof. - induction n; intros m H. trivial. + intros a n; induction n as [|n IHn]; intros m H. trivial. now rewrite sub_0_r. destruct m. inversion H. simpl. apply succ_le_mono in H. @@ -611,7 +615,7 @@ Qed. Lemma shiftl_spec_low : forall a n m, m<n -> testbit (shiftl a n) m = false. Proof. - induction n; intros m H. inversion H. + intros a n; induction n as [|n IHn]; intros m H. inversion H. change (shiftl a (S n)) with (double (shiftl a n)). destruct m; simpl. unfold odd. apply negb_false_iff. @@ -623,7 +627,7 @@ Qed. Lemma div2_bitwise : forall op n a b, div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). Proof. - intros. unfold bitwise; fold bitwise. + intros op n a b. unfold bitwise; fold bitwise. destruct (op (odd a) (odd b)). now rewrite div2_succ_double. now rewrite add_0_l, div2_double. @@ -632,7 +636,7 @@ Qed. Lemma odd_bitwise : forall op n a b, odd (bitwise op (S n) a b) = op (odd a) (odd b). Proof. - intros. unfold bitwise; fold bitwise. + intros op n a b. unfold bitwise; fold bitwise. destruct (op (odd a) (odd b)). apply odd_spec. rewrite add_comm. eexists; eauto. unfold odd. apply negb_false_iff. apply even_spec. @@ -644,7 +648,7 @@ Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) -> testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). Proof. intros op Hop. - induction n; intros m a b Ha. + intro n; induction n as [|n IHn]; intros m a b Ha. simpl. inversion Ha; subst. now rewrite testbit_0_l. destruct m. apply odd_bitwise. @@ -657,7 +661,7 @@ Lemma testbit_bitwise_2 : forall op, op false false = false -> testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). Proof. intros op Hop. - induction n; intros m a b Ha Hb. + intro n; induction n as [|n IHn]; intros m a b Ha Hb. simpl. inversion Ha; inversion Hb; subst. now rewrite testbit_0_l. destruct m. apply odd_bitwise. @@ -682,11 +686,11 @@ Lemma lor_spec a b n : Proof. unfold lor. apply testbit_bitwise_2. - trivial. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_l; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_r; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. @@ -697,11 +701,11 @@ Lemma lxor_spec a b n : Proof. unfold lxor. apply testbit_bitwise_2. - trivial. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_l; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_r; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index a673a1119f..9a7a397023 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -16,7 +16,7 @@ Implicit Types m n x y : nat. Theorem O_or_S n : {m : nat | S m = n} + {0 = n}. Proof. - induction n. + induction n as [|n IHn]. - now right. - left; exists n; auto. Defined. @@ -47,7 +47,7 @@ pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2). 2: reflexivity. generalize def_n2; revert le_mn1 le_mn2. generalize n0 at 1 4 5 7; intros n1 le_mn1. -destruct le_mn1; intros le_mn2; destruct le_mn2. +destruct le_mn1 as [|? le_mn1]; intros le_mn2; destruct le_mn2 as [|? le_mn2]. + now intros def_n0; rewrite (UIP_nat _ _ def_n0 eq_refl). + intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0. now destruct (Nat.nle_succ_diag_l _ le_mn0). diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index ec7426e648..5da7738adc 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -156,7 +156,7 @@ Fixpoint tail_plus n m : nat := Lemma plus_tail_plus : forall n m, n + m = tail_plus n m. Proof. -induction n as [| n IHn]; simpl; auto. +intro n; induction n as [| n IHn]; simpl; auto. intro m; rewrite <- IHn; simpl; auto. Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 3bfef93726..ebd909c1dc 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -27,8 +27,8 @@ Definition gtof (a b:A) := f b > f a. Theorem well_founded_ltof : well_founded ltof. Proof. assert (H : forall n (a:A), f a < n -> Acc ltof a). - { induction n. - - intros; absurd (f a < 0); auto with arith. + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto with arith. - intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb. apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } intros a. apply (H (S (f a))). auto with arith. @@ -69,8 +69,8 @@ Theorem induction_ltof1 : Proof. intros P F. assert (H : forall n (a:A), f a < n -> P a). - { induction n. - - intros; absurd (f a < 0); auto with arith. + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto with arith. - intros a Ha. apply F. unfold ltof. intros b Hb. apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } intros a. apply (H (S (f a))). auto with arith. @@ -107,8 +107,8 @@ Hypothesis H_compat : forall x y:A, R x y -> f x < f y. Theorem well_founded_lt_compat : well_founded R. Proof. assert (H : forall n (a:A), f a < n -> Acc R a). - { induction n. - - intros; absurd (f a < 0); auto with arith. + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto with arith. - intros a Ha. apply Acc_intro. intros b Hb. apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } intros a. apply (H (S (f a))). auto with arith. @@ -212,26 +212,26 @@ Section LT_WF_REL. Remark acc_lt_rel : forall x:A, (exists n, F x n) -> Acc R x. Proof. intros x [n fxn]; generalize dependent x. - pattern n; apply lt_wf_ind; intros. - constructor; intros. + pattern n; apply lt_wf_ind; intros n0 H x fxn. + constructor; intros y H0. destruct (F_compat y x) as (x0,H1,H2); trivial. apply (H x0); auto. Qed. Theorem well_founded_inv_lt_rel_compat : well_founded R. Proof. - constructor; intros. - case (F_compat y a); trivial; intros. + intro a; constructor; intros y H. + case (F_compat y a); trivial; intros x **. apply acc_lt_rel; trivial. exists x; trivial. Qed. End LT_WF_REL. -Lemma well_founded_inv_rel_inv_lt_rel : - forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F). +Lemma well_founded_inv_rel_inv_lt_rel (A:Set) (F:A -> nat -> Prop) : + well_founded (inv_lt_rel A F). Proof. - intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial. + apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial. Qed. (** A constructive proof that any non empty decidable subset of @@ -253,8 +253,8 @@ Proof. intros P Pdec (n0,HPn0). assert (forall n, (exists n', n'<n /\ P n' /\ forall n'', P n'' -> n'<=n'') - \/ (forall n', P n' -> n<=n')). - { induction n. + \/ (forall n', P n' -> n<=n')) as H. + { intro n; induction n as [|n IHn]. - right. intros. apply Nat.le_0_l. - destruct IHn as [(n' & IH1 & IH2)|IH]. + left. exists n'; auto with arith. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 76633ab201..4cc3597029 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -74,31 +74,31 @@ Section Facts. (** *** Generic facts *) (** Discrimination *) - Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l. + Theorem nil_cons (x:A) (l:list A) : [] <> x :: l. Proof. - intros; discriminate. + discriminate. Qed. (** Destruction *) - Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = []}. + Theorem destruct_list (l : list A) : {x:A & {tl:list A | l = x::tl}}+{l = []}. Proof. induction l as [|a tail]. right; reflexivity. left; exists a, tail; reflexivity. Qed. - Lemma hd_error_tl_repr : forall l (a:A) r, + Lemma hd_error_tl_repr l (a:A) r : hd_error l = Some a /\ tl l = r <-> l = a :: r. Proof. destruct l as [|x xs]. - - unfold hd_error, tl; intros a r. split; firstorder discriminate. + - unfold hd_error, tl; split; firstorder discriminate. - intros. simpl. split. * intros (H1, H2). inversion H1. rewrite H2. reflexivity. * inversion 1. subst. auto. Qed. - Lemma hd_error_some_nil : forall l (a:A), hd_error l = Some a -> l <> nil. + Lemma hd_error_some_nil l (a:A) : hd_error l = Some a -> l <> nil. Proof. unfold hd_error. destruct l; now discriminate. Qed. Theorem length_zero_iff_nil (l : list A): @@ -114,9 +114,9 @@ Section Facts. simpl; reflexivity. Qed. - Theorem hd_error_cons : forall (l : list A) (x : A), hd_error (x::l) = Some x. + Theorem hd_error_cons (l : list A) (x : A) : hd_error (x::l) = Some x. Proof. - intros; simpl; reflexivity. + simpl; reflexivity. Qed. @@ -125,41 +125,41 @@ Section Facts. (**************************) (** Discrimination *) - Theorem app_cons_not_nil : forall (x y:list A) (a:A), [] <> x ++ a :: y. + Theorem app_cons_not_nil (x y:list A) (a:A) : [] <> x ++ a :: y. Proof. unfold not. - destruct x as [| a l]; simpl; intros. + destruct x; simpl; intros H. discriminate H. discriminate H. Qed. (** Concat with [nil] *) - Theorem app_nil_l : forall l:list A, [] ++ l = l. + Theorem app_nil_l (l:list A) : [] ++ l = l. Proof. reflexivity. Qed. - Theorem app_nil_r : forall l:list A, l ++ [] = l. + Theorem app_nil_r (l:list A) : l ++ [] = l. Proof. induction l; simpl; f_equal; auto. Qed. (* begin hide *) (* Deprecated *) - Theorem app_nil_end : forall (l:list A), l = l ++ []. + Theorem app_nil_end (l:list A) : l = l ++ []. Proof. symmetry; apply app_nil_r. Qed. (* end hide *) (** [app] is associative *) - Theorem app_assoc : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n. + Theorem app_assoc (l m n:list A) : l ++ m ++ n = (l ++ m) ++ n. Proof. - intros l m n; induction l; simpl; f_equal; auto. + induction l; simpl; f_equal; auto. Qed. (* begin hide *) (* Deprecated *) - Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n. + Theorem app_assoc_reverse (l m n:list A) : (l ++ m) ++ n = l ++ m ++ n. Proof. auto using app_assoc. Qed. @@ -167,42 +167,41 @@ Section Facts. (* end hide *) (** [app] commutes with [cons] *) - Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y. + Theorem app_comm_cons (x y:list A) (a:A) : a :: (x ++ y) = (a :: x) ++ y. Proof. auto. Qed. (** Facts deduced from the result of a concatenation *) - Theorem app_eq_nil : forall l l':list A, l ++ l' = [] -> l = [] /\ l' = []. + Theorem app_eq_nil (l l':list A) : l ++ l' = [] -> l = [] /\ l' = []. Proof. destruct l as [| x l]; destruct l' as [| y l']; simpl; auto. intro; discriminate. intros H; discriminate H. Qed. - Theorem app_eq_unit : - forall (x y:list A) (a:A), + Theorem app_eq_unit (x y:list A) (a:A) : x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = []. Proof. - destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; + destruct x as [|a' l]; [ destruct y as [|a' l] | destruct y as [| a0 l0] ]; simpl. - intros a H; discriminate H. + intros H; discriminate H. left; split; auto. - right; split; auto. + intro H; right; split; auto. generalize H. generalize (app_nil_r l); intros E. rewrite -> E; auto. - intros. + intros H. injection H as [= H H0]. - assert ([] = l ++ a0 :: l0) by auto. + assert ([] = l ++ a0 :: l0) as H1 by auto. apply app_cons_not_nil in H1 as []. Qed. - Lemma elt_eq_unit : forall l1 l2 (a b : A), + Lemma elt_eq_unit l1 l2 (a b : A) : l1 ++ a :: l2 = [b] -> a = b /\ l1 = [] /\ l2 = []. Proof. - intros l1 l2 a b Heq. + intros Heq. apply app_eq_unit in Heq. now destruct Heq as [[Heq1 Heq2]|[Heq1 Heq2]]; inversion_clear Heq2. Qed. @@ -210,7 +209,7 @@ Section Facts. Lemma app_inj_tail_iff : forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] <-> x = y /\ a = b. Proof. - induction x as [| x l IHl]; + intro x; induction x as [| x l IHl]; intro y; [ destruct y as [| a l] | destruct y as [| a l0] ]; simpl; auto. - intros a b. split. @@ -220,7 +219,7 @@ Section Facts. + intros [= H1 H0]. apply app_cons_not_nil in H0 as []. + intros [H0 H1]. inversion H0. - intros a b. split. - + intros [= H1 H0]. assert ([] = l ++ [a]) by auto. apply app_cons_not_nil in H as []. + + intros [= H1 H0]. assert ([] = l ++ [a]) as H by auto. apply app_cons_not_nil in H as []. + intros [H0 H1]. inversion H0. - intros a0 b. split. + intros [= <- H0]. specialize (IHl l0 a0 b). apply IHl in H0. destruct H0. subst. split; auto. @@ -237,7 +236,7 @@ Section Facts. Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'. Proof. - induction l; simpl; auto. + intro l; induction l; simpl; auto. Qed. Lemma last_length : forall (l : list A) a, length (l ++ a :: nil) = S (length l). @@ -249,7 +248,7 @@ Section Facts. Lemma app_inv_head_iff: forall l l1 l2 : list A, l ++ l1 = l ++ l2 <-> l1 = l2. Proof. - induction l; split; intros; simpl; auto. + intro l; induction l as [|? l IHl]; split; intros H; simpl; auto. - apply IHl. inversion H. auto. - subst. auto. Qed. @@ -264,7 +263,7 @@ Section Facts. forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. Proof. intros l l1 l2; revert l1 l2 l. - induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; + intro l1; induction l1 as [ | x1 l1]; intro l2; destruct l2 as [ | x2 l2]; simpl; auto; intros l H. absurd (length (x2 :: l2 ++ l) <= length l). simpl; rewrite app_length; auto with arith. @@ -344,7 +343,7 @@ Section Facts. Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2. Proof. - induction l; simpl; destruct 1. + intros x l; induction l as [|a l IHl]; simpl; [destruct 1|destruct 1 as [?|H]]. subst a; auto. exists [], l; auto. destruct (IHl H) as (l1,(l2,H0)). @@ -375,7 +374,7 @@ Section Facts. (forall x y:A, {x = y} + {x <> y}) -> forall (a:A) (l:list A), {In a l} + {~ In a l}. Proof. - intro H; induction l as [| a0 l IHl]. + intros H a l; induction l as [| a0 l IHl]. right; apply in_nil. destruct (H a0 a); simpl; auto. destruct IHl; simpl; auto. @@ -425,8 +424,8 @@ Section Elts. Lemma nth_in_or_default : forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}. Proof. - intros n l d; revert n; induction l. - - right; destruct n; trivial. + intros n l d; revert n; induction l as [|? ? IHl]. + - intro n; right; destruct n; trivial. - intros [|n]; simpl. * left; auto. * destruct (IHl n); auto. @@ -455,7 +454,7 @@ Section Elts. Lemma nth_default_eq : forall n l (d:A), nth_default d l n = nth n l d. Proof. - unfold nth_default; induction n; intros [ | ] ?; simpl; auto. + unfold nth_default; intro n; induction n; intros [ | ] ?; simpl; auto. Qed. (** Results about [nth] *) @@ -463,7 +462,7 @@ Section Elts. Lemma nth_In : forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l. Proof. - unfold lt; induction n as [| n hn]; simpl. + unfold lt; intro n; induction n as [| n hn]; simpl; intro l. - destruct l; simpl; [ inversion 2 | auto ]. - destruct l; simpl. * inversion 2. @@ -483,7 +482,8 @@ Section Elts. Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d. Proof. - induction l; destruct n; simpl; intros; auto. + intro l; induction l as [|? ? IHl]; intro n; destruct n; + simpl; intros d H; auto. - inversion H. - apply IHl; auto with arith. Qed. @@ -491,7 +491,7 @@ Section Elts. Lemma nth_indep : forall l n d d', n < length l -> nth n l d = nth n l d'. Proof. - induction l. + intro l; induction l. - inversion 1. - intros [|n] d d'; simpl; auto with arith. Qed. @@ -499,7 +499,7 @@ Section Elts. Lemma app_nth1 : forall l l' d n, n < length l -> nth n (l++l') d = nth n l d. Proof. - induction l. + intro l; induction l. - inversion 1. - intros l' d [|n]; simpl; auto with arith. Qed. @@ -507,7 +507,7 @@ Section Elts. Lemma app_nth2 : forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d. Proof. - induction l; intros l' d [|n]; auto. + intro l; induction l as [|? ? IHl]; intros l' d [|n]; auto. - inversion 1. - intros; simpl; rewrite IHl; auto with arith. Qed. @@ -541,7 +541,8 @@ Section Elts. Lemma nth_ext : forall l l' d d', length l = length l' -> (forall n, n < length l -> nth n l d = nth n l' d') -> l = l'. Proof. - induction l; intros l' d d' Hlen Hnth; destruct l' as [| b l']. + intro l; induction l as [|a l IHl]; + intros l' d d' Hlen Hnth; destruct l' as [| b l']. - reflexivity. - inversion Hlen. - inversion Hlen. @@ -575,7 +576,7 @@ Section Elts. Lemma nth_error_None l n : nth_error l n = None <-> length l <= n. Proof. - revert n. induction l; destruct n; simpl. + revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; auto. - split; auto with arith. - split; now auto with arith. @@ -584,7 +585,7 @@ Section Elts. Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l. Proof. - revert n. induction l; destruct n; simpl. + revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; [now destruct 1 | inversion 1]. - split; [now destruct 1 | inversion 1]. - split; now auto with arith. @@ -605,7 +606,7 @@ Section Elts. nth_error (l++l') n = nth_error l n. Proof. revert l. - induction n; intros [|a l] H; auto; try solve [inversion H]. + induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. simpl in *. apply IHn. auto with arith. Qed. @@ -613,7 +614,7 @@ Section Elts. nth_error (l++l') n = nth_error l' (n-length l). Proof. revert l. - induction n; intros [|a l] H; auto; try solve [inversion H]. + induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. simpl in *. apply IHn. auto with arith. Qed. @@ -632,7 +633,7 @@ Section Elts. n < length l -> nth_error l n = Some (nth n l d). Proof. intros l n d H. - apply nth_split with (d:=d) in H. destruct H as [l1 [l2 [H H']]]. + apply (nth_split _ d) in H. destruct H as [l1 [l2 [H H']]]. subst. rewrite H. rewrite nth_error_app2; [|auto]. rewrite app_nth2; [| auto]. repeat (rewrite Nat.sub_diag). reflexivity. Qed. @@ -653,7 +654,7 @@ Section Elts. Lemma last_last : forall l a d, last (l ++ [a]) d = a. Proof. - induction l; intros; [ reflexivity | ]. + intro l; induction l as [|? l IHl]; intros; [ reflexivity | ]. simpl; rewrite IHl. destruct l; reflexivity. Qed. @@ -670,17 +671,17 @@ Section Elts. Lemma app_removelast_last : forall l d, l <> [] -> l = removelast l ++ [last l d]. Proof. - induction l. + intro l; induction l as [|? l IHl]. destruct 1; auto. intros d _. - destruct l; auto. + destruct l as [|a0 l]; auto. pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate. Qed. Lemma exists_last : forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}. Proof. - induction l. + intro l; induction l as [|a l IHl]. destruct 1; auto. intros _. destruct l. @@ -693,10 +694,10 @@ Section Elts. Lemma removelast_app : forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'. Proof. - induction l. + intro l; induction l as [|? l IHl]. simpl; auto. - simpl; intros. - assert (l++l' <> []). + simpl; intros l' H. + assert (l++l' <> []) as H0. destruct l. simpl; auto. simpl; discriminate. @@ -733,7 +734,7 @@ Section Elts. Lemma remove_app : forall x l1 l2, remove x (l1 ++ l2) = remove x l1 ++ remove x l2. Proof. - induction l1; intros l2; simpl. + intros x l1; induction l1 as [|a l1 IHl1]; intros l2; simpl. - reflexivity. - destruct (eq_dec x a). + apply IHl1. @@ -743,7 +744,7 @@ Section Elts. Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). Proof. - induction l as [|x l]; auto. + intro l; induction l as [|x l IHl]; auto. intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. apply IHl. unfold not; intro HF; simpl in HF; destruct HF; auto. @@ -760,7 +761,7 @@ Section Elts. Lemma in_remove: forall l x y, In x (remove y l) -> In x l /\ x <> y. Proof. - induction l as [|z l]; intros x y Hin. + intro l; induction l as [|z l IHl]; intros x y Hin. - inversion Hin. - simpl in Hin. destruct (eq_dec y z) as [Heq|Hneq]; subst; split. @@ -775,7 +776,7 @@ Section Elts. Lemma in_in_remove : forall l x y, x <> y -> In x l -> In x (remove y l). Proof. - induction l as [|z l]; simpl; intros x y Hneq Hin. + intro l; induction l as [|z l IHl]; simpl; intros x y Hneq Hin. - apply Hin. - destruct (eq_dec y z); subst. + destruct Hin. @@ -788,7 +789,7 @@ Section Elts. Lemma remove_remove_comm : forall l x y, remove x (remove y l) = remove y (remove x l). Proof. - induction l as [| z l]; simpl; intros x y. + intro l; induction l as [| z l IHl]; simpl; intros x y. - reflexivity. - destruct (eq_dec y z); simpl; destruct (eq_dec x z); try rewrite IHl; auto. + subst; symmetry; apply remove_cons. @@ -800,7 +801,7 @@ Section Elts. Lemma remove_length_le : forall l x, length (remove x l) <= length l. Proof. - induction l as [|y l IHl]; simpl; intros x; trivial. + intro l; induction l as [|y l IHl]; simpl; intros x; trivial. destruct (eq_dec x y); simpl. - rewrite IHl; constructor; reflexivity. - apply (proj1 (Nat.succ_le_mono _ _) (IHl x)). @@ -808,7 +809,7 @@ Section Elts. Lemma remove_length_lt : forall l x, In x l -> length (remove x l) < length l. Proof. - induction l as [|y l IHl]; simpl; intros x Hin. + intro l; induction l as [|y l IHl]; simpl; intros x Hin. - contradiction Hin. - destruct Hin as [-> | Hin]. + destruct (eq_dec x x); intuition. @@ -833,7 +834,7 @@ Section Elts. (** Compatibility of count_occ with operations on list *) Theorem count_occ_In l x : In x l <-> count_occ l x > 0. Proof. - induction l as [|y l]; simpl. + induction l as [|y l IHl]; simpl. - split; [destruct 1 | apply gt_irrefl]. - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition. Qed. @@ -892,8 +893,8 @@ Section ListOps. Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x. Proof. - induction x as [| a l IHl]. - destruct y as [| a l]. + intro x; induction x as [| a l IHl]. + intro y; destruct y as [| a l]. simpl. auto. @@ -908,13 +909,13 @@ Section ListOps. Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l. Proof. - intros. + intros l a. apply (rev_app_distr l [a]); simpl; auto. Qed. Lemma rev_involutive : forall l:list A, rev (rev l) = l. Proof. - induction l as [| a l IHl]. + intro l; induction l as [| a l IHl]. simpl; auto. simpl. @@ -933,11 +934,11 @@ Section ListOps. Lemma in_rev : forall l x, In x l <-> In x (rev l). Proof. - induction l. + intro l; induction l. simpl; intuition. intros. simpl. - intuition. + split; intro H; [destruct H|]. subst. apply in_or_app; right; simpl; auto. apply in_or_app; left; firstorder. @@ -946,7 +947,7 @@ Section ListOps. Lemma rev_length : forall l, length (rev l) = length l. Proof. - induction l;simpl; auto. + intro l; induction l as [|? l IHl];simpl; auto. rewrite app_length. rewrite IHl. simpl. @@ -956,9 +957,9 @@ Section ListOps. Lemma rev_nth : forall l d n, n < length l -> nth n (rev l) d = nth (length l - S n) l d. Proof. - induction l. - intros; inversion H. - intros. + intro l; induction l as [|a l IHl]. + intros d n H; inversion H. + intros ? n H. simpl in H. simpl (rev (a :: l)). simpl (length (a :: l) - S n). @@ -988,7 +989,7 @@ Section ListOps. Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'. Proof. - induction l; simpl; auto; intros. + intro l; induction l; simpl; auto; intros. rewrite <- app_assoc; firstorder. Qed. @@ -1010,20 +1011,20 @@ Section ListOps. (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) -> forall l:list A, P (rev l). Proof. - induction l; auto. + intros P ? ? l; induction l; auto. Qed. Theorem rev_ind : forall P:list A -> Prop, P [] -> (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l. Proof. - intros. + intros P H H0 l. generalize (rev_involutive l). intros E; rewrite <- E. apply (rev_list_ind P). - auto. - simpl. - intros. + intros a l0 ?. apply (H0 a (rev l0)). auto. Qed. @@ -1060,10 +1061,10 @@ Section ListOps. Lemma in_concat : forall l y, In y (concat l) <-> exists x, In x l /\ In y x. Proof. - induction l; simpl; split; intros. + intro l; induction l as [|a l IHl]; simpl; intro y; split; intros H. contradiction. destruct H as (x,(H,_)); contradiction. - destruct (in_app_or _ _ _ H). + destruct (in_app_or _ _ _ H) as [H0|H0]. exists a; auto. destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)). exists x; auto. @@ -1112,69 +1113,69 @@ Section Map. Lemma in_map : forall (l:list A) (x:A), In x l -> In (f x) (map l). Proof. - induction l; firstorder (subst; auto). + intro l; induction l; firstorder (subst; auto). Qed. Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l. Proof. - induction l; firstorder (subst; auto). + intro l; induction l; firstorder (subst; auto). Qed. Lemma map_length : forall l, length (map l) = length l. Proof. - induction l; simpl; auto. + intro l; induction l; simpl; auto. Qed. Lemma map_nth : forall l d n, nth n (map l) (f d) = f (nth n l d). Proof. - induction l; simpl map; destruct n; firstorder. + intro l; induction l; simpl map; intros d n; destruct n; firstorder. Qed. Lemma map_nth_error : forall n l d, nth_error l n = Some d -> nth_error (map l) n = Some (f d). Proof. - induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. + intro n; induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. Qed. Lemma map_app : forall l l', map (l++l') = (map l)++(map l'). Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. intros; rewrite IHl; auto. Qed. Lemma map_last : forall l a, map (l ++ [a]) = (map l) ++ [f a]. Proof. - induction l; intros; [ reflexivity | ]. + intro l; induction l as [|a l IHl]; intros; [ reflexivity | ]. simpl; rewrite IHl; reflexivity. Qed. Lemma map_rev : forall l, map (rev l) = rev (map l). Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. rewrite map_app. rewrite IHl; auto. Qed. Lemma map_eq_nil : forall l, map l = [] -> l = []. Proof. - destruct l; simpl; reflexivity || discriminate. + intro l; destruct l; simpl; reflexivity || discriminate. Qed. Lemma map_eq_cons : forall l l' b, map l = b :: l' -> exists a tl, l = a :: tl /\ f a = b /\ map tl = l'. Proof. intros l l' b Heq. - destruct l; inversion_clear Heq. + destruct l as [|a l]; inversion_clear Heq. exists a, l; repeat split. Qed. Lemma map_eq_app : forall l l1 l2, map l = l1 ++ l2 -> exists l1' l2', l = l1' ++ l2' /\ map l1' = l1 /\ map l2' = l2. Proof. - induction l; simpl; intros l1 l2 Heq. + intro l; induction l as [|a l IHl]; simpl; intros l1 l2 Heq. - symmetry in Heq; apply app_eq_nil in Heq; destruct Heq; subst. exists nil, nil; repeat split. - destruct l1; simpl in Heq; inversion Heq as [[Heq2 Htl]]. @@ -1215,7 +1216,7 @@ Section Map. flat_map f (l1 ++ l2) = flat_map f l1 ++ flat_map f l2. Proof. intros F l1 l2. - induction l1; [ reflexivity | simpl ]. + induction l1 as [|? ? IHl1]; [ reflexivity | simpl ]. rewrite IHl1, app_assoc; reflexivity. Qed. @@ -1223,10 +1224,10 @@ Section Map. In y (flat_map f l) <-> exists x, In x l /\ In y (f x). Proof. clear f Hfinjective. - induction l; simpl; split; intros. + intros f l; induction l as [|a l IHl]; simpl; intros y; split; intros H. contradiction. destruct H as (x,(H,_)); contradiction. - destruct (in_app_or _ _ _ H). + destruct (in_app_or _ _ _ H) as [H0|H0]. exists a; auto. destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)). exists x; auto. @@ -1257,33 +1258,33 @@ Qed. Lemma remove_concat A (eq_dec : forall x y : A, {x = y}+{x <> y}) : forall l x, remove eq_dec x (concat l) = flat_map (remove eq_dec x) l. Proof. - intros l x; induction l; [ reflexivity | simpl ]. + intros l x; induction l as [|? ? IHl]; [ reflexivity | simpl ]. rewrite remove_app, IHl; reflexivity. Qed. Lemma map_id : forall (A :Type) (l : list A), map (fun x => x) l = l. Proof. - induction l; simpl; auto; rewrite IHl; auto. + intros A l; induction l as [|? ? IHl]; simpl; auto; rewrite IHl; auto. Qed. Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, map g (map f l) = map (fun x => g (f x)) l. Proof. - induction l; simpl; auto. + intros A B C f g l; induction l as [|? ? IHl]; simpl; auto. rewrite IHl; auto. Qed. Lemma map_ext_in : forall (A B : Type)(f g:A->B) l, (forall a, In a l -> f a = g a) -> map f l = map g l. Proof. - induction l; simpl; auto. - intros; rewrite H by intuition; rewrite IHl; auto. + intros A B f g l; induction l as [|? ? IHl]; simpl; auto. + intros H; rewrite H by intuition; rewrite IHl; auto. Qed. Lemma ext_in_map : forall (A B : Type)(f g:A->B) l, map f l = map g l -> forall a, In a l -> f a = g a. -Proof. induction l; intros [=] ? []; subst; auto. Qed. +Proof. intros A B f g l; induction l; intros [=] ? []; subst; auto. Qed. Arguments ext_in_map [A B f g l]. @@ -1304,13 +1305,13 @@ Lemma flat_map_ext : forall (A B : Type)(f g : A -> list B), Proof. intros A B f g Hext l. rewrite 2 flat_map_concat_map. - now rewrite map_ext with (g := g). + now rewrite (map_ext _ g). Qed. Lemma nth_nth_nth_map A : forall (l : list A) n d ln dn, n < length ln \/ length l <= dn -> nth (nth n ln dn) l d = nth n (map (fun x => nth x l d) ln) d. Proof. - intros l n d ln dn; revert n; induction ln; intros n Hlen. + intros l n d ln dn; revert n; induction ln as [|? ? IHln]; intros n Hlen. - destruct Hlen as [Hlen|Hlen]. + inversion Hlen. + now rewrite nth_overflow; destruct n. @@ -1336,7 +1337,7 @@ Section Fold_Left_Recursor. Lemma fold_left_app : forall (l l':list B)(i:A), fold_left (l++l') i = fold_left l' (fold_left l i). Proof. - induction l. + intro l; induction l. simpl; auto. intros. simpl. @@ -1350,7 +1351,7 @@ Lemma fold_left_length : Proof. intros A l. enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0). - induction l; simpl; auto. + induction l as [|? ? IHl]; simpl; auto. intros; rewrite IHl. simpl; auto with arith. Qed. @@ -1375,7 +1376,7 @@ End Fold_Right_Recursor. Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, fold_right f i (l++l') = fold_right f (fold_right f i l') l. Proof. - induction l. + intros A B f l; induction l. simpl; auto. simpl; intros. f_equal; auto. @@ -1384,7 +1385,7 @@ End Fold_Right_Recursor. Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, fold_right f i (rev l) = fold_left (fun x y => f y x) l i. Proof. - induction l. + intros A B f l; induction l. simpl; auto. intros. simpl. @@ -1398,8 +1399,9 @@ End Fold_Right_Recursor. forall (l : list A), fold_left f l a0 = fold_right f a0 l. Proof. intros A f assoc a0 comma0 l. - induction l as [ | a1 l ]; [ simpl; reflexivity | ]. - simpl. rewrite <- IHl. clear IHl. revert a1. induction l; [ auto | ]. + induction l as [ | a1 l IHl]; [ simpl; reflexivity | ]. + simpl. rewrite <- IHl. clear IHl. revert a1. + induction l as [|? ? IHl]; [ auto | ]. simpl. intro. rewrite <- assoc. rewrite IHl. rewrite IHl. auto. Qed. @@ -1436,7 +1438,7 @@ End Fold_Right_Recursor. Lemma existsb_exists : forall l, existsb l = true <-> exists x, In x l /\ f x = true. Proof. - induction l as [ | a m IH ]; split; simpl. + intro l; induction l as [ | a m IH ]; split; simpl. - easy. - intros [x [[]]]. - rewrite orb_true_iff; intros [ H | H ]. @@ -1451,9 +1453,9 @@ End Fold_Right_Recursor. Lemma existsb_nth : forall l n d, n < length l -> existsb l = false -> f (nth n l d) = false. Proof. - induction l. + intro l; induction l as [|? ? IHl]. inversion 1. - simpl; intros. + simpl; intros n ? ? H0. destruct (orb_false_elim _ _ H0); clear H0; auto. destruct n ; auto. rewrite IHl; auto with arith. @@ -1462,7 +1464,7 @@ End Fold_Right_Recursor. Lemma existsb_app : forall l1 l2, existsb (l1++l2) = existsb l1 || existsb l2. Proof. - induction l1; intros l2; simpl. + intro l1; induction l1 as [|a ? ?]; intros l2; simpl. solve[auto]. case (f a); simpl; solve[auto]. Qed. @@ -1479,19 +1481,19 @@ End Fold_Right_Recursor. Lemma forallb_forall : forall l, forallb l = true <-> (forall x, In x l -> f x = true). Proof. - induction l; simpl; intuition. - destruct (andb_prop _ _ H1). - congruence. - destruct (andb_prop _ _ H1); auto. - assert (forallb l = true). - apply H0; intuition. - rewrite H1; auto. + intro l; induction l as [|a l IHl]; simpl; [ tauto | split; intro H ]. + + destruct (andb_prop _ _ H); intros a' [?|?]. + - congruence. + - apply IHl; assumption. + + apply andb_true_intro; split. + - apply H; left; reflexivity. + - apply IHl; intros; apply H; right; assumption. Qed. Lemma forallb_app : forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2. Proof. - induction l1; simpl. + intro l1; induction l1 as [|a ? ?]; simpl. solve[auto]. case (f a); simpl; solve[auto]. Qed. @@ -1506,7 +1508,7 @@ End Fold_Right_Recursor. Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true. Proof. - induction l; simpl. + intros x l; induction l as [|a ? ?]; simpl. intuition. intros. case_eq (f a); intros; simpl; intuition congruence. @@ -1522,7 +1524,7 @@ End Fold_Right_Recursor. Lemma concat_filter_map : forall (l : list (list A)), concat (map filter l) = filter (concat l). Proof. - induction l as [| v l IHl]; [auto|]. + intro l; induction l as [| v l IHl]; [auto|]. simpl. rewrite IHl. rewrite filter_app. reflexivity. Qed. @@ -1618,10 +1620,10 @@ End Fold_Right_Recursor. Lemma filter_map : forall (f g : A -> bool) (l : list A), filter f l = filter g l <-> map f l = map g l. Proof. - induction l as [| a l IHl]; [firstorder|]. + intros f g l; induction l as [| a l IHl]; [firstorder|]. simpl. destruct (f a) eqn:Hfa; destruct (g a) eqn:Hga; split; intros H. - - inversion H. apply IHl in H1. rewrite H1. reflexivity. - - inversion H. apply IHl in H1. rewrite H1. reflexivity. + - inversion H as [H1]. apply IHl in H1. rewrite H1. reflexivity. + - inversion H as [H1]. apply IHl in H1. rewrite H1. reflexivity. - assert (Ha : In a (filter g l)). { rewrite <- H. apply in_eq. } apply filter_In in Ha. destruct Ha as [_ Hga']. rewrite Hga in Hga'. inversion Hga'. - inversion H. @@ -1702,9 +1704,9 @@ End Fold_Right_Recursor. Lemma in_split_l : forall (l:list (A*B))(p:A*B), In p l -> In (fst p) (fst (split l)). Proof. - induction l; simpl; intros; auto. - destruct p; destruct a; destruct (split l); simpl in *. - destruct H. + intro l; induction l as [|a l IHl]; simpl; intros p H; auto. + destruct p as [a0 b]; destruct a; destruct (split l); simpl in *. + destruct H as [H|H]. injection H; auto. right; apply (IHl (a0,b) H). Qed. @@ -1712,9 +1714,9 @@ End Fold_Right_Recursor. Lemma in_split_r : forall (l:list (A*B))(p:A*B), In p l -> In (snd p) (snd (split l)). Proof. - induction l; simpl; intros; auto. - destruct p; destruct a; destruct (split l); simpl in *. - destruct H. + intro l; induction l as [|a l IHl]; simpl; intros p H; auto. + destruct p as [a0 b]; destruct a; destruct (split l); simpl in *. + destruct H as [H|H]. injection H; auto. right; apply (IHl (a0,b) H). Qed. @@ -1722,9 +1724,9 @@ End Fold_Right_Recursor. Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)). Proof. - induction l. - destruct n; destruct d; simpl; auto. - destruct n; destruct d; simpl; auto. + intro l; induction l as [|a l IHl]. + intros n d; destruct n; destruct d; simpl; auto. + intros n d; destruct n; destruct d; simpl; auto. destruct a; destruct (split l); simpl; auto. destruct a; destruct (split l); simpl in *; auto. apply IHl. @@ -1733,14 +1735,14 @@ End Fold_Right_Recursor. Lemma split_length_l : forall (l:list (A*B)), length (fst (split l)) = length l. Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. Lemma split_length_r : forall (l:list (A*B)), length (snd (split l)) = length l. Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. @@ -1757,7 +1759,7 @@ End Fold_Right_Recursor. Lemma split_combine : forall (l: list (A*B)), let (l1,l2) := split l in combine l1 l2 = l. Proof. - induction l. + intro l; induction l as [|a l IHl]. simpl; auto. destruct a; simpl. destruct (split l); simpl in *. @@ -1767,18 +1769,19 @@ End Fold_Right_Recursor. Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> split (combine l l') = (l,l'). Proof. - induction l, l'; simpl; trivial; try discriminate. + intro l; induction l as [|a l IHl]; intro l'; destruct l'; + simpl; trivial; try discriminate. now intros [= ->%IHl]. Qed. Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In x l. Proof. - induction l. + intro l; induction l as [|a l IHl]. simpl; auto. - destruct l'; simpl; auto; intros. + intro l'; destruct l' as [|a0 l']; simpl; auto; intros x y H. contradiction. - destruct H. + destruct H as [H|H]. injection H; auto. right; apply IHl with l' y; auto. Qed. @@ -1786,10 +1789,10 @@ End Fold_Right_Recursor. Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In y l'. Proof. - induction l. + intro l; induction l as [|? ? IHl]. simpl; intros; contradiction. - destruct l'; simpl; auto; intros. - destruct H. + intro l'; destruct l'; simpl; auto; intros x y H. + destruct H as [H|H]. injection H; auto. right; apply IHl with x; auto. Qed. @@ -1797,16 +1800,16 @@ End Fold_Right_Recursor. Lemma combine_length : forall (l:list A)(l':list B), length (combine l l') = min (length l) (length l'). Proof. - induction l. + intro l; induction l. simpl; auto. - destruct l'; simpl; auto. + intro l'; destruct l'; simpl; auto. Qed. Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), length l = length l' -> nth n (combine l l') (x,y) = (nth n l x, nth n l' y). Proof. - induction l; destruct l'; intros; try discriminate. + intro l; induction l; intro l'; destruct l'; intros n x y; try discriminate. destruct n; simpl; auto. destruct n; simpl in *; auto. Qed. @@ -1826,7 +1829,7 @@ End Fold_Right_Recursor. forall (x:A) (y:B) (l:list B), In y l -> In (x, y) (map (fun y0:B => (x, y0)) l). Proof. - induction l; + intros x y l; induction l; [ simpl; auto | simpl; destruct 1 as [H1| ]; [ left; rewrite H1; trivial | right; auto ] ]. @@ -1836,9 +1839,9 @@ End Fold_Right_Recursor. forall (l:list A) (l':list B) (x:A) (y:B), In x l -> In y l' -> In (x, y) (list_prod l l'). Proof. - induction l; + intro l; induction l; [ simpl; tauto - | simpl; intros; apply in_or_app; destruct H; + | simpl; intros l' x y H H0; apply in_or_app; destruct H as [H|H]; [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. Qed. @@ -1846,10 +1849,10 @@ End Fold_Right_Recursor. forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (list_prod l l') <-> In x l /\ In y l'. Proof. - split; [ | intros; apply in_prod; intuition ]. - induction l; simpl; intros. + intros l l' x y; split; [ | intros H; apply in_prod; intuition ]. + induction l as [|a l IHl]; simpl; intros H. intuition. - destruct (in_app_or _ _ _ H); clear H. + destruct (in_app_or _ _ _ H) as [H0|H0]; clear H. destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_). destruct (H1 H0) as (z,(H2,H3)); clear H0 H1. injection H2 as [= -> ->]; intuition. @@ -1859,7 +1862,7 @@ End Fold_Right_Recursor. Lemma prod_length : forall (l:list A)(l':list B), length (list_prod l l') = (length l) * (length l'). Proof. - induction l; simpl; auto. + intro l; induction l; simpl; auto. intros. rewrite app_length. rewrite map_length. @@ -1947,7 +1950,7 @@ Section SetIncl. Lemma incl_l_nil : forall l, incl l nil -> l = nil. Proof. - destruct l; intros Hincl. + intro l; destruct l as [|a l]; intros Hincl. - reflexivity. - exfalso; apply Hincl with a; simpl; auto. Qed. @@ -2021,7 +2024,7 @@ Section SetIncl. Lemma incl_app_inv : forall l1 l2 m : list A, incl (l1 ++ l2) m -> incl l1 m /\ incl l2 m. Proof. - induction l1; intros l2 m Hin; split; auto. + intro l1; induction l1 as [|a l1 IHl1]; intros l2 m Hin; split; auto. - apply incl_nil_l. - intros b Hb; inversion_clear Hb; subst; apply Hin. + now constructor. @@ -2083,9 +2086,9 @@ Section Cutting. Lemma firstn_all2 n: forall (l:list A), (length l) <= n -> firstn n l = l. Proof. induction n as [|k iHk]. - - intro. inversion 1 as [H1|?]. + - intro l. inversion 1 as [H1|?]. rewrite (length_zero_iff_nil l) in H1. subst. now simpl. - - destruct l as [|x xs]; simpl. + - intro l; destruct l as [|x xs]; simpl. * now reflexivity. * simpl. intro H. apply Peano.le_S_n in H. f_equal. apply iHk, H. Qed. @@ -2095,16 +2098,16 @@ Section Cutting. Lemma firstn_le_length n: forall l:list A, length (firstn n l) <= n. Proof. - induction n as [|k iHk]; simpl; [auto | destruct l as [|x xs]; simpl]. + induction n as [|k iHk]; simpl; [auto | intro l; destruct l as [|x xs]; simpl]. - auto with arith. - apply Peano.le_n_S, iHk. Qed. Lemma firstn_length_le: forall l:list A, forall n:nat, n <= length l -> length (firstn n l) = n. - Proof. induction l as [|x xs Hrec]. + Proof. intro l; induction l as [|x xs Hrec]. - simpl. intros n H. apply le_n_0_eq in H. rewrite <- H. now simpl. - - destruct n. + - intro n; destruct n as [|n]. * now simpl. * simpl. intro H. apply le_S_n in H. now rewrite (Hrec n H). Qed. @@ -2137,11 +2140,11 @@ Section Cutting. forall l:list A, forall i j : nat, firstn i (firstn j l) = firstn (min i j) l. - Proof. induction l as [|x xs Hl]. + Proof. intro l; induction l as [|x xs Hl]. - intros. simpl. now rewrite ?firstn_nil. - - destruct i. + - intro i; destruct i. * intro. now simpl. - * destruct j. + * intro j; destruct j. + now simpl. + simpl. f_equal. apply Hl. Qed. @@ -2157,11 +2160,11 @@ Section Cutting. Lemma firstn_skipn_comm : forall m n l, firstn m (skipn n l) = skipn n (firstn (n + m) l). - Proof. now intros m; induction n; intros []; simpl; destruct m. Qed. + Proof. now intros m n; induction n; intros []; simpl; destruct m. Qed. Lemma skipn_firstn_comm : forall m n l, skipn m (firstn n l) = firstn (n - m) (skipn m l). - Proof. now induction m; intros [] []; simpl; rewrite ?firstn_nil. Qed. + Proof. now intro m; induction m; intros [] []; simpl; rewrite ?firstn_nil. Qed. Lemma skipn_O : forall l, skipn 0 l = l. Proof. reflexivity. Qed. @@ -2173,7 +2176,7 @@ Section Cutting. Proof. reflexivity. Qed. Lemma skipn_all : forall l, skipn (length l) l = nil. - Proof. now induction l. Qed. + Proof. now intro l; induction l. Qed. #[deprecated(since="8.12",note="Use skipn_all instead.")] Notation skipn_none := skipn_all. @@ -2185,15 +2188,15 @@ Section Cutting. Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l. Proof. - induction n. + intro n; induction n. simpl; auto. - destruct l; simpl; auto. + intro l; destruct l; simpl; auto. f_equal; auto. Qed. Lemma firstn_length : forall n l, length (firstn n l) = min n (length l). Proof. - induction n; destruct l; simpl; auto. + intro n; induction n; intro l; destruct l; simpl; auto. Qed. Lemma skipn_length n : @@ -2201,7 +2204,7 @@ Section Cutting. Proof. induction n. - intros l; simpl; rewrite Nat.sub_0_r; reflexivity. - - destruct l; simpl; auto. + - intro l; destruct l; simpl; auto. Qed. Lemma skipn_app n : forall l1 l2, @@ -2241,11 +2244,11 @@ Section Cutting. Lemma removelast_firstn : forall n l, n < length l -> removelast (firstn (S n) l) = firstn n l. Proof. - induction n; destruct l. + intro n; induction n as [|n IHn]; intro l; destruct l as [|a l]. simpl; auto. simpl; auto. simpl; auto. - intros. + intros H. simpl in H. change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l). change (firstn (S n) (a::l)) with (a::firstn n l). @@ -2253,30 +2256,30 @@ Section Cutting. rewrite IHn; auto with arith. clear IHn; destruct l; simpl in *; try discriminate. - inversion_clear H. - inversion_clear H0. + inversion_clear H as [|? H1]. + inversion_clear H1. Qed. Lemma removelast_firstn_len : forall l, removelast l = firstn (pred (length l)) l. Proof. - induction l; [ reflexivity | simpl ]. + intro l; induction l as [|a l IHl]; [ reflexivity | simpl ]. destruct l; [ | rewrite IHl ]; reflexivity. Qed. Lemma firstn_removelast : forall n l, n < length l -> firstn n (removelast l) = firstn n l. Proof. - induction n; destruct l. + intro n; induction n; intro l; destruct l as [|a l]. simpl; auto. simpl; auto. simpl; auto. - intros. + intros H. simpl in H. change (removelast (a :: l)) with (removelast ((a::nil)++l)). rewrite removelast_app. simpl; f_equal; auto with arith. - intro H0; rewrite H0 in H; inversion_clear H; inversion_clear H1. + intro H0; rewrite H0 in H; inversion_clear H as [|? H1]; inversion_clear H1. Qed. End Cutting. @@ -2300,9 +2303,9 @@ Section Combining. Lemma combine_firstn_l : forall (l : list A) (l' : list B), combine l l' = combine l (firstn (length l) l'). Proof. - induction l as [| x l IHl]; intros l'; [reflexivity|]. + intro l; induction l as [| x l IHl]; intros l'; [reflexivity|]. destruct l' as [| x' l']; [reflexivity|]. - simpl. specialize IHl with (l':=l'). rewrite <- IHl. + simpl. specialize IHl with l'. rewrite <- IHl. reflexivity. Qed. @@ -2313,14 +2316,14 @@ Section Combining. induction l' as [| x' l' IHl']; intros l. - simpl. apply combine_nil. - destruct l as [| x l]; [reflexivity|]. - simpl. specialize IHl' with (l:=l). rewrite <- IHl'. + simpl. specialize IHl' with l. rewrite <- IHl'. reflexivity. Qed. Lemma combine_firstn : forall (l : list A) (l' : list B) (n : nat), firstn n (combine l l') = combine (firstn n l) (firstn n l'). Proof. - induction l as [| x l IHl]; intros l' n. + intro l; induction l as [| x l IHl]; intros l' n. - simpl. repeat (rewrite firstn_nil). reflexivity. - destruct l' as [| x' l']. + simpl. repeat (rewrite firstn_nil). rewrite combine_nil. reflexivity. @@ -2353,7 +2356,7 @@ Section Add. Lemma Add_split a l l' : Add a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2. Proof. - induction 1. + induction 1 as [l|x ? ? ? IHAdd]. - exists nil; exists l; split; trivial. - destruct IHAdd as (l1 & l2 & Hl & Hl'). exists (x::l1); exists l2; split; simpl; f_equal; trivial. @@ -2362,7 +2365,7 @@ Section Add. Lemma Add_in a l l' : Add a l l' -> forall x, In x l' <-> In x (a::l). Proof. - induction 1; intros; simpl in *; rewrite ?IHAdd; tauto. + induction 1 as [|? ? ? ? IHAdd]; intros; simpl in *; rewrite ?IHAdd; tauto. Qed. Lemma Add_length a l l' : Add a l l' -> length l' = S (length l). @@ -2437,7 +2440,7 @@ Section ReDun. Lemma NoDup_rev l : NoDup l -> NoDup (rev l). Proof. - induction l; simpl; intros Hnd; [ constructor | ]. + induction l as [|a l IHl]; simpl; intros Hnd; [ constructor | ]. inversion_clear Hnd as [ | ? ? Hnin Hndl ]. assert (Add a (rev l) (rev l ++ a :: nil)) as Hadd by (rewrite <- (app_nil_r (rev l)) at 1; apply Add_app). @@ -2447,10 +2450,10 @@ Section ReDun. Lemma NoDup_filter f l : NoDup l -> NoDup (filter f l). Proof. - induction l; simpl; intros Hnd; auto. + induction l as [|a l IHl]; simpl; intros Hnd; auto. apply NoDup_cons_iff in Hnd. destruct (f a); [ | intuition ]. - apply NoDup_cons_iff; split; intuition. + apply NoDup_cons_iff; split; [intro H|]; intuition. apply filter_In in H; intuition. Qed. @@ -2464,7 +2467,7 @@ Section ReDun. | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs) end. - Lemma nodup_fixed_point : forall (l : list A), + Lemma nodup_fixed_point (l : list A) : NoDup l -> nodup l = l. Proof. induction l as [| x l IHl]; [auto|]. intros H. @@ -2512,7 +2515,7 @@ Section ReDun. - rewrite NoDup_cons_iff, Hrec, (count_occ_not_In decA). clear Hrec. split. + intros (Ha, H) x. simpl. destruct (decA a x); auto. subst; now rewrite Ha. - + split. + + intro H; split. * specialize (H a). rewrite count_occ_cons_eq in H; trivial. now inversion H. * intros x. specialize (H x). simpl in *. destruct (decA a x); auto. @@ -2547,7 +2550,7 @@ Section ReDun. * elim Hal. eapply nth_error_In; eauto. * elim Hal. eapply nth_error_In; eauto. * f_equal. apply IH; auto with arith. } - { induction l as [|a l]; intros H; constructor. + { induction l as [|a l IHl]; intros H; constructor. * intro Ha. apply In_nth_error in Ha. destruct Ha as (n,Hn). assert (n < length l) by (now rewrite <- nth_error_Some, Hn). specialize (H 0 (S n)). simpl in H. discriminate H; auto with arith. @@ -2567,7 +2570,7 @@ Section ReDun. * elim Hal. subst a. apply nth_In; auto with arith. * elim Hal. subst a. apply nth_In; auto with arith. * f_equal. apply IH; auto with arith. } - { induction l as [|a l]; intros H; constructor. + { induction l as [|a l IHl]; intros H; constructor. * intro Ha. eapply In_nth in Ha. destruct Ha as (n & Hn & Hn'). specialize (H 0 (S n)). simpl in H. discriminate H; eauto with arith. * apply IHl. @@ -2591,7 +2594,7 @@ Section ReDun. NoDup l -> length l' <= length l -> incl l l' -> incl l' l. Proof. intros N. revert l'. induction N as [|a l Hal N IH]. - - destruct l'; easy. + - intro l'; destruct l'; easy. - intros l' E H x Hx. destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } rewrite (Add_in AD) in Hx. simpl in Hx. @@ -2604,7 +2607,7 @@ Section ReDun. Lemma NoDup_incl_NoDup (l l' : list A) : NoDup l -> length l' <= length l -> incl l l' -> NoDup l'. Proof. - revert l'; induction l; simpl; intros l' Hnd Hlen Hincl. + revert l'; induction l as [|a l IHl]; simpl; intros l' Hnd Hlen Hincl. - now destruct l'; inversion Hlen. - assert (In a l') as Ha by now apply Hincl; left. apply in_split in Ha as [l1' [l2' ->]]. @@ -2614,7 +2617,7 @@ Section ReDun. * rewrite app_length. rewrite app_length in Hlen; simpl in Hlen; rewrite Nat.add_succ_r in Hlen. now apply Nat.succ_le_mono. - * apply incl_Add_inv with (u:= l1' ++ l2') in Hincl; auto. + * apply (incl_Add_inv (u:= l1' ++ l2')) in Hincl; auto. apply Add_app. + intros Hnin'. assert (incl (a :: l) (l1' ++ l2')) as Hincl''. @@ -2663,13 +2666,13 @@ Section NatSeq. Lemma seq_length : forall len start, length (seq start len) = len. Proof. - induction len; simpl; auto. + intro len; induction len; simpl; auto. Qed. Lemma seq_nth : forall len start n d, n < len -> nth n (seq start len) d = start+n. Proof. - induction len; intros. + intro len; induction len as [|len IHlen]; intros start n d H. inversion H. simpl seq. destruct n; simpl. @@ -2680,7 +2683,7 @@ Section NatSeq. Lemma seq_shift : forall len start, map S (seq start len) = seq (S start) len. Proof. - induction len; simpl; auto. + intro len; induction len as [|len IHlen]; simpl; auto. intros. rewrite IHlen. auto with arith. @@ -2689,7 +2692,7 @@ Section NatSeq. Lemma in_seq len start n : In n (seq start len) <-> start <= n < start+len. Proof. - revert start. induction len; simpl; intros. + revert start. induction len as [|len IHlen]; simpl; intros. - rewrite <- plus_n_O. split;[easy|]. intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')). - rewrite IHlen, <- plus_n_Sm; simpl; split. @@ -2706,7 +2709,7 @@ Section NatSeq. Lemma seq_app : forall len1 len2 start, seq start (len1 + len2) = seq start len1 ++ seq (start + len1) len2. Proof. - induction len1 as [|len1' IHlen]; intros; simpl in *. + intro len1; induction len1 as [|len1' IHlen]; intros; simpl in *. - now rewrite Nat.add_0_r. - now rewrite Nat.add_succ_r, IHlen. Qed. @@ -2751,7 +2754,7 @@ Section Exists_Forall. split. - intros HE; apply Exists_exists in HE. destruct HE as [a [Hin HP]]. - apply In_nth with (d := a) in Hin; destruct Hin as [i [Hl Heq]]. + apply (In_nth _ _ a) in Hin; destruct Hin as [i [Hl Heq]]. rewrite <- Heq in HP. now exists i; exists a. - intros [i [d [Hl HP]]]. @@ -2827,23 +2830,23 @@ Section Exists_Forall. Proof. split. - intros HF i d Hl. - apply Forall_forall with (x := nth i l d) in HF. + apply (Forall_forall l). assumption. apply nth_In; assumption. - intros HF. apply Forall_forall; intros a Hin. - apply In_nth with (d := a) in Hin; destruct Hin as [i [Hl Heq]]. + apply (In_nth _ _ a) in Hin; destruct Hin as [i [Hl Heq]]. rewrite <- Heq; intuition. Qed. Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a. Proof. - intros; inversion H; trivial. + intros a l H; inversion H; trivial. Qed. Theorem Forall_inv_tail : forall (a:A) l, Forall (a :: l) -> Forall l. Proof. - intros; inversion H; trivial. + intros a l H; inversion H; trivial. Qed. Lemma Forall_app l1 l2 : @@ -2868,14 +2871,14 @@ Section Exists_Forall. Lemma Forall_rect : forall (Q : list A -> Type), Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall l -> Q l. Proof. - intros Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption. + intros Q H H' l; induction l; intro; [|eapply H', Forall_inv]; eassumption. Qed. Lemma Forall_dec : (forall x:A, {P x} + { ~ P x }) -> forall l:list A, {Forall l} + {~ Forall l}. Proof. - intro Pdec. induction l as [|a l' Hrec]. + intros Pdec l. induction l as [|a l' Hrec]. - left. apply Forall_nil. - destruct Hrec as [Hl'|Hl']. + destruct (Pdec a) as [Ha|Ha]. @@ -2894,7 +2897,7 @@ Section Exists_Forall. Proof. intros Hincl HF. apply Forall_forall; intros a Ha. - apply Forall_forall with (x:=a) in HF; intuition. + apply (Forall_forall l1); intuition. Qed. End One_predicate. @@ -2909,7 +2912,7 @@ Section Exists_Forall. forall l, Exists P l -> Exists Q l. Proof. intros P Q H l H0. - induction H0. + induction H0 as [x l H0|x l H0 IHExists]. apply (Exists_cons_hd Q x l (H x H0)). apply (Exists_cons_tl x IHExists). Qed. @@ -2917,7 +2920,7 @@ Section Exists_Forall. Lemma Exists_or : forall (P Q : A -> Prop) l, Exists P l \/ Exists Q l -> Exists (fun x => P x \/ Q x) l. Proof. - induction l; intros [H | H]; inversion H; subst. + intros P Q l; induction l as [|a l IHl]; intros [H | H]; inversion H; subst. 1,3: apply Exists_cons_hd; auto. all: apply Exists_cons_tl, IHl; auto. Qed. @@ -2925,7 +2928,8 @@ Section Exists_Forall. Lemma Exists_or_inv : forall (P Q : A -> Prop) l, Exists (fun x => P x \/ Q x) l -> Exists P l \/ Exists Q l. Proof. - induction l; intro Hl; inversion Hl as [ ? ? H | ? ? H ]; subst. + intros P Q l; induction l as [|a l IHl]; + intro Hl; inversion Hl as [ ? ? H | ? ? H ]; subst. - inversion H; now repeat constructor. - destruct (IHl H); now repeat constructor. Qed. @@ -2939,13 +2943,13 @@ Section Exists_Forall. Lemma Forall_and : forall (P Q : A -> Prop) l, Forall P l -> Forall Q l -> Forall (fun x => P x /\ Q x) l. Proof. - induction l; intros HP HQ; constructor; inversion HP; inversion HQ; auto. + intros P Q l; induction l; intros HP HQ; constructor; inversion HP; inversion HQ; auto. Qed. Lemma Forall_and_inv : forall (P Q : A -> Prop) l, Forall (fun x => P x /\ Q x) l -> Forall P l /\ Forall Q l. Proof. - induction l; intro Hl; split; constructor; inversion Hl; firstorder. + intros P Q l; induction l; intro Hl; split; constructor; inversion Hl; firstorder. Qed. Lemma Forall_Exists_neg (P:A->Prop)(l:list A) : @@ -2975,7 +2979,7 @@ Section Exists_Forall. Exists (fun x => ~ P x) l. Proof. intro Dec. - apply Exists_Forall_neg; intros. + apply Exists_Forall_neg; intros x. destruct (Dec x); auto. Qed. @@ -3001,7 +3005,7 @@ Hint Constructors Forall : core. Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, (exists k, Forall (P k) l) -> Forall (fun x => exists k, P k x) l. Proof. - induction l; intros [k HF]; constructor; inversion_clear HF. + intros P l; induction l as [|a l IHl]; intros [k HF]; constructor; inversion_clear HF. - now exists k. - now apply IHl; exists k. Qed. @@ -3009,7 +3013,7 @@ Qed. Lemma Forall_image A B : forall (f : A -> B) l, Forall (fun y => exists x, y = f x) l <-> exists l', l = map f l'. Proof. - induction l; split; intros HF. + intros f l; induction l as [|a l IHl]; split; intros HF. - exists nil; reflexivity. - constructor. - inversion_clear HF as [| ? ? [x Hx] HFtl]; subst. @@ -3026,7 +3030,7 @@ Qed. Lemma concat_nil_Forall A : forall (l : list (list A)), concat l = nil <-> Forall (fun x => x = nil) l. Proof. - induction l; simpl; split; intros Hc; auto. + intro l; induction l as [|a l IHl]; simpl; split; intros Hc; auto. - apply app_eq_nil in Hc. constructor; firstorder. - inversion Hc; subst; simpl. @@ -3069,9 +3073,9 @@ Section Forall2. Forall2 (l1 ++ l2) l' -> exists l1' l2', Forall2 l1 l1' /\ Forall2 l2 l2' /\ l' = l1' ++ l2'. Proof. - induction l1; intros. + intro l1; induction l1 as [|a l1 IHl1]; intros l2 l' H. exists [], l'; auto. - simpl in H; inversion H; subst; clear H. + simpl in H; inversion H as [|? y ? ? ? H4]; subst; clear H. apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->). exists (y::l1'), l2'; simpl; auto. Qed. @@ -3080,9 +3084,9 @@ Section Forall2. Forall2 l (l1' ++ l2') -> exists l1 l2, Forall2 l1 l1' /\ Forall2 l2 l2' /\ l = l1 ++ l2. Proof. - induction l1'; intros. + intro l1'; induction l1' as [|a l1' IHl1']; intros l2' l H. exists [], l; auto. - simpl in H; inversion H; subst; clear H. + simpl in H; inversion H as [|x ? ? ? ? H4]; subst; clear H. apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->). exists (x::l1), l2; simpl; auto. Qed. @@ -3090,7 +3094,7 @@ Section Forall2. Theorem Forall2_app : forall l1 l2 l1' l2', Forall2 l1 l1' -> Forall2 l2 l2' -> Forall2 (l1 ++ l2) (l1' ++ l2'). Proof. - intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto. + intros l1 l2 l1' l2' H H0. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto. Qed. End Forall2. @@ -3133,7 +3137,7 @@ Section ForallPairs. Lemma ForallPairs_ForallOrdPairs l: ForallPairs l -> ForallOrdPairs l. Proof. - induction l; auto. intros H. + induction l as [|a l IHl]; auto. intros H. constructor. apply <- Forall_forall. intros; apply H; simpl; auto. apply IHl. red; intros; apply H; simpl; auto. @@ -3173,7 +3177,7 @@ Section Repeat. Lemma repeat_cons n a : a :: repeat a n = repeat a n ++ (a :: nil). Proof. - induction n; simpl. + induction n as [|n IHn]; simpl. - reflexivity. - f_equal; apply IHn. Qed. @@ -3221,7 +3225,7 @@ End Repeat. Lemma repeat_to_concat A n (a:A) : repeat a n = concat (repeat [a] n). Proof. - induction n; simpl. + induction n as [|n IHn]; simpl. - reflexivity. - f_equal; apply IHn. Qed. @@ -3234,7 +3238,7 @@ Definition list_sum l := fold_right plus 0 l. Lemma list_sum_app : forall l1 l2, list_sum (l1 ++ l2) = list_sum l1 + list_sum l2. Proof. -induction l1; intros l2; [ reflexivity | ]. +intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. simpl; rewrite IHl1. apply Nat.add_assoc. Qed. @@ -3246,14 +3250,14 @@ Definition list_max l := fold_right max 0 l. Lemma list_max_app : forall l1 l2, list_max (l1 ++ l2) = max (list_max l1) (list_max l2). Proof. -induction l1; intros l2; [ reflexivity | ]. +intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. now simpl; rewrite IHl1, Nat.max_assoc. Qed. Lemma list_max_le : forall l n, list_max l <= n <-> Forall (fun k => k <= n) l. Proof. -induction l; simpl; intros n; split; intros H; intuition. +intro l; induction l as [|a l IHl]; simpl; intros n; split; intros H; intuition. - apply Nat.max_lub_iff in H. now constructor; [ | apply IHl ]. - inversion_clear H as [ | ? ? Hle HF ]. @@ -3263,7 +3267,7 @@ Qed. Lemma list_max_lt : forall l n, l <> nil -> list_max l < n <-> Forall (fun k => k < n) l. Proof. -induction l; simpl; intros n Hnil; split; intros H; intuition. +intro l; induction l as [|a l IHl]; simpl; intros n Hnil; split; intros H; intuition. - destruct l. + repeat constructor. now simpl in H; rewrite Nat.max_0_r in H. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 23d486ff90..a918d1ecd7 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -104,7 +104,7 @@ Section Dependent_Equality. Lemma eq_dep_dep1 : forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y. Proof. - destruct 1. + intros p; destruct 1. apply eq_dep1_intro with (eq_refl p). simpl; trivial. Qed. @@ -120,7 +120,7 @@ Lemma eq_sigT_eq_dep : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), existT P p x = existT P q y -> eq_dep p x q y. Proof. - intros. + intros * H. dependent rewrite H. apply eq_dep_intro. Qed. @@ -145,7 +145,7 @@ Lemma eq_sig_eq_dep : forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q), exist P p x = exist P q y -> eq_dep p x q y. Proof. - intros. + intros * H. dependent rewrite H. apply eq_dep_intro. Qed. @@ -168,10 +168,10 @@ Qed. Set Implicit Arguments. -Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> - {H:x1=x2 | rew H in H1 = H2}. +Lemma eq_sigT_sig_eq X P (x1 x2:X) H1 H2 : + existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}. Proof. - intros; split; intro H. + split; intro H. - change x2 with (projT1 (existT P x2 H2)). change H2 with (projT2 (existT P x2 H2)) at 5. destruct H. simpl. @@ -181,19 +181,17 @@ Proof. reflexivity. Defined. -Lemma eq_sigT_fst : - forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2. +Lemma eq_sigT_fst X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2) : + x1 = x2. Proof. - intros. change x2 with (projT1 (existT P x2 H2)). destruct H. reflexivity. Defined. -Lemma eq_sigT_snd : - forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2. +Lemma eq_sigT_snd X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2) : + rew (eq_sigT_fst H) in H1 = H2. Proof. - intros. unfold eq_sigT_fst. change x2 with (projT1 (existT P x2 H2)). change H2 with (projT2 (existT P x2 H2)) at 3. @@ -201,19 +199,17 @@ Proof. reflexivity. Defined. -Lemma eq_sig_fst : - forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2. +Lemma eq_sig_fst X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2) : + x1 = x2. Proof. - intros. change x2 with (proj1_sig (exist P x2 H2)). destruct H. reflexivity. Defined. -Lemma eq_sig_snd : - forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2. +Lemma eq_sig_snd X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2) : + rew (eq_sig_fst H) in H1 = H2. Proof. - intros. unfold eq_sig_fst, eq_ind. change x2 with (proj1_sig (exist P x2 H2)). change H2 with (proj2_sig (exist P x2 H2)) at 3. @@ -283,7 +279,7 @@ Section Equivalences. Lemma eq_rect_eq_on__eq_dep_eq_on (p : U) (P : U -> Type) (x : P p) : Eq_rect_eq_on p P x -> Eq_dep_eq_on P p x. Proof. - intros eq_rect_eq; red; intros. + intros eq_rect_eq; red; intros y H. symmetry; apply (eq_rect_eq_on__eq_dep1_eq_on _ _ _ eq_rect_eq). apply eq_dep_sym in H; apply eq_dep_dep1; trivial. Qed. @@ -299,7 +295,7 @@ Section Equivalences. Proof. intro eq_dep_eq; red. elim p1 using eq_indd. - intros; apply eq_dep_eq. + intros p2; apply eq_dep_eq. elim p2 using eq_indd. apply eq_dep_intro. Qed. diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 6ef5fa7d4c..4af90ae12d 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -46,9 +46,8 @@ Section EqdepDec. Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' := eq_ind _ (fun a => a = y') eq2 _ eq1. - Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = eq_refl y. + Remark trans_sym_eq (x y:A) (u:x = y) : comp u u = eq_refl y. Proof. - intros. case u; trivial. Qed. @@ -62,8 +61,7 @@ Section EqdepDec. | or_intror neqxy => False_ind _ (neqxy u) end. - Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v. - intros. + Let nu_constant (y:A) (u v:x = y) : nu u = nu v. unfold nu. destruct (eq_dec y) as [Heq|Hneq]. - reflexivity. @@ -75,27 +73,23 @@ Section EqdepDec. Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v. - Remark nu_left_inv_on : forall (y:A) (u:x = y), nu_inv (nu u) = u. + Remark nu_left_inv_on (y:A) (u:x = y) : nu_inv (nu u) = u. Proof. - intros. case u; unfold nu_inv. apply trans_sym_eq. Qed. - Theorem eq_proofs_unicity_on : forall (y:A) (p1 p2:x = y), p1 = p2. + Theorem eq_proofs_unicity_on (y:A) (p1 p2:x = y) : p1 = p2. Proof. - intros. - elim nu_left_inv_on with (u := p1). - elim nu_left_inv_on with (u := p2). + elim (nu_left_inv_on p1). + elim (nu_left_inv_on p2). elim nu_constant with y p1 p2. reflexivity. Qed. - Theorem K_dec_on : - forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p. + Theorem K_dec_on (P:x = x -> Prop) (H:P (eq_refl x)) (p:x = x) : P p. Proof. - intros. elim eq_proofs_unicity_on with x (eq_refl x) p. trivial. Qed. @@ -112,11 +106,10 @@ Section EqdepDec. end. - Theorem inj_right_pair_on : - forall (P:A -> Prop) (y y':P x), - ex_intro P x y = ex_intro P x y' -> y = y'. + Theorem inj_right_pair_on (P:A -> Prop) (y y':P x) : + ex_intro P x y = ex_intro P x y' -> y = y'. Proof. - intros. + intros H. cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y). - simpl. destruct (eq_dec x) as [Heq|Hneq]. @@ -156,14 +149,11 @@ Proof (@inj_right_pair_on A x (eq_dec x)). Require Import EqdepFacts. (** We deduce axiom [K] for (decidable) types *) -Theorem K_dec_type : - forall A:Type, - (forall x y:A, {x = y} + {x <> y}) -> - forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. +Theorem K_dec_type (A:Type) (eq_dec:forall x y:A, {x = y} + {x <> y}) (x:A) + (P:x = x -> Prop) (H:P (eq_refl x)) (p:x = x) : P p. Proof. - intros A eq_dec x P H p. - elim p using K_dec; intros. - - case (eq_dec x0 y); [left|right]; assumption. + elim p using K_dec. + - intros x0 y; case (eq_dec x0 y); [left|right]; assumption. - trivial. Qed. @@ -259,7 +249,7 @@ Module DecidableEqDep (M:DecidableType). ex_intro P x p = ex_intro P x q -> p = q. Proof. intros. - apply inj_right_pair with (A:=U). + apply inj_right_pair. - intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. - assumption. Qed. @@ -377,7 +367,7 @@ Defined. Lemma UIP_refl_nat (n:nat) (x : n = n) : x = eq_refl. Proof. - induction n. + induction n as [|n IHn]. - change (match 0 as n return 0=n -> Prop with | 0 => fun x => x = eq_refl | _ => fun _ => True diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 28ba9daed0..039e920c29 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -94,7 +94,7 @@ Defined. Definition discr n : { p:positive | n = pos p } + { n = 0 }. Proof. - destruct n; auto. + destruct n as [|p]; auto. left; exists p; auto. Defined. @@ -486,7 +486,7 @@ Qed. Lemma size_le n : 2^(size n) <= succ_double n. Proof. - destruct n. discriminate. simpl. + destruct n as [|p]. discriminate. simpl. change (2^Pos.size p <= Pos.succ (p~0))%positive. apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le. Qed. @@ -512,10 +512,10 @@ Qed. Lemma even_spec n : even n = true <-> Even n. Proof. - destruct n. + destruct n as [|p]. split. now exists 0. trivial. - destruct p; simpl; split; try easy. + destruct p as [p|p|]; simpl; split; try easy. intros (m,H). now destruct m. now exists (pos p). intros (m,H). now destruct m. @@ -523,10 +523,10 @@ Qed. Lemma odd_spec n : odd n = true <-> Odd n. Proof. - destruct n. + destruct n as [|p]. split. discriminate. intros (m,H). now destruct m. - destruct p; simpl; split; try easy. + destruct p as [p|p|]; simpl; split; try easy. now exists (pos p). intros (m,H). now destruct m. now exists 0. @@ -537,7 +537,8 @@ Qed. Theorem pos_div_eucl_spec (a:positive)(b:N) : let (q,r) := pos_div_eucl a b in pos a = q * b + r. Proof. - induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. + induction a as [a IHa|a IHa|]; + cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. (* a~1 *) destruct pos_div_eucl as (q,r). change (pos a~1) with (succ_double (pos a)). @@ -579,7 +580,8 @@ Theorem pos_div_eucl_remainder (a:positive) (b:N) : b<>0 -> snd (pos_div_eucl a b) < b. Proof. intros Hb. - induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. + induction a as [a IHa|a IHa|]; + cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. (* a~1 *) destruct pos_div_eucl as (q,r); simpl in *. case leb_spec; intros H; simpl; trivial. @@ -612,7 +614,7 @@ Qed. Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. Proof. - destruct n. reflexivity. + destruct n as [|p]. reflexivity. unfold sqrtrem, sqrt, Pos.sqrt. destruct (Pos.sqrtrem p) as (s,r). now destruct r. Qed. @@ -620,7 +622,7 @@ Qed. Lemma sqrtrem_spec n : let (s,r) := sqrtrem n in n = s*s + r /\ r <= 2*s. Proof. - destruct n. now split. + destruct n as [|p]. now split. generalize (Pos.sqrtrem_spec p). simpl. destruct 1; simpl; subst; now split. Qed. @@ -628,7 +630,7 @@ Qed. Lemma sqrt_spec n : 0<=n -> let s := sqrt n in s*s <= n < (succ s)*(succ s). Proof. - intros _. destruct n. now split. apply (Pos.sqrt_spec p). + intros _. destruct n as [|p]. now split. apply (Pos.sqrt_spec p). Qed. Lemma sqrt_neg n : n<0 -> sqrt n = 0. @@ -749,7 +751,7 @@ Lemma shiftr_spec a n m : 0<=m -> testbit (shiftr a n) m = testbit a (m+n). Proof. intros _. revert a m. - induction n using peano_ind; intros a m. now rewrite add_0_r. + induction n as [|n IHn] using peano_ind; intros a m. now rewrite add_0_r. rewrite add_comm, add_succ_l, add_comm, <- add_succ_l. now rewrite <- IHn, testbit_succ_r_div2, shiftr_succ_r by apply le_0_l. Qed. @@ -771,10 +773,10 @@ Lemma shiftl_spec_low a n m : m<n -> testbit (shiftl a n) m = false. Proof. revert a m. - induction n using peano_ind; intros a m H. + induction n as [|n IHn] using peano_ind; intros a m H. elim (le_0_l m). now rewrite compare_antisym, H. rewrite shiftl_succ_r. - destruct m. now destruct (shiftl a n). + destruct m as [|p]. now destruct (shiftl a n). rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l. apply IHn. apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl. @@ -902,8 +904,8 @@ Qed. Lemma pos_pred_shiftl_low : forall p n m, m<n -> testbit (Pos.pred_N (Pos.shiftl p n)) m = true. Proof. - induction n using peano_ind. - now destruct m. + intros p n; induction n as [|n IHn] using peano_ind. + now intro m; destruct m. intros m H. unfold Pos.shiftl. destruct n as [|n]; simpl in *. destruct m. now destruct p. elim (Pos.nlt_1_r _ H). @@ -921,7 +923,7 @@ Lemma pos_pred_shiftl_high : forall p n m, n<=m -> testbit (Pos.pred_N (Pos.shiftl p n)) m = testbit (shiftl (Pos.pred_N p) n) m. Proof. - induction n using peano_ind; intros m H. + intros p n; induction n as [|n IHn] using peano_ind; intros m H. unfold shiftl. simpl. now destruct (Pos.pred_N p). rewrite shiftl_succ_r. destruct n as [|n]. @@ -945,11 +947,11 @@ Qed. (** ** Properties of [iter] *) -Lemma iter_swap_gen : forall A B (f:A -> B) (g:A -> A) (h:B -> B), +Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : (forall a, f (g a) = h (f a)) -> forall n a, f (iter n g a) = iter n h (f a). Proof. - destruct n; simpl; intros; rewrite ?H; trivial. + intros H n; destruct n; simpl; intros; rewrite ?H; trivial. now apply Pos.iter_swap_gen. Qed. @@ -964,7 +966,7 @@ Theorem iter_succ : forall n (A:Type) (f:A -> A) (x:A), iter (succ n) f x = f (iter n f x). Proof. - destruct n; intros; simpl; trivial. + intro n; destruct n; intros; simpl; trivial. now apply Pos.iter_succ. Qed. @@ -979,17 +981,16 @@ Theorem iter_add : forall p q (A:Type) (f:A -> A) (x:A), iter (p+q) f x = iter p f (iter q f x). Proof. - induction p using peano_ind; intros; trivial. + intro p; induction p as [|p IHp] using peano_ind; intros; trivial. now rewrite add_succ_l, !iter_succ, IHp. Qed. -Theorem iter_ind : - forall (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop), +Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop) : P 0 a -> (forall n a', P n a' -> P (succ n) (f a')) -> forall n, P n (iter n f a). Proof. - induction n using peano_ind; trivial. + intros ? ? n; induction n using peano_ind; trivial. rewrite iter_succ; auto. Qed. @@ -998,7 +999,7 @@ Theorem iter_invariant : (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter n f x). Proof. - intros; apply iter_ind with (P := fun _ => Inv); trivial. + intros; apply iter_ind; trivial. Qed. End N. diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index 43fa8516d3..48df5fe884 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -70,7 +70,7 @@ Lemma inj_sub a a' : N.to_nat (a - a') = N.to_nat a - N.to_nat a'. Proof. destruct a as [|a], a' as [|a']; simpl; rewrite ?Nat.sub_0_r; trivial. - destruct (Pos.compare_spec a a'). + destruct (Pos.compare_spec a a') as [H|H|H]. - subst. now rewrite Pos.sub_mask_diag, Nat.sub_diag. - rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H. simpl; symmetry; apply Nat.sub_0_le. now apply Nat.lt_le_incl. @@ -93,8 +93,8 @@ Qed. Lemma inj_compare a a' : (a ?= a')%N = (N.to_nat a ?= N.to_nat a'). Proof. - destruct a, a'; simpl; trivial. - - now destruct (Pos2Nat.is_succ p) as (n,->). + destruct a as [|p], a' as [|p']; simpl; trivial. + - now destruct (Pos2Nat.is_succ p') as (n,->). - now destruct (Pos2Nat.is_succ p) as (n,->). - apply Pos2Nat.inj_compare. Qed. diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index 8c4d072114..55c4b193a5 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -58,7 +58,7 @@ Qed. Theorem succ_add_discr : forall n m, m ~= S (n + m). Proof. -intro n; induct m. +intros n m; induct m. apply neq_sym. apply neq_succ_0. intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. unfold not in IH; now apply IH. diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v index 7c74de6364..d0ef94d1a4 100644 --- a/theories/Numbers/Natural/Abstract/NAddOrder.v +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -19,7 +19,7 @@ Include NOrderProp N. Theorem le_add_r : forall n m, n <= n + m. Proof. -intro n; induct m. +intros n m; induct m. rewrite add_0_r; now apply eq_le_incl. intros m IH. rewrite add_succ_r; now apply le_le_succ_r. Qed. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index a141cb7c0d..185a5974c2 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -39,7 +39,7 @@ Qed. Theorem le_0_l : forall n, 0 <= n. Proof. -nzinduct n. +intro n; nzinduct n. now apply eq_le_incl. intro n; split. apply le_le_succ_r. @@ -79,21 +79,21 @@ Proof. intro H; apply (neq_succ_0 0). apply H. Qed. -Theorem neq_0_r : forall n, n ~= 0 <-> exists m, n == S m. +Theorem neq_0_r n : n ~= 0 <-> exists m, n == S m. Proof. cases n. split; intro H; [now elim H | destruct H as [m H]; symmetry in H; false_hyp H neq_succ_0]. intro n; split; intro H; [now exists n | apply neq_succ_0]. Qed. -Theorem zero_or_succ : forall n, n == 0 \/ exists m, n == S m. +Theorem zero_or_succ n : n == 0 \/ exists m, n == S m. Proof. cases n. now left. intro n; right; now exists n. Qed. -Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1. +Theorem eq_pred_0 n : P n == 0 <-> n == 0 \/ n == 1. Proof. cases n. rewrite pred_0. now split; [left|]. @@ -103,16 +103,16 @@ intros [H|H]. elim (neq_succ_0 _ H). apply succ_inj_wd. now rewrite <- one_succ. Qed. -Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n. +Theorem succ_pred n : n ~= 0 -> S (P n) == n. Proof. cases n. intro H; exfalso; now apply H. intros; now rewrite pred_succ. Qed. -Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m. +Theorem pred_inj n m : n ~= 0 -> m ~= 0 -> P n == P m -> n == m. Proof. -intros n m; cases n. +cases n. intros H; exfalso; now apply H. intros n _; cases m. intros H; exfalso; now apply H. @@ -134,7 +134,7 @@ Proof. rewrite one_succ. intros until 3. assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))]. -induct n; [ | intros n [IH1 IH2]]; auto. +intro n; induct n; [ | intros n [IH1 IH2]]; auto. Qed. End PairInduction. @@ -151,10 +151,10 @@ Theorem two_dim_induction : (forall n m, R n m -> R n (S m)) -> (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m. Proof. -intros H1 H2 H3. induct n. -induct m. +intros H1 H2 H3. intro n; induct n. +intro m; induct m. exact H1. exact (H2 0). -intros n IH. induct m. +intros n IH. intro m; induct m. now apply H3. exact (H2 (S n)). Qed. @@ -171,8 +171,8 @@ Theorem double_induction : (forall n, R (S n) 0) -> (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m. Proof. -intros H1 H2 H3; induct n; auto. -intros n H; cases m; auto. +intros H1 H2 H3 n; induct n; auto. +intros n H m; cases m; auto. Qed. End DoubleInduction. diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v index 6e557a567e..313b9adfd1 100644 --- a/theories/Numbers/Natural/Abstract/NBits.v +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -190,7 +190,7 @@ Qed. Lemma bit0_odd : forall a, a.[0] = odd a. Proof. - intros. symmetry. + intros a. symmetry. destruct (exists_div2 a) as (a' & b & EQ). rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. destruct b; simpl; apply odd_1 || apply odd_0. @@ -272,14 +272,14 @@ Qed. Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n]. Proof. - intros. + intros a n m ?. rewrite <- (sub_add n m) at 1 by order'. now rewrite mul_pow2_bits_add. Qed. Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false. Proof. - intros. apply testbit_false. + intros a n m H. apply testbit_false. rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc. rewrite div_mul by order_nz. rewrite <- (succ_pred (n-m)). rewrite pow_succ_r. @@ -370,7 +370,10 @@ Qed. Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. -Ltac bitwise := apply bits_inj; intros ?m; autorewrite with bitwise. +Tactic Notation "bitwise" "as" simple_intropattern(m) + := apply bits_inj; intros m; autorewrite with bitwise. + +Ltac bitwise := bitwise as ?m. (** The streams of bits that correspond to a natural numbers are exactly the ones that are always 0 after some point *) @@ -418,7 +421,7 @@ Qed. Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n. Proof. - intros. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m) as [H|H]. now rewrite shiftl_spec_high', mul_pow2_bits_high. now rewrite shiftl_spec_low, mul_pow2_bits_low. @@ -455,7 +458,7 @@ Qed. Lemma shiftr_shiftl_l : forall a n m, m<=n -> (a << n) >> m == a << (n-m). Proof. - intros. + intros a n m ?. rewrite shiftr_div_pow2, !shiftl_mul_pow2. rewrite <- (sub_add m n) at 1 by trivial. now rewrite pow_add_r, mul_assoc, div_mul by order_nz. @@ -464,7 +467,7 @@ Qed. Lemma shiftr_shiftl_r : forall a n m, n<=m -> (a << n) >> m == a >> (m-n). Proof. - intros. + intros a n m ?. rewrite !shiftr_div_pow2, shiftl_mul_pow2. rewrite <- (sub_add n m) at 1 by trivial. rewrite pow_add_r, (mul_comm (2^(m-n))). @@ -630,7 +633,7 @@ Qed. Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. Proof. - intros a b H. bitwise. + intros a b H. bitwise as m. apply (orb_false_iff a.[m] b.[m]). now rewrite <- lor_spec, H, bits_0. Qed. @@ -638,7 +641,7 @@ Qed. Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. Proof. intros a b. split. - split. now apply lor_eq_0_l in H. + intro H; split. now apply lor_eq_0_l in H. rewrite lor_comm in H. now apply lor_eq_0_l in H. intros (EQ,EQ'). now rewrite EQ, lor_0_l. Qed. @@ -751,13 +754,13 @@ Proof. unfold clearbit. solve_proper. Qed. Lemma pow2_bits_true : forall n, (2^n).[n] = true. Proof. - intros. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. + intros n. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. now rewrite mul_pow2_bits_add, bit0_odd, odd_1. Qed. Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. Proof. - intros. + intros n m ?. rewrite <- (mul_1_l (2^n)). destruct (le_gt_cases n m). rewrite mul_pow2_bits_high; trivial. @@ -768,7 +771,7 @@ Qed. Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m. Proof. - intros. apply eq_true_iff_eq. rewrite eqb_eq. split. + intros n m. apply eq_true_iff_eq. rewrite eqb_eq. split. destruct (eq_decidable n m) as [H|H]. trivial. now rewrite (pow2_bits_false _ _ H). intros EQ. rewrite EQ. apply pow2_bits_true. @@ -813,7 +816,7 @@ Qed. Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. Proof. - intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). + intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). apply andb_false_r. Qed. @@ -830,7 +833,7 @@ Qed. Lemma shiftl_lxor : forall a b n, (lxor a b) << n == lxor (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', lxor_spec. now rewrite !shiftl_spec_low. @@ -845,7 +848,7 @@ Qed. Lemma shiftl_land : forall a b n, (land a b) << n == land (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', land_spec. now rewrite !shiftl_spec_low. @@ -860,7 +863,7 @@ Qed. Lemma shiftl_lor : forall a b n, (lor a b) << n == lor (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', lor_spec. now rewrite !shiftl_spec_low. @@ -875,7 +878,7 @@ Qed. Lemma shiftl_ldiff : forall a b n, (ldiff a b) << n == ldiff (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', ldiff_spec. now rewrite !shiftl_spec_low. @@ -944,7 +947,7 @@ Qed. Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false. Proof. - intros. + intros n m ?. destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv. now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0. apply bits_above_log2. @@ -973,7 +976,7 @@ Qed. Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a. Proof. - intros a n. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m). now rewrite 2 lnot_spec_high. now rewrite 2 lnot_spec_low, negb_involutive. @@ -994,7 +997,7 @@ Qed. Lemma lor_ones_low : forall a n, log2 a < n -> lor a (ones n) == ones n. Proof. - intros a n H. bitwise. destruct (le_gt_cases n m). + intros a n H. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. now rewrite ones_spec_low, orb_true_r. @@ -1002,7 +1005,7 @@ Qed. Lemma land_ones : forall a n, land a (ones n) == a mod 2^n. Proof. - intros a n. bitwise. destruct (le_gt_cases n m). + intros a n. bitwise as m. destruct (le_gt_cases n m). now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r. now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r. Qed. @@ -1017,7 +1020,7 @@ Qed. Lemma ldiff_ones_r : forall a n, ldiff a (ones n) == (a >> n) << n. Proof. - intros a n. bitwise. destruct (le_gt_cases n m). + intros a n. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial. rewrite sub_add; trivial. apply andb_true_r. now rewrite ones_spec_low, shiftl_spec_low, andb_false_r. @@ -1026,7 +1029,7 @@ Qed. Lemma ldiff_ones_r_low : forall a n, log2 a < n -> ldiff a (ones n) == 0. Proof. - intros a n H. bitwise. destruct (le_gt_cases n m). + intros a n H. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. now rewrite ones_spec_low, andb_false_r. @@ -1035,7 +1038,7 @@ Qed. Lemma ldiff_ones_l_low : forall a n, log2 a < n -> ldiff (ones n) a == lnot a n. Proof. - intros a n H. bitwise. destruct (le_gt_cases n m). + intros a n H. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. now rewrite ones_spec_low, lnot_spec_low. @@ -1044,7 +1047,7 @@ Qed. Lemma lor_lnot_diag : forall a n, lor a (lnot a n) == lor a (ones n). Proof. - intros a n. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m). rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. @@ -1059,7 +1062,7 @@ Qed. Lemma land_lnot_diag : forall a n, land a (lnot a n) == ldiff a (ones n). Proof. - intros a n. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m). rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. @@ -1074,7 +1077,7 @@ Qed. Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n -> lnot (lor a b) n == land (lnot a n) (lnot b n). Proof. - intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial. now apply lt_le_trans with n. now apply lt_le_trans with n. @@ -1084,7 +1087,7 @@ Qed. Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n -> lnot (land a b) n == lor (lnot a n) (lnot b n). Proof. - intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial. now apply lt_le_trans with n. now apply lt_le_trans with n. @@ -1094,7 +1097,7 @@ Qed. Lemma ldiff_land_low : forall a b n, log2 a < n -> ldiff a b == land a (lnot b n). Proof. - intros a b n Ha. bitwise. destruct (le_gt_cases n m). + intros a b n Ha. bitwise as m. destruct (le_gt_cases n m). rewrite (bits_above_log2 a m). trivial. now apply lt_le_trans with n. rewrite !lnot_spec_low; trivial. @@ -1103,7 +1106,7 @@ Qed. Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n -> lnot (ldiff a b) n == lor (lnot a n) b. Proof. - intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial. now apply lt_le_trans with n. now apply lt_le_trans with n. @@ -1113,7 +1116,7 @@ Qed. Lemma lxor_lnot_lnot : forall a b n, lxor (lnot a n) (lnot b n) == lxor a b. Proof. - intros a b n. bitwise. destruct (le_gt_cases n m). + intros a b n. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high; trivial. rewrite !lnot_spec_low, xorb_negb_negb; trivial. Qed. @@ -1121,7 +1124,7 @@ Qed. Lemma lnot_lxor_l : forall a b n, lnot (lxor a b) n == lxor (lnot a n) b. Proof. - intros a b n. bitwise. destruct (le_gt_cases n m). + intros a b n. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, lxor_spec; trivial. rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial. Qed. @@ -1129,7 +1132,7 @@ Qed. Lemma lnot_lxor_r : forall a b n, lnot (lxor a b) n == lxor a (lnot b n). Proof. - intros a b n. bitwise. destruct (le_gt_cases n m). + intros a b n. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, lxor_spec; trivial. rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial. Qed. @@ -1137,7 +1140,7 @@ Qed. Lemma lxor_lor : forall a b, land a b == 0 -> lxor a b == lor a b. Proof. - intros a b H. bitwise. + intros a b H. bitwise as m. assert (a.[m] && b.[m] = false) by now rewrite <- land_spec, H, bits_0. now destruct a.[m], b.[m]. @@ -1264,7 +1267,7 @@ Qed. Lemma add_carry_div2 : forall a b (c0:bool), (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. Proof. - intros. + intros a b c0. rewrite <- add3_bits_div2. rewrite (add_comm ((a/2)+_)). rewrite <- div_add by order'. @@ -1312,7 +1315,7 @@ Proof. apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'. exists (c0 + 2*c). repeat split. (* - add *) - bitwise. + bitwise as m. destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0. rewrite <- !div2_bits, <- 2 lxor_spec. @@ -1320,7 +1323,7 @@ Proof. rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2. (* - carry *) rewrite add_b2n_double_div2. - bitwise. + bitwise as m. destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. now rewrite add_b2n_double_bit0. rewrite <- !div2_bits, IH2. autorewrite with bitwise. @@ -1356,7 +1359,7 @@ Proof. symmetry in H. now apply lor_eq_0_l in H. intros EQ. rewrite EQ, lor_0_l in H. apply bits_inj_0. - induct n. trivial. + intro n; induct n. trivial. intros n IH. rewrite <- div2_bits, H. autorewrite with bitwise. @@ -1381,7 +1384,7 @@ Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b. Proof. cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b). intros H a b. apply (H a), pow_gt_lin_r; order'. - induct n. + intro n; induct n. intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. assert (Ha' : a == 0) by (generalize (le_0_l a); order'). rewrite Ha'. apply le_0_l. @@ -1410,7 +1413,7 @@ Proof. rewrite sub_add. symmetry. rewrite add_nocarry_lxor. - bitwise. + bitwise as m. apply bits_inj_iff in H. specialize (H m). rewrite ldiff_spec, bits_0 in H. now destruct a.[m], b.[m]. @@ -1454,7 +1457,7 @@ Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 -> Proof. intros a b n H. apply add_nocarry_lt_pow2. - bitwise. + bitwise as m. destruct (le_gt_cases n m). now rewrite mod_pow2_bits_high. now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v index 9c50d5ca58..bb2f32935f 100644 --- a/theories/Numbers/Natural/Abstract/NDiv.v +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -39,15 +39,15 @@ Qed. Theorem div_mod_unique : forall b q1 q2 r1 r2, r1<b -> r2<b -> b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. intros. apply div_mod_unique with b; auto'. Qed. +Proof. intros b q1 q2 r1 r2 ? ? ?. apply div_mod_unique with b; auto'. Qed. Theorem div_unique: forall a b q r, r<b -> a == b*q + r -> q == a/b. -Proof. intros; apply div_unique with r; auto'. Qed. +Proof. intros a b q r ? ?; apply div_unique with r; auto'. Qed. Theorem mod_unique: forall a b q r, r<b -> a == b*q + r -> r == a mod b. -Proof. intros. apply mod_unique with q; auto'. Qed. +Proof. intros a b q r ? ?. apply mod_unique with q; auto'. Qed. Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b. Proof. intros. apply div_unique_exact; auto'. Qed. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v index a80ae8dc45..c1d8308e34 100644 --- a/theories/Numbers/Natural/Abstract/NGcd.v +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -53,7 +53,7 @@ Definition divide_gcd_iff' n m := divide_gcd_iff n m (le_0_l n). Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. Proof. - intros. apply gcd_unique_alt'. + intros n m p. apply gcd_unique_alt'. intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. apply divide_add_r; trivial. now apply divide_mul_r. apply divide_add_cancel_r with (p*n); trivial. @@ -98,11 +98,11 @@ Lemma gcd_bezout_pos_pos : forall n, 0<n -> forall m, 0<m -> Bezout n m (gcd n m) /\ Bezout m n (gcd n m). Proof. intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. - pattern n. apply strong_right_induction with (z:=1); trivial. + pattern n. apply (fun H => strong_right_induction _ H 1); trivial. unfold Bezout. solve_proper. clear n Hn. intros n Hn IHn. intros m Hm. rewrite <- le_succ_l, <- one_succ in Hm. - pattern m. apply strong_right_induction with (z:=1); trivial. + pattern m. apply (fun H => strong_right_induction _ H 1); trivial. unfold Bezout. solve_proper. clear m Hm. intros m Hm IHm. destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. @@ -156,7 +156,7 @@ Qed. Theorem bezout_comm : forall a b g, b ~= 0 -> Bezout a b g -> Bezout b a g. Proof. - intros * Hbz (u & v & Huv). + intros a b g Hbz (u & v & Huv). destruct (eq_0_gt_0_cases a) as [Haz| Haz]. -rewrite Haz in Huv |-*. rewrite mul_0_r in Huv; symmetry in Huv. @@ -260,7 +260,7 @@ Qed. Lemma gcd_mul_mono_r : forall n m p, gcd (n*p) (m*p) == gcd n m * p. Proof. - intros. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. + intros n m p. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. Qed. Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v index 3a9cf34b25..b75b4521df 100644 --- a/theories/Numbers/Natural/Abstract/NLcm.v +++ b/theories/Numbers/Natural/Abstract/NLcm.v @@ -169,7 +169,7 @@ Qed. Lemma lcm_divide_iff : forall n m p, (lcm n m | p) <-> (n | p) /\ (m | p). Proof. - intros. split. split. + intros n m p. split. split. transitivity (lcm n m); trivial using divide_lcm_l. transitivity (lcm n m); trivial using divide_lcm_r. intros (H,H'). now apply lcm_least. diff --git a/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v index ad6e2d65f0..3a41a2a560 100644 --- a/theories/Numbers/Natural/Abstract/NMaxMin.v +++ b/theories/Numbers/Natural/Abstract/NMaxMin.v @@ -42,95 +42,95 @@ Qed. (** Succ *) -Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m). +Lemma succ_max_distr n m : S (max n m) == max (S n) (S m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. Qed. -Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m). +Lemma succ_min_distr n m : S (min n m) == min (S n) (S m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. Qed. (** Add *) -Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m. +Lemma add_max_distr_l n m p : max (p + n) (p + m) == p + max n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. Qed. -Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p. +Lemma add_max_distr_r n m p : max (n + p) (m + p) == max n m + p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. Qed. -Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m. +Lemma add_min_distr_l n m p : min (p + n) (p + m) == p + min n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. Qed. -Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p. +Lemma add_min_distr_r n m p : min (n + p) (m + p) == min n m + p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. Qed. (** Mul *) -Lemma mul_max_distr_l : forall n m p, max (p * n) (p * m) == p * max n m. +Lemma mul_max_distr_l n m p : max (p * n) (p * m) == p * max n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l. Qed. -Lemma mul_max_distr_r : forall n m p, max (n * p) (m * p) == max n m * p. +Lemma mul_max_distr_r n m p : max (n * p) (m * p) == max n m * p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r. Qed. -Lemma mul_min_distr_l : forall n m p, min (p * n) (p * m) == p * min n m. +Lemma mul_min_distr_l n m p : min (p * n) (p * m) == p * min n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l. Qed. -Lemma mul_min_distr_r : forall n m p, min (n * p) (m * p) == min n m * p. +Lemma mul_min_distr_r n m p : min (n * p) (m * p) == min n m * p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r. Qed. (** Sub *) -Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m. +Lemma sub_max_distr_l n m p : max (p - n) (p - m) == p - min n m. Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l. rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l. Qed. -Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p. +Lemma sub_max_distr_r n m p : max (n - p) (m - p) == max n m - p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. Qed. -Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m. +Lemma sub_min_distr_l n m p : min (p - n) (p - m) == p - max n m. Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l. rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l. Qed. -Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p. +Lemma sub_min_distr_r n m p : min (n - p) (m - p) == min n m - p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. Qed. diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v index 9a9a882239..ccdac104a3 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -46,19 +46,19 @@ Qed. Theorem lt_0_succ : forall n, 0 < S n. Proof. -induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. +intro n; induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. Qed. Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n. Proof. -cases n. +intro n; cases n. split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. Qed. Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n. Proof. -cases n. +intro n; cases n. now left. intro; right; apply lt_0_succ. Qed. @@ -66,8 +66,8 @@ Qed. Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. Proof. setoid_rewrite one_succ. -induct n. now left. -cases n. intros; right; now left. +intro n; induct n. now left. +intro n; cases n. intros; right; now left. intros n IH. destruct IH as [H | [H | H]]. false_hyp H neq_succ_0. right; right. rewrite H. apply lt_succ_diag_r. @@ -77,7 +77,7 @@ Qed. Theorem lt_1_r : forall n, n < 1 <-> n == 0. Proof. setoid_rewrite one_succ. -cases n. +intro n; cases n. split; intro; [reflexivity | apply lt_succ_diag_r]. intros n. rewrite <- succ_lt_mono. split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. @@ -86,7 +86,7 @@ Qed. Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. Proof. setoid_rewrite one_succ. -cases n. +intro n; cases n. split; intro; [now left | apply le_succ_diag_r]. intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. @@ -101,7 +101,7 @@ Qed. Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p. Proof. -intros. apply lt_1_l with m; auto. +intros n m p H H0. apply lt_1_l with m; auto. apply le_lt_trans with n; auto. now apply le_0_l. Qed. @@ -117,7 +117,7 @@ Theorem le_ind_rel : (forall n m, n <= m -> R n m -> R (S n) (S m)) -> forall n m, n <= m -> R n m. Proof. -intros Base Step; induct n. +intros Base Step n; induct n. intros; apply Base. intros n IH m H. elim H using le_ind. solve_proper. @@ -130,7 +130,7 @@ Theorem lt_ind_rel : (forall n m, n < m -> R n m -> R (S n) (S m)) -> forall n m, n < m -> R n m. Proof. -intros Base Step; induct n. +intros Base Step n; induct n. intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]]. rewrite H; apply Base. intros n IH m H. elim H using lt_ind. @@ -151,14 +151,14 @@ Qed. Theorem le_pred_l : forall n, P n <= n. Proof. -cases n. +intro n; cases n. rewrite pred_0; now apply eq_le_incl. intros; rewrite pred_succ; apply le_succ_diag_r. Qed. Theorem lt_pred_l : forall n, n ~= 0 -> P n < n. Proof. -cases n. +intro n; cases n. intro H; exfalso; now apply H. intros; rewrite pred_succ; apply lt_succ_diag_r. Qed. @@ -176,7 +176,7 @@ Qed. Theorem lt_le_pred : forall n m, n < m -> n <= P m. (* Converse is false for n == m == 0 *) Proof. -intro n; cases m. +intros n m; cases m. intro H; false_hyp H nlt_0_r. intros m IH. rewrite pred_succ; now apply lt_succ_r. Qed. diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v index 58bc1499e1..4bb465c93c 100644 --- a/theories/Numbers/Natural/Abstract/NParity.v +++ b/theories/Numbers/Natural/Abstract/NParity.v @@ -16,19 +16,19 @@ Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N). Include NZParityProp N N NP. -Lemma odd_pred : forall n, n~=0 -> odd (P n) = even n. +Lemma odd_pred n : n~=0 -> odd (P n) = even n. Proof. intros. rewrite <- (succ_pred n) at 2 by trivial. symmetry. apply even_succ. Qed. -Lemma even_pred : forall n, n~=0 -> even (P n) = odd n. +Lemma even_pred n : n~=0 -> even (P n) = odd n. Proof. intros. rewrite <- (succ_pred n) at 2 by trivial. symmetry. apply odd_succ. Qed. -Lemma even_sub : forall n m, m<=n -> even (n-m) = Bool.eqb (even n) (even m). +Lemma even_sub n m : m<=n -> even (n-m) = Bool.eqb (even n) (even m). Proof. intros. case_eq (even n); case_eq (even m); @@ -56,7 +56,7 @@ Proof. rewrite add_1_r in Hm,Hn. order. Qed. -Lemma odd_sub : forall n m, m<=n -> odd (n-m) = xorb (odd n) (odd m). +Lemma odd_sub n m : m<=n -> odd (n-m) = xorb (odd n) (odd m). Proof. intros. rewrite <- !negb_even. rewrite even_sub by trivial. now destruct (even n), (even m). diff --git a/theories/Numbers/Natural/Abstract/NPow.v b/theories/Numbers/Natural/Abstract/NPow.v index 0b7720fd57..b49b6bf03c 100644 --- a/theories/Numbers/Natural/Abstract/NPow.v +++ b/theories/Numbers/Natural/Abstract/NPow.v @@ -55,7 +55,7 @@ Proof. wrap pow_mul_r. Qed. (** Power and nullity *) Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0. -Proof. intros. apply (pow_eq_0 a b); trivial. auto'. Qed. +Proof. intros a b ? ?. apply (pow_eq_0 a b); trivial. auto'. Qed. Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0. Proof. wrap pow_nonzero. Qed. diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v index e06604db53..b939352144 100644 --- a/theories/Numbers/Natural/Abstract/NSub.v +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -17,21 +17,21 @@ Include NMulOrderProp N. Theorem sub_0_l : forall n, 0 - n == 0. Proof. -induct n. +intro n; induct n. apply sub_0_r. intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0. Qed. Theorem sub_succ : forall n m, S n - S m == n - m. Proof. -intro n; induct m. +intros n m; induct m. rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ. intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r. Qed. Theorem sub_diag : forall n, n - n == 0. Proof. -induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH. +intro n; induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH. Qed. Theorem sub_gt : forall n m, n > m -> n - m ~= 0. @@ -96,7 +96,7 @@ Qed. Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. Proof. -intros n m; induct p. +intros n m p; induct p. rewrite add_0_r; now rewrite sub_0_r. intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. Qed. @@ -113,7 +113,7 @@ Qed. Theorem le_sub_l : forall n m, n - m <= n. Proof. -intro n; induct m. +intros n m; induct m. rewrite sub_0_r; now apply eq_le_incl. intros m IH. rewrite sub_succ_r. apply le_trans with (n - m); [apply le_pred_l | assumption]. @@ -121,7 +121,7 @@ Qed. Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m. Proof. -double_induct n m. +intros n m; double_induct n m. intro m; split; intro; [apply le_0_l | apply sub_0_l]. intro m; rewrite sub_0_r; split; intro H; [false_hyp H neq_succ_0 | false_hyp H nle_succ_0]. @@ -130,7 +130,7 @@ Qed. Theorem sub_add_le : forall n m, n <= n - m + m. Proof. -intros. +intros n m. destruct (le_ge_cases n m) as [LE|GE]. rewrite <- sub_0_le in LE. rewrite LE; nzsimpl. now rewrite <- sub_0_le. @@ -216,12 +216,13 @@ Qed. Lemma sub_le_mono_r : forall n m p, n <= m -> n-p <= m-p. Proof. - intros. rewrite le_sub_le_add_r. transitivity m. assumption. apply sub_add_le. + intros n m p. rewrite le_sub_le_add_r. + transitivity m. assumption. apply sub_add_le. Qed. Lemma sub_le_mono_l : forall n m p, n <= m -> p-m <= p-n. Proof. - intros. rewrite le_sub_le_add_r. + intros n m p. rewrite le_sub_le_add_r. transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l]. Qed. @@ -264,14 +265,14 @@ Definition lt_alt n m := exists p, S p + n == m. Lemma le_equiv : forall n m, le_alt n m <-> n <= m. Proof. -split. +intros n m; split. intros (p,H). rewrite <- H, add_comm. apply le_add_r. intro H. exists (m-n). now apply sub_add. Qed. Lemma lt_equiv : forall n m, lt_alt n m <-> n < m. Proof. -split. +intros n m; split. intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r. intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r. apply sub_add. now rewrite le_succ_l. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index e73060af0b..e97f2dc748 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -145,7 +145,7 @@ Qed. Lemma succ_inj p q : succ p = succ q -> p = q. Proof. revert q. - induction p; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto. + induction p as [p|p|]; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto. elim (succ_not_1 p); auto. elim (succ_not_1 q); auto. Qed. @@ -177,14 +177,14 @@ Qed. Theorem add_carry_spec p q : add_carry p q = succ (p + q). Proof. - revert q. induction p; destruct q; simpl; now f_equal. + revert q. induction p; intro q; destruct q; simpl; now f_equal. Qed. (** ** Commutativity *) Theorem add_comm p q : p + q = q + p. Proof. - revert q. induction p; destruct q; simpl; f_equal; trivial. + revert q. induction p; intro q; destruct q; simpl; f_equal; trivial. rewrite 2 add_carry_spec; now f_equal. Qed. @@ -193,7 +193,7 @@ Qed. Theorem add_succ_r p q : p + succ q = succ (p + q). Proof. revert q. - induction p; destruct q; simpl; f_equal; + induction p; intro q; destruct q; simpl; f_equal; auto using add_1_r; rewrite add_carry_spec; auto. Qed. @@ -247,13 +247,13 @@ Qed. Lemma add_carry_reg_r p q r : add_carry p r = add_carry q r -> p = q. Proof. - intros H. apply add_reg_r with (r:=r); now apply add_carry_add. + intros H. apply (add_reg_r _ _ r); now apply add_carry_add. Qed. Lemma add_carry_reg_l p q r : add_carry p q = add_carry p r -> q = r. Proof. - intros H; apply add_reg_r with (r:=p); + intros H; apply (add_reg_r _ _ p); rewrite (add_comm r), (add_comm q); now apply add_carry_add. Qed. @@ -288,7 +288,7 @@ Qed. Lemma add_xO_pred_double p q : pred_double (p + q) = p~0 + pred_double q. Proof. - revert q. induction p as [p IHp| p IHp| ]; destruct q; simpl; + revert q. induction p as [p IHp| p IHp| ]; intro q; destruct q; simpl; rewrite ?add_carry_spec, ?pred_double_succ, ?add_xI_pred_double; try reflexivity. rewrite IHp; auto. @@ -323,7 +323,7 @@ Theorem peano_rect_succ (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) (p:positive) : peano_rect P a f (succ p) = f _ (peano_rect P a f p). Proof. - revert P a f. induction p; trivial. + revert P a f. induction p as [p IHp|p IHp|]; trivial. intros. simpl. now rewrite IHp. Qed. @@ -393,17 +393,17 @@ Qed. Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. Proof. - intros. + intros p q q'. induction q as [ | p q IHq ]. apply eq_dep_eq_positive. - cut (1=1). pattern 1 at 1 2 5, q'. destruct q'. trivial. + cut (1=1). pattern 1 at 1 2 5, q'. destruct q' as [|p ?]. trivial. destruct p; intros; discriminate. trivial. apply eq_dep_eq_positive. - cut (succ p=succ p). pattern (succ p) at 1 2 5, q'. destruct q'. + cut (succ p=succ p). pattern (succ p) at 1 2 5, q'. destruct q' as [|? q']. intro. destruct p; discriminate. - intro. apply succ_inj in H. - generalize q'. rewrite H. intro. + intro H. apply succ_inj in H. + generalize q'. rewrite H. intro q'0. rewrite (IHq q'0). trivial. trivial. @@ -412,7 +412,7 @@ Qed. Lemma peano_equiv (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) p : PeanoView_iter P a f p (peanoView p) = peano_rect P a f p. Proof. - revert P a f. induction p using peano_rect. + revert P a f. induction p as [|p IHp] using peano_rect. trivial. intros; simpl. rewrite peano_rect_succ. rewrite (PeanoViewUnique _ (peanoView (succ p)) (PeanoSucc _ (peanoView p))). @@ -575,11 +575,11 @@ Qed. (** ** Properties of [iter] *) -Lemma iter_swap_gen : forall A B (f:A->B)(g:A->A)(h:B->B), +Lemma iter_swap_gen A B (f:A->B)(g:A->A)(h:B->B) : (forall a, f (g a) = h (f a)) -> forall p a, f (iter g a p) = iter h (f a) p. Proof. - induction p; simpl; intros; now rewrite ?H, ?IHp. + intros H p; induction p as [p IHp|p IHp|]; simpl; intros; now rewrite ?H, ?IHp. Qed. Theorem iter_swap : @@ -593,7 +593,7 @@ Theorem iter_succ : forall p (A:Type) (f:A -> A) (x:A), iter f x (succ p) = f (iter f x p). Proof. - induction p as [p IHp|p IHp|]; intros; simpl; trivial. + intro p; induction p as [p IHp|p IHp|]; intros; simpl; trivial. now rewrite !IHp, iter_swap. Qed. @@ -608,18 +608,17 @@ Theorem iter_add : forall p q (A:Type) (f:A -> A) (x:A), iter f x (p+q) = iter f (iter f x q) p. Proof. - induction p using peano_ind; intros. + intro p; induction p as [|p IHp] using peano_ind; intros. now rewrite add_1_l, iter_succ. now rewrite add_succ_l, !iter_succ, IHp. Qed. -Theorem iter_ind : - forall (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop), +Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop) : P 1 (f a) -> (forall p a', P p a' -> P (succ p) (f a')) -> forall p, P p (iter f a p). Proof. - induction p using peano_ind; trivial. + intros ? ? p; induction p as [|p IHp] using peano_ind; trivial. rewrite iter_succ; auto. Qed. @@ -628,7 +627,7 @@ Theorem iter_invariant : (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter f x p). Proof. - intros; apply iter_ind with (P := fun _ => Inv); auto. + intros; apply iter_ind; auto. Qed. (** ** Properties of power *) @@ -647,7 +646,7 @@ Qed. Lemma square_spec p : square p = p * p. Proof. - induction p. + induction p as [p IHp|p IHp|]. - rewrite square_xI. simpl. now rewrite IHp. - rewrite square_xO. simpl. now rewrite IHp. - trivial. @@ -658,13 +657,14 @@ Qed. Lemma sub_mask_succ_r p q : sub_mask p (succ q) = sub_mask_carry p q. Proof. - revert q. induction p; destruct q; simpl; f_equal; trivial; now destruct p. + revert q. induction p as [p ?|p ?|]; intro q; destruct q; + simpl; f_equal; trivial; now destruct p. Qed. Theorem sub_mask_carry_spec p q : sub_mask_carry p q = pred_mask (sub_mask p q). Proof. - revert q. induction p as [p IHp|p IHp| ]; destruct q; simpl; + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; try reflexivity; rewrite ?IHp; destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto. Qed. @@ -676,16 +676,17 @@ Inductive SubMaskSpec (p q : positive) : mask -> Prop := Theorem sub_mask_spec p q : SubMaskSpec p q (sub_mask p q). Proof. - revert q. induction p; destruct q; simpl; try constructor; trivial. + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; + simpl; try constructor; trivial. (* p~1 q~1 *) - destruct (IHp q); subst; try now constructor. + destruct (IHp q) as [|r|r]; subst; try now constructor. now apply SubIsNeg with r~0. (* p~1 q~0 *) - destruct (IHp q); subst; try now constructor. + destruct (IHp q) as [|r|r]; subst; try now constructor. apply SubIsNeg with (pred_double r). symmetry. apply add_xI_pred_double. (* p~0 q~1 *) rewrite sub_mask_carry_spec. - destruct (IHp q); subst; try constructor. + destruct (IHp q) as [|r|r]; subst; try constructor. now apply SubIsNeg with 1. destruct r; simpl; try constructor; simpl. now rewrite add_carry_spec, <- add_succ_r. @@ -693,7 +694,7 @@ Proof. now rewrite add_1_r. now apply SubIsNeg with r~1. (* p~0 q~0 *) - destruct (IHp q); subst; try now constructor. + destruct (IHp q) as [|r|r]; subst; try now constructor. now apply SubIsNeg with r~0. (* p~0 1 *) now rewrite add_1_l, succ_pred_double. @@ -707,7 +708,7 @@ Theorem sub_mask_nul_iff p q : sub_mask p q = IsNul <-> p = q. Proof. split. now case sub_mask_spec. - intros <-. induction p; simpl; now rewrite ?IHp. + intros <-. induction p as [p IHp|p IHp|]; simpl; now rewrite ?IHp. Qed. Theorem sub_mask_diag p : sub_mask p p = IsNul. @@ -752,7 +753,8 @@ Qed. Theorem eqb_eq p q : (p =? q) = true <-> p=q. Proof. - revert q. induction p; destruct q; simpl; rewrite ?IHp; split; congruence. + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q; + simpl; rewrite ?IHp; split; congruence. Qed. Theorem ltb_lt p q : (p <? q) = true <-> p < q. @@ -786,7 +788,7 @@ Lemma compare_cont_spec p q c : Proof. unfold compare. revert q c. - induction p; destruct q; simpl; trivial. + induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; trivial. intros c. rewrite 2 IHp. now destruct (compare_cont Eq p q). intros c. @@ -1026,7 +1028,8 @@ Qed. Lemma compare_succ_succ p q : (succ p ?= succ q) = (p ?= q). Proof. revert q. - induction p; destruct q; simpl; simpl_compare; trivial; + induction p as [p|p|]; intro q; destruct q as [q|q|]; + simpl; simpl_compare; trivial; apply compare_succ_l || apply compare_succ_r || (now destruct p) || (now destruct q). Qed. @@ -1159,7 +1162,7 @@ Qed. Lemma add_compare_mono_l p q r : (p+q ?= p+r) = (q ?= r). Proof. - revert p q r. induction p using peano_ind; intros q r. + revert q r. induction p using peano_ind; intros q r. rewrite 2 add_1_l. apply compare_succ_succ. now rewrite 2 add_succ_l, compare_succ_succ. Qed. @@ -1214,7 +1217,7 @@ Qed. Lemma mul_compare_mono_l p q r : (p*q ?= p*r) = (q ?= r). Proof. - revert q r. induction p; simpl; trivial. + revert q r. induction p as [p IHp|p IHp|]; simpl; trivial. intros q r. specialize (IHp q r). destruct (compare_spec q r). subst. apply compare_refl. @@ -1265,7 +1268,7 @@ Qed. Lemma lt_add_r p q : p < p+q. Proof. - induction q using peano_ind. + induction q as [|q] using peano_ind. rewrite add_1_r. apply lt_succ_diag_r. apply lt_trans with (p+q); auto. apply add_lt_mono_l, lt_succ_diag_r. @@ -1476,10 +1479,11 @@ Qed. Lemma size_nat_monotone p q : p<q -> (size_nat p <= size_nat q)%nat. Proof. - assert (le0 : forall n, (0<=n)%nat) by (induction n; auto). + assert (le0 : forall n, (0<=n)%nat) by (intro n; induction n; auto). assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). revert q. - induction p; destruct q; simpl; intros; auto; easy || apply leS; + induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; + simpl; intros H; auto; easy || apply leS; red in H; simpl_compare_in H. apply IHp. red. now destruct (p?=q). destruct (compare_spec p q); subst; now auto. @@ -1487,13 +1491,13 @@ Qed. Lemma size_gt p : p < 2^(size p). Proof. - induction p; simpl; try rewrite pow_succ_r; try easy. + induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. apply le_succ_l in IHp. now apply le_succ_l. Qed. Lemma size_le p : 2^(size p) <= p~0. Proof. - induction p; simpl; try rewrite pow_succ_r; try easy. + induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. apply mul_le_mono_l. apply le_lteq; left. rewrite xI_succ_xO. apply lt_succ_r, IHp. Qed. @@ -1612,7 +1616,7 @@ Lemma iter_op_succ : forall A (op:A->A->A), forall p a, iter_op op (succ p) a = op a (iter_op op p a). Proof. - induction p; simpl; intros; trivial. + intros A op H p; induction p as [p IHp|p IHp|]; simpl; intros; trivial. rewrite H. apply IHp. Qed. @@ -1620,7 +1624,7 @@ Qed. Lemma of_nat_succ (n:nat) : of_succ_nat n = of_nat (S n). Proof. - induction n. trivial. simpl. f_equal. now rewrite IHn. + induction n as [|n IHn]. trivial. simpl. f_equal. now rewrite IHn. Qed. Lemma pred_of_succ_nat (n:nat) : pred (of_succ_nat n) = of_nat n. @@ -1671,7 +1675,7 @@ Qed. Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. Proof. revert p. fix sqrtrem_spec 1. - destruct p; try destruct p; try (constructor; easy); + intro p; destruct p as [p|p|]; try destruct p; try (constructor; easy); apply sqrtrem_step_spec; auto. Qed. @@ -1688,7 +1692,7 @@ Proof. split. apply lt_le_incl, lt_add_r. rewrite <- add_1_l, mul_add_distr_r, !mul_add_distr_l, !mul_1_r, !mul_1_l. - rewrite add_assoc, (add_comm _ r). apply add_lt_mono_r. + rewrite add_assoc, (add_comm _ _). apply add_lt_mono_r. now rewrite <- add_assoc, add_diag, add_1_l, lt_succ_r. Qed. @@ -1710,7 +1714,7 @@ Lemma divide_xO_xI p q r : (p | q~0) -> (p | r~1) -> (p | q). Proof. intros (s,Hs) (t,Ht). destruct p. - destruct s; try easy. simpl in Hs. destr_eq Hs. now exists s. + destruct s as [s|s|]; try easy. simpl in Hs. destr_eq Hs. now exists s. rewrite mul_xO_r in Ht; discriminate. exists q; now rewrite mul_1_r. Qed. @@ -1738,9 +1742,9 @@ Qed. Lemma ggcdn_gcdn : forall n a b, fst (ggcdn n a b) = gcdn n a b. Proof. - induction n. + intro n; induction n as [|n IHn]. simpl; auto. - destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; + intros a b; destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; rewrite <- IHn; destruct ggcdn as (g,(u,v)); simpl; auto. Qed. @@ -1760,9 +1764,10 @@ Lemma ggcdn_correct_divisors : forall n a b, let '(g,(aa,bb)) := ggcdn n a b in a = g*aa /\ b = g*bb. Proof. - induction n. + intro n; induction n as [|n IHn]. simpl; auto. - destruct a, b; simpl; auto; try case compare_spec; try destr_pggcdn IHn. + intros a b; destruct a, b; + simpl; auto; try case compare_spec; try destr_pggcdn IHn. (* Eq *) intros ->. now rewrite mul_comm. (* Lt *) @@ -1809,9 +1814,9 @@ Qed. Lemma gcdn_greatest : forall n a b, (size_nat a + size_nat b <= n)%nat -> forall p, (p|a) -> (p|b) -> (p|gcdn n a b). Proof. - induction n. + intro n; induction n as [|n IHn]; intros a b. destruct a, b; simpl; inversion 1. - destruct a, b; simpl; try case compare_spec; simpl; auto. + destruct a as [a|a|], b as [b|b|]; simpl; try case compare_spec; simpl; auto. (* Lt *) intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. apply le_S_n in LE. eapply Le.le_trans; [|eapply LE]. @@ -1839,7 +1844,7 @@ Proof. apply divide_xO_xI with b; trivial. (* a~0 b~0 *) intros LE p Hp1 Hp2. - destruct p. + destruct p as [p|p|]. change (gcdn n a b)~0 with (2*(gcdn n a b)). apply divide_mul_r. apply IHn; clear IHn. @@ -1865,7 +1870,7 @@ Lemma ggcd_greatest : forall a b, let (aa,bb) := snd (ggcd a b) in forall p, (p|aa) -> (p|bb) -> p=1. Proof. - intros. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). + intros a b **. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). rewrite <- ggcd_gcd. destruct ggcd as (g,(aa,bb)); simpl. intros H (EQa,EQb) p Hp1 Hp2; subst. assert (H' : (g*p | g)). @@ -2126,7 +2131,7 @@ Qed. Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt. Proof. - destruct r; auto. + intro r; destruct r; auto. Qed. (** Incompatibilities : diff --git a/theories/PArith/Pnat.v b/theories/PArith/Pnat.v index abb33d462d..09c65f848f 100644 --- a/theories/PArith/Pnat.v +++ b/theories/PArith/Pnat.v @@ -32,14 +32,14 @@ Qed. Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q. Proof. - revert q. induction p using peano_ind; intros q. + revert q. induction p as [|p IHp] using peano_ind; intros q. now rewrite add_1_l, inj_succ. now rewrite add_succ_l, !inj_succ, IHp. Qed. Theorem inj_mul p q : to_nat (p * q) = to_nat p * to_nat q. Proof. - revert q. induction p using peano_ind; simpl; intros; trivial. + revert q. induction p as [|p IHp] using peano_ind; simpl; intros; trivial. now rewrite mul_succ_l, inj_add, IHp, inj_succ. Qed. @@ -62,9 +62,9 @@ Qed. (** [Pos.to_nat] maps to the strictly positive subset of [nat] *) -Lemma is_succ : forall p, exists n, to_nat p = S n. +Lemma is_succ p : exists n, to_nat p = S n. Proof. - induction p using peano_ind. + induction p as [|p IHp] using peano_ind. now exists 0. destruct IHp as (n,Hn). exists (S n). now rewrite inj_succ, Hn. Qed. @@ -82,7 +82,7 @@ Qed. Theorem id p : of_nat (to_nat p) = p. Proof. - induction p using peano_ind. trivial. + induction p as [|p IHp] using peano_ind. trivial. rewrite inj_succ. rewrite <- IHp at 2. now destruct (is_succ p) as (n,->). Qed. @@ -149,7 +149,7 @@ Qed. Theorem inj_sub_max p q : to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q). Proof. - destruct (ltb_spec q p). + destruct (ltb_spec q p) as [H|H]. - (* q < p *) rewrite <- inj_sub by trivial. now destruct (is_succ (p - q)) as (m,->). @@ -192,11 +192,10 @@ Proof. - now apply Nat.max_l, Nat.lt_le_incl. Qed. -Theorem inj_iter : - forall p {A} (f:A->A) (x:A), +Theorem inj_iter p {A} (f:A->A) (x:A) : Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p). Proof. - induction p using peano_ind. + induction p as [|p IHp] using peano_ind. - trivial. - intros. rewrite inj_succ, iter_succ. simpl. f_equal. apply IHp. @@ -443,7 +442,7 @@ Section ObsoletePmultNat. Lemma Pmult_nat_mult : forall p n, Pmult_nat p n = Pos.to_nat p * n. Proof. - induction p; intros n; unfold Pos.to_nat; simpl. + intro p; induction p as [p IHp|p IHp|]; intros n; unfold Pos.to_nat; simpl. f_equal. rewrite 2 IHp. rewrite <- Nat.mul_assoc. f_equal. simpl. now rewrite Nat.add_0_r. rewrite 2 IHp. rewrite <- Nat.mul_assoc. @@ -482,7 +481,7 @@ Qed. Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n. Proof. - intros. rewrite Pmult_nat_mult. + intros p n. rewrite Pmult_nat_mult. apply Nat.le_trans with (1*n). now rewrite Nat.mul_1_l. apply Nat.mul_le_mono_r. apply Pos2Nat.is_pos. Qed. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index cec1033fdf..547d180d95 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -19,7 +19,7 @@ Require Coq.ssr.ssrsetoid. Definition Setoid_Theory := @Equivalence. Definition Build_Setoid_Theory := @Build_Equivalence. -Register Build_Setoid_Theory as plugins.setoid_ring.Build_Setoid_Theory. +Register Build_Setoid_Theory as plugins.ring.Build_Setoid_Theory. Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x. Proof. diff --git a/theories/dune b/theories/dune index de8dcdc5b1..c2d8197ee4 100644 --- a/theories/dune +++ b/theories/dune @@ -23,7 +23,7 @@ coq.plugins.btauto coq.plugins.rtauto - coq.plugins.setoid_ring + coq.plugins.ring coq.plugins.nsatz coq.plugins.omega diff --git a/theories/setoid_ring/BinList.v b/theories/setoid_ring/BinList.v index b6b8b45e1a..892909fd40 100644 --- a/theories/setoid_ring/BinList.v +++ b/theories/setoid_ring/BinList.v @@ -33,13 +33,13 @@ Section MakeBinList. Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). Proof. - induction j;simpl;intros; now rewrite ?IHj. + intro j;induction j as [j IHj|j IHj|];simpl;intros; now rewrite ?IHj. Qed. Lemma jump_succ : forall j l, jump (Pos.succ j) l = jump 1 (jump j l). Proof. - induction j;simpl;intros. + intro j;induction j as [j IHj|j IHj|];simpl;intros. - rewrite !IHj; simpl; now rewrite !jump_tl. - now rewrite !jump_tl. - trivial. @@ -48,7 +48,7 @@ Section MakeBinList. Lemma jump_add : forall i j l, jump (i + j) l = jump i (jump j l). Proof. - induction i using Pos.peano_ind; intros. + intro i; induction i as [|i IHi] using Pos.peano_ind; intros. - now rewrite Pos.add_1_l, jump_succ. - now rewrite Pos.add_succ_l, !jump_succ, IHi. Qed. @@ -56,7 +56,7 @@ Section MakeBinList. Lemma jump_pred_double : forall i l, jump (Pos.pred_double i) (tl l) = jump i (jump i l). Proof. - induction i;intros;simpl. + intro i;induction i as [i IHi|i IHi|];intros;simpl. - now rewrite !jump_tl. - now rewrite IHi, <- 2 jump_tl, IHi. - trivial. @@ -64,7 +64,7 @@ Section MakeBinList. Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l). Proof. - induction p;simpl;intros. + intro p;induction p as [p IHp|p IHp|];simpl;intros. - now rewrite <-jump_tl, IHp. - now rewrite <-jump_tl, IHp. - trivial. @@ -73,7 +73,7 @@ Section MakeBinList. Lemma nth_pred_double : forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l). Proof. - induction p;simpl;intros. + intro p;induction p as [p IHp|p IHp|];simpl;intros. - now rewrite !jump_tl. - now rewrite jump_pred_double, <- !jump_tl, IHp. - trivial. diff --git a/theories/setoid_ring/Ring_base.v b/theories/setoid_ring/Ring_base.v index 04c7a3a83b..4986661ad1 100644 --- a/theories/setoid_ring/Ring_base.v +++ b/theories/setoid_ring/Ring_base.v @@ -12,7 +12,7 @@ ring tactic. Abstract rings need more theory, depending on ZArith_base. *) -Declare ML Module "newring_plugin". +Declare ML Module "ring_plugin". Require Export Ring_theory. Require Export Ring_tac. Require Import InitialRing. diff --git a/theories/setoid_ring/Ring_polynom.v b/theories/setoid_ring/Ring_polynom.v index e0a3d5a3bf..a13b1fc738 100644 --- a/theories/setoid_ring/Ring_polynom.v +++ b/theories/setoid_ring/Ring_polynom.v @@ -919,14 +919,14 @@ Section MakeRingPol. | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. - Register PExpr as plugins.setoid_ring.pexpr. - Register PEc as plugins.setoid_ring.const. - Register PEX as plugins.setoid_ring.var. - Register PEadd as plugins.setoid_ring.add. - Register PEsub as plugins.setoid_ring.sub. - Register PEmul as plugins.setoid_ring.mul. - Register PEopp as plugins.setoid_ring.opp. - Register PEpow as plugins.setoid_ring.pow. + Register PExpr as plugins.ring.pexpr. + Register PEc as plugins.ring.const. + Register PEX as plugins.ring.var. + Register PEadd as plugins.ring.add. + Register PEsub as plugins.ring.sub. + Register PEmul as plugins.ring.mul. + Register PEopp as plugins.ring.opp. + Register PEpow as plugins.ring.pow. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/theories/setoid_ring/Ring_tac.v b/theories/setoid_ring/Ring_tac.v index df54989169..76e9b1e947 100644 --- a/theories/setoid_ring/Ring_tac.v +++ b/theories/setoid_ring/Ring_tac.v @@ -15,7 +15,7 @@ Require Import Ring_polynom. Require Import BinList. Require Export ListTactics. Require Import InitialRing. -Declare ML Module "newring_plugin". +Declare ML Module "ring_plugin". (* adds a definition t' on the normal form of t and an hypothesis id diff --git a/theories/setoid_ring/Ring_theory.v b/theories/setoid_ring/Ring_theory.v index 230e789e21..32f21e2737 100644 --- a/theories/setoid_ring/Ring_theory.v +++ b/theories/setoid_ring/Ring_theory.v @@ -53,7 +53,7 @@ Section Power. Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j. Proof. - induction j; simpl; rewrite <- ?mul_assoc. + induction j as [j IHj|j IHj|]; simpl; rewrite <- ?mul_assoc. - f_equiv. now do 2 (rewrite IHj, mul_assoc). - now do 2 (rewrite IHj, mul_assoc). - reflexivity. @@ -62,7 +62,7 @@ Section Power. Lemma pow_pos_succ x j : pow_pos x (Pos.succ j) == x * pow_pos x j. Proof. - induction j; simpl; try reflexivity. + induction j as [j IHj|j IHj|]; simpl; try reflexivity. rewrite IHj, <- mul_assoc; f_equiv. now rewrite mul_assoc, pow_pos_swap, mul_assoc. Qed. @@ -70,7 +70,7 @@ Section Power. Lemma pow_pos_add x i j : pow_pos x (i + j) == pow_pos x i * pow_pos x j. Proof. - induction i using Pos.peano_ind. + induction i as [|i IHi] using Pos.peano_ind. - now rewrite Pos.add_1_l, pow_pos_succ. - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc. Qed. diff --git a/vernac/classes.ml b/vernac/classes.ml index b38a249b73..a464eab127 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -58,13 +58,7 @@ let is_local_for_hint i = let add_instance_base inst = let locality = if is_local_for_hint inst then Goptions.OptLocal else Goptions.OptGlobal in add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] ~locality - inst.is_info; - List.iter (fun (path, pri, c) -> - let h = Hints.IsConstr (EConstr.of_constr c, None) [@ocaml.warning "-3"] in - add_instance_hint h path - ~locality pri) - (build_subclasses ~check:(not (isVarRef inst.is_impl)) - (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) + inst.is_info let mk_instance cl info glob impl = let global = @@ -161,8 +155,17 @@ let subst_class (subst,cl) = let do_subst_context (grs,ctx) = List.Smart.map (Option.Smart.map do_subst_gr) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> - (x, y, Option.Smart.map do_subst_con z)) projs in + let do_subst_meth m = + let c = Option.Smart.map do_subst_con m.meth_const in + if c == m.meth_const then m + else + { + meth_name = m.meth_name; + meth_info = m.meth_info; + meth_const = c; + } + in + let do_subst_projs projs = List.Smart.map do_subst_meth projs in { cl_univs = cl.cl_univs; cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; @@ -247,10 +250,10 @@ let add_class cl = let add_class env sigma cl = add_class cl; - List.iter (fun (n, inst, body) -> - match inst with - | Some (Backward, info) -> - (match body with + List.iter (fun m -> + match m.meth_info with + | Some info -> + (match m.meth_const with | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") | Some b -> declare_instance ~warn:true env sigma (Some info) false (GlobRef.ConstRef b)) | _ -> ()) @@ -430,9 +433,9 @@ let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = let rest' = List.filter (fun v -> not (is_id v)) rest in let {CAst.loc;v=mid} = get_id loc_mid in - List.iter (fun (n, _, x) -> - if Name.equal n (Name mid) then - Option.iter (fun x -> Dumpglob.add_glob ?loc (GlobRef.ConstRef x)) x) k.cl_projs; + List.iter (fun m -> + if Name.equal m.meth_name (Name mid) then + Option.iter (fun x -> Dumpglob.add_glob ?loc (GlobRef.ConstRef x)) m.meth_const) k.cl_projs; c :: props, rest' with Not_found -> ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 564d24c1ea..78572c6aa6 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -110,7 +110,7 @@ let interp_fix_context ~program_mode ~cofix env sigma fix = else [], fix.Vernacexpr.binders in let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma before in let sigma, (impl_env', ((env'', ctx'), imps')) = - interp_context_evars ~program_mode ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after + interp_context_evars ~program_mode ~impl_env env' sigma after in let annot = Option.map (fun _ -> List.length (Termops.assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 452de69b1d..bb26ce652e 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -16,7 +16,6 @@ open Context open Environ open Names open Libnames -open Nameops open Constrexpr open Constrexpr_ops open Constrintern @@ -139,7 +138,7 @@ let model_conclusion env sigma ind_rel params n arity_indices = let sigma,model_indices = List.fold_right (fun (_,t) (sigma, subst) -> - let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) (EConstr.Vars.liftn 1 (List.length params + List.length subst + 1) t)) in + let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) t) in let sigma, c = Evarutil.new_evar env sigma t in sigma, c::subst) arity_indices (sigma, []) in @@ -443,9 +442,8 @@ let interp_params env udecl uparamsl paramsl = interp_context_evars ~program_mode:false ~impl_env:uimpls env_uparams sigma paramsl in (* Names of parameters as arguments of the inductive type (defs removed) *) - let assums = List.filter is_local_assum ctx_params in sigma, env_params, (ctx_params, env_uparams, ctx_uparams, - List.map (RelDecl.get_name %> Name.get_id) assums, userimpls, useruimpls, impls, udecl) + userimpls, useruimpls, impls, udecl) (* When a hole remains for a param, pretend the param is uniform and do the unification. @@ -482,11 +480,12 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not then user_err (str "Inductives with uniform parameters may not have attached notations."); let indnames = List.map (fun ind -> ind.ind_name) indl in + let ninds = List.length indl in (* In case of template polymorphism, we need to compute more constraints *) let env0 = if poly then env0 else Environ.set_universes_lbound env0 UGraph.Bound.Prop in - let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, params, userimpls, useruimpls, impls, udecl) = + let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, userimpls, useruimpls, impls, udecl) = interp_params env0 udecl uparamsl paramsl in @@ -496,16 +495,17 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let sigma, arities = List.fold_left_map (pretype_ind_arity env_params) sigma arities in let arities, relevances, arityconcl, indimpls = List.split4 arities in - let lift1_ctx ctx = + let lift_ctx n ctx = let t = EConstr.it_mkProd_or_LetIn EConstr.mkProp ctx in - let t = EConstr.Vars.lift 1 t in + let t = EConstr.Vars.lift n t in let ctx, _ = EConstr.decompose_prod_assum sigma t in ctx in - let ctx_params_lifted, fullarities = CList.fold_left_map - (fun ctx_params c -> lift1_ctx ctx_params, EConstr.it_mkProd_or_LetIn c ctx_params) - ctx_params - arities + let ctx_params_lifted, fullarities = + lift_ctx ninds ctx_params, + CList.map_i + (fun i c -> EConstr.Vars.lift i (EConstr.it_mkProd_or_LetIn c ctx_params)) + 0 arities in let env_ar = push_types env_uparams indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params_lifted env_ar in @@ -515,14 +515,15 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let impls = compute_internalization_env env_uparams sigma ~impls Inductive indnames fullarities indimpls in let ntn_impls = compute_internalization_env env_uparams sigma Inductive indnames fullarities indimpls in - let ninds = List.length indl in let (sigma, _), constructors = Metasyntax.with_syntax_protection (fun () -> (* Temporary declaration of notations and scopes *) List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; (* Interpret the constructor types *) List.fold_left2_map - (fun (sigma, ind_rel) -> interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params) + (fun (sigma, ind_rel) ind arity -> + interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params_lifted + ind (EConstr.Vars.liftn ninds (Rel.length ctx_params + 1) arity)) (sigma, ninds) indl arities) () in @@ -540,7 +541,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let nuparams = Context.Rel.length ctx_uparams in let uargs = Context.Rel.to_extended_vect EConstr.mkRel 0 ctx_uparams in let uparam_subst = - List.init (List.length indl) EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs)) + List.init ninds EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs)) @ List.init nuparams EConstr.(fun i -> mkRel (i + 1)) in let generalize_constructor c = EConstr.Unsafe.to_constr (EConstr.Vars.substnl uparam_subst nparams c) in let cimpls = List.map pi3 constructors in diff --git a/vernac/declare.ml b/vernac/declare.ml index 099a63cf8f..ae7878b615 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -725,7 +725,6 @@ module Obligation = struct ; obl_tac : unit Proofview.tactic option } let set_type ~typ obl = {obl with obl_type = typ} - let set_body ~body obl = {obl with obl_body = Some body} end type obligations = {obls : Obligation.t array; remaining : int} @@ -2464,32 +2463,25 @@ let add_mutual_definitions l ~pm ~info ?obl_hook ~uctx in pm -let admit_prog ~pm prg = - let {obls; remaining} = Internal.get_obligations prg 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 uctx = Internal.get_uctx prg in - let univs = UState.univ_entry ~poly:false uctx in - let kn = declare_constant ~name:x.obl_name ~local:Locality.ImportNeedQualified - (ParameterEntry (None, (x.obl_type, univs), None)) ~kind:Decls.(IsAssumption Conjectural) - in - assumption_message x.obl_name; - obls.(i) <- Obligation.set_body ~body:(DefinedObl (kn, Univ.Instance.empty)) x - | Some _ -> ()) - obls; - Obls_.update_obls ~pm prg obls 0 - -(* get_any_prog *) +let rec admit_prog ~pm prg = + let {obls} = Internal.get_obligations prg in + let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in + let i = match Array.findi is_open obls with + | Some i -> i + | None -> CErrors.anomaly (Pp.str "Could not find a solvable obligation.") + in + let proof = solve_obligation prg i None in + let pm = Proof.save_admitted ~pm ~proof in + match ProgMap.find_opt (Internal.get_name prg) pm with + | Some prg -> admit_prog ~pm (CEphemeron.get prg) + | None -> pm + let rec admit_all_obligations ~pm = let prg = State.first_pending pm in match prg with | None -> pm | Some prg -> - let pm, _prog = admit_prog ~pm prg in + let pm = admit_prog ~pm prg in admit_all_obligations ~pm let admit_obligations ~pm n = @@ -2497,7 +2489,7 @@ let admit_obligations ~pm n = | None -> admit_all_obligations ~pm | Some _ -> let prg = get_unique_prog ~pm n in - let pm, _ = admit_prog ~pm prg in + let pm = admit_prog ~pm prg in pm let next_obligation ~pm n tac = diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index e0550fd744..5b039e76f3 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -469,11 +469,8 @@ GRAMMAR EXTEND Gram [ [ id = identref; c=constructor_type -> { c id } ] ] ; of_type_with_opt_coercion: - [ [ ":>>" -> { Some false } - | ":>"; ">" -> { Some false } - | ":>" -> { Some true } - | ":"; ">"; ">" -> { Some false } - | ":"; ">" -> { Some true } + [ [ ":>" -> { Some () } + | ":"; ">" -> { Some () } | ":" -> { None } ] ] ; END diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 762c95fffe..c16eaac516 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -71,6 +71,9 @@ let rec contract3' env sigma a b c = function | ConversionFailed (env',t1,t2) -> let (env',t1,t2) = contract2 env' sigma t1 t2 in contract3 env sigma a b c, ConversionFailed (env',t1,t2) + | IncompatibleInstances (env',ev,t1,t2) -> + let (env',ev,t1,t2) = contract3 env' sigma (EConstr.mkEvar ev) t1 t2 in + contract3 env sigma a b c, IncompatibleInstances (env',EConstr.destEvar sigma ev,t1,t2) | NotSameArgSize | NotSameHead | NoCanonicalStructure | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities | UnifUnivInconsistency _ as x -> contract3 env sigma a b c, x @@ -313,6 +316,13 @@ let explain_unification_error env sigma p1 p2 = function let t1, t2 = pr_explicit env sigma t1 t2 in [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] else [] + | IncompatibleInstances (env,ev,t1,t2) -> + let env = make_all_name_different env sigma in + let ev = pr_leconstr_env env sigma (EConstr.mkEvar ev) in + let t1 = Reductionops.nf_betaiota env sigma t1 in + let t2 = Reductionops.nf_betaiota env sigma t2 in + let t1, t2 = pr_explicit env sigma t1 t2 in + [ev ++ strbrk " has otherwise to unify with " ++ t1 ++ str " which is incompatible with " ++ t2] | MetaOccurInBody evk -> [str "instance for " ++ quote (pr_existential_key sigma evk) ++ strbrk " refers to a metavariable - please report your example" ++ @@ -689,34 +699,29 @@ let explain_cannot_unify_binding_type env sigma m n = str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "." let explain_cannot_find_well_typed_abstraction env sigma p l e = - let p = EConstr.to_constr sigma p in str "Abstracting over the " ++ str (String.plural (List.length l) "term") ++ spc () ++ - hov 0 (pr_enum (fun c -> pr_lconstr_env env sigma (EConstr.to_constr sigma c)) l) ++ spc () ++ - str "leads to a term" ++ spc () ++ pr_ltype_env ~goal_concl_style:true env sigma p ++ + hov 0 (pr_enum (fun c -> pr_leconstr_env env sigma c) l) ++ spc () ++ + str "leads to a term" ++ spc () ++ pr_letype_env ~goal_concl_style:true env sigma p ++ spc () ++ str "which is ill-typed." ++ (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e) let explain_wrong_abstraction_type env sigma na abs expected result = - let abs = EConstr.to_constr sigma abs in - let expected = EConstr.to_constr sigma expected in - let result = EConstr.to_constr sigma result in let ppname = match na with Name id -> Id.print id ++ spc () | _ -> mt () in str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++ - pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++ - pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++ - pr_lconstr_env env sigma result ++ str "." + pr_leconstr_env env sigma expected ++ strbrk " with abstraction " ++ + pr_leconstr_env env sigma abs ++ strbrk " of incompatible type " ++ + pr_leconstr_env env sigma result ++ str "." let explain_abstraction_over_meta _ m n = strbrk "Too complex unification problem: cannot find a solution for both " ++ Name.print m ++ spc () ++ str "and " ++ Name.print n ++ str "." let explain_non_linear_unification env sigma m t = - let t = EConstr.to_constr sigma t in strbrk "Cannot unambiguously instantiate " ++ Name.print m ++ str ":" ++ strbrk " which would require to abstract twice on " ++ - pr_lconstr_env env sigma t ++ str "." + pr_leconstr_env env sigma t ++ str "." let explain_unsatisfied_constraints env sigma cst = strbrk "Unsatisfied constraints: " ++ @@ -803,10 +808,10 @@ let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1 explain_unification_error env sigma c1 c2 (Some e) in str "Found incompatible occurrences of the pattern" ++ str ":" ++ - spc () ++ str "Matched term " ++ pr_lconstr_env env sigma (EConstr.to_constr sigma t2) ++ + spc () ++ str "Matched term " ++ pr_leconstr_env env sigma t2 ++ strbrk " at position " ++ pr_position (cl2,pos2) ++ strbrk " is not compatible with matched term " ++ - pr_lconstr_env env sigma (EConstr.to_constr sigma t1) ++ strbrk " at position " ++ + pr_leconstr_env env sigma t1 ++ strbrk " at position " ++ pr_position (cl1,pos1) ++ ppreason ++ str "." let pr_constraints printenv env sigma evars cstrs = @@ -1287,9 +1292,8 @@ let explain_recursion_scheme_error env = function (* Pattern-matching errors *) let explain_bad_pattern env sigma cstr ty = - let ty = EConstr.to_constr sigma ty in let env = make_all_name_different env sigma in - let pt = pr_lconstr_env env sigma ty in + let pt = pr_leconstr_env env sigma ty in let pc = pr_constructor env cstr in str "Found the constructor " ++ pc ++ brk(1,1) ++ str "while matching a term of type " ++ pt ++ brk(1,1) ++ @@ -1326,12 +1330,11 @@ let explain_non_exhaustive env pats = spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) let explain_cannot_infer_predicate env sigma typs = - let inj c = EConstr.to_constr sigma c in - let typs = Array.map_to_list (fun (c1, c2) -> (inj c1, inj c2)) typs in + let typs = Array.to_list typs in let env = make_all_name_different env sigma in let pr_branch (cstr,typ) = - let cstr,_ = decompose_app cstr in - str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ + let cstr,_ = EConstr.decompose_app sigma cstr in + str "For " ++ pr_leconstr_env env sigma cstr ++ str ": " ++ pr_leconstr_env env sigma typ in str "Unable to unify the types found in the branches:" ++ spc () ++ hov 0 (prlist_with_sep fnl pr_branch typs) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index b73e7c7515..8a98a43ba0 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -504,8 +504,7 @@ let pr_intarg n = spc () ++ int n let pr_oc = function | None -> str" :" - | Some true -> str" :>" - | Some false -> str" :>>" + | Some () -> str" :>" let pr_record_field (x, { rf_subclass = oc ; rf_priority = pri ; rf_notation = ntn }) = let prx = match x with diff --git a/vernac/record.ml b/vernac/record.ml index bd5b71cd6b..89acd79dda 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -557,10 +557,15 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with - | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | Some () -> Some (List.hd priorities) | None -> None in - [cref, [Name proj_name, sub, Some proj_cst]] + let m = { + meth_name = Name proj_name; + meth_info = sub; + meth_const = Some proj_cst; + } in + [cref, [m]] | _ -> let record_data = [id, idbuild, univ, arity, fieldimpls, fields, false, List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in @@ -568,14 +573,17 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni params template ~kind:Decls.Method ~name:[|binder_name|] record_data in let coers = List.map2 (fun coe pri -> - Option.map (fun b -> - if b then Backward, pri else Forward, pri) coe) + Option.map (fun () -> pri) coe) coers priorities in let map ind = - let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) - (List.rev fields) coers (Recordops.lookup_projections ind) - in GlobRef.IndRef ind, l + let map decl b y = { + meth_name = RelDecl.get_name decl; + meth_info = b; + meth_const = y; + } in + let l = List.map3 map (List.rev fields) coers (Recordops.lookup_projections ind) in + GlobRef.IndRef ind, l in List.map map inds in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index fba6800729..60c6d2ec0b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -776,7 +776,7 @@ let vernac_inductive ~atts kind indl = | _ -> CErrors.user_err Pp.(str "Definitional classes do not support the \"|\" syntax.") in let (coe, (lid, ce)) = l in - let coe' = if coe then Some true else None in + let coe' = if coe then Some () else None in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in vernac_record ~template udecl ~cumulative (Class true) ~poly finite [id, bl, c, None, [f]] diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d8e17d00e3..721e710e1d 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -106,8 +106,8 @@ type search_restriction = type verbose_flag = bool (* true = Verbose; false = Silent *) type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) -type instance_flag = bool option - (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) +type instance_flag = unit option + (* Some () = Backward instance, None = NoInstance *) type export_flag = bool (* true = Export; false = Import *) |