diff options
60 files changed, 3136 insertions, 3033 deletions
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/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/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/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/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/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/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/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/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/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/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/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/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/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_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/himsg.ml b/vernac/himsg.ml index 762c95fffe..99a90bb29d 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" ++ |