From ab222f4194b24452318aab6a76d4dee3f5a2a7ff Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 20 Apr 2016 18:01:10 +0200 Subject: Fix compilation after the merge of the dynamic tactic value branch. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 8 +++++--- mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 | 5 ++++- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 6d512b1..e75d40b 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -209,13 +209,15 @@ let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = let wit = Genarg.make0 tag in + let tag = Geninterp.Val.create tag in let glob ist x = (ist, x) in let subst _ x = x in - let interp ist x = Ftactic.return x in + let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in let gen_pr _ _ _ = pr in let () = Genintern.register_intern0 wit glob in let () = Genintern.register_subst0 wit subst in let () = Geninterp.register_interp0 wit interp in + let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; wit @@ -1862,8 +1864,8 @@ ARGUMENT EXTEND ssrterm PRINTED BY pr_ssrterm INTERPRETED BY interp_ssrterm GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm - RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm - GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm + RAW_PRINTED BY pr_ssrterm + GLOB_PRINTED BY pr_ssrterm | [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] END diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 index cc2643a..7bd7f37 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 @@ -123,13 +123,15 @@ let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = let wit = Genarg.make0 tag in + let tag = Geninterp.Val.create tag in let glob ist x = (ist, x) in let subst _ x = x in - let interp ist x = Ftactic.return x in + let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in let gen_pr _ _ _ = pr in let () = Genintern.register_intern0 wit glob in let () = Genintern.register_subst0 wit subst in let () = Geninterp.register_interp0 wit interp in + let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; wit @@ -1015,6 +1017,7 @@ GEXTEND Gram END ARGUMENT EXTEND lcpattern + TYPED AS cpattern PRINTED BY pr_ssrterm INTERPRETED BY interp_ssrterm GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm -- cgit v1.2.3 From 9a33b2edbd1b44b37a423458de2970a174795650 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 13 May 2016 17:18:29 +0200 Subject: Fix compilation after the renaming of Lexer into CLexer. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 8 ++++---- mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index e75d40b..0bccc0c 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -16,7 +16,7 @@ let () = Mltop.add_known_plugin (fun () -> (* Defining grammar rules with "xx" in it automatically declares keywords too, * we thus save the lexer to restore it at the end of the file *) -let frozen_lexer = Lexer.freeze () ;; +let frozen_lexer = CLexer.freeze () ;; (*i camlp4use: "pa_extend.cmo" i*) (*i camlp4deps: "grammar/grammar.cma" i*) @@ -136,7 +136,7 @@ let pf_fresh_global name gl = let ssr_loaded = Summary.ref ~name:"SSR:loaded" false let is_ssr_loaded () = !ssr_loaded || - (if Lexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; + (if CLexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; !ssr_loaded) (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) @@ -1220,7 +1220,7 @@ let pr_ssr_search_item _ _ _ = pr_search_item (* Workaround the notation API that can only print notations *) -let is_ident s = try Lexer.check_ident s; true with _ -> false +let is_ident s = try CLexer.check_ident s; true with _ -> false let is_ident_part s = is_ident ("H" ^ s) @@ -6218,6 +6218,6 @@ END (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) (* consequence the extended ssreflect grammar. *) -let () = Lexer.unfreeze frozen_lexer ;; +let () = CLexer.unfreeze frozen_lexer ;; (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 index 7bd7f37..03dcb2f 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 @@ -3,7 +3,7 @@ (* Defining grammar rules with "xx" in it automatically declares keywords too, * we thus save the lexer to restore it at the end of the file *) -let frozen_lexer = Lexer.freeze () ;; +let frozen_lexer = CLexer.freeze () ;; (*i camlp4use: "pa_extend.cmo" i*) (*i camlp4deps: "grammar/grammar.cma" i*) @@ -1357,6 +1357,6 @@ END (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) (* consequence the extended ssreflect grammar. *) -let () = Lexer.unfreeze frozen_lexer ;; +let () = CLexer.unfreeze frozen_lexer ;; (* vim: set filetype=ocaml foldmethod=marker: *) -- cgit v1.2.3 From 1327aada8c68d8ba5ff97b22f4296a3cd5a33f6e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 13 May 2016 17:19:08 +0200 Subject: Fix compilation after the change of API in Tactics. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 25 ++++++++++++++----------- mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 | 20 ++++++++++++++++++-- 2 files changed, 32 insertions(+), 13 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 0bccc0c..579a742 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -1906,7 +1906,7 @@ ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear | [ ] -> [ [] ] END -let cleartac clr = check_hyps_uniq [] clr; clear (hyps_ids clr) +let cleartac clr = check_hyps_uniq [] clr; Proofview.V82.of_tactic (clear (hyps_ids clr)) (* type ssrwgen = ssrclear * ssrhyp * string *) @@ -2056,7 +2056,7 @@ let endclausestac id_map clseq gl_id cl0 gl = let ugtac gl' = Proofview.V82.of_tactic (convert_concl_no_check (unmark (pf_concl gl'))) gl' in - let ctacs = if hide_goal then [clear [gl_id]] else [] in + let ctacs = if hide_goal then [Proofview.V82.of_tactic (clear [gl_id])] else [] in let mktac itacs = tclTHENLIST (itacs @ utacs @ ugtac :: ctacs) in let itac (_, id) = Proofview.V82.of_tactic (introduction id) in if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else @@ -2788,7 +2788,7 @@ let injectl2rtac c = match kind_of_term c with | Var id -> injectidl2rtac id (mkVar id, NoBindings) | _ -> let id = injecteq_id in - tclTHENLIST [havetac id c; injectidl2rtac id (mkVar id, NoBindings); clear [id]] + tclTHENLIST [havetac id c; injectidl2rtac id (mkVar id, NoBindings); Proofview.V82.of_tactic (clear [id])] let is_injection_case c gl = let gl, cty = pf_type_of gl c in @@ -2827,7 +2827,7 @@ let rec intro_anon gl = (* with _ -> Errors.error "No product even after reduction" *) let with_top tac = - tclTHENLIST [introid top_id; tac (mkVar top_id); clear [top_id]] + tclTHENLIST [introid top_id; tac (mkVar top_id); Proofview.V82.of_tactic (clear [top_id])] let rec mapLR f = function [] -> [] | x :: s -> let y = f x in y :: mapLR f s @@ -2840,7 +2840,7 @@ let new_wild_id () = id let clear_wilds wilds gl = - clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl)) gl + Proofview.V82.of_tactic (clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl))) gl let clear_with_wilds wilds clr0 gl = let extend_clr clr nd = @@ -2849,7 +2849,7 @@ let clear_with_wilds wilds clr0 gl = let vars = global_vars_set_of_decl (pf_env gl) nd in let occurs id' = Idset.mem id' vars in if List.exists occurs clr then id :: clr else clr in - clear (Context.Named.fold_inside extend_clr ~init:clr0 (pf_hyps gl)) gl + Proofview.V82.of_tactic (clear (Context.Named.fold_inside extend_clr ~init:clr0 (pf_hyps gl))) gl let tclTHENS_nonstrict tac tacl taclname gl = let tacres = tac gl in @@ -4378,7 +4378,7 @@ let refine_interp_apply_view i ist gl gv = loop (pair i viewtab.(i) @ if i = 2 then pair 1 viewtab.(1) else []) let apply_top_tac gl = - tclTHENLIST [introid top_id; apply_rconstr (mkRVar top_id); clear [top_id]] gl + tclTHENLIST [introid top_id; apply_rconstr (mkRVar top_id); Proofview.V82.of_tactic (clear [top_id])] gl let inner_ssrapplytac gviews ggenl gclr ist gl = let _, clr = interp_hyps ist gl gclr in @@ -4422,12 +4422,15 @@ ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg [ mk_exactarg [] ([], clr) ] END -let vmexacttac pf gl = exact_no_check (mkCast (pf, VMcast, pf_concl gl)) gl +let vmexacttac pf = + Proofview.Goal.nf_enter { enter = begin fun gl -> + exact_no_check (mkCast (pf, VMcast, Tacmach.New.pf_concl gl)) + end } TACTIC EXTEND ssrexact | [ "exact" ssrexactarg(arg) ] -> [ Proofview.V82.tactic (tclBY (ssrapplytac ist arg)) ] | [ "exact" ] -> [ Proofview.V82.tactic (tclORELSE donetac (tclBY apply_top_tac)) ] -| [ "exact" "<:" lconstr(pf) ] -> [ Proofview.V82.tactic (vmexacttac pf) ] +| [ "exact" "<:" lconstr(pf) ] -> [ vmexacttac pf ] END (** The "congr" tactic *) @@ -4900,7 +4903,7 @@ let rwcltac cl rdx dir sr gl = let cl' = mkNamedProd rule_id (compose_prod dc r3t) (lift 1 cl) in let cl'' = mkNamedProd pattern_id rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in - let cltac = clear [pattern_id; rule_id] in + let cltac = Proofview.V82.of_tactic (clear [pattern_id; rule_id]) in let rwtacs = [rewritetac dir (mkVar rule_id); cltac] in apply_type cl'' [rdx; compose_lam dc r3], tclTHENLIST (itacs @ rwtacs), gl in @@ -6066,7 +6069,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = | Some (Some id),_ -> Some id, introid id, clear0, pats | Some _,_ -> let id = mk_anon_id "tmp" gl in - Some id, introid id, tclTHEN clear0 (clear [id]), pats in + Some id, introid id, tclTHEN clear0 (Proofview.V82.of_tactic (clear [id])), pats in let tac_specialize = match id with | None -> tclIDTAC | Some id -> diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 index 03dcb2f..e508ab7 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 @@ -1033,6 +1033,23 @@ GEXTEND Gram if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; END +let thin id sigma goal = + let ids = Id.Set.singleton id in + let env = Goal.V82.env sigma goal in + let cl = Goal.V82.concl sigma goal in + let evdref = ref (Evd.clear_metas sigma) in + let ans = + try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) + with Evarutil.ClearDependencyError _ -> None + in + match ans with + | None -> sigma + | Some (hyps, concl) -> + let sigma = !evdref in + let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in + let sigma = Goal.V82.partial_solution_to sigma goal gl ev in + sigma + let interp_pattern ist gl red redty = pp(lazy(str"interpreting: " ++ pr_pattern red)); let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in @@ -1073,8 +1090,7 @@ let interp_pattern ist gl red redty = if Option.is_empty !to_clean then sigma else let name = Option.get !to_clean in pp(lazy(pr_id name)); - try snd(Logic.prim_refiner (Proof_type.Thin [name]) sigma e) - with Evarutil.ClearDependencyError _ -> sigma) + thin name sigma e) sigma new_evars in sigma in let red = match red with -- cgit v1.2.3 From 760351d5864d5f98d75f310ace6b37bda7a471a9 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 31 May 2016 14:59:15 +0200 Subject: Compatibility with latest Coq trunk. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 7 ++++++- mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 | 5 ++++- 2 files changed, 10 insertions(+), 2 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 579a742..2ee0d97 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -23,6 +23,7 @@ let frozen_lexer = CLexer.freeze () ;; open Names open Pp +open Feedback open Pcoq open Pcoq.Prim open Pcoq.Constr @@ -99,6 +100,10 @@ let errorstrm = Errors.errorlabstrm "ssreflect" let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) let anomaly s = Errors.anomaly (str s) +(* Compatibility with Coq 8.6 *) +let ppnl = msg_info +let msgnl = msg_info + (** look up a name in the ssreflect internals module *) let ssrdirpath = make_dirpath [id_of_string "ssreflect"] let ssrqid name = make_qualid ssrdirpath (id_of_string name) @@ -142,7 +147,7 @@ let is_ssr_loaded () = (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) (* or if SsrDebug is Set *) let pp_ref = ref (fun _ -> ()) -let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let ssr_pp s = msg_error (str"SSR: "++Lazy.force s) let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () let _ = Goptions.declare_bool_option diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 index e508ab7..f04a910 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 @@ -57,10 +57,13 @@ let dummy_loc = Loc.ghost let errorstrm = Errors.errorlabstrm "ssreflect" let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) +(* Compatibility with Coq 8.6 *) +let ppnl = Feedback.msg_info + (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) (* or if SsrDebug is Set *) let pp_ref = ref (fun _ -> ()) -let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let ssr_pp s = Feedback.msg_error (str"SSR: "++Lazy.force s) let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () let debug b = if b then pp_ref := ssr_pp else pp_ref := fun _ -> () -- cgit v1.2.3 From 961344bd556656b2feb69ce2c0592a5bdcb5c020 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 3 Jun 2016 12:58:58 +0200 Subject: fixing compilation (with Coq trunk & Coq v8.5) --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 2ee0d97..a5037ee 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -2388,7 +2388,7 @@ END (* Populating the table *) let cache_viewhint (_, (i, lvh)) = - let mem_raw h = List.exists (Notation_ops.eq_glob_constr h) in + let mem_raw h = List.exists (Glob_ops.glob_constr_eq h) in let add_hint h hdb = if mem_raw h hdb then hdb else h :: hdb in viewtab.(i) <- List.fold_right add_hint lvh viewtab.(i) -- cgit v1.2.3 From 0e36c8f0247cbd814cd82592e2722b052283b495 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 16 Jun 2016 11:53:53 +0200 Subject: Port build system to trunk (ssrmatching merged in Coq) --- mathcomp/Make | 4 - mathcomp/ssreflect/Make | 4 - mathcomp/ssreflect/Makefile.coq-makefile | 19 +- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 7 +- mathcomp/ssreflect/plugin/trunk/ssreflect.mllib | 2 - .../ssreflect/plugin/trunk/ssreflect_plugin.mlpack | 2 + mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 | 1381 -------------------- mathcomp/ssreflect/plugin/trunk/ssrmatching.mli | 241 ---- mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib | 2 - .../ssreflect/plugin/v8.4/ssreflect_plugin.mllib | 2 + mathcomp/ssreflect/plugin/v8.4/ssrmatching.v | 27 + mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 | 6 +- mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib | 2 - .../ssreflect/plugin/v8.5/ssreflect_plugin.mllib | 2 + mathcomp/ssreflect/plugin/v8.5/ssrmatching.v | 27 + mathcomp/ssreflect/ssreflect.v | 2 +- mathcomp/ssreflect/ssrmatching.v | 28 - 18 files changed, 85 insertions(+), 1675 deletions(-) delete mode 100644 mathcomp/ssreflect/plugin/trunk/ssreflect.mllib create mode 100644 mathcomp/ssreflect/plugin/trunk/ssreflect_plugin.mlpack delete mode 100644 mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 delete mode 100644 mathcomp/ssreflect/plugin/trunk/ssrmatching.mli delete mode 100644 mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib create mode 100644 mathcomp/ssreflect/plugin/v8.4/ssreflect_plugin.mllib create mode 100644 mathcomp/ssreflect/plugin/v8.4/ssrmatching.v delete mode 100644 mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib create mode 100644 mathcomp/ssreflect/plugin/v8.5/ssreflect_plugin.mllib create mode 100644 mathcomp/ssreflect/plugin/v8.5/ssrmatching.v delete mode 100644 mathcomp/ssreflect/ssrmatching.v (limited to 'mathcomp') diff --git a/mathcomp/Make b/mathcomp/Make index a235149..9735a62 100644 --- a/mathcomp/Make +++ b/mathcomp/Make @@ -128,7 +128,6 @@ ssreflect/seq.v ssreflect/ssrbool.v ssreflect/ssreflect.v ssreflect/ssrfun.v -ssreflect/ssrmatching.v ssreflect/ssrnat.v ssreflect/tuple.v ssrtest/absevarprop.v @@ -174,9 +173,6 @@ ssrtest/wlog_suff.v ssrtest/wlong_intro.v ssrtest/tacnotationpattern.v ssreflect.ml4 -ssreflect.mllib -ssrmatching.ml4 -ssrmatching.mli -I . -R . mathcomp diff --git a/mathcomp/ssreflect/Make b/mathcomp/ssreflect/Make index 4dd672c..a10b9c5 100644 --- a/mathcomp/ssreflect/Make +++ b/mathcomp/ssreflect/Make @@ -4,7 +4,6 @@ seq.v ssrbool.v ssreflect.v ssrfun.v -ssrmatching.v ssrnat.v bigop.v binomial.v @@ -19,9 +18,6 @@ path.v prime.v tuple.v -ssreflect.mllib -ssrmatching.mli -ssrmatching.ml4 ssreflect.ml4 -I . diff --git a/mathcomp/ssreflect/Makefile.coq-makefile b/mathcomp/ssreflect/Makefile.coq-makefile index 52beace..d815286 100644 --- a/mathcomp/ssreflect/Makefile.coq-makefile +++ b/mathcomp/ssreflect/Makefile.coq-makefile @@ -1,9 +1,22 @@ define coqmakefile (echo "Generating Makefile.coq for Coq $(V) with COQBIN=$(COQBIN)";\ if [ "$$OS" = "Windows_NT" ]; then LN=cp; else LN="ln -sf"; fi;\ - $$LN $(1)/plugin/$(V)/ssreflect.mllib .;\ - $$LN $(1)/plugin/$(V)/ssrmatching.mli .;\ - $$LN $(1)/plugin/$(V)/ssrmatching.ml4 .;\ + case $(V) in\ + v8.5*|v8.4*)\ + $$LN $(1)/plugin/$(V)/ssrmatching.mli .;\ + $$LN $(1)/plugin/$(V)/ssrmatching.ml4 .;\ + echo ssrmatching.mli >> Make;\ + echo ssrmatching.ml4 >> Make;\ + $$LN $(1)/plugin/$(V)/ssrmatching.v .;\ + echo ssrmatching.v >> Make;\ + $$LN $(1)/plugin/$(V)/ssreflect_plugin.mllib .;\ + echo ssreflect_plugin.mllib >> Make;\ + ;;\ + *)\ + $$LN $(1)/plugin/$(V)/ssreflect_plugin.mlpack .;\ + echo ssreflect_plugin.mlpack >> Make;\ + ;;\ + esac;\ $$LN $(1)/plugin/$(V)/ssreflect.ml4 .;\ $(COQBIN)coq_makefile -f Make -o Makefile.coq) endef diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index a5037ee..0d41ac5 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -2,7 +2,7 @@ (* Distributed under the terms of CeCILL-B. *) (* This line is read by the Makefile's dist target: do not remove. *) -DECLARE PLUGIN "ssreflect" +DECLARE PLUGIN "ssreflect_plugin" let ssrversion = "1.6";; let ssrAstVersion = 1;; let () = Mltop.add_known_plugin (fun () -> @@ -11,7 +11,7 @@ let () = Mltop.add_known_plugin (fun () -> Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" end) - "ssreflect" + "ssreflect_plugin" ;; (* Defining grammar rules with "xx" in it automatically declares keywords too, @@ -71,6 +71,7 @@ open Locusops open Compat open Tok +open Ssrmatching_plugin open Ssrmatching @@ -1028,7 +1029,7 @@ let pf_unabs_evars gl ise n c0 = type ssrargfmt = ArgSsr of string | ArgCoq of argument_type | ArgSep of string let ssrtac_name name = { - mltac_plugin = "ssreflect"; + mltac_plugin = "ssreflect_plugin"; mltac_tactic = "ssr" ^ name; } diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.mllib b/mathcomp/ssreflect/plugin/trunk/ssreflect.mllib deleted file mode 100644 index 006b70f..0000000 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Ssrmatching -Ssreflect diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect_plugin.mlpack b/mathcomp/ssreflect/plugin/trunk/ssreflect_plugin.mlpack new file mode 100644 index 0000000..006b70f --- /dev/null +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect_plugin.mlpack @@ -0,0 +1,2 @@ +Ssrmatching +Ssreflect diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 deleted file mode 100644 index f04a910..0000000 --- a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 +++ /dev/null @@ -1,1381 +0,0 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) - -(* Defining grammar rules with "xx" in it automatically declares keywords too, - * we thus save the lexer to restore it at the end of the file *) -let frozen_lexer = CLexer.freeze () ;; - -(*i camlp4use: "pa_extend.cmo" i*) -(*i camlp4deps: "grammar/grammar.cma" i*) - -open Names -open Pp -open Pcoq -open Genarg -open Constrarg -open Term -open Vars -open Topconstr -open Libnames -open Tactics -open Tacticals -open Termops -open Namegen -open Recordops -open Tacmach -open Coqlib -open Glob_term -open Util -open Evd -open Extend -open Goptions -open Tacexpr -open Proofview.Notations -open Tacinterp -open Pretyping -open Constr -open Tactic -open Extraargs -open Ppconstr -open Printer - -open Globnames -open Misctypes -open Decl_kinds -open Evar_kinds -open Constrexpr -open Constrexpr_ops -open Notation_term -open Notation_ops -open Locus -open Locusops - -DECLARE PLUGIN "ssreflect" - -type loc = Loc.t -let dummy_loc = Loc.ghost -let errorstrm = Errors.errorlabstrm "ssreflect" -let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) - -(* Compatibility with Coq 8.6 *) -let ppnl = Feedback.msg_info - -(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) -(* or if SsrDebug is Set *) -let pp_ref = ref (fun _ -> ()) -let ssr_pp s = Feedback.msg_error (str"SSR: "++Lazy.force s) -let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () -let debug b = - if b then pp_ref := ssr_pp else pp_ref := fun _ -> () -let _ = - Goptions.declare_bool_option - { Goptions.optsync = false; - Goptions.optname = "ssrmatching debugging"; - Goptions.optkey = ["SsrMatchingDebug"]; - Goptions.optdepr = false; - Goptions.optread = (fun _ -> !pp_ref == ssr_pp); - Goptions.optwrite = debug } -let pp s = !pp_ref s - -(** Utils {{{ *****************************************************************) -let env_size env = List.length (Environ.named_context env) -let safeDestApp c = - match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] -let get_index = function ArgArg i -> i | _ -> - Errors.anomaly (str"Uninterpreted index") -(* Toplevel constr must be globalized twice ! *) -let glob_constr ist genv = function - | _, Some ce -> - let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in - let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in - Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv ce - | rc, None -> rc - -(* Term printing utilities functions for deciding bracketing. *) -let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") -(* String lexing utilities *) -let skip_wschars s = - let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop -(* We also guard characters that might interfere with the ssreflect *) -(* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with - | '(' -> false - | '{' | '/' | '=' -> true - | _ -> ch1 = '(' -(* The call 'guard s i' should return true if the contents of s *) -(* starting at i need bracketing to avoid ambiguities. *) -let pr_guarded guard prc c = - msg_with Format.str_formatter (prc c); - let s = Format.flush_str_formatter () ^ "$" in - if guard s (skip_wschars s 0) then pr_paren prc c else prc c -(* More sensible names for constr printers *) -let pr_constr = pr_constr -let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c -let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c -let prl_constr_expr = pr_lconstr_expr -let pr_constr_expr = pr_constr_expr -let prl_glob_constr_and_expr = function - | _, Some c -> prl_constr_expr c - | c, None -> prl_glob_constr c -let pr_glob_constr_and_expr = function - | _, Some c -> pr_constr_expr c - | c, None -> pr_glob_constr c -let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c -let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c - -(** Adding a new uninterpreted generic argument type *) -let add_genarg tag pr = - let wit = Genarg.make0 tag in - let tag = Geninterp.Val.create tag in - let glob ist x = (ist, x) in - let subst _ x = x in - let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in - let gen_pr _ _ _ = pr in - let () = Genintern.register_intern0 wit glob in - let () = Genintern.register_subst0 wit subst in - let () = Geninterp.register_interp0 wit interp in - let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in - Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; - wit - -(** Constructors for cast type *) -let dC t = CastConv t -(** Constructors for constr_expr *) -let isCVar = function CRef (Ident _, _) -> true | _ -> false -let destCVar = function CRef (Ident (_, id), _) -> id | _ -> - Errors.anomaly (str"not a CRef") -let mkCHole loc = CHole (loc, None, IntroAnonymous, None) -let mkCLambda loc name ty t = - CLambdaN (loc, [[loc, name], Default Explicit, ty], t) -let mkCLetIn loc name bo t = - CLetIn (loc, (loc, name), bo, t) -let mkCCast loc t ty = CCast (loc,t, dC ty) -(** Constructors for rawconstr *) -let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) -let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) -let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) -let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) - -(* ssrterm conbinators *) -let combineCG t1 t2 f g = match t1, t2 with - | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) - | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) - | _, (_, (_, None)) -> Errors.anomaly (str"have: mixed C-G constr") - | _ -> Errors.anomaly (str"have: mixed G-C constr") -let loc_ofCG = function - | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s - | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s - -let mk_term k c = k, (mkRHole, Some c) -let mk_lterm = mk_term ' ' - -let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty - -(* }}} *) - -(** Profiling {{{ *************************************************************) -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } -let profile_now = ref false -let something_profiled = ref false -let profilers = ref [] -let add_profiler f = profilers := f :: !profilers;; -let profile b = - profile_now := b; - if b then List.iter (fun f -> f.reset ()) !profilers; - if not b then List.iter (fun f -> f.print ()) !profilers -;; -let _ = - Goptions.declare_bool_option - { Goptions.optsync = false; - Goptions.optname = "ssrmatching profiling"; - Goptions.optkey = ["SsrMatchingProfiling"]; - Goptions.optread = (fun _ -> !profile_now); - Goptions.optdepr = false; - Goptions.optwrite = profile } -let () = - let prof_total = - let init = ref 0.0 in { - profile = (fun f x -> assert false); - reset = (fun () -> init := Unix.gettimeofday ()); - print = (fun () -> if !something_profiled then - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in - let prof_legenda = { - profile = (fun f x -> assert false); - reset = (fun () -> ()); - print = (fun () -> if !something_profiled then begin - prerr_endline - (Printf.sprintf "!! %39s ---------- --------- --------- ---------" - (String.make 39 '-')); - prerr_endline - (Printf.sprintf "!! %-39s %10s %9s %9s %9s" - "function" "#calls" "total" "max" "average") end) } in - add_profiler prof_legenda; - add_profiler prof_total -;; - -let mk_profiler s = - let total, calls, max = ref 0.0, ref 0, ref 0.0 in - let reset () = total := 0.0; calls := 0; max := 0.0 in - let profile f x = - if not !profile_now then f x else - let before = Unix.gettimeofday () in - try - incr calls; - let res = f x in - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - res - with exc -> - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - raise exc in - let print () = - if !calls <> 0 then begin - something_profiled := true; - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - s !calls !total !max (!total /. (float_of_int !calls))) end in - let prof = { profile = profile; reset = reset; print = print } in - add_profiler prof; - prof -;; -(* }}} *) - -exception NoProgress - -(** Unification procedures. *) - -(* To enforce the rigidity of the rooted match we always split *) -(* top applications, so the unification procedures operate on *) -(* arrays of patterns and terms. *) -(* We perform three kinds of unification: *) -(* EQ: exact conversion check *) -(* FO: first-order unification of evars, without conversion *) -(* HO: higher-order unification with conversion *) -(* The subterm unification strategy is to find the first FO *) -(* match, if possible, and the first HO match otherwise, then *) -(* compute all the occurrences that are EQ matches for the *) -(* relevant subterm. *) -(* Additional twists: *) -(* - If FO/HO fails then we attempt to fill evars using *) -(* typeclasses before raising an outright error. We also *) -(* fill typeclasses even after a successful match, since *) -(* beta-reduction and canonical instances may leave *) -(* undefined evars. *) -(* - We do postchecks to rule out matches that are not *) -(* closed or that assign to a global evar; these can be *) -(* disabled for rewrite or dependent family matches. *) -(* - We do a full FO scan before turning to HO, as the FO *) -(* comparison can be much faster than the HO one. *) - -let unif_EQ env sigma p c = - let evars = existential_opt_value sigma, Evd.universes sigma in - try let _ = Reduction.conv env p ~evars c in true with _ -> false - -let unif_EQ_args env sigma pa a = - let n = Array.length pa in - let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in - loop 0 - -let prof_unif_eq_args = mk_profiler "unif_EQ_args";; -let unif_EQ_args env sigma pa a = - prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a -;; - -let unif_HO env ise p c = Evarconv.the_conv_x env p c ise - -let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise - -let unif_HO_args env ise0 pa i ca = - let n = Array.length pa in - let rec loop ise j = - if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in - loop ise0 0 - -(* FO unification should boil down to calling w_unify with no_delta, but *) -(* alas things are not so simple: w_unify does partial type-checking, *) -(* which breaks down when the no-delta flag is on (as the Coq type system *) -(* requires full convertibility. The workaround here is to convert all *) -(* evars into metas, since 8.2 does not TC metas. This means some lossage *) -(* for HO evars, though hopefully Miller patterns can pick up some of *) -(* those cases, and HO matching will mop up the rest. *) -let flags_FO = - let flags = - { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags - with - Unification.modulo_conv_on_closed_terms = None; - Unification.modulo_eta = true; - Unification.modulo_betaiota = true; - Unification.modulo_delta_types = full_transparent_state} - in - { Unification.core_unify_flags = flags; - Unification.merge_unify_flags = flags; - Unification.subterm_unify_flags = flags; - Unification.allow_K_in_toplevel_higher_order_unification = false; - Unification.resolve_evars = - (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars - } -let unif_FO env ise p c = - Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c - -(* Perform evar substitution in main term and prune substitution. *) -let nf_open_term sigma0 ise c = - let s = ise and s' = ref sigma0 in - let rec nf c' = match kind_of_term c' with - | Evar ex -> - begin try nf (existential_value s ex) with _ -> - let k, a = ex in let a' = Array.map nf a in - if not (Evd.mem !s' k) then - s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); - mkEvar (k, a') - end - | _ -> map_constr nf c' in - let copy_def k evi () = - if evar_body evi != Evd.Evar_empty then () else - match Evd.evar_body (Evd.find s k) with - | Evar_defined c' -> s' := Evd.define k (nf c') !s' - | _ -> () in - let c' = nf c in let _ = Evd.fold copy_def sigma0 () in - !s', Evd.evar_universe_context s, c' - -let unif_end env sigma0 ise0 pt ok = - let ise = Evarconv.consider_remaining_unif_problems env ise0 in - let s, uc, t = nf_open_term sigma0 ise pt in - let ise1 = create_evar_defs s in - let ise1 = Evd.set_universe_context ise1 uc in - let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in - if not (ok ise) then raise NoProgress else - if ise2 == ise1 then (s, uc, t) - else - let s, uc', t = nf_open_term sigma0 ise2 t in - s, Evd.union_evar_universe_context uc uc', t - -let pf_unif_HO gl sigma pt p c = - let env = pf_env gl in - let ise = unif_HO env (create_evar_defs sigma) p c in - unif_end env (project gl) ise pt (fun _ -> true) - -let unify_HO env sigma0 t1 t2 = - let sigma = unif_HO env sigma0 t1 t2 in - let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in - Evd.set_universe_context sigma uc - -let pf_unify_HO gl t1 t2 = - let env, sigma0, si = pf_env gl, project gl, sig_it gl in - let sigma = unify_HO env sigma0 t1 t2 in - re_sig si sigma - -(* This is what the definition of iter_constr should be... *) -let iter_constr_LR f c = match kind_of_term c with - | Evar (k, a) -> Array.iter f a - | Cast (cc, _, t) -> f cc; f t - | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b - | LetIn (_, v, t, b) -> f v; f t; f b - | App (cf, a) -> f cf; Array.iter f a - | Case (_, p, v, b) -> f v; f p; Array.iter f b - | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> - for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done - | _ -> () - -(* The comparison used to determine which subterms matches is KEYED *) -(* CONVERSION. This looks for convertible terms that either have the same *) -(* same head constant as pat if pat is an application (after beta-iota), *) -(* or start with the same constr constructor (esp. for LetIn); this is *) -(* disregarded if the head term is let x := ... in x, and casts are always *) -(* ignored and removed). *) -(* Record projections get special treatment: in addition to the projection *) -(* constant itself, ssreflect also recognizes head constants of canonical *) -(* projections. *) - -exception NoMatch -type ssrdir = L2R | R2L -let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS" -let inv_dir = function L2R -> R2L | R2L -> L2R - - -type pattern_class = - | KpatFixed - | KpatConst - | KpatEvar of existential_key - | KpatLet - | KpatLam - | KpatRigid - | KpatFlex - | KpatProj of constant - -type tpattern = { - up_k : pattern_class; - up_FO : constr; - up_f : constr; - up_a : constr array; - up_t : constr; (* equation proof term or matched term *) - up_dir : ssrdir; (* direction of the rule *) - up_ok : constr -> evar_map -> bool; (* progess test for rewrite *) - } - -let all_ok _ _ = true - -let proj_nparams c = - try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 - -let isFixed c = match kind_of_term c with - | Var _ | Ind _ | Construct _ | Const _ -> true - | _ -> false - -let isRigid c = match kind_of_term c with - | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true - | _ -> false - -exception UndefPat - -let hole_var = mkVar (id_of_string "_") -let pr_constr_pat c0 = - let rec wipe_evar c = - if isEvar c then hole_var else map_constr wipe_evar c in - pr_constr (wipe_evar c0) - -(* Turn (new) evars into metas *) -let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = - let ise = ref ise0 in - let sigma = ref ise0 in - let nenv = env_size env + if hack then 1 else 0 in - let rec put c = match kind_of_term c with - | Evar (k, a as ex) -> - begin try put (existential_value !sigma ex) - with NotInstantiatedEvar -> - if Evd.mem sigma0 k then map_constr put c else - let evi = Evd.find !sigma k in - let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in - let abs_dc (d, c) = function - | Context.Named.Declaration.LocalDef (x, b, t) -> - d, mkNamedLetIn x (put b) (put t) c - | Context.Named.Declaration.LocalAssum (x, t) -> - mkVar x :: d, mkNamedProd x (put t) c in - let a, t = - Context.Named.fold_inside abs_dc ~init:([], (put evi.evar_concl)) dc in - let m = Evarutil.new_meta () in - ise := meta_declare m t !ise; - sigma := Evd.define k (applist (mkMeta m, a)) !sigma; - put (existential_value !sigma ex) - end - | _ -> map_constr put c in - let c1 = put c0 in !ise, c1 - -(* Compile a match pattern from a term; t is the term to fill. *) -(* p_origin can be passed to obtain a better error message *) -let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = - let k, f, a = - let f, a = Reductionops.whd_betaiota_stack ise p in - match kind_of_term f with - | Const (p,_) -> - let np = proj_nparams p in - if np = 0 || np > List.length a then KpatConst, f, a else - let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2 - | Var _ | Ind _ | Construct _ -> KpatFixed, f, a - | Evar (k, _) -> - if Evd.mem sigma0 k then KpatEvar k, f, a else - if a <> [] then KpatFlex, f, a else - (match p_origin with None -> Errors.error "indeterminate pattern" - | Some (dir, rule) -> - errorstrm (str "indeterminate " ++ pr_dir_side dir - ++ str " in " ++ pr_constr_pat rule)) - | LetIn (_, v, _, b) -> - if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a - | Lambda _ -> KpatLam, f, a - | _ -> KpatRigid, f, a in - let aa = Array.of_list a in - let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in - ise', - { up_k = k; up_FO = p'; up_f = f; - up_a = aa; up_ok = ok; up_dir = dir; up_t = t} - -(* Specialize a pattern after a successful match: assign a precise head *) -(* kind and arity for Proj and Flex patterns. *) -let ungen_upat lhs (sigma, uc, t) u = - let f, a = safeDestApp lhs in - let k = match kind_of_term f with - | Var _ | Ind _ | Construct _ -> KpatFixed - | Const _ -> KpatConst - | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k - | LetIn _ -> KpatLet - | Lambda _ -> KpatLam - | _ -> KpatRigid in - sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} - -let nb_cs_proj_args pc f u = - let na k = - List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in - try match kind_of_term f with - | Prod _ -> na Prod_cs - | Sort s -> na (Sort_cs (family_of_sort s)) - | Const (c',_) when Constant.equal c' pc -> Array.length (snd (destApp u.up_f)) - | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) - | _ -> -1 - with Not_found -> -1 - -let isEvar_k k f = - match kind_of_term f with Evar (k', _) -> k = k' | _ -> false - -let nb_args c = - match kind_of_term c with App (_, a) -> Array.length a | _ -> 0 - -let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i -let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a) - -let splay_app ise = - let rec loop c a = match kind_of_term c with - | App (f, a') -> loop f (Array.append a' a) - | Cast (c', _, _) -> loop c' a - | Evar ex -> - (try loop (existential_value ise ex) a with _ -> c, a) - | _ -> c, a in - fun c -> match kind_of_term c with - | App (f, a) -> loop f a - | Cast _ | Evar _ -> loop c [| |] - | _ -> c, [| |] - -let filter_upat i0 f n u fpats = - let na = Array.length u.up_a in - if n < na then fpats else - let np = match u.up_k with - | KpatConst when Term.eq_constr u.up_f f -> na - | KpatFixed when Term.eq_constr u.up_f f -> na - | KpatEvar k when isEvar_k k f -> na - | KpatLet when isLetIn f -> na - | KpatLam when isLambda f -> na - | KpatRigid when isRigid f -> na - | KpatFlex -> na - | KpatProj pc -> - let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np - | _ -> -1 in - if np < na then fpats else - let () = if !i0 < np then i0 := n in (u, np) :: fpats - -let filter_upat_FO i0 f n u fpats = - let np = nb_args u.up_FO in - if n < np then fpats else - let ok = match u.up_k with - | KpatConst -> Term.eq_constr u.up_f f - | KpatFixed -> Term.eq_constr u.up_f f - | KpatEvar k -> isEvar_k k f - | KpatLet -> isLetIn f - | KpatLam -> isLambda f - | KpatRigid -> isRigid f - | KpatProj pc -> Term.eq_constr f (mkConst pc) - | KpatFlex -> i0 := n; true in - if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats - -exception FoundUnif of (evar_map * evar_universe_context * tpattern) -(* Note: we don't update env as we descend into the term, as the primitive *) -(* unification procedure always rejects subterms with bound variables. *) - -let dont_impact_evars_in cl = - let evs_in_cl = Evd.evars_of_term cl in - fun sigma -> Evar.Set.for_all (fun k -> - try let _ = Evd.find_undefined sigma k in true - with Not_found -> false) evs_in_cl - -(* We are forced to duplicate code between the FO/HO matching because we *) -(* have to work around several kludges in unify.ml: *) -(* - w_unify drops into second-order unification when the pattern is an *) -(* application whose head is a meta. *) -(* - w_unify tries to unify types without subsumption when the pattern *) -(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *) -(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) -(* match a head let rigidly. *) -let match_upats_FO upats env sigma0 ise orig_c = - let dont_impact_evars = dont_impact_evars_in orig_c in - let rec loop c = - let f, a = splay_app ise c in let i0 = ref (-1) in - let fpats = - List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in - while !i0 >= 0 do - let i = !i0 in i0 := -1; - let c' = mkSubApp f i a in - let one_match (u, np) = - let skip = - if i <= np then i < np else - if u.up_k == KpatFlex then begin i0 := i - 1; false end else - begin if !i0 < np then i0 := np; true end in - if skip || not (closed0 c') then () else try - let _ = match u.up_k with - | KpatFlex -> - let kludge v = mkLambda (Anonymous, mkProp, v) in - unif_FO env ise (kludge u.up_FO) (kludge c') - | KpatLet -> - let kludge vla = - let vl, a = safeDestApp vla in - let x, v, t, b = destLetIn vl in - mkApp (mkLambda (x, t, b), Array.cons v a) in - unif_FO env ise (kludge u.up_FO) (kludge c') - | _ -> unif_FO env ise u.up_FO c' in - let ise' = (* Unify again using HO to assign evars *) - let p = mkApp (u.up_f, u.up_a) in - try unif_HO env ise p c' with _ -> raise NoMatch in - let lhs = mkSubApp f i a in - let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in - raise (FoundUnif (ungen_upat lhs pt' u)) - with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u - | Not_found -> Errors.anomaly (str"incomplete ise in match_upats_FO") - | _ -> () in - List.iter one_match fpats - done; - iter_constr_LR loop f; Array.iter loop a in - try loop orig_c with Invalid_argument _ -> Errors.anomaly (str"IN FO") - -let prof_FO = mk_profiler "match_upats_FO";; -let match_upats_FO upats env sigma0 ise c = - prof_FO.profile (match_upats_FO upats env sigma0) ise c -;; - - -let match_upats_HO ~on_instance upats env sigma0 ise c = - let dont_impact_evars = dont_impact_evars_in c in - let it_did_match = ref false in - let failed_because_of_TC = ref false in - let rec aux upats env sigma0 ise c = - let f, a = splay_app ise c in let i0 = ref (-1) in - let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in - while !i0 >= 0 do - let i = !i0 in i0 := -1; - let one_match (u, np) = - let skip = - if i <= np then i < np else - if u.up_k == KpatFlex then begin i0 := i - 1; false end else - begin if !i0 < np then i0 := np; true end in - if skip then () else try - let ise' = match u.up_k with - | KpatFixed | KpatConst -> ise - | KpatEvar _ -> - let _, pka = destEvar u.up_f and _, ka = destEvar f in - unif_HO_args env ise pka 0 ka - | KpatLet -> - let x, v, t, b = destLetIn f in - let _, pv, _, pb = destLetIn u.up_f in - let ise' = unif_HO env ise pv v in - unif_HO - (Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env) - ise' pb b - | KpatFlex | KpatProj _ -> - unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a) - | _ -> unif_HO env ise u.up_f f in - let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in - let lhs = mkSubApp f i a in - let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in - on_instance (ungen_upat lhs pt' u) - with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u - | NoProgress -> it_did_match := true - | Pretype_errors.PretypeError - (_,_,Pretype_errors.UnsatisfiableConstraints _) -> - failed_because_of_TC:=true - | e when Errors.noncritical e -> () in - List.iter one_match fpats - done; - iter_constr_LR (aux upats env sigma0 ise) f; - Array.iter (aux upats env sigma0 ise) a - in - aux upats env sigma0 ise c; - if !it_did_match then raise NoProgress; - !failed_because_of_TC - -let prof_HO = mk_profiler "match_upats_HO";; -let match_upats_HO ~on_instance upats env sigma0 ise c = - prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c -;; - - -let fixed_upat = function -| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false -| {up_t = t} -> not (occur_existential t) - -let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) - -let assert_done r = - match !r with Some x -> x | None -> Errors.anomaly (str"do_once never called") - -let assert_done_multires r = - match !r with - | None -> Errors.anomaly (str"do_once never called") - | Some (n, xs) -> - r := Some (n+1,xs); - try List.nth xs n with Failure _ -> raise NoMatch - -type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr -type find_P = - Environ.env -> Term.constr -> int -> - k:subst -> - Term.constr -type conclude = unit -> - Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr) - -(* upats_origin makes a better error message only *) -let mk_tpattern_matcher ?(all_instances=false) - ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats) -= - let nocc = ref 0 and skip_occ = ref false in - let use_occ, occ_list = match occ with - | Some (true, ol) -> ol = [], ol - | Some (false, ol) -> ol <> [], ol - | None -> false, [] in - let max_occ = List.fold_right max occ_list 0 in - let subst_occ = - let occ_set = Array.make max_occ (not use_occ) in - let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in - let _ = if max_occ = 0 then skip_occ := use_occ in - fun () -> incr nocc; - if !nocc = max_occ then skip_occ := use_occ; - if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in - let upat_that_matched = ref None in - let match_EQ env sigma u = - match u.up_k with - | KpatLet -> - let x, pv, t, pb = destLetIn u.up_f in - let env' = - Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env in - let match_let f = match kind_of_term f with - | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b - | _ -> false in match_let - | KpatFixed -> Term.eq_constr u.up_f - | KpatConst -> Term.eq_constr u.up_f - | KpatLam -> fun c -> - (match kind_of_term c with - | Lambda _ -> unif_EQ env sigma u.up_f c - | _ -> false) - | _ -> unif_EQ env sigma u.up_f in -let p2t p = mkApp(p.up_f,p.up_a) in -let source () = match upats_origin, upats with - | None, [p] -> - (if fixed_upat p then str"term " else str"partial term ") ++ - pr_constr_pat (p2t p) ++ spc() - | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() - | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ spc() - | _, [] | None, _::_::_ -> - Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in -let on_instance, instances = - let instances = ref [] in - (fun x -> - if all_instances then instances := !instances @ [x] - else raise (FoundUnif x)), - (fun () -> !instances) in -let rec uniquize = function - | [] -> [] - | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs -> - let t = Reductionops.nf_evar sigma t in - let f = Reductionops.nf_evar sigma f in - let a = Array.map (Reductionops.nf_evar sigma) a in - let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) = - let t1 = Reductionops.nf_evar sigma1 t1 in - let f1 = Reductionops.nf_evar sigma1 f1 in - let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in - not (Term.eq_constr t t1 && - Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in - x :: uniquize (List.filter neq xs) in - -((fun env c h ~k -> - do_once upat_that_matched (fun () -> - let failed_because_of_TC = ref false in - try - if not all_instances then match_upats_FO upats env sigma0 ise c; - failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c; - raise NoMatch - with FoundUnif sigma_u -> 0,[sigma_u] - | (NoMatch|NoProgress) when all_instances && instances () <> [] -> - 0, uniquize (instances ()) - | NoMatch when (not raise_NoMatch) -> - if !failed_because_of_TC then - errorstrm (source ()++strbrk"matches but type classes inference fails") - else - errorstrm (source () ++ str "does not match any subterm of the goal") - | NoProgress when (not raise_NoMatch) -> - let dir = match upats_origin with Some (d,_) -> d | _ -> - Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in - errorstrm (str"all matches of "++source()++ - str"are equal to the " ++ pr_dir_side (inv_dir dir)) - | NoProgress -> raise NoMatch); - let sigma, _, ({up_f = pf; up_a = pa} as u) = - if all_instances then assert_done_multires upat_that_matched - else List.hd (snd(assert_done upat_that_matched)) in -(* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *) - if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else - let match_EQ = match_EQ env sigma u in - let pn = Array.length pa in - let rec subst_loop (env,h as acc) c' = - if !skip_occ then c' else - let f, a = splay_app sigma c' in - if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then - let a1, a2 = Array.chop (Array.length pa) a in - let fa1 = mkApp (f, a1) in - let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in - mkApp (f', Array.map_left (subst_loop acc) a2) - else - (* TASSI: clear letin values to avoid unfolding *) - let inc_h rd (env,h') = - let ctx_item = - match rd with - | Context.Rel.Declaration.LocalAssum _ as x -> x - | Context.Rel.Declaration.LocalDef (x,_,y) -> - Context.Rel.Declaration.LocalAssum(x,y) in - Environ.push_rel ctx_item env, h' + 1 in - let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in - mkApp (f', Array.map_left (subst_loop acc) a) in - subst_loop (env,h) c) : find_P), -((fun () -> - let sigma, uc, ({up_f = pf; up_a = pa} as u) = - match !upat_that_matched with - | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch - | None -> Errors.anomaly (str"companion function never called") in - let p' = mkApp (pf, pa) in - if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) - else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ - str(String.plural !nocc " occurence") ++ match upats_origin with - | None -> str" of" ++ spc() ++ pr_constr_pat p' - | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ - ws 4 ++ pr_constr_pat p' ++ fnl () ++ - str"of " ++ pr_constr_pat rule)) : conclude) - -type ('ident, 'term) ssrpattern = - | T of 'term - | In_T of 'term - | X_In_T of 'ident * 'term - | In_X_In_T of 'ident * 'term - | E_In_X_In_T of 'term * 'ident * 'term - | E_As_X_In_T of 'term * 'ident * 'term - -let pr_pattern = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t - | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t - -let pr_pattern_w_ids = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t - | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t - -let pr_pattern_aux pr_constr = function - | T t -> pr_constr t - | In_T t -> str "in " ++ pr_constr t - | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t - | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t - | E_In_X_In_T (e,x,t) -> - pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t - | E_As_X_In_T (e,x,t) -> - pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t -let pp_pattern (sigma, p) = - pr_pattern_aux (fun t -> pr_constr_pat (pi3 (nf_open_term sigma sigma t))) p -let pr_cpattern = pr_term -let pr_rpattern _ _ _ = pr_pattern - -let pr_option f = function None -> mt() | Some x -> f x -let pr_ssrpattern _ _ _ = pr_option pr_pattern -let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]") -let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep -let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")") -let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp - -let wit_rpatternty = add_genarg "rpatternty" pr_pattern - -ARGUMENT EXTEND rpattern TYPED AS rpatternty PRINTED BY pr_rpattern - | [ lconstr(c) ] -> [ T (mk_lterm c) ] - | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ] - | [ lconstr(x) "in" lconstr(c) ] -> - [ X_In_T (mk_lterm x, mk_lterm c) ] - | [ "in" lconstr(x) "in" lconstr(c) ] -> - [ In_X_In_T (mk_lterm x, mk_lterm c) ] - | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> - [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] - | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> - [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] -END - -type cpattern = char * glob_constr_and_expr -let tag_of_cpattern = fst -let loc_of_cpattern = loc_ofCG -let cpattern_of_term t = t -type occ = (bool * int list) option - -type rpattern = (cpattern, cpattern) ssrpattern -let pr_rpattern = pr_pattern - -type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern - - -let id_of_cpattern = function - | _,(_,Some (CRef (Ident (_, x), _))) -> Some x - | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x - | _,(GRef (_, VarRef x, _) ,None) -> Some x - | _ -> None -let id_of_Cterm t = match id_of_cpattern t with - | Some x -> x - | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" - -let of_ftactic ftac gl = - let r = ref None in - let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in - let tac = Proofview.V82.of_tactic tac in - let { sigma = sigma } = tac gl in - let ans = match !r with - | None -> assert false (** If the tactic failed we should not reach this point *) - | Some ans -> ans - in - (sigma, ans) - -let interp_wit wit ist gl x = - let globarg = in_gen (glbwit wit) x in - let arg = interp_genarg ist globarg in - let (sigma, arg) = of_ftactic arg gl in - sigma, Value.cast (topwit wit) arg -let interp_constr = interp_wit wit_constr -let interp_open_constr ist gl gc = - interp_wit wit_open_constr ist gl gc -let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c -let interp_term ist gl (_, c) = (interp_open_constr ist gl c) -let glob_ssrterm gs = function - | k, (_, Some c) -> k, Tacintern.intern_constr gs c - | ct -> ct -let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c -let pr_ssrterm _ _ _ = pr_term -let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with - | Tok.KEYWORD "(" -> '(' - | Tok.KEYWORD "@" -> '@' - | _ -> ' ' -let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind - -(* This piece of code asserts the following notations are reserved *) -(* Reserved Notation "( a 'in' b )" (at level 0). *) -(* Reserved Notation "( a 'as' b )" (at level 0). *) -(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) -(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) -let glob_cpattern gs p = - pp(lazy(str"globbing pattern: " ++ pr_term p)); - let glob x = snd (glob_ssrterm gs (mk_lterm x)) in - let encode k s l = - let name = Name (id_of_string ("_ssrpat_" ^ s)) in - k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in - let bind_in t1 t2 = - let d = dummy_loc in let n = Name (destCVar t1) in - fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in - let check_var t2 = if not (isCVar t2) then - loc_error (constr_loc t2) "Only identifiers are allowed here" in - match p with - | _, (_, None) as x -> x - | k, (v, Some t) as orig -> - if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else - match t with - | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> - (try match glob t1, glob t2 with - | (r1, None), (r2, None) -> encode k "In" [r1;r2] - | (r1, Some _), (r2, Some _) when isCVar t1 -> - encode k "In" [r1; r2; bind_in t1 t2] - | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] - | _ -> Errors.anomaly (str"where are we?") - with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) - | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> - check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> - encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> - check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] - | _ -> glob_ssrterm gs orig -;; - -let interp_ssrterm _ gl t = Tacmach.project gl, t - -ARGUMENT EXTEND cpattern - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm - RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm - GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm -| [ "Qed" constr(c) ] -> [ mk_lterm c ] -END - -let (!@) = Compat.to_coqloc - -GEXTEND Gram - GLOBAL: cpattern; - cpattern: [[ k = ssrtermkind; c = constr -> - let pattern = mk_term k c in - if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; -END - -ARGUMENT EXTEND lcpattern - TYPED AS cpattern - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm - RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm - GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm -| [ "Qed" lconstr(c) ] -> [ mk_lterm c ] -END - -GEXTEND Gram - GLOBAL: lcpattern; - lcpattern: [[ k = ssrtermkind; c = lconstr -> - let pattern = mk_term k c in - if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; -END - -let thin id sigma goal = - let ids = Id.Set.singleton id in - let env = Goal.V82.env sigma goal in - let cl = Goal.V82.concl sigma goal in - let evdref = ref (Evd.clear_metas sigma) in - let ans = - try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) - with Evarutil.ClearDependencyError _ -> None - in - match ans with - | None -> sigma - | Some (hyps, concl) -> - let sigma = !evdref in - let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in - let sigma = Goal.V82.partial_solution_to sigma goal gl ev in - sigma - -let interp_pattern ist gl red redty = - pp(lazy(str"interpreting: " ++ pr_pattern red)); - let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in - let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in - let eAsXInT e x t = E_As_X_In_T(e,x,t) in - let mkG ?(k=' ') x = k,(x,None) in - let decode t f g = - try match (pf_intern_term ist gl t) with - | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None)) - | it -> g t with _ -> g t in - let decodeG t f g = decode (mkG t) f g in - let bad_enc id _ = Errors.anomaly (str"bad encoding for pattern "++str id) in - let cleanup_XinE h x rp sigma = - let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in - let to_clean, update = (* handle rename if x is already used *) - let ctx = pf_hyps gl in - let len = Context.Named.length ctx in - let name = ref None in - try ignore(Context.Named.lookup x ctx); (name, fun k -> - if !name = None then - let nctx = Evd.evar_context (Evd.find sigma k) in - let nlen = Context.Named.length nctx in - if nlen > len then begin - name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1))) - end) - with Not_found -> ref (Some x), fun _ -> () in - let sigma0 = project gl in - let new_evars = - let rec aux acc t = match kind_of_term t with - | Evar (k,_) -> - if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else - (update k; k::acc) - | _ -> fold_constr aux acc t in - aux [] (Evarutil.nf_evar sigma rp) in - let sigma = - List.fold_left (fun sigma e -> - if Evd.is_defined sigma e then sigma else (* clear may be recursive *) - if Option.is_empty !to_clean then sigma else - let name = Option.get !to_clean in - pp(lazy(pr_id name)); - thin name sigma e) - sigma new_evars in - sigma in - let red = match red with - | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None)) - when let id = string_of_id id in let len = String.length id in - (len > 8 && String.sub id 0 8 = "_ssrpat_") -> - let id = string_of_id id in let len = String.length id in - (match String.sub id 8 (len - 8), t with - | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x) - | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) - | "In", GApp(_, _, [e; t; e_in_t]) -> - decodeG t (eInXInT (mkG e)) - (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) - | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) - | _ -> bad_enc id ()) - | T t -> decode t xInT (fun x -> T x) - | In_T t -> decode t inXInT inT - | X_In_T (e,t) -> decode t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) - | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t - | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp - | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in - pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); - let red = match redty with None -> red | Some ty -> let ty = ' ', ty in - match red with - | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast) - | X_In_T (x,t) -> - let ty = pf_intern_term ist gl ty in - E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t) - | E_In_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term ist gl ty) in - E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) - | E_As_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term ist gl ty) in - E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) - | red -> red in - pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); - let mkXLetIn loc x (a,(g,c)) = match c with - | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b)) - | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in - match red with - | T t -> let sigma, t = interp_term ist gl t in sigma, T t - | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t - | X_In_T (x, rp) | In_X_In_T (x, rp) -> - let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in - let rp = mkXLetIn dummy_loc (Name x) rp in - let sigma, rp = interp_term ist gl rp in - let _, h, _, rp = destLetIn rp in - let sigma = cleanup_XinE h x rp sigma in - let rp = subst1 h (Evarutil.nf_evar sigma rp) in - sigma, mk h rp - | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> - let mk e x p = - match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in - let rp = mkXLetIn dummy_loc (Name x) rp in - let sigma, rp = interp_term ist gl rp in - let _, h, _, rp = destLetIn rp in - let sigma = cleanup_XinE h x rp sigma in - let rp = subst1 h (Evarutil.nf_evar sigma rp) in - let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in - sigma, mk e h rp -;; -let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;; -let interp_rpattern ist gl red = interp_pattern ist gl red None;; - -let id_of_pattern = function - | _, T t -> (match kind_of_term t with Var id -> Some id | _ -> None) - | _ -> None - -(* The full occurrence set *) -let noindex = Some(false,[]) - -(* calls do_subst on every sub-term identified by (pattern,occ) *) -let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = - let fs sigma x = Reductionops.nf_evar sigma x in - let pop_evar sigma e p = - let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in - let e_body = match e_body with Evar_defined c -> c - | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++ - str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ - str "Does the variable bound by the \"in\" construct occur "++ - str "in the pattern?") in - let sigma = - Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in - sigma, e_body in - let ex_value hole = - match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in - let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok = - let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in - sigma, [pat] in - match pattern with - | None -> do_subst env0 concl0 concl0 1 - | Some (sigma, (T rp | In_T rp)) -> - let rp = fs sigma rp in - let ise = create_evar_defs sigma in - let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in - let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in - let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in - let concl = find_T env0 concl0 1 do_subst in - let _ = end_T () in - concl - | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> - let p = fs sigma p in - let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in - let ex = ex_value hole in - let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in - let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in - (* we start from sigma, so hole is considered a rigid head *) - let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in - let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in - let concl = find_T env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in - let sigma, e_body = pop_evar p_sigma ex p in - fs p_sigma (find_X env (fs sigma p) h - (fun env _ -> do_subst env e_body))) in - let _ = end_X () in let _ = end_T () in - concl - | Some (sigma, E_In_X_In_T (e, hole, p)) -> - let p, e = fs sigma p, fs sigma e in - let ex = ex_value hole in - let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in - let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in - let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in - let find_X, end_X = mk_tpattern_matcher sigma noindex holep in - let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in - let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in - let concl = find_T env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in - let sigma, e_body = pop_evar p_sigma ex p in - fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> - find_E env e_body h do_subst))) in - let _ = end_E () in let _ = end_X () in let _ = end_T () in - concl - | Some (sigma, E_As_X_In_T (e, hole, p)) -> - let p, e = fs sigma p, fs sigma e in - let ex = ex_value hole in - let rp = - let e_sigma = unify_HO env0 sigma hole e in - e_sigma, fs e_sigma p in - let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in - let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in - let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in - let find_X, end_X = mk_tpattern_matcher sigma occ holep in - let concl = find_TE env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in - let sigma, e_body = pop_evar p_sigma ex p in - fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> - let e_sigma = unify_HO env sigma e_body e in - let e_body = fs e_sigma e in - do_subst env e_body e_body h))) in - let _ = end_X () in let _ = end_TE () in - concl -;; - -let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = - let e = match p with - | In_T _ | In_X_In_T _ -> Errors.anomaly (str"pattern without redex") - | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in - let sigma = - if not resolve_typeclasses then sigma - else Typeclasses.resolve_typeclasses ~fail:false env sigma in - Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma - -let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = - let do_make_rel, occ = - if occ = Some(true,[]) then false, Some(false,[1]) else true, occ in - let find_R, conclude = - let r = ref None in - (fun env c _ h' -> - do_once r (fun () -> c, Evd.empty_evar_universe_context); - if do_make_rel then mkRel (h'+h-1) else c), - (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in - let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in - let e = conclude cl in - e, cl -;; - -(* clenup interface for external use *) -let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = - mk_tpattern ?p_origin env sigma0 sigma_t f dir c -;; - -let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = - let ise = create_evar_defs sigma in - let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in - let find_U, end_U = - mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in - let concl = find_U env concl h (fun _ _ _ -> mkRel) in - let rdx, _, (sigma, uc, p) = end_U () in - sigma, uc, p, concl, rdx - -let fill_occ_term env cl occ sigma0 (sigma, t) = - try - let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in - if sigma' != sigma0 then Errors.error "matching impacts evars" - else cl, (Evd.merge_universe_context sigma' uc, t') - with NoMatch -> try - let sigma', uc, t' = - unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in - if sigma' != sigma0 then raise NoMatch - else cl, (Evd.merge_universe_context sigma' uc, t') - with _ -> - errorstrm (str "partial term " ++ pr_constr_pat t - ++ str " does not match any subterm of the goal") - -let pf_fill_occ_term gl occ t = - let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in - let cl,(_,t) = fill_occ_term env concl occ sigma0 t in - cl, t - -let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id, None), None) - -let is_wildcard = function - | _,(_,Some (CHole _)|GHole _,None) -> true - | _ -> false - -(* "ssrpattern" *) -let pr_ssrpatternarg _ _ _ cpat = pr_rpattern cpat - -ARGUMENT EXTEND ssrpatternarg - TYPED AS rpattern - PRINTED BY pr_ssrpatternarg -| [ "[" rpattern(pat) "]" ] -> [ pat ] -END - -let pf_merge_uc uc gl = - re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) - -let pf_unsafe_merge_uc uc gl = - re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc) - -let ssrpatterntac ist arg gl = - let pat = interp_rpattern ist gl arg in - let sigma0 = project gl in - let concl0 = pf_concl gl in - let (t, uc), concl_x = - fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in - let gl, tty = pf_type_of gl t in - let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl - -(* Register "ssrpattern" tactic *) -let () = - let mltac _ ist = - let arg = - let v = Id.Map.find (Names.Id.of_string "ssrpatternarg") ist.lfun in - Value.cast (topwit wit_ssrpatternarg) v in - Proofview.V82.tactic (ssrpatterntac ist arg) in - let name = { mltac_plugin = "ssrmatching"; mltac_tactic = "ssrpattern"; } in - let () = Tacenv.register_ml_tactic name [|mltac|] in - let tac = - TacFun ([Some (Id.of_string "ssrpatternarg")], - TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in - let obj () = - Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in - Mltop.declare_cache_obj obj "ssreflect" - -let ssrinstancesof ist arg gl = - let ok rhs lhs ise = true in -(* not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *) - let env, sigma, concl = pf_env gl, project gl, pf_concl gl in - let sigma0, cpat = interp_cpattern ist gl arg None in - let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in - let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in - let find, conclude = - mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true - sigma None (etpat,[tpat]) in - let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in - ppnl (str"BEGIN INSTANCES"); - try - while true do - ignore(find env concl 1 ~k:print) - done; raise NoMatch - with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl - -TACTIC EXTEND ssrinstoftpat -| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof ist arg) ] -END - -(* We wipe out all the keywords generated by the grammar rules we defined. *) -(* The user is supposed to Require Import ssreflect or Require ssreflect *) -(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) -(* consequence the extended ssreflect grammar. *) -let () = CLexer.unfreeze frozen_lexer ;; - -(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.mli b/mathcomp/ssreflect/plugin/trunk/ssrmatching.mli deleted file mode 100644 index 74a603e..0000000 --- a/mathcomp/ssreflect/plugin/trunk/ssrmatching.mli +++ /dev/null @@ -1,241 +0,0 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) - -open Genarg -open Tacexpr -open Environ -open Tacmach -open Evd -open Proof_type -open Term - -(** ******** Small Scale Reflection pattern matching facilities ************* *) - -(** Pattern parsing *) - -(** The type of context patterns, the patterns of the [set] tactic and - [:] tactical. These are patterns that identify a precise subterm. *) -type cpattern -val pr_cpattern : cpattern -> Pp.std_ppcmds - -(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *) -val cpattern : cpattern Pcoq.Gram.entry -val wit_cpattern : cpattern uniform_genarg_type - -(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *) -val lcpattern : cpattern Pcoq.Gram.entry -val wit_lcpattern : cpattern uniform_genarg_type - -(** The type of rewrite patterns, the patterns of the [rewrite] tactic. - These patterns also include patterns that identify all the subterms - of a context (i.e. "in" prefix) *) -type rpattern -val pr_rpattern : rpattern -> Pp.std_ppcmds - -(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *) -val rpattern : rpattern Pcoq.Gram.entry -val wit_rpattern : rpattern uniform_genarg_type - -(** Pattern interpretation and matching *) - -exception NoMatch -exception NoProgress - -(** AST for [rpattern] (and consequently [cpattern]) *) -type ('ident, 'term) ssrpattern = - | T of 'term - | In_T of 'term - | X_In_T of 'ident * 'term - | In_X_In_T of 'ident * 'term - | E_In_X_In_T of 'term * 'ident * 'term - | E_As_X_In_T of 'term * 'ident * 'term - -type pattern = evar_map * (constr, constr) ssrpattern -val pp_pattern : pattern -> Pp.std_ppcmds - -(** Extracts the redex and applies to it the substitution part of the pattern. - @raise Anomaly if called on [In_T] or [In_X_In_T] *) -val redex_of_pattern : - ?resolve_typeclasses:bool -> env -> pattern -> - constr Evd.in_evar_universe_context - -(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] - in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) -val interp_rpattern : - Tacinterp.interp_sign -> goal sigma -> - rpattern -> - pattern - -(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat] - in the current [Ltac] interpretation signature [ise] and tactic input [gl]. - [ty] is an optional type for the redex of [cpat] *) -val interp_cpattern : - Tacinterp.interp_sign -> goal sigma -> - cpattern -> glob_constr_and_expr option -> - pattern - -(** The set of occurrences to be matched. The boolean is set to true - * to signal the complement of this set (i.e. {-1 3}) *) -type occ = (bool * int list) option - -(** [subst e p t i]. [i] is the number of binders - traversed so far, [p] the term from the pattern, [t] the matched one *) -type subst = env -> constr -> constr -> int -> constr - -(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every - [occ] occurrence of [pat]. The [int] argument is the number of - binders traversed. If [pat] is [None] then then subst is called on [t]. - [t] must live in [env] and [sigma], [pat] must have been interpreted in - (an extension of) [sigma]. - @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) - @return [t] where all [occ] occurrences of [pat] have been mapped using - [subst] *) -val eval_pattern : - ?raise_NoMatch:bool -> - env -> evar_map -> constr -> - pattern option -> occ -> subst -> - constr - -(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of - [eval_pattern]. - It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. - [t] must live in [env] and [sigma], [pat] must have been interpreted in - (an extension of) [sigma]. - @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) - @return the instance of the redex of [pat] that was matched and [t] - transformed as described above. *) -val fill_occ_pattern : - ?raise_NoMatch:bool -> - env -> evar_map -> constr -> - pattern -> occ -> int -> - constr Evd.in_evar_universe_context * constr - -(** *************************** Low level APIs ****************************** *) - -(* The primitive matching facility. It matches of a term with holes, like - the T pattern above, and calls a continuation on its occurrences. *) - -type ssrdir = L2R | R2L -val pr_dir_side : ssrdir -> Pp.std_ppcmds - -(** a pattern for a term with wildcards *) -type tpattern - -(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t] - living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern]. - The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok] - callback is used to filter occurrences. - @return the compiled [tpattern] and its [evar_map] - @raise UserEerror is the pattern is a wildcard *) -val mk_tpattern : - ?p_origin:ssrdir * constr -> - env -> evar_map -> - evar_map * constr -> - (constr -> evar_map -> bool) -> - ssrdir -> constr -> - evar_map * tpattern - -(** [findP env t i k] is a stateful function that finds the next occurrence - of a tpattern and calls the callback [k] to map the subterm matched. - The [int] argument passed to [k] is the number of binders traversed so far - plus the initial value [i]. - @return [t] where the subterms identified by the selected occurrences of - the patter have been mapped using [k] - @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is - [true] and if the pattern did not match - @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is - [false] and if the pattern did not match *) -type find_P = - env -> constr -> int -> k:subst -> constr - -(** [conclude ()] asserts that all mentioned ocurrences have been visited. - @return the instance of the pattern, the evarmap after the pattern - instantiation, the proof term and the ssrdit stored in the tpattern - @raise UserEerror if too many occurrences were specified *) -type conclude = - unit -> constr * ssrdir * (evar_map * Evd.evar_universe_context * constr) - -(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair - a function [find_P] and [conclude] with the behaviour explained above. - The flag [b] (default [false]) changes the error reporting behaviour - of [find_P] if none of the [tpattern] matches. The argument [o] can - be passed to tune the [UserError] eventually raised (useful if the - pattern is coming from the LHS/RHS of an equation) *) -val mk_tpattern_matcher : - ?all_instances:bool -> - ?raise_NoMatch:bool -> - ?upats_origin:ssrdir * constr -> - evar_map -> occ -> evar_map * tpattern list -> - find_P * conclude - -(** Example of [mk_tpattern_matcher] to implement - [rewrite \{occ\}\[in t\]rules]. - It first matches "in t" (called [pat]), then in all matched subterms - it matches the LHS of the rules using [find_R]. - [concl0] is the initial goal, [concl] will be the goal where some terms - are replaced by a De Bruijn index. The [rw_progress] extra check - selects only occurrences that are not rewritten to themselves (e.g. - an occurrence "x + x" rewritten with the commutativity law of addition - is skipped) {[ - let find_R, conclude = match pat with - | Some (_, In_T _) -> - let aux (sigma, pats) (d, r, lhs, rhs) = - let sigma, pat = - mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in - sigma, pats @ [pat] in - let rpats = List.fold_left aux (r_sigma, []) rules in - let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in - find_R ~k:(fun _ _ h -> mkRel h), - fun cl -> let rdx, d, r = end_R () in (d,r),rdx - | _ -> ... in - let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in - let (d, r), rdx = conclude concl in ]} *) - -(* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns - * the conclusion of [gl] where [occ] occurrences of [t] have been replaced - * by [Rel 1] and the instance of [t] *) -val pf_fill_occ_term : goal sigma -> occ -> evar_map * constr -> constr * constr - -(* It may be handy to inject a simple term into the first form of cpattern *) -val cpattern_of_term : char * glob_constr_and_expr -> cpattern - -(** Helpers to make stateful closures. Example: a [find_P] function may be - called many times, but the pattern instantiation phase is performed only the - first time. The corresponding [conclude] has to return the instantiated - pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern - has no instance, [conclude] considers it an anomaly if the pattern did - not match *) - -(** [do_once r f] calls [f] and updates the ref only once *) -val do_once : 'a option ref -> (unit -> 'a) -> unit -(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) -val assert_done : 'a option ref -> 'a - -(** Very low level APIs. - these are calls to evarconv's [the_conv_x] followed by - [consider_remaining_unif_problems] and [resolve_typeclasses]. - In case of failure they raise [NoMatch] *) - -val unify_HO : env -> evar_map -> constr -> constr -> evar_map -val pf_unify_HO : goal sigma -> constr -> constr -> goal sigma - -(** Some more low level functions needed to implement the full SSR language - on top of the former APIs *) -val tag_of_cpattern : cpattern -> char -val loc_of_cpattern : cpattern -> Loc.t -val id_of_pattern : pattern -> Names.variable option -val is_wildcard : cpattern -> bool -val cpattern_of_id : Names.variable -> cpattern -val cpattern_of_id : Names.variable -> cpattern -val pr_constr_pat : constr -> Pp.std_ppcmds -val pf_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma -val pf_unsafe_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma - -(* One can also "Set SsrMatchingDebug" from a .v *) -val debug : bool -> unit - -(* One should delimit a snippet with "Set SsrMatchingProfiling" and - * "Unset SsrMatchingProfiling" to get timings *) -val profile : bool -> unit - -(* eof *) diff --git a/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 index 23b4ae5..b5cd80a 100644 --- a/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 @@ -10,7 +10,7 @@ let () = Mltop.add_known_plugin (fun () -> Printf.printf "Copyright 2005-2012 Microsoft Corporation and INRIA.\n"; Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" end) - "ssreflect" + "ssreflect_plugin" ;; (* Defining grammar rules with "xx" in it automatically declares keywords too *) let frozen_lexer = Lexer.freeze () ;; diff --git a/mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib b/mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib deleted file mode 100644 index 006b70f..0000000 --- a/mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Ssrmatching -Ssreflect diff --git a/mathcomp/ssreflect/plugin/v8.4/ssreflect_plugin.mllib b/mathcomp/ssreflect/plugin/v8.4/ssreflect_plugin.mllib new file mode 100644 index 0000000..006b70f --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.4/ssreflect_plugin.mllib @@ -0,0 +1,2 @@ +Ssrmatching +Ssreflect diff --git a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.v b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.v new file mode 100644 index 0000000..311d494 --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.v @@ -0,0 +1,27 @@ +(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* Distributed under the terms of CeCILL-B. *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module SsrMatchingSyntax. + +(* Reserve the notation for rewrite patterns so that the user is not allowed *) +(* to declare it at a different level. *) +Reserved Notation "( a 'in' b )" (at level 0). +Reserved Notation "( a 'as' b )" (at level 0). +Reserved Notation "( a 'in' b 'in' c )" (at level 0). +Reserved Notation "( a 'as' b 'in' c )" (at level 0). + +(* Notation to define shortcuts for the "X in t" part of a pattern. *) +Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. +Delimit Scope ssrpatternscope with pattern. + +(* Some shortcuts for recurrent "X in t" parts. *) +Notation RHS := (X in _ = X)%pattern. +Notation LHS := (X in X = _)%pattern. + +End SsrMatchingSyntax. + +Export SsrMatchingSyntax. diff --git a/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 index c40d965..85a6fef 100644 --- a/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 @@ -2,7 +2,7 @@ (* Distributed under the terms of CeCILL-B. *) (* This line is read by the Makefile's dist target: do not remove. *) -DECLARE PLUGIN "ssreflect" +DECLARE PLUGIN "ssreflect_plugin" let ssrversion = "1.6";; let ssrAstVersion = 1;; let () = Mltop.add_known_plugin (fun () -> @@ -11,7 +11,7 @@ let () = Mltop.add_known_plugin (fun () -> Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" end) - "ssreflect" + "ssreflect_plugin" ;; (* Defining grammar rules with "xx" in it automatically declares keywords too, @@ -1011,7 +1011,7 @@ let pf_unabs_evars gl ise n c0 = type ssrargfmt = ArgSsr of string | ArgCoq of argument_type | ArgSep of string let ssrtac_name name = { - mltac_plugin = "ssreflect"; + mltac_plugin = "ssreflect_plugin"; mltac_tactic = "ssr" ^ name; } diff --git a/mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib b/mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib deleted file mode 100644 index 006b70f..0000000 --- a/mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Ssrmatching -Ssreflect diff --git a/mathcomp/ssreflect/plugin/v8.5/ssreflect_plugin.mllib b/mathcomp/ssreflect/plugin/v8.5/ssreflect_plugin.mllib new file mode 100644 index 0000000..006b70f --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.5/ssreflect_plugin.mllib @@ -0,0 +1,2 @@ +Ssrmatching +Ssreflect diff --git a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.v b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.v new file mode 100644 index 0000000..311d494 --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.v @@ -0,0 +1,27 @@ +(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* Distributed under the terms of CeCILL-B. *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module SsrMatchingSyntax. + +(* Reserve the notation for rewrite patterns so that the user is not allowed *) +(* to declare it at a different level. *) +Reserved Notation "( a 'in' b )" (at level 0). +Reserved Notation "( a 'as' b )" (at level 0). +Reserved Notation "( a 'in' b 'in' c )" (at level 0). +Reserved Notation "( a 'as' b 'in' c )" (at level 0). + +(* Notation to define shortcuts for the "X in t" part of a pattern. *) +Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. +Delimit Scope ssrpatternscope with pattern. + +(* Some shortcuts for recurrent "X in t" parts. *) +Notation RHS := (X in _ = X)%pattern. +Notation LHS := (X in X = _)%pattern. + +End SsrMatchingSyntax. + +Export SsrMatchingSyntax. diff --git a/mathcomp/ssreflect/ssreflect.v b/mathcomp/ssreflect/ssreflect.v index a271eb2..38a8013 100644 --- a/mathcomp/ssreflect/ssreflect.v +++ b/mathcomp/ssreflect/ssreflect.v @@ -2,7 +2,7 @@ (* Distributed under the terms of CeCILL-B. *) Require Import Bool. (* For bool_scope delimiter 'bool'. *) Require Import ssrmatching. -Declare ML Module "ssreflect". +Declare ML Module "ssreflect_plugin". Set SsrAstVersion. (******************************************************************************) diff --git a/mathcomp/ssreflect/ssrmatching.v b/mathcomp/ssreflect/ssrmatching.v deleted file mode 100644 index bf7d21d..0000000 --- a/mathcomp/ssreflect/ssrmatching.v +++ /dev/null @@ -1,28 +0,0 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) -Declare ML Module "ssreflect". - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Module SsrMatchingSyntax. - -(* Reserve the notation for rewrite patterns so that the user is not allowed *) -(* to declare it at a different level. *) -Reserved Notation "( a 'in' b )" (at level 0). -Reserved Notation "( a 'as' b )" (at level 0). -Reserved Notation "( a 'in' b 'in' c )" (at level 0). -Reserved Notation "( a 'as' b 'in' c )" (at level 0). - -(* Notation to define shortcuts for the "X in t" part of a pattern. *) -Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. -Delimit Scope ssrpatternscope with pattern. - -(* Some shortcuts for recurrent "X in t" parts. *) -Notation RHS := (X in _ = X)%pattern. -Notation LHS := (X in X = _)%pattern. - -End SsrMatchingSyntax. - -Export SsrMatchingSyntax. -- cgit v1.2.3 From e33a23bbaefea57b486f7ea136ef4d058dbb34e1 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 17 Jun 2016 16:35:32 +0200 Subject: this test is now in Coq, removing it. --- mathcomp/Make | 1 - mathcomp/ssrtest/Make | 1 - mathcomp/ssrtest/tacnotationpattern.v | 14 -------------- 3 files changed, 16 deletions(-) delete mode 100644 mathcomp/ssrtest/tacnotationpattern.v (limited to 'mathcomp') diff --git a/mathcomp/Make b/mathcomp/Make index 9735a62..ef657d5 100644 --- a/mathcomp/Make +++ b/mathcomp/Make @@ -171,7 +171,6 @@ ssrtest/view_case.v ssrtest/wlogletin.v ssrtest/wlog_suff.v ssrtest/wlong_intro.v -ssrtest/tacnotationpattern.v ssreflect.ml4 -I . diff --git a/mathcomp/ssrtest/Make b/mathcomp/ssrtest/Make index 716dc4a..ab4c666 100644 --- a/mathcomp/ssrtest/Make +++ b/mathcomp/ssrtest/Make @@ -39,7 +39,6 @@ view_case.v wlogletin.v wlog_suff.v wlong_intro.v -tacnotationpattern.v -R ../theories Ssreflect -I ../src/ diff --git a/mathcomp/ssrtest/tacnotationpattern.v b/mathcomp/ssrtest/tacnotationpattern.v deleted file mode 100644 index 13de4bc..0000000 --- a/mathcomp/ssrtest/tacnotationpattern.v +++ /dev/null @@ -1,14 +0,0 @@ -Require Import mathcomp.ssreflect.ssreflect. -Tactic Notation "at" ssrpatternarg(p) tactic(t) - := - ssrpattern p; let top := fresh in intro top; - t top; try unfold top in * |- *; try clear top. - -Goal forall x y, x + y = 4. -intros. -at [RHS] (fun top => remember top as E eqn:E_def). -match goal with -| |- x + y = E => idtac -| |- _ => fail -end. -Admitted. -- cgit v1.2.3 From 8a701c74a1fd3d05fefe48e6129c59793c5d611c Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 17 Jun 2016 16:38:57 +0200 Subject: fix parsing (coq trunk goal selector/ltac:) --- mathcomp/ssrtest/first_n.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mathcomp') diff --git a/mathcomp/ssrtest/first_n.v b/mathcomp/ssrtest/first_n.v index 2cb6c32..3d99a0f 100644 --- a/mathcomp/ssrtest/first_n.v +++ b/mathcomp/ssrtest/first_n.v @@ -5,7 +5,7 @@ From mathcomp Require Import ssrbool. Lemma test : False -> (bool -> False -> True -> True) -> True. -move=> F; let w := 2 in apply; last w first. +move=> F; let w := constr:(2) in apply; last w first. - by apply: F. - by apply: I. by apply: true. -- cgit v1.2.3 From 3dffd6632843d9851289ef6cab9430b7e62321fa Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 1 Jul 2016 17:29:50 +0200 Subject: Fix compilation after renaming of reduction functions and flags in Coq. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 0d41ac5..a5b3404 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -3405,7 +3405,7 @@ let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_ | AtomicType _ -> let ty = prof_saturate_whd.profile - (Reductionops.whd_betadeltaiota env sigma) ty in + (Reductionops.whd_all env sigma) ty in match kind_of_type ty with | ProdType _ -> loop ty args sigma n | _ -> raise NotEnoughProducts @@ -3783,7 +3783,7 @@ let analyze_eliminator elimty env sigma = | LetInType (x,b,ty,t) -> loop (Rel.Declaration.LocalDef (x, b, ty) :: ctx) (subst1 b t) | _ -> let env' = Environ.push_rel_context ctx env in - let t' = Reductionops.whd_betadeltaiota env' sigma t in + let t' = Reductionops.whd_all env' sigma t in if not (Term.eq_constr t t') then loop ctx t' else errorstrm (str"The eliminator has the wrong shape."++spc()++ str"A (applied) bound variable was expected as the conclusion of "++ @@ -3818,7 +3818,9 @@ let unprotecttac gl = (Closure.RedFlags.mkflags [Closure.RedFlags.fBETA; Closure.RedFlags.fCONST prot; - Closure.RedFlags.fIOTA]), DEFAULTcast) hyploc)) + Closure.RedFlags.fMATCH; + Closure.RedFlags.fFIX; + Closure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) allHypsAndConcl gl let dependent_apply_error = @@ -3962,7 +3964,7 @@ let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = let elim, elimty, elim_args, gl = pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in let pred = List.assoc pred_id elim_args in - let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + let elimty = Reductionops.whd_all env (project gl) elimty in let cty, gl = if Option.is_empty oc then None, gl else @@ -4000,7 +4002,7 @@ let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = | 0, Some p -> interp_cpattern (Option.get ist) orig_gl p None | _ -> mkTpat gl c in let cty = Some (c, c_ty, pc) in - let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + let elimty = Reductionops.whd_all env (project gl) elimty in cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl in pp(lazy(str"elim= "++ pr_constr_pat elim)); @@ -4856,7 +4858,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = | App (hd, args) -> let hd_ty = Retyping.get_type_of env sigma hd in let names = let rec aux t = function 0 -> [] | n -> - let t = Reductionops.whd_betadeltaiota env sigma t in + let t = Reductionops.whd_all env sigma t in match kind_of_type t with | ProdType (name, _, t) -> name :: aux t (n-1) | _ -> assert false in aux hd_ty (Array.length args) in @@ -4891,7 +4893,7 @@ let rwcltac cl rdx dir sr gl = let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, build_coq_eq () in let sigma, c_ty = Typing.type_of env sigma c in pp(lazy(str"c_ty@rwcltac=" ++ pr_constr c_ty)); - match kind_of_type (Reductionops.whd_betadeltaiota env sigma c_ty) with + match kind_of_type (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when is_ind_ref e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl @@ -5743,7 +5745,8 @@ let pf_find_abstract_proof check_lock gl abstract_n = let unfold cl = let module R = Reductionops in let module F = Closure.RedFlags in reduct_in_concl (R.clos_norm_flags (F.mkflags - (List.map (fun c -> F.fCONST (fst (destConst c))) cl @ [F.fBETA; F.fIOTA]))) + (List.map (fun c -> F.fCONST (fst (destConst c))) cl @ + [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) let havegentac ist t gl = let sigma, c, ucst, _ = pf_abs_ssrterm ist gl t in -- cgit v1.2.3 From 3dea07facaa438769a3a65220dcda1b62bbae6d3 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 3 Jul 2016 19:09:26 +0200 Subject: Fix compilation after Errors and Closure were renamed. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 124 +++++++++++++------------- 1 file changed, 62 insertions(+), 62 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index a5b3404..8dc9b64 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -97,9 +97,9 @@ module Intset = Evar.Set type loc = Loc.t let dummy_loc = Loc.ghost -let errorstrm = Errors.errorlabstrm "ssreflect" -let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) -let anomaly s = Errors.anomaly (str s) +let errorstrm = CErrors.errorlabstrm "ssreflect" +let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg) +let anomaly s = CErrors.anomaly (str s) (* Compatibility with Coq 8.6 *) let ppnl = msg_info @@ -114,7 +114,7 @@ let locate_reference qid = let mkSsrRef name = try locate_reference (ssrqid name) with Not_found -> try locate_reference (ssrtopqid name) with Not_found -> - Errors.error "Small scale reflection library not loaded" + CErrors.error "Small scale reflection library not loaded" let mkSsrRRef name = GRef (dummy_loc, mkSsrRef name,None), None let mkSsrConst name env sigma = Sigma.fresh_global env sigma (mkSsrRef name) @@ -455,7 +455,7 @@ let mk_profiler s = let inVersion = Libobject.declare_object { (Libobject.default_object "SSRASTVERSION") with Libobject.load_function = (fun _ (_,v) -> - if v <> ssrAstVersion then Errors.error "Please recompile your .vo files"); + if v <> ssrAstVersion then CErrors.error "Please recompile your .vo files"); Libobject.classify_function = (fun v -> Libobject.Keep v); } @@ -598,15 +598,15 @@ let apply_type x xs = Proofview.V82.of_tactic (apply_type x xs) (* we reduce head beta redexes *) let betared env = - Closure.create_clos_infos - (Closure.RedFlags.mkflags [Closure.RedFlags.fBETA]) + CClosure.create_clos_infos + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fBETA]) env ;; let introid name = tclTHEN (fun gl -> let g, env = pf_concl gl, pf_env gl in match kind_of_term g with | App (hd, _) when isLambda hd -> - let g = Closure.whd_val (betared env) (Closure.inject g) in + let g = CClosure.whd_val (betared env) (CClosure.inject g) in Proofview.V82.of_tactic (convert_concl_no_check g) gl | _ -> tclIDTAC gl) (Proofview.V82.of_tactic (intro_mustbe_force name)) @@ -1220,7 +1220,7 @@ let interp_search_notation loc s opt_scope = let ambig = "This string refers to a complex or ambiguous notation." in str ambig ++ str "\nTry searching with one of\n" ++ ntns with _ -> str "This string is not part of an identifier or notation." in - Errors.user_err_loc (loc, "interp_search_notation", diagnosis) + CErrors.user_err_loc (loc, "interp_search_notation", diagnosis) let pr_ssr_search_item _ _ _ = pr_search_item @@ -1231,7 +1231,7 @@ let is_ident s = try CLexer.check_ident s; true with _ -> false let is_ident_part s = is_ident ("H" ^ s) let interp_search_notation loc tag okey = - let err msg = Errors.user_err_loc (loc, "interp_search_notation", msg) in + let err msg = CErrors.user_err_loc (loc, "interp_search_notation", msg) in let mk_pntn s for_key = let n = String.length s in let s' = String.make (n + 2) ' ' in @@ -1355,7 +1355,7 @@ let rec splay_search_pattern na = function | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp | Pattern.PLetIn (_, _, bp) -> splay_search_pattern na bp | Pattern.PRef hr -> hr, na - | _ -> Errors.error "no head constant in head search pattern" + | _ -> CErrors.error "no head constant in head search pattern" let coerce_search_pattern_to_sort hpat = let env = Global.env () and sigma = Evd.empty in @@ -1366,7 +1366,7 @@ let coerce_search_pattern_to_sort hpat = let dc, ht = Reductionops.splay_prod env sigma (Universes.unsafe_type_of_global hr) in let np = List.length dc in - if np < na then Errors.error "too many arguments in head search pattern" else + if np < na then CErrors.error "too many arguments in head search pattern" else let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in let warn () = msg_warning (str "Listing only lemmas with conclusion matching " ++ @@ -1417,7 +1417,7 @@ let interp_search_arg arg = try let intern = Constrintern.intern_constr_pattern in Search.GlobSearchSubPattern (snd (intern (Global.env()) p)) - with e -> let e = Errors.push e in iraise (Cerrors.process_vernac_interp_error e)) arg in + with e -> let e = CErrors.push e in iraise (ExplainErr.process_vernac_interp_error e)) arg in let hpat, a1 = match arg with | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' | (true, Search.GlobSearchSubPattern p) :: a' -> @@ -1452,7 +1452,7 @@ let interp_modloc mr = let interp_mod (_, mr) = let (loc, qid) = qualid_of_reference mr in try Nametab.full_name_module qid with Not_found -> - Errors.user_err_loc (loc, "interp_modloc", str "No Module " ++ pr_qualid qid) in + CErrors.user_err_loc (loc, "interp_modloc", str "No Module " ++ pr_qualid qid) in let mr_out, mr_in = List.partition fst mr in let interp_bmod b = function | [] -> fun _ _ _ -> true @@ -1584,7 +1584,7 @@ let donetac gl = let tacname = try Nametab.locate_tactic (qualid_of_ident (id_of_string "done")) with Not_found -> try Nametab.locate_tactic (ssrqid "done") - with Not_found -> Errors.error "The ssreflect library was not loaded" in + with Not_found -> CErrors.error "The ssreflect library was not loaded" in let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl @@ -1758,7 +1758,7 @@ let pr_ssrhyp _ _ _ = pr_hyp let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp let hyp_err loc msg id = - Errors.user_err_loc (loc, "ssrhyp", str msg ++ pr_id id) + CErrors.user_err_loc (loc, "ssrhyp", str msg ++ pr_id id) let intern_hyp ist (SsrHyp (loc, id) as hyp) = let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) (loc, id)) in @@ -2020,7 +2020,7 @@ let pf_clauseids gl gens clseq = let keep_clears = List.map (fun (x, _) -> x, None) in if gens <> [] then (check_wgen_uniq gens; gens) else if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else - Errors.error "assumptions should be named explicitly" + CErrors.error "assumptions should be named explicitly" let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false @@ -2068,7 +2068,7 @@ let endclausestac id_map clseq gl_id cl0 gl = if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else - Errors.error "tampering with discharged assumptions of \"in\" tactical" + CErrors.error "tampering with discharged assumptions of \"in\" tactical" let is_id_constr c = match kind_of_term c with | Lambda(_,_,c) when isRel c -> 1 = destRel c @@ -2082,7 +2082,7 @@ let abs_wgen keep_let ist f gen (gl,args,c) = let sigma, env = project gl, pf_env gl in let evar_closed t p = if occur_existential t then - Errors.user_err_loc (loc_of_cpattern p,"ssreflect", + CErrors.user_err_loc (loc_of_cpattern p,"ssreflect", pr_constr_pat t ++ str" contains holes and matches no subterm of the goal") in match gen with @@ -2521,7 +2521,7 @@ let rec ipat_of_intro_pattern = function | IntroNaming IntroAnonymous -> IpatAnon | IntroAction (IntroRewrite b) -> IpatRw (allocc, if b then L2R else R2L) | IntroNaming (IntroFresh id) -> IpatAnon - | IntroAction (IntroApplyOn _) -> (* to do *) Errors.error "TO DO" + | IntroAction (IntroApplyOn _) -> (* to do *) CErrors.error "TO DO" | IntroAction (IntroInjection ips) -> IpatCase [List.map ipat_of_intro_pattern (List.map remove_loc ips)] | IntroForthcoming _ -> (* Unable to determine which kind of ipat interp_introid could return [HH] *) @@ -2686,7 +2686,7 @@ END (* subsets of patterns *) let check_ssrhpats loc w_binders ipats = - let err_loc s = Errors.user_err_loc (loc, "ssreflect", s) in + let err_loc s = CErrors.user_err_loc (loc, "ssreflect", s) in let clr, ipats = let rec aux clr = function | IpatSimpl (cl, Nop) :: tl -> aux (clr @ cl) tl @@ -2779,8 +2779,8 @@ let equality_inj l b id c gl = let msg = ref "" in try Proofview.V82.of_tactic (Equality.inj l b None c) gl with - | Compat.Exc_located(_,Errors.UserError (_,s)) - | Errors.UserError (_,s) + | Compat.Exc_located(_,CErrors.UserError (_,s)) + | CErrors.UserError (_,s) when msg := Pp.string_of_ppcmds s; !msg = "Not a projectable equality but a discriminable one." || !msg = "Nothing to inject." -> @@ -2807,7 +2807,7 @@ let perform_injection c gl = let dc, eqt = decompose_prod t in if dc = [] then injectl2rtac c gl else if not (closed0 eqt) then - Errors.error "can't decompose a quantified equality" else + CErrors.error "can't decompose a quantified equality" else let cl = pf_concl gl in let n = List.length dc in let c_eq = mkEtaApp c n 2 in let cl1 = mkLambda (Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in @@ -2830,7 +2830,7 @@ let intro_all gl = let rec intro_anon gl = try anontac (List.hd (fst (Term.decompose_prod_n_assum 1 (pf_concl gl)))) gl with err0 -> try tclTHEN (Proofview.V82.of_tactic red_in_concl) intro_anon gl with _ -> raise err0 - (* with _ -> Errors.error "No product even after reduction" *) + (* with _ -> CErrors.error "No product even after reduction" *) let with_top tac = tclTHENLIST [introid top_id; tac (mkVar top_id); Proofview.V82.of_tactic (clear [top_id])] @@ -3080,12 +3080,12 @@ let tclDO n tac = let tac_err_at i gl = try tac gl with - | Errors.UserError (l, s) as e -> - let _, info = Errors.push e in - let e' = Errors.UserError (l, prefix i ++ s) in + | CErrors.UserError (l, s) as e -> + let _, info = CErrors.push e in + let e' = CErrors.UserError (l, prefix i ++ s) in Util.iraise (e', info) - | Compat.Exc_located(loc, Errors.UserError (l, s)) -> - raise (Compat.Exc_located(loc, Errors.UserError (l, prefix i ++ s))) in + | Compat.Exc_located(loc, CErrors.UserError (l, s)) -> + raise (Compat.Exc_located(loc, CErrors.UserError (l, prefix i ++ s))) in let rec loop i gl = if i = n then tac_err_at i gl else (tclTHEN (tac_err_at i) (loop (i + 1))) gl in @@ -3252,7 +3252,7 @@ let tclREV tac gl = tclPERM List.rev tac gl let rot_hyps dir i hyps = let n = List.length hyps in if i = 0 then List.rev hyps else - if i > n then Errors.error "Not enough subgoals" else + if i > n then CErrors.error "Not enough subgoals" else let rec rot i l_hyps = function | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' | hyps' -> hyps' @ (List.rev l_hyps) in @@ -3470,7 +3470,7 @@ let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = let genclrtac cl cs clr = let tclmyORELSE tac1 tac2 gl = try tac1 gl - with e when Errors.noncritical e -> tac2 e gl in + with e when CErrors.noncritical e -> tac2 e gl in (* apply_type may give a type error, but the useful message is * the one of clear. You type "move: x" and you get * "x is used in hyp H" instead of @@ -3529,7 +3529,7 @@ let cons_gen gen = function let cons_dep (gensl, clr) = if List.length gensl = 1 then ([] :: gensl, clr) else - Errors.error "multiple dependents switches '/'" + CErrors.error "multiple dependents switches '/'" ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear PRINTED BY pr_ssrdgens @@ -3574,7 +3574,7 @@ let with_dgens (gensl, clr) maintac ist = match gensl with let first_goal gls = let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in - if List.is_empty gl then Errors.error "first_goal"; + if List.is_empty gl then CErrors.error "first_goal"; { Evd.it = List.hd gl; Evd.sigma = sig_0; } let with_deps deps0 maintac cl0 cs0 clr0 ist gl0 = @@ -3714,13 +3714,13 @@ let rec improper_intros = function let check_movearg = function | view, (eqid, _) when view <> [] && eqid <> None -> - Errors.error "incompatible view and equation in move tactic" + CErrors.error "incompatible view and equation in move tactic" | view, (_, (([gen :: _], _), _)) when view <> [] && has_occ gen -> - Errors.error "incompatible view and occurrence switch in move tactic" + CErrors.error "incompatible view and occurrence switch in move tactic" | _, (_, ((dgens, _), _)) when List.length dgens > 1 -> - Errors.error "dependents switch `/' in move tactic" + CErrors.error "dependents switch `/' in move tactic" | _, (eqid, (_, ipats)) when eqid <> None && improper_intros ipats -> - Errors.error "no proper intro pattern for equation in move tactic" + CErrors.error "no proper intro pattern for equation in move tactic" | arg -> arg ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg @@ -3815,16 +3815,16 @@ let unprotecttac gl = let hyploc = Option.map (fun id -> id, InHyp) idopt in Proofview.V82.of_tactic (reduct_option (Reductionops.clos_norm_flags - (Closure.RedFlags.mkflags - [Closure.RedFlags.fBETA; - Closure.RedFlags.fCONST prot; - Closure.RedFlags.fMATCH; - Closure.RedFlags.fFIX; - Closure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) + (CClosure.RedFlags.mkflags + [CClosure.RedFlags.fBETA; + CClosure.RedFlags.fCONST prot; + CClosure.RedFlags.fMATCH; + CClosure.RedFlags.fFIX; + CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) allHypsAndConcl gl let dependent_apply_error = - try Errors.error "Could not fill dependent hole in \"apply\"" with err -> err + try CErrors.error "Could not fill dependent hole in \"apply\"" with err -> err (* TASSI: Sometimes Coq's apply fails. According to my experience it may be * related to goals that are products and with beta redexes. In that case it @@ -3878,7 +3878,7 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = in pp(lazy(str"after: " ++ pr_constr oc)); try applyn ~with_evars ~with_shelve:true ?beta n oc gl - with e when Errors.noncritical e -> raise dependent_apply_error + with e when CErrors.noncritical e -> raise dependent_apply_error let pf_fresh_inductive_instance ind gl = let sigma, env, it = project gl, pf_env gl, sig_it gl in @@ -3951,7 +3951,7 @@ let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = | X_In_T (e, p) -> sigma, E_As_X_In_T (t, e, p) | _ -> try unify_HO env sigma t (fst (redex_of_pattern env p)), r - with e when Errors.noncritical e -> p in + with e when CErrors.noncritical e -> p in (* finds the eliminator applies it to evars and c saturated as needed *) (* obtaining "elim ??? (c ???)". pred is the higher order evar *) (* cty is None when the user writes _ (hence we can't make a pattern *) @@ -4017,7 +4017,7 @@ let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = Some (c, c_ty, gl, gl') with | NotEnoughProducts -> None - | e when Errors.noncritical e -> loop (n+1) in loop 0 in + | e when CErrors.noncritical e -> loop (n+1) in loop 0 in (* Here we try to understand if the main pattern/term the user gave is * the first pattern to be matched (i.e. if elimty ends in P t1 .. tn, * weather tn is the t the user wrote in 'elim: t' *) @@ -4231,7 +4231,7 @@ let _ = simplest_newcase_ref := simplest_newcase let check_casearg = function | view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> - Errors.error "incompatible view and occurrence switch in dependent case tactic" + CErrors.error "incompatible view and occurrence switch in dependent case tactic" | arg -> arg ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg @@ -4647,11 +4647,11 @@ let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) = && (clr = None || clr = Some []) then anomaly "Improper rewrite clear switch"; if d = R2L && rt <> RWdef then - Errors.error "Right-to-left switch on simplification"; + CErrors.error "Right-to-left switch on simplification"; if n <> 1 && rt = RWred Cut then - Errors.error "Bad or useless multiplier"; + CErrors.error "Bad or useless multiplier"; if occ <> None && rx = None && rt <> RWdef then - Errors.error "Missing redex for simplification occurrence" + CErrors.error "Missing redex for simplification occurrence" end; (d, m), ((docc, rx), r) let norwmult = L2R, nomult @@ -4734,7 +4734,7 @@ let unfoldintac occ rdx t (kt,_) gl = let body env t c = Tacred.unfoldn [OnlyOccurrences [1], get_evalref t] env sigma0 c in let easy = occ = None && rdx = None in - let red_flags = if easy then Closure.betaiotazeta else Closure.betaiota in + let red_flags = if easy then CClosure.betaiotazeta else CClosure.betaiota in let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in let unfold, conclude = match rdx with | Some (_, (In_T _ | In_X_In_T _)) | None -> @@ -4825,7 +4825,7 @@ exception PRindetermined_rhs of constr let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (* pp(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) let env = pf_env gl in - let beta = Reductionops.clos_norm_flags Closure.beta env sigma in + let beta = Reductionops.clos_norm_flags CClosure.beta env sigma in let sigma, p = let sigma = create_evar_defs sigma in let sigma = Sigma.Unsafe.of_evar_map sigma in @@ -4922,7 +4922,7 @@ let rwcltac cl rdx dir sr gl = then errorstrm (str "Rewriting impacts evars") else errorstrm (str "Dependent type error in rewrite of " ++ pf_pr_constr gl (project gl) (mkNamedLambda pattern_id rdxt cl)) - | Errors.UserError _ as e -> raise e + | CErrors.UserError _ as e -> raise e | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); in tclTHEN cvtac' rwtac gl @@ -5198,7 +5198,7 @@ END let unfoldtac occ ko t kt gl = let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term t kt)) in let cl' = subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref c] gl c) cl in - let f = if ko = None then Closure.betaiotazeta else Closure.betaiota in + let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in Proofview.V82.of_tactic (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl @@ -5546,7 +5546,7 @@ let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd let bvar_locid = function | CRef (Ident (loc, id), _) -> loc, id - | _ -> Errors.error "Missing identifier after \"(co)fix\"" + | _ -> CErrors.error "Missing identifier after \"(co)fix\"" ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd @@ -5563,7 +5563,7 @@ ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd (l', Name id') :: _ when Option.equal Id.equal sid (Some id') -> true, (l', id') | [l', Name id'] when sid = None -> false, (l', id') | _ :: bn -> loop bn - | [] -> Errors.error "Bad structural argument" in + | [] -> CErrors.error "Bad structural argument" in loop (names_of_local_assums lb) in let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in let fix = CFix (loc, lid, [lid, (Some i, CStructRec), lb, t', c']) in @@ -5743,7 +5743,7 @@ let pf_find_abstract_proof check_lock gl abstract_n = strbrk"Did you tamper with it?") let unfold cl = - let module R = Reductionops in let module F = Closure.RedFlags in + let module R = Reductionops in let module F = CClosure.RedFlags in reduct_in_concl (R.clos_norm_flags (F.mkflags (List.map (fun c -> F.fCONST (fst (destConst c))) cl @ [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) @@ -5824,7 +5824,7 @@ let havetac ist let sigma, t, uc, n_evars = interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in if skols <> [] && n_evars <> 0 then - Errors.error ("Automatic generalization of unresolved implicit "^ + CErrors.error ("Automatic generalization of unresolved implicit "^ "arguments together with abstract variables is "^ "not supported"); let gl = re_sig (sig_it gl) (Evd.merge_universe_context sigma uc) in @@ -6049,14 +6049,14 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = | Sort _, [] -> Vars.subst_vars s ct | LetIn(Name id as n,b,ty,c), _::g -> mkLetIn (n,b,ty,var2rel c g (id::s)) | Prod(Name id as n,ty,c), _::g -> mkProd (n,ty,var2rel c g (id::s)) - | _ -> Errors.anomaly(str"SSR: wlog: var2rel: " ++ pr_constr c) in + | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_constr c) in let c = var2rel c gens [] in let rec pired c = function | [] -> c | t::ts as args -> match kind_of_term c with | Prod(_,_,c) -> pired (subst1 t c) ts | LetIn(id,b,ty,c) -> mkLetIn (id,b,ty,pired c args) - | _ -> Errors.anomaly(str"SSR: wlog: pired: " ++ pr_constr c) in + | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_constr c) in c, args, pired c args, pf_merge_uc uc gl in let tacipat pats = introstac ~ist pats in let tacigens = -- cgit v1.2.3 From 682801347b039ccad048625d97e4a8c6790ace19 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 16 Aug 2016 09:56:32 +0200 Subject: fix compilation on trunk (thanks Matej) --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 8dc9b64..0d0897b 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -105,6 +105,11 @@ let anomaly s = CErrors.anomaly (str s) let ppnl = msg_info let msgnl = msg_info +let mk_reldecl name obody ty = + match obody with + | None -> Rel.Declaration.LocalAssum (name, ty) + | Some bo -> Rel.Declaration.LocalDef (name, bo, ty) + (** look up a name in the ssreflect internals module *) let ssrdirpath = make_dirpath [id_of_string "ssreflect"] let ssrqid name = make_qualid ssrdirpath (id_of_string name) @@ -2091,10 +2096,10 @@ let abs_wgen keep_let ist f gen (gl,args,c) = let _, bo, ty = Named.Declaration.to_tuple (pf_get_hyp gl x) in gl, (if bo <> None then args else mkVar x :: args), - mkProd_or_LetIn (Rel.Declaration.of_tuple (Name (f x),bo,ty)) (subst_var x c) + mkProd_or_LetIn (mk_reldecl (Name (f x)) bo ty) (subst_var x c) | _, Some ((x, _), None) -> let x = hoi_id x in - gl, mkVar x :: args, mkProd (Name (f x), pf_get_hyp_typ gl x, subst_var x c) + gl, mkVar x :: args, mkProd (Name (f x),pf_get_hyp_typ gl x, subst_var x c) | _, Some ((x, "@"), Some p) -> let x = hoi_id x in let cp = interp_cpattern ist gl p None in -- cgit v1.2.3 From c353aa577c4bed12746dc8433b5daba31ebd7759 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 17 Aug 2016 12:46:16 +0200 Subject: use a convenient module alias instead of "Context.Rel.Declaration" and "Context.Named.Declaration" --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 44 ++++++++++++++------------- 1 file changed, 23 insertions(+), 21 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 0d0897b..666b46e 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -74,6 +74,8 @@ open Tok open Ssrmatching_plugin open Ssrmatching +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration (* Tentative patch from util.ml *) @@ -107,8 +109,8 @@ let msgnl = msg_info let mk_reldecl name obody ty = match obody with - | None -> Rel.Declaration.LocalAssum (name, ty) - | Some bo -> Rel.Declaration.LocalDef (name, bo, ty) + | None -> RelDecl.LocalAssum (name, ty) + | Some bo -> RelDecl.LocalDef (name, bo, ty) (** look up a name in the ssreflect internals module *) let ssrdirpath = make_dirpath [id_of_string "ssreflect"] @@ -568,7 +570,7 @@ let is_pf_var c = isVar c && not_section_id (destVar c) let pf_ids_of_proof_hyps gl = let add_hyp decl ids = - let id = Named.Declaration.get_id decl in + let id = NamedDecl.get_id decl in if not_section_id id then id :: ids else ids in Context.Named.fold_outside add_hyp (pf_hyps gl) ~init:[] @@ -760,7 +762,7 @@ let mk_anon_id t gl = let ssr_anon_hyp = "Hyp" let anontac decl gl = - let id = match Rel.Declaration.get_name decl with + let id = match RelDecl.get_name decl with | Name id -> if is_discharged_id id then id else mk_anon_id (string_of_id id) gl | _ -> mk_anon_id ssr_anon_hyp gl in @@ -810,7 +812,7 @@ let pf_abs_evars gl (sigma, c0) = let abs_evar n k = let evi = Evd.find sigma k in let dc = List.firstn n (evar_filtered_context evi) in - let abs_dc c decl = match Named.Declaration.to_tuple decl with + let abs_dc c decl = match NamedDecl.to_tuple decl with | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) | x, None, t -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in @@ -865,7 +867,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let abs_evar n k = let evi = Evd.find sigma k in let dc = List.firstn n (evar_filtered_context evi) in - let abs_dc c decl = match Named.Declaration.to_tuple decl with + let abs_dc c decl = match NamedDecl.to_tuple decl with | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) | x, None, t -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in @@ -1005,10 +1007,10 @@ let pf_unabs_evars gl ise n c0 = let push_rel = Environ.push_rel in let rec mk_evar j env i c = match kind_of_term c with | Prod (x, t, c1) when i < j -> - mk_evar j (push_rel (Rel.Declaration.LocalAssum (x, unabs i t)) env) (i + 1) c1 + mk_evar j (push_rel (RelDecl.LocalAssum (x, unabs i t)) env) (i + 1) c1 | LetIn (x, b, t, c1) when i < j -> let _, _, c2 = destProd c1 in - mk_evar j (push_rel (Rel.Declaration.LocalDef (x, unabs i b, unabs i t)) env) (i + 1) c2 + mk_evar j (push_rel (RelDecl.LocalDef (x, unabs i b, unabs i t)) env) (i + 1) c2 | _ -> Evarutil.e_new_evar env ise (unabs i c) in let rec unabs_evars c = if !nev = n then unabs n c else match kind_of_term c with @@ -2001,10 +2003,10 @@ let rec safe_depth c = match kind_of_term c with let red_safe r e s c0 = let rec red_to e c n = match kind_of_term c with | Prod (x, t, c') when n > 0 -> - let t' = r e s t in let e' = Environ.push_rel (Rel.Declaration.LocalAssum (x, t')) e in + let t' = r e s t in let e' = Environ.push_rel (RelDecl.LocalAssum (x, t')) e in mkProd (x, t', red_to e' c' (n - 1)) | LetIn (x, b, t, c') when n > 0 -> - let t' = r e s t in let e' = Environ.push_rel (Rel.Declaration.LocalAssum (x, t')) e in + let t' = r e s t in let e' = Environ.push_rel (RelDecl.LocalAssum (x, t')) e in mkLetIn (x, r e s b, t', red_to e' c' (n - 1)) | _ -> r e s c in red_to e c0 (safe_depth c0) @@ -2036,7 +2038,7 @@ let hidetacs clseq idhide cl0 = let discharge_hyp (id', (id, mode)) gl = let cl' = subst_var id (pf_concl gl) in - match Named.Declaration.to_tuple (pf_get_hyp gl id), mode with + match NamedDecl.to_tuple (pf_get_hyp gl id), mode with | (_, None, t), _ | (_, Some _, t), "(" -> apply_type (mkProd (Name id', t, cl')) [mkVar id] gl | (_, Some v, t), _ -> @@ -2049,7 +2051,7 @@ let endclausestac id_map clseq gl_id cl0 gl = let hide_goal = hidden_clseq clseq in let c_hidden = hide_goal && c = mkVar gl_id in let rec fits forced = function - | (id, _) :: ids, decl :: dc' when Rel.Declaration.get_name decl = Name id -> + | (id, _) :: ids, decl :: dc' when RelDecl.get_name decl = Name id -> fits true (ids, dc') | ids, dc' -> forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in @@ -2062,7 +2064,7 @@ let endclausestac id_map clseq gl_id cl0 gl = | _ -> map_constr unmark c in let utac hyp = Proofview.V82.of_tactic - (convert_hyp_no_check (Context.Named.Declaration.map_constr unmark hyp)) in + (convert_hyp_no_check (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = Proofview.V82.of_tactic @@ -2093,7 +2095,7 @@ let abs_wgen keep_let ist f gen (gl,args,c) = match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> let x = hoi_id x in - let _, bo, ty = Named.Declaration.to_tuple (pf_get_hyp gl x) in + let _, bo, ty = NamedDecl.to_tuple (pf_get_hyp gl x) in gl, (if bo <> None then args else mkVar x :: args), mkProd_or_LetIn (mk_reldecl (Name (f x)) bo ty) (subst_var x c) @@ -2855,7 +2857,7 @@ let clear_wilds wilds gl = let clear_with_wilds wilds clr0 gl = let extend_clr clr nd = - let id = Named.Declaration.get_id nd in + let id = NamedDecl.get_id nd in if List.mem id clr || not (List.mem id wilds) then clr else let vars = global_vars_set_of_decl (pf_env gl) nd in let occurs id' = Idset.mem id' vars in @@ -2909,7 +2911,7 @@ let ssrmkabs id gl = let Sigma (m, sigma, p5) = Evarutil.new_evar env sigma abstract_ty in Sigma ((m, abstract_ty), sigma, p1 +> p2 +> p3 +> p4 +> p5) in let sigma, kont = - let rd = Rel.Declaration.LocalAssum (Name id, abstract_ty) in + let rd = RelDecl.LocalAssum (Name id, abstract_ty) in let Sigma (ev, sigma, _) = Evarutil.new_evar (Environ.push_rel rd env) sigma concl in let sigma = Sigma.to_evar_map sigma in (sigma, ev) @@ -3460,7 +3462,7 @@ let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = if tag_of_cpattern t = '@' then if not (isVar c) then errorstrm (str "@ can be used with variables only") - else match Named.Declaration.to_tuple (pf_get_hyp gl (destVar c)) with + else match NamedDecl.to_tuple (pf_get_hyp gl (destVar c)) with | _, None, _ -> errorstrm (str "@ can be used with let-ins only") | name, Some bo, ty -> true, pat, mkLetIn (Name name,bo,ty,cl),c,clr,ucst,gl else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl @@ -3784,8 +3786,8 @@ let analyze_eliminator elimty env sigma = | AtomicType (hd, args) when isRel hd -> ctx, destRel hd, not (noccurn 1 t), Array.length args | CastType (t, _) -> loop ctx t - | ProdType (x, ty, t) -> loop (Rel.Declaration.LocalAssum (x, ty) :: ctx) t - | LetInType (x,b,ty,t) -> loop (Rel.Declaration.LocalDef (x, b, ty) :: ctx) (subst1 b t) + | ProdType (x, ty, t) -> loop (RelDecl.LocalAssum (x, ty) :: ctx) t + | LetInType (x,b,ty,t) -> loop (RelDecl.LocalDef (x, b, ty) :: ctx) (subst1 b t) | _ -> let env' = Environ.push_rel_context ctx env in let t' = Reductionops.whd_all env' sigma t in @@ -6017,8 +6019,8 @@ END let destProd_or_LetIn c = match kind_of_term c with - | Prod (n,ty,c) -> Rel.Declaration.LocalAssum (n, ty), c - | LetIn (n,bo,ty,c) -> Rel.Declaration.LocalDef (n, bo, ty), c + | Prod (n,ty,c) -> RelDecl.LocalAssum (n, ty), c + | LetIn (n,bo,ty,c) -> RelDecl.LocalDef (n, bo, ty), c | _ -> raise DestKO let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = -- cgit v1.2.3 From 2bc134ff7c90bbc63ff388d2a456f154cc563ed7 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 17 Aug 2016 12:58:08 +0200 Subject: Removing calls of "Context.Named.Declaration.to_tuple" function --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 42 +++++++++++++-------------- 1 file changed, 21 insertions(+), 21 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 666b46e..f7c2bf0 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -107,11 +107,6 @@ let anomaly s = CErrors.anomaly (str s) let ppnl = msg_info let msgnl = msg_info -let mk_reldecl name obody ty = - match obody with - | None -> RelDecl.LocalAssum (name, ty) - | Some bo -> RelDecl.LocalDef (name, bo, ty) - (** look up a name in the ssreflect internals module *) let ssrdirpath = make_dirpath [id_of_string "ssreflect"] let ssrqid name = make_qualid ssrdirpath (id_of_string name) @@ -812,9 +807,9 @@ let pf_abs_evars gl (sigma, c0) = let abs_evar n k = let evi = Evd.find sigma k in let dc = List.firstn n (evar_filtered_context evi) in - let abs_dc c decl = match NamedDecl.to_tuple decl with - | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) - | x, None, t -> mkNamedProd x t c in + let abs_dc c = function + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in Evarutil.nf_evar sigma t in let rec put evlist c = match kind_of_term c with @@ -867,9 +862,9 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let abs_evar n k = let evi = Evd.find sigma k in let dc = List.firstn n (evar_filtered_context evi) in - let abs_dc c decl = match NamedDecl.to_tuple decl with - | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) - | x, None, t -> mkNamedProd x t c in + let abs_dc c = function + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in Evarutil.nf_evar sigma0 (Evarutil.nf_evar sigma t) in let rec put evlist c = match kind_of_term c with @@ -2038,10 +2033,10 @@ let hidetacs clseq idhide cl0 = let discharge_hyp (id', (id, mode)) gl = let cl' = subst_var id (pf_concl gl) in - match NamedDecl.to_tuple (pf_get_hyp gl id), mode with - | (_, None, t), _ | (_, Some _, t), "(" -> + match pf_get_hyp gl id, mode with + | NamedDecl.LocalAssum (_, t), _ | NamedDecl.LocalDef (_, _, t), "(" -> apply_type (mkProd (Name id', t, cl')) [mkVar id] gl - | (_, Some v, t), _ -> + | NamedDecl.LocalDef (_, v, t), _ -> Proofview.V82.of_tactic (convert_concl (mkLetIn (Name id', v, t, cl'))) gl let endclausestac id_map clseq gl_id cl0 gl = @@ -2095,10 +2090,15 @@ let abs_wgen keep_let ist f gen (gl,args,c) = match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> let x = hoi_id x in - let _, bo, ty = NamedDecl.to_tuple (pf_get_hyp gl x) in - gl, - (if bo <> None then args else mkVar x :: args), - mkProd_or_LetIn (mk_reldecl (Name (f x)) bo ty) (subst_var x c) + (match pf_get_hyp gl x with + | LocalAssum (_,ty) -> + gl, + mkVar x :: args, + mkProd_or_LetIn (RelDecl.LocalAssum (Name (f x),ty)) (subst_var x c) + | LocalDef (_,b,ty) -> + gl, + args, + mkProd_or_LetIn (RelDecl.LocalDef (Name (f x),b,ty)) (subst_var x c)) | _, Some ((x, _), None) -> let x = hoi_id x in gl, mkVar x :: args, mkProd (Name (f x),pf_get_hyp_typ gl x, subst_var x c) @@ -3462,9 +3462,9 @@ let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = if tag_of_cpattern t = '@' then if not (isVar c) then errorstrm (str "@ can be used with variables only") - else match NamedDecl.to_tuple (pf_get_hyp gl (destVar c)) with - | _, None, _ -> errorstrm (str "@ can be used with let-ins only") - | name, Some bo, ty -> true, pat, mkLetIn (Name name,bo,ty,cl),c,clr,ucst,gl + else match pf_get_hyp gl (destVar c) with + | NamedDecl.LocalAssum _ -> errorstrm (str "@ can be used with let-ins only") + | NamedDecl.LocalDef (name, b, ty) -> true, pat, mkLetIn (Name name,b,ty,cl),c,clr,ucst,gl else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl else if to_ind && occ = None then let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in -- cgit v1.2.3 From 6bc53af07a100aad305393edb14c4a3d73b3e3b7 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 24 Aug 2016 16:01:35 +0200 Subject: Possible code compaction motivated by Enrico's remark: https://github.com/math-comp/math-comp/pull/58#discussion_r76048943 --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index f7c2bf0..6fa7235 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -2090,15 +2090,11 @@ let abs_wgen keep_let ist f gen (gl,args,c) = match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> let x = hoi_id x in - (match pf_get_hyp gl x with - | LocalAssum (_,ty) -> - gl, - mkVar x :: args, - mkProd_or_LetIn (RelDecl.LocalAssum (Name (f x),ty)) (subst_var x c) - | LocalDef (_,b,ty) -> - gl, - args, - mkProd_or_LetIn (RelDecl.LocalDef (Name (f x),b,ty)) (subst_var x c)) + let decl = pf_get_hyp gl x in + gl, + (if NamedDecl.is_local_def decl then args else mkVar x :: args), + mkProd_or_LetIn (decl |> NamedDecl.to_rel |> RelDecl.set_name (Name (f x))) + (subst_var x c) | _, Some ((x, _), None) -> let x = hoi_id x in gl, mkVar x :: args, mkProd (Name (f x),pf_get_hyp_typ gl x, subst_var x c) -- cgit v1.2.3 From 2d824f394e8c3148e95b3374fb9903f6032ba3e6 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Thu, 25 Aug 2016 01:38:44 +0200 Subject: Enriched numClosedFieldType so that it factors a lot of theory from both complex and algC. The definitions of 'i, conjC, Re, Im, n.-root, sqrtC and their theory have been moved to the numClosedFieldType structure in ssrnum. This covers boths the uses in algC and complex.v. To that end the numClosedFieldType structure has been enriched with conjugation and 'i. Note that 'i can be deduced from the property of algebraic closure and is only here to let the user chose which definitional equality should hold on 'i. Same thing for conjC that could be written `|x|^+2/x, the only nontrivial (up to my knowledge) property is the fact that conjugation is a ring morphism. --- mathcomp/algebra/rat.v | 2 - mathcomp/algebra/ssralg.v | 7 + mathcomp/algebra/ssrnum.v | 738 ++++++++++++++++++++++++++++++- mathcomp/character/all_character.v | 14 +- mathcomp/character/classfun.v | 3 +- mathcomp/field/algC.v | 672 ++-------------------------- mathcomp/field/algebraics_fundamentals.v | 8 +- mathcomp/fingroup/fingroup.v | 2 +- mathcomp/odd_order/BGappendixC.v | 11 +- mathcomp/odd_order/PFsection11.v | 2 +- mathcomp/odd_order/PFsection3.v | 2 +- mathcomp/odd_order/PFsection5.v | 8 +- mathcomp/odd_order/PFsection6.v | 6 +- mathcomp/odd_order/PFsection7.v | 2 +- mathcomp/real_closed/complex.v | 320 ++++++++------ mathcomp/real_closed/polyrcf.v | 42 -- 16 files changed, 980 insertions(+), 859 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/algebra/rat.v b/mathcomp/algebra/rat.v index 9012291..9a38f5b 100644 --- a/mathcomp/algebra/rat.v +++ b/mathcomp/algebra/rat.v @@ -11,8 +11,6 @@ Require Import bigop ssralg div ssrnum ssrint. (* structure of archimedean, real field, with int and nat declared as closed *) (* subrings. *) (* rat == the type of rational number, with single constructor Rat *) -(* Rat p h == the element of type rat build from p a pair of integers and*) -(* h a proof of (0 < p.2) && coprime `|p.1| `|p.2| *) (* n%:Q == explicit cast from int to rat, postfix notation for the *) (* ratz constant *) (* numq r == numerator of (r : rat) *) diff --git a/mathcomp/algebra/ssralg.v b/mathcomp/algebra/ssralg.v index a494f3f..887fa9b 100644 --- a/mathcomp/algebra/ssralg.v +++ b/mathcomp/algebra/ssralg.v @@ -5107,6 +5107,12 @@ Variable F : closedFieldType. Lemma solve_monicpoly : ClosedField.axiom F. Proof. by case: F => ? []. Qed. +Lemma imaginary_exists : {i : F | i ^+ 2 = -1}. +Proof. +have /sig_eqW[i Di2] := @solve_monicpoly 2 (nth 0 [:: -1]) isT. +by exists i; rewrite Di2 !big_ord_recl big_ord0 mul0r mulr1 !addr0. +Qed. + End ClosedFieldTheory. Module SubType. @@ -5741,6 +5747,7 @@ Definition rmorph_alg := rmorph_alg. Definition lrmorphismP := lrmorphismP. Definition can2_lrmorphism := can2_lrmorphism. Definition bij_lrmorphism := bij_lrmorphism. +Definition imaginary_exists := imaginary_exists. Notation null_fun V := (null_fun V) (only parsing). Notation in_alg A := (in_alg_loc A). diff --git a/mathcomp/algebra/ssrnum.v b/mathcomp/algebra/ssrnum.v index b1c1746..47d73e6 100644 --- a/mathcomp/algebra/ssrnum.v +++ b/mathcomp/algebra/ssrnum.v @@ -2,7 +2,7 @@ (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp -Require Import ssrfun ssrbool eqtype ssrnat seq div choice fintype. +Require Import ssrfun ssrbool eqtype ssrnat seq div choice fintype path. From mathcomp Require Import bigop ssralg finset fingroup zmodp poly. @@ -60,17 +60,24 @@ Require Import bigop ssralg finset fingroup zmodp poly. (* == clone of a canonical archiFieldType structure on T *) (* *) (* * RealClosedField (Real Field with the real closed axiom) *) -(* realClosedFieldType *) -(* == interface for a real closed field. *) -(* RealClosedFieldType T r *) -(* == packs the real closed axiom r into a *) -(* realClodedFieldType. The carrier T must have a real *) +(* rcfType == interface for a real closed field. *) +(* RcfType T r == packs the real closed axiom r into a *) +(* rcfType. The carrier T must have a real *) (* field type structure. *) -(* [realClosedFieldType of T for S ] *) -(* == T-clone of the realClosedFieldType structure S. *) -(* [realClosedFieldype of T] *) -(* == clone of a canonical realClosedFieldType structure on *) +(* [rcfType of T] == clone of a canonical realClosedFieldType structure on *) (* T. *) +(* [rcfType of T for S ] *) +(* == T-clone of the realClosedFieldType structure S. *) +(* *) +(* * NumClosedField (Partially ordered Closed Field with conjugation) *) +(* numClosedFieldType == interface for a closed field with conj. *) +(* NumClosedFieldType T r == packs the real closed axiom r into a *) +(* numClosedFieldType. The carrier T must have a closed *) +(* field type structure. *) +(* [numClosedFieldType of T] == clone of a canonical numClosedFieldType *) +(* structure on T *) +(* [numClosedFieldType of T for S ] *) +(* == T-clone of the realClosedFieldType structure S. *) (* *) (* Over these structures, we have the following operations *) (* `|x| == norm of x. *) @@ -89,6 +96,18 @@ Require Import bigop ssralg finset fingroup zmodp poly. (* and n such that `|x| < n%:R. *) (* Num.sqrt x == in a real-closed field, a positive square root of x if *) (* x >= 0, or 0 otherwise. *) +(* For numeric algebraically closed fields we provide the generic definitions *) +(* 'i == the imaginary number (:= sqrtC (-1)). *) +(* 'Re z == the real component of z. *) +(* 'Im z == the imaginary component of z. *) +(* z^* == the complex conjugate of z (:= conjC z). *) +(* sqrtC z == a nonnegative square root of z, i.e., 0 <= sqrt x if 0 <= x. *) +(* n.-root z == more generally, for n > 0, an nth root of z, chosen with a *) +(* minimal non-negative argument for n > 1 (i.e., with a *) +(* maximal real part subject to a nonnegative imaginary part). *) +(* Note that n.-root (-1) is a primitive 2nth root of unity, *) +(* an thus not equal to -1 for n odd > 1 (this will be shown in *) +(* file cyclotomic.v). *) (* *) (* There are now three distinct uses of the symbols <, <=, > and >=: *) (* 0-ary, unary (prefix) and binary (infix). *) @@ -401,9 +420,17 @@ Module ClosedField. Section ClassDef. +Record imaginary_mixin_of (R : numDomainType) := ImaginaryMixin { + imaginary : R; + conj_op : {rmorphism R -> R}; + _ : imaginary ^+ 2 = - 1; + _ : forall x, x * conj_op x = `|x| ^+ 2; +}. + Record class_of R := Class { base : GRing.ClosedField.class_of R; - mixin : mixin_of (ring_for R base) + mixin : mixin_of (ring_for R base); + conj_mixin : imaginary_mixin_of (num_for R (NumDomain.Class mixin)) }. Definition base2 R (c : class_of R) := NumField.Class (mixin c). Local Coercion base : class_of >-> GRing.ClosedField.class_of. @@ -419,7 +446,8 @@ Definition pack := fun bT b & phant_id (GRing.ClosedField.class bT) (b : GRing.ClosedField.class_of T) => fun mT m & phant_id (NumField.class mT) (@NumField.Class T b m) => - Pack (@Class T b m) T. + fun mc => Pack (@Class T b m mc) T. +Definition clone := fun b & phant_id class (b : class_of T) => Pack b T. Definition eqType := @Equality.Pack cT xclass xT. Definition choiceType := @Choice.Pack cT xclass xT. @@ -431,6 +459,7 @@ Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT. Definition numDomainType := @NumDomain.Pack cT xclass xT. Definition fieldType := @GRing.Field.Pack cT xclass xT. +Definition numFieldType := @NumField.Pack cT xclass xT. Definition decFieldType := @GRing.DecidableField.Pack cT xclass xT. Definition closedFieldType := @GRing.ClosedField.Pack cT xclass xT. Definition join_dec_numDomainType := @NumDomain.Pack decFieldType xclass xT. @@ -467,6 +496,8 @@ Coercion fieldType : type >-> GRing.Field.type. Canonical fieldType. Coercion decFieldType : type >-> GRing.DecidableField.type. Canonical decFieldType. +Coercion numFieldType : type >-> NumField.type. +Canonical numFieldType. Coercion closedFieldType : type >-> GRing.ClosedField.type. Canonical closedFieldType. Canonical join_dec_numDomainType. @@ -474,7 +505,11 @@ Canonical join_dec_numFieldType. Canonical join_numDomainType. Canonical join_numFieldType. Notation numClosedFieldType := type. -Notation "[ 'numClosedFieldType' 'of' T ]" := (@pack T _ _ id _ _ id) +Notation NumClosedFieldType T m := (@pack T _ _ id _ _ id m). +Notation "[ 'numClosedFieldType' 'of' T 'for' cT ]" := (@clone T cT _ id) + (at level 0, format "[ 'numClosedFieldType' 'of' T 'for' cT ]") : + form_scope. +Notation "[ 'numClosedFieldType' 'of' T ]" := (@clone T _ _ id) (at level 0, format "[ 'numClosedFieldType' 'of' T ]") : form_scope. End Exports. @@ -4085,6 +4120,682 @@ Qed. End RealClosedFieldTheory. +Definition conjC {C : numClosedFieldType} : {rmorphism C -> C} := + ClosedField.conj_op (ClosedField.conj_mixin (ClosedField.class C)). +Notation "z ^*" := (@conjC _ z) (at level 2, format "z ^*") : ring_scope. + +Definition imaginaryC {C : numClosedFieldType} : C := + ClosedField.imaginary (ClosedField.conj_mixin (ClosedField.class C)). +Notation "'i" := (@imaginaryC _) (at level 0) : ring_scope. + +Section ClosedFieldTheory. + +Variable C : numClosedFieldType. +Implicit Types a x y z : C. + +Definition normCK x : `|x| ^+ 2 = x * x^*. +Proof. by case: C x => ? [? ? []]. Qed. + +Lemma sqrCi : 'i ^+ 2 = -1 :> C. +Proof. by case: C => ? [? ? []]. Qed. + +Lemma conjCK : involutive (@conjC C). +Proof. +have JE x : x^* = `|x|^+2 / x. + have [->|x_neq0] := eqVneq x 0; first by rewrite rmorph0 invr0 mulr0. + by apply: (canRL (mulfK _)) => //; rewrite mulrC -normCK. +move=> x; have [->|x_neq0] := eqVneq x 0; first by rewrite !rmorph0. +rewrite !JE normrM normfV exprMn normrX normr_id. +rewrite invfM exprVn mulrA -[X in X * _]mulrA -invfM -exprMn. +by rewrite divff ?mul1r ?invrK // !expf_eq0 normr_eq0 //. +Qed. + +Let Re2 z := z + z^*. +Definition nnegIm z := (0 <= imaginaryC * (z^* - z)). +Definition argCle y z := nnegIm z ==> nnegIm y && (Re2 z <= Re2 y). + +CoInductive rootC_spec n (x : C) : Type := + RootCspec (y : C) of if (n > 0)%N then y ^+ n = x else y = 0 + & forall z, (n > 0)%N -> z ^+ n = x -> argCle y z. + +Fact rootC_subproof n x : rootC_spec n x. +Proof. +have realRe2 u : Re2 u \is Num.real. + rewrite realEsqr expr2 {2}/Re2 -{2}[u]conjCK addrC -rmorphD -normCK. + by rewrite exprn_ge0 ?normr_ge0. +have argCle_total : total argCle. + move=> u v; rewrite /total /argCle. + by do 2!case: (nnegIm _) => //; rewrite ?orbT //= real_leVge. +have argCle_trans : transitive argCle. + move=> u v w /implyP geZuv /implyP geZvw; apply/implyP. + by case/geZvw/andP=> /geZuv/andP[-> geRuv] /ler_trans->. +pose p := 'X^n - (x *+ (n > 0))%:P; have [r0 Dp] := closed_field_poly_normal p. +have sz_p: size p = n.+1. + rewrite size_addl ?size_polyXn // ltnS size_opp size_polyC mulrn_eq0. + by case: posnP => //; case: negP. +pose r := sort argCle r0; have r_arg: sorted argCle r by apply: sort_sorted. +have{Dp} Dp: p = \prod_(z <- r) ('X - z%:P). + rewrite Dp lead_coefE sz_p coefB coefXn coefC -mulrb -mulrnA mulnb lt0n andNb. + rewrite subr0 eqxx scale1r; apply: eq_big_perm. + by rewrite perm_eq_sym perm_sort. +have mem_rP z: (n > 0)%N -> reflect (z ^+ n = x) (z \in r). + move=> n_gt0; rewrite -root_prod_XsubC -Dp rootE !hornerE hornerXn n_gt0. + by rewrite subr_eq0; apply: eqP. +exists r`_0 => [|z n_gt0 /(mem_rP z n_gt0) r_z]. + have sz_r: size r = n by apply: succn_inj; rewrite -sz_p Dp size_prod_XsubC. + case: posnP => [n0 | n_gt0]; first by rewrite nth_default // sz_r n0. + by apply/mem_rP=> //; rewrite mem_nth ?sz_r. +case: {Dp mem_rP}r r_z r_arg => // y r1; rewrite inE => /predU1P[-> _|r1z]. + by apply/implyP=> ->; rewrite lerr. +by move/(order_path_min argCle_trans)/allP->. +Qed. + +Definition nthroot n x := let: RootCspec y _ _ := rootC_subproof n x in y. +Notation "n .-root" := (nthroot n) (at level 2, format "n .-root") : ring_core_scope. +Notation "n .-root" := (nthroot n) (only parsing) : ring_scope. +Notation sqrtC := 2.-root. + +Definition Re x := (x + x^*) / 2%:R. +Definition Im x := 'i * (x^* - x) / 2%:R. +Notation "'Re z" := (Re z) (at level 10, z at level 8) : ring_scope. +Notation "'Im z" := (Im z) (at level 10, z at level 8) : ring_scope. + +Let nz2 : 2%:R != 0 :> C. Proof. by rewrite pnatr_eq0. Qed. + +Lemma normCKC x : `|x| ^+ 2 = x^* * x. Proof. by rewrite normCK mulrC. Qed. + +Lemma mul_conjC_ge0 x : 0 <= x * x^*. +Proof. by rewrite -normCK exprn_ge0 ?normr_ge0. Qed. + +Lemma mul_conjC_gt0 x : (0 < x * x^*) = (x != 0). +Proof. +have [->|x_neq0] := altP eqP; first by rewrite rmorph0 mulr0. +by rewrite -normCK exprn_gt0 ?normr_gt0. +Qed. + +Lemma mul_conjC_eq0 x : (x * x^* == 0) = (x == 0). +Proof. by rewrite -normCK expf_eq0 normr_eq0. Qed. + +Lemma conjC_ge0 x : (0 <= x^*) = (0 <= x). +Proof. +wlog suffices: x / 0 <= x -> 0 <= x^*. + by move=> IH; apply/idP/idP=> /IH; rewrite ?conjCK. +rewrite le0r => /predU1P[-> | x_gt0]; first by rewrite rmorph0. +by rewrite -(pmulr_rge0 _ x_gt0) mul_conjC_ge0. +Qed. + +Lemma conjC_nat n : (n%:R)^* = n%:R :> C. Proof. exact: rmorph_nat. Qed. +Lemma conjC0 : 0^* = 0 :> C. Proof. exact: rmorph0. Qed. +Lemma conjC1 : 1^* = 1 :> C. Proof. exact: rmorph1. Qed. +Lemma conjC_eq0 x : (x^* == 0) = (x == 0). Proof. exact: fmorph_eq0. Qed. + +Lemma invC_norm x : x^-1 = `|x| ^- 2 * x^*. +Proof. +have [-> | nx_x] := eqVneq x 0; first by rewrite conjC0 mulr0 invr0. +by rewrite normCK invfM divfK ?conjC_eq0. +Qed. + +(* Real number subset. *) + +Lemma CrealE x : (x \is real) = (x^* == x). +Proof. +rewrite realEsqr ger0_def normrX normCK. +by have [-> | /mulfI/inj_eq-> //] := eqVneq x 0; rewrite rmorph0 !eqxx. +Qed. + +Lemma CrealP {x} : reflect (x^* = x) (x \is real). +Proof. by rewrite CrealE; apply: eqP. Qed. + +Lemma conj_Creal x : x \is real -> x^* = x. +Proof. by move/CrealP. Qed. + +Lemma conj_normC z : `|z|^* = `|z|. +Proof. by rewrite conj_Creal ?normr_real. Qed. + +Lemma geC0_conj x : 0 <= x -> x^* = x. +Proof. by move=> /ger0_real/CrealP. Qed. + +Lemma geC0_unit_exp x n : 0 <= x -> (x ^+ n.+1 == 1) = (x == 1). +Proof. by move=> x_ge0; rewrite pexpr_eq1. Qed. + +(* Elementary properties of roots. *) + +Ltac case_rootC := rewrite /nthroot; case: (rootC_subproof _ _). + +Lemma root0C x : 0.-root x = 0. Proof. by case_rootC. Qed. + +Lemma rootCK n : (n > 0)%N -> cancel n.-root (fun x => x ^+ n). +Proof. by case: n => //= n _ x; case_rootC. Qed. + +Lemma root1C x : 1.-root x = x. Proof. exact: (@rootCK 1). Qed. + +Lemma rootC0 n : n.-root 0 = 0. +Proof. +have [-> | n_gt0] := posnP n; first by rewrite root0C. +by have /eqP := rootCK n_gt0 0; rewrite expf_eq0 n_gt0 /= => /eqP. +Qed. + +Lemma rootC_inj n : (n > 0)%N -> injective n.-root. +Proof. by move/rootCK/can_inj. Qed. + +Lemma eqr_rootC n : (n > 0)%N -> {mono n.-root : x y / x == y}. +Proof. by move/rootC_inj/inj_eq. Qed. + +Lemma rootC_eq0 n x : (n > 0)%N -> (n.-root x == 0) = (x == 0). +Proof. by move=> n_gt0; rewrite -{1}(rootC0 n) eqr_rootC. Qed. + +(* Rectangular coordinates. *) + +Lemma nonRealCi : ('i : C) \isn't real. +Proof. by rewrite realEsqr sqrCi oppr_ge0 ltr_geF ?ltr01. Qed. + +Lemma neq0Ci : 'i != 0 :> C. +Proof. by apply: contraNneq nonRealCi => ->; apply: real0. Qed. + +Lemma normCi : `|'i| = 1 :> C. +Proof. +apply/eqP; rewrite -(@pexpr_eq1 _ _ 2) ?normr_ge0 //. +by rewrite -normrX sqrCi normrN1. +Qed. + +Lemma invCi : 'i^-1 = - 'i :> C. +Proof. by rewrite -div1r -[1]opprK -sqrCi mulNr mulfK ?neq0Ci. Qed. + +Lemma conjCi : 'i^* = - 'i :> C. +Proof. by rewrite -invCi invC_norm normCi expr1n invr1 mul1r. Qed. + +Lemma Crect x : x = 'Re x + 'i * 'Im x. +Proof. +rewrite 2!mulrA -expr2 sqrCi mulN1r opprB -mulrDl addrACA subrr addr0. +by rewrite -mulr2n -mulr_natr mulfK. +Qed. + +Lemma Creal_Re x : 'Re x \is real. +Proof. by rewrite CrealE fmorph_div rmorph_nat rmorphD conjCK addrC. Qed. + +Lemma Creal_Im x : 'Im x \is real. +Proof. +rewrite CrealE fmorph_div rmorph_nat rmorphM rmorphB conjCK. +by rewrite conjCi -opprB mulrNN. +Qed. +Hint Resolve Creal_Re Creal_Im. + +Fact Re_is_additive : additive Re. +Proof. by move=> x y; rewrite /Re rmorphB addrACA -opprD mulrBl. Qed. +Canonical Re_additive := Additive Re_is_additive. + +Fact Im_is_additive : additive Im. +Proof. +by move=> x y; rewrite /Im rmorphB opprD addrACA -opprD mulrBr mulrBl. +Qed. +Canonical Im_additive := Additive Im_is_additive. + +Lemma Creal_ImP z : reflect ('Im z = 0) (z \is real). +Proof. +rewrite CrealE -subr_eq0 -(can_eq (mulKf neq0Ci)) mulr0. +by rewrite -(can_eq (divfK nz2)) mul0r; apply: eqP. +Qed. + +Lemma Creal_ReP z : reflect ('Re z = z) (z \in real). +Proof. +rewrite (sameP (Creal_ImP z) eqP) -(can_eq (mulKf neq0Ci)) mulr0. +by rewrite -(inj_eq (addrI ('Re z))) addr0 -Crect eq_sym; apply: eqP. +Qed. + +Lemma ReMl : {in real, forall x, {morph Re : z / x * z}}. +Proof. +by move=> x Rx z /=; rewrite /Re rmorphM (conj_Creal Rx) -mulrDr -mulrA. +Qed. + +Lemma ReMr : {in real, forall x, {morph Re : z / z * x}}. +Proof. by move=> x Rx z /=; rewrite mulrC ReMl // mulrC. Qed. + +Lemma ImMl : {in real, forall x, {morph Im : z / x * z}}. +Proof. +by move=> x Rx z; rewrite /Im rmorphM (conj_Creal Rx) -mulrBr mulrCA !mulrA. +Qed. + +Lemma ImMr : {in real, forall x, {morph Im : z / z * x}}. +Proof. by move=> x Rx z /=; rewrite mulrC ImMl // mulrC. Qed. + +Lemma Re_i : 'Re 'i = 0. Proof. by rewrite /Re conjCi subrr mul0r. Qed. + +Lemma Im_i : 'Im 'i = 1. +Proof. +rewrite /Im conjCi -opprD mulrN -mulr2n mulrnAr ['i * _]sqrCi. +by rewrite mulNrn opprK divff. +Qed. + +Lemma Re_conj z : 'Re z^* = 'Re z. +Proof. by rewrite /Re addrC conjCK. Qed. + +Lemma Im_conj z : 'Im z^* = - 'Im z. +Proof. by rewrite /Im -mulNr -mulrN opprB conjCK. Qed. + +Lemma Re_rect : {in real &, forall x y, 'Re (x + 'i * y) = x}. +Proof. +move=> x y Rx Ry; rewrite /= raddfD /= (Creal_ReP x Rx). +by rewrite ReMr // Re_i mul0r addr0. +Qed. + +Lemma Im_rect : {in real &, forall x y, 'Im (x + 'i * y) = y}. +Proof. +move=> x y Rx Ry; rewrite /= raddfD /= (Creal_ImP x Rx) add0r. +by rewrite ImMr // Im_i mul1r. +Qed. + +Lemma conjC_rect : {in real &, forall x y, (x + 'i * y)^* = x - 'i * y}. +Proof. +by move=> x y Rx Ry; rewrite /= rmorphD rmorphM conjCi mulNr !conj_Creal. +Qed. + +Lemma addC_rect x1 y1 x2 y2 : + (x1 + 'i * y1) + (x2 + 'i * y2) = x1 + x2 + 'i * (y1 + y2). +Proof. by rewrite addrACA -mulrDr. Qed. + +Lemma oppC_rect x y : - (x + 'i * y) = - x + 'i * (- y). +Proof. by rewrite mulrN -opprD. Qed. + +Lemma subC_rect x1 y1 x2 y2 : + (x1 + 'i * y1) - (x2 + 'i * y2) = x1 - x2 + 'i * (y1 - y2). +Proof. by rewrite oppC_rect addC_rect. Qed. + +Lemma mulC_rect x1 y1 x2 y2 : + (x1 + 'i * y1) * (x2 + 'i * y2) + = x1 * x2 - y1 * y2 + 'i * (x1 * y2 + x2 * y1). +Proof. +rewrite mulrDl !mulrDr mulrCA -!addrA mulrAC -mulrA; congr (_ + _). +by rewrite mulrACA -expr2 sqrCi mulN1r addrA addrC. +Qed. + +Lemma normC2_rect : + {in real &, forall x y, `|x + 'i * y| ^+ 2 = x ^+ 2 + y ^+ 2}. +Proof. +move=> x y Rx Ry; rewrite /= normCK rmorphD rmorphM conjCi !conj_Creal //. +by rewrite mulrC mulNr -subr_sqr exprMn sqrCi mulN1r opprK. +Qed. + +Lemma normC2_Re_Im z : `|z| ^+ 2 = 'Re z ^+ 2 + 'Im z ^+ 2. +Proof. by rewrite -normC2_rect -?Crect. Qed. + +Lemma invC_rect : + {in real &, forall x y, (x + 'i * y)^-1 = (x - 'i * y) / (x ^+ 2 + y ^+ 2)}. +Proof. +by move=> x y Rx Ry; rewrite /= invC_norm conjC_rect // mulrC normC2_rect. +Qed. + +Lemma lerif_normC_Re_Creal z : `|'Re z| <= `|z| ?= iff (z \is real). +Proof. +rewrite -(mono_in_lerif ler_sqr); try by rewrite qualifE normr_ge0. +rewrite normCK conj_Creal // normC2_Re_Im -expr2. +rewrite addrC -lerif_subLR subrr (sameP (Creal_ImP _) eqP) -sqrf_eq0 eq_sym. +by apply: lerif_eq; rewrite -realEsqr. +Qed. + +Lemma lerif_Re_Creal z : 'Re z <= `|z| ?= iff (0 <= z). +Proof. +have ubRe: 'Re z <= `|'Re z| ?= iff (0 <= 'Re z). + by rewrite ger0_def eq_sym; apply/lerif_eq/real_ler_norm. +congr (_ <= _ ?= iff _): (lerif_trans ubRe (lerif_normC_Re_Creal z)). +apply/andP/idP=> [[zRge0 /Creal_ReP <- //] | z_ge0]. +by have Rz := ger0_real z_ge0; rewrite (Creal_ReP _ _). +Qed. + +(* Equality from polar coordinates, for the upper plane. *) +Lemma eqC_semipolar x y : + `|x| = `|y| -> 'Re x = 'Re y -> 0 <= 'Im x * 'Im y -> x = y. +Proof. +move=> eq_norm eq_Re sign_Im. +rewrite [x]Crect [y]Crect eq_Re; congr (_ + 'i * _). +have /eqP := congr1 (fun z => z ^+ 2) eq_norm. +rewrite !normC2_Re_Im eq_Re (can_eq (addKr _)) eqf_sqr => /pred2P[] // eq_Im. +rewrite eq_Im mulNr -expr2 oppr_ge0 real_exprn_even_le0 //= in sign_Im. +by rewrite eq_Im (eqP sign_Im) oppr0. +Qed. + +(* Nth roots. *) + +Let argCleP y z : + reflect (0 <= 'Im z -> 0 <= 'Im y /\ 'Re z <= 'Re y) (argCle y z). +Proof. +suffices dIm x: nnegIm x = (0 <= 'Im x). + rewrite /argCle !dIm ler_pmul2r ?invr_gt0 ?ltr0n //. + by apply: (iffP implyP) => geZyz /geZyz/andP. +by rewrite /('Im x) pmulr_lge0 ?invr_gt0 ?ltr0n //; congr (0 <= _ * _). +Qed. +(* case Du: sqrCi => [u u2N1] /=. *) +(* have/eqP := u2N1; rewrite -sqrCi eqf_sqr => /pred2P[] //. *) +(* have:= conjCi; rewrite /'i; case_rootC => /= v v2n1 min_v conj_v Duv. *) +(* have{min_v} /idPn[] := min_v u isT u2N1; rewrite negb_imply /nnegIm Du /= Duv. *) +(* rewrite rmorphN conj_v opprK -opprD mulrNN mulNr -mulr2n mulrnAr -expr2 v2n1. *) +(* by rewrite mulNrn opprK ler0n oppr_ge0 (ler_nat _ 2 0). *) + + +Lemma rootC_Re_max n x y : + (n > 0)%N -> y ^+ n = x -> 0 <= 'Im y -> 'Re y <= 'Re (n.-root x). +Proof. +by move=> n_gt0 yn_x leI0y; case_rootC=> z /= _ /(_ y n_gt0 yn_x)/argCleP[]. +Qed. + +Let neg_unity_root n : (n > 1)%N -> exists2 w : C, w ^+ n = 1 & 'Re w < 0. +Proof. +move=> n_gt1; have [|w /eqP pw_0] := closed_rootP (\poly_(i < n) (1 : C)) _. + by rewrite size_poly_eq ?oner_eq0 // -(subnKC n_gt1). +rewrite horner_poly (eq_bigr _ (fun _ _ => mul1r _)) in pw_0. +have wn1: w ^+ n = 1 by apply/eqP; rewrite -subr_eq0 subrX1 pw_0 mulr0. +suffices /existsP[i ltRwi0]: [exists i : 'I_n, 'Re (w ^+ i) < 0]. + by exists (w ^+ i) => //; rewrite exprAC wn1 expr1n. +apply: contra_eqT (congr1 Re pw_0); rewrite negb_exists => /forallP geRw0. +rewrite raddf_sum raddf0 /= (bigD1 (Ordinal (ltnW n_gt1))) //=. +rewrite (Creal_ReP _ _) ?rpred1 // gtr_eqF ?ltr_paddr ?ltr01 //=. +by apply: sumr_ge0 => i _; rewrite real_lerNgt ?rpred0. +Qed. + +Lemma Im_rootC_ge0 n x : (n > 1)%N -> 0 <= 'Im (n.-root x). +Proof. +set y := n.-root x => n_gt1; have n_gt0 := ltnW n_gt1. +apply: wlog_neg; rewrite -real_ltrNge ?rpred0 // => ltIy0. +suffices [z zn_x leI0z]: exists2 z, z ^+ n = x & 'Im z >= 0. + by rewrite /y; case_rootC => /= y1 _ /(_ z n_gt0 zn_x)/argCleP[]. +have [w wn1 ltRw0] := neg_unity_root n_gt1. +wlog leRI0yw: w wn1 ltRw0 / 0 <= 'Re y * 'Im w. + move=> IHw; have: 'Re y * 'Im w \is real by rewrite rpredM. + case/real_ger0P=> [|/ltrW leRIyw0]; first exact: IHw. + apply: (IHw w^*); rewrite ?Re_conj ?Im_conj ?mulrN ?oppr_ge0 //. + by rewrite -rmorphX wn1 rmorph1. +exists (w * y); first by rewrite exprMn wn1 mul1r rootCK. +rewrite [w]Crect [y]Crect mulC_rect. +by rewrite Im_rect ?rpredD ?rpredN 1?rpredM // addr_ge0 // ltrW ?nmulr_rgt0. +Qed. + +Lemma rootC_lt0 n x : (1 < n)%N -> (n.-root x < 0) = false. +Proof. +set y := n.-root x => n_gt1; have n_gt0 := ltnW n_gt1. +apply: negbTE; apply: wlog_neg => /negbNE lt0y; rewrite ler_gtF //. +have Rx: x \is real by rewrite -[x](rootCK n_gt0) rpredX // ltr0_real. +have Re_y: 'Re y = y by apply/Creal_ReP; rewrite ltr0_real. +have [z zn_x leR0z]: exists2 z, z ^+ n = x & 'Re z >= 0. + have [w wn1 ltRw0] := neg_unity_root n_gt1. + exists (w * y); first by rewrite exprMn wn1 mul1r rootCK. + by rewrite ReMr ?ltr0_real // ltrW // nmulr_lgt0. +without loss leI0z: z zn_x leR0z / 'Im z >= 0. + move=> IHz; have: 'Im z \is real by []. + case/real_ger0P=> [|/ltrW leIz0]; first exact: IHz. + apply: (IHz z^*); rewrite ?Re_conj ?Im_conj ?oppr_ge0 //. + by rewrite -rmorphX zn_x conj_Creal. +by apply: ler_trans leR0z _; rewrite -Re_y ?rootC_Re_max ?ltr0_real. +Qed. + +Lemma rootC_ge0 n x : (n > 0)%N -> (0 <= n.-root x) = (0 <= x). +Proof. +set y := n.-root x => n_gt0. +apply/idP/idP=> [/(exprn_ge0 n) | x_ge0]; first by rewrite rootCK. +rewrite -(ger_lerif (lerif_Re_Creal y)). +have Ray: `|y| \is real by apply: normr_real. +rewrite -(Creal_ReP _ Ray) rootC_Re_max ?(Creal_ImP _ Ray) //. +by rewrite -normrX rootCK // ger0_norm. +Qed. + +Lemma rootC_gt0 n x : (n > 0)%N -> (n.-root x > 0) = (x > 0). +Proof. by move=> n_gt0; rewrite !lt0r rootC_ge0 ?rootC_eq0. Qed. + +Lemma rootC_le0 n x : (1 < n)%N -> (n.-root x <= 0) = (x == 0). +Proof. +by move=> n_gt1; rewrite ler_eqVlt rootC_lt0 // orbF rootC_eq0 1?ltnW. +Qed. + +Lemma ler_rootCl n : (n > 0)%N -> {in Num.nneg, {mono n.-root : x y / x <= y}}. +Proof. +move=> n_gt0 x x_ge0 y; have [y_ge0 | not_y_ge0] := boolP (0 <= y). + by rewrite -(ler_pexpn2r n_gt0) ?qualifE ?rootC_ge0 ?rootCK. +rewrite (contraNF (@ler_trans _ _ 0 _ _)) ?rootC_ge0 //. +by rewrite (contraNF (ler_trans x_ge0)). +Qed. + +Lemma ler_rootC n : (n > 0)%N -> {in Num.nneg &, {mono n.-root : x y / x <= y}}. +Proof. by move=> n_gt0 x y x_ge0 _; apply: ler_rootCl. Qed. + +Lemma ltr_rootCl n : (n > 0)%N -> {in Num.nneg, {mono n.-root : x y / x < y}}. +Proof. by move=> n_gt0 x x_ge0 y; rewrite !ltr_def ler_rootCl ?eqr_rootC. Qed. + +Lemma ltr_rootC n : (n > 0)%N -> {in Num.nneg &, {mono n.-root : x y / x < y}}. +Proof. by move/ler_rootC/lerW_mono_in. Qed. + +Lemma exprCK n x : (0 < n)%N -> 0 <= x -> n.-root (x ^+ n) = x. +Proof. +move=> n_gt0 x_ge0; apply/eqP. +by rewrite -(eqr_expn2 n_gt0) ?rootC_ge0 ?exprn_ge0 ?rootCK. +Qed. + +Lemma norm_rootC n x : `|n.-root x| = n.-root `|x|. +Proof. +have [-> | n_gt0] := posnP n; first by rewrite !root0C normr0. +apply/eqP; rewrite -(eqr_expn2 n_gt0) ?rootC_ge0 ?normr_ge0 //. +by rewrite -normrX !rootCK. +Qed. + +Lemma rootCX n x k : (n > 0)%N -> 0 <= x -> n.-root (x ^+ k) = n.-root x ^+ k. +Proof. +move=> n_gt0 x_ge0; apply/eqP. +by rewrite -(eqr_expn2 n_gt0) ?(exprn_ge0, rootC_ge0) // 1?exprAC !rootCK. +Qed. + +Lemma rootC1 n : (n > 0)%N -> n.-root 1 = 1. +Proof. by move/(rootCX 0)/(_ ler01). Qed. + +Lemma rootCpX n x k : (k > 0)%N -> 0 <= x -> n.-root (x ^+ k) = n.-root x ^+ k. +Proof. +by case: n => [|n] k_gt0; [rewrite !root0C expr0n gtn_eqF | apply: rootCX]. +Qed. + +Lemma rootCV n x : (n > 0)%N -> 0 <= x -> n.-root x^-1 = (n.-root x)^-1. +Proof. +move=> n_gt0 x_ge0; apply/eqP. +by rewrite -(eqr_expn2 n_gt0) ?(invr_ge0, rootC_ge0) // !exprVn !rootCK. +Qed. + +Lemma rootC_eq1 n x : (n > 0)%N -> (n.-root x == 1) = (x == 1). +Proof. by move=> n_gt0; rewrite -{1}(rootC1 n_gt0) eqr_rootC. Qed. + +Lemma rootC_ge1 n x : (n > 0)%N -> (n.-root x >= 1) = (x >= 1). +Proof. +by move=> n_gt0; rewrite -{1}(rootC1 n_gt0) ler_rootCl // qualifE ler01. +Qed. + +Lemma rootC_gt1 n x : (n > 0)%N -> (n.-root x > 1) = (x > 1). +Proof. by move=> n_gt0; rewrite !ltr_def rootC_eq1 ?rootC_ge1. Qed. + +Lemma rootC_le1 n x : (n > 0)%N -> 0 <= x -> (n.-root x <= 1) = (x <= 1). +Proof. by move=> n_gt0 x_ge0; rewrite -{1}(rootC1 n_gt0) ler_rootCl. Qed. + +Lemma rootC_lt1 n x : (n > 0)%N -> 0 <= x -> (n.-root x < 1) = (x < 1). +Proof. by move=> n_gt0 x_ge0; rewrite !ltr_neqAle rootC_eq1 ?rootC_le1. Qed. + +Lemma rootCMl n x z : 0 <= x -> n.-root (x * z) = n.-root x * n.-root z. +Proof. +rewrite le0r => /predU1P[-> | x_gt0]; first by rewrite !(mul0r, rootC0). +have [| n_gt1 | ->] := ltngtP n 1; last by rewrite !root1C. + by case: n => //; rewrite !root0C mul0r. +have [x_ge0 n_gt0] := (ltrW x_gt0, ltnW n_gt1). +have nx_gt0: 0 < n.-root x by rewrite rootC_gt0. +have Rnx: n.-root x \is real by rewrite ger0_real ?ltrW. +apply: eqC_semipolar; last 1 first; try apply/eqP. +- by rewrite ImMl // !(Im_rootC_ge0, mulr_ge0, rootC_ge0). +- by rewrite -(eqr_expn2 n_gt0) ?normr_ge0 // -!normrX exprMn !rootCK. +rewrite eqr_le; apply/andP; split; last first. + rewrite rootC_Re_max ?exprMn ?rootCK ?ImMl //. + by rewrite mulr_ge0 ?Im_rootC_ge0 ?ltrW. +rewrite -[n.-root _](mulVKf (negbT (gtr_eqF nx_gt0))) !(ReMl Rnx) //. +rewrite ler_pmul2l // rootC_Re_max ?exprMn ?exprVn ?rootCK ?mulKf ?gtr_eqF //. +by rewrite ImMl ?rpredV // mulr_ge0 ?invr_ge0 ?Im_rootC_ge0 ?ltrW. +Qed. + +Lemma rootCMr n x z : 0 <= x -> n.-root (z * x) = n.-root z * n.-root x. +Proof. by move=> x_ge0; rewrite mulrC rootCMl // mulrC. Qed. + +Lemma imaginaryCE : 'i = sqrtC (-1). +Proof. +have : sqrtC (-1) ^+ 2 - 'i ^+ 2 == 0 by rewrite sqrCi rootCK // subrr. +rewrite subr_sqr mulf_eq0 subr_eq0 addr_eq0; have [//|_/= /eqP sCN1E] := eqP. +by have := @Im_rootC_ge0 2 (-1) isT; rewrite sCN1E raddfN /= Im_i ler0N1. +Qed. + +(* More properties of n.-root will be established in cyclotomic.v. *) + +(* The proper form of the Arithmetic - Geometric Mean inequality. *) + +Lemma lerif_rootC_AGM (I : finType) (A : pred I) (n := #|A|) E : + {in A, forall i, 0 <= E i} -> + n.-root (\prod_(i in A) E i) <= (\sum_(i in A) E i) / n%:R + ?= iff [forall i in A, forall j in A, E i == E j]. +Proof. +move=> Ege0; have [n0 | n_gt0] := posnP n. + rewrite n0 root0C invr0 mulr0; apply/lerif_refl/forall_inP=> i. + by rewrite (card0_eq n0). +rewrite -(mono_in_lerif (ler_pexpn2r n_gt0)) ?rootCK //=; first 1 last. +- by rewrite qualifE rootC_ge0 // prodr_ge0. +- by rewrite rpred_div ?rpred_nat ?rpred_sum. +exact: lerif_AGM. +Qed. + +(* Square root. *) + +Lemma sqrtC0 : sqrtC 0 = 0. Proof. exact: rootC0. Qed. +Lemma sqrtC1 : sqrtC 1 = 1. Proof. exact: rootC1. Qed. +Lemma sqrtCK x : sqrtC x ^+ 2 = x. Proof. exact: rootCK. Qed. +Lemma sqrCK x : 0 <= x -> sqrtC (x ^+ 2) = x. Proof. exact: exprCK. Qed. + +Lemma sqrtC_ge0 x : (0 <= sqrtC x) = (0 <= x). Proof. exact: rootC_ge0. Qed. +Lemma sqrtC_eq0 x : (sqrtC x == 0) = (x == 0). Proof. exact: rootC_eq0. Qed. +Lemma sqrtC_gt0 x : (sqrtC x > 0) = (x > 0). Proof. exact: rootC_gt0. Qed. +Lemma sqrtC_lt0 x : (sqrtC x < 0) = false. Proof. exact: rootC_lt0. Qed. +Lemma sqrtC_le0 x : (sqrtC x <= 0) = (x == 0). Proof. exact: rootC_le0. Qed. + +Lemma ler_sqrtC : {in Num.nneg &, {mono sqrtC : x y / x <= y}}. +Proof. exact: ler_rootC. Qed. +Lemma ltr_sqrtC : {in Num.nneg &, {mono sqrtC : x y / x < y}}. +Proof. exact: ltr_rootC. Qed. +Lemma eqr_sqrtC : {mono sqrtC : x y / x == y}. +Proof. exact: eqr_rootC. Qed. +Lemma sqrtC_inj : injective sqrtC. +Proof. exact: rootC_inj. Qed. +Lemma sqrtCM : {in Num.nneg &, {morph sqrtC : x y / x * y}}. +Proof. by move=> x y _; apply: rootCMr. Qed. + +Lemma sqrCK_P x : reflect (sqrtC (x ^+ 2) = x) ((0 <= 'Im x) && ~~ (x < 0)). +Proof. +apply: (iffP andP) => [[leI0x not_gt0x] | <-]; last first. + by rewrite sqrtC_lt0 Im_rootC_ge0. +have /eqP := sqrtCK (x ^+ 2); rewrite eqf_sqr => /pred2P[] // defNx. +apply: sqrCK; rewrite -real_lerNgt ?rpred0 // in not_gt0x; +apply/Creal_ImP/ler_anti; +by rewrite leI0x -oppr_ge0 -raddfN -defNx Im_rootC_ge0. +Qed. + +Lemma normC_def x : `|x| = sqrtC (x * x^*). +Proof. by rewrite -normCK sqrCK ?normr_ge0. Qed. + +Lemma norm_conjC x : `|x^*| = `|x|. +Proof. by rewrite !normC_def conjCK mulrC. Qed. + +Lemma normC_rect : + {in real &, forall x y, `|x + 'i * y| = sqrtC (x ^+ 2 + y ^+ 2)}. +Proof. by move=> x y Rx Ry; rewrite /= normC_def -normCK normC2_rect. Qed. + +Lemma normC_Re_Im z : `|z| = sqrtC ('Re z ^+ 2 + 'Im z ^+ 2). +Proof. by rewrite normC_def -normCK normC2_Re_Im. Qed. + +(* Norm sum (in)equalities. *) + +Lemma normC_add_eq x y : + `|x + y| = `|x| + `|y| -> + {t : C | `|t| == 1 & (x, y) = (`|x| * t, `|y| * t)}. +Proof. +move=> lin_xy; apply: sig2_eqW; pose u z := if z == 0 then 1 else z / `|z|. +have uE z: (`|u z| = 1) * (`|z| * u z = z). + rewrite /u; have [->|nz_z] := altP eqP; first by rewrite normr0 normr1 mul0r. + by rewrite normf_div normr_id mulrCA divff ?mulr1 ?normr_eq0. +have [->|nz_x] := eqVneq x 0; first by exists (u y); rewrite uE ?normr0 ?mul0r. +exists (u x); rewrite uE // /u (negPf nz_x); congr (_ , _). +have{lin_xy} def2xy: `|x| * `|y| *+ 2 = x * y ^* + y * x ^*. + apply/(addrI (x * x^*))/(addIr (y * y^*)); rewrite -2!{1}normCK -sqrrD. + by rewrite addrA -addrA -!mulrDr -mulrDl -rmorphD -normCK lin_xy. +have def_xy: x * y^* = y * x^*. + apply/eqP; rewrite -subr_eq0 -[_ == 0](@expf_eq0 _ _ 2). + rewrite (canRL (subrK _) (subr_sqrDB _ _)) opprK -def2xy exprMn_n exprMn. + by rewrite mulrN mulrAC mulrA -mulrA mulrACA -!normCK mulNrn addNr. +have{def_xy def2xy} def_yx: `|y * x| = y * x^*. + by apply: (mulIf nz2); rewrite !mulr_natr mulrC normrM def2xy def_xy. +rewrite -{1}(divfK nz_x y) invC_norm mulrCA -{}def_yx !normrM invfM. +by rewrite mulrCA divfK ?normr_eq0 // mulrAC mulrA. +Qed. + +Lemma normC_sum_eq (I : finType) (P : pred I) (F : I -> C) : + `|\sum_(i | P i) F i| = \sum_(i | P i) `|F i| -> + {t : C | `|t| == 1 & forall i, P i -> F i = `|F i| * t}. +Proof. +have [i /andP[Pi nzFi] | F0] := pickP [pred i | P i & F i != 0]; last first. + exists 1 => [|i Pi]; first by rewrite normr1. + by case/nandP: (F0 i) => [/negP[]// | /negbNE/eqP->]; rewrite normr0 mul0r. +rewrite !(bigD1 i Pi) /= => norm_sumF; pose Q j := P j && (j != i). +rewrite -normr_eq0 in nzFi; set c := F i / `|F i|; exists c => [|j Pj]. + by rewrite normrM normfV normr_id divff. +have [Qj | /nandP[/negP[]// | /negbNE/eqP->]] := boolP (Q j); last first. + by rewrite mulrC divfK. +have: `|F i + F j| = `|F i| + `|F j|. + do [rewrite !(bigD1 j Qj) /=; set z := \sum_(k | _) `|_|] in norm_sumF. + apply/eqP; rewrite eqr_le ler_norm_add -(ler_add2r z) -addrA -norm_sumF addrA. + by rewrite (ler_trans (ler_norm_add _ _)) // ler_add2l ler_norm_sum. +by case/normC_add_eq=> k _ [/(canLR (mulKf nzFi)) <-]; rewrite -(mulrC (F i)). +Qed. + +Lemma normC_sum_eq1 (I : finType) (P : pred I) (F : I -> C) : + `|\sum_(i | P i) F i| = (\sum_(i | P i) `|F i|) -> + (forall i, P i -> `|F i| = 1) -> + {t : C | `|t| == 1 & forall i, P i -> F i = t}. +Proof. +case/normC_sum_eq=> t t1 defF normF. +by exists t => // i Pi; rewrite defF // normF // mul1r. +Qed. + +Lemma normC_sum_upper (I : finType) (P : pred I) (F G : I -> C) : + (forall i, P i -> `|F i| <= G i) -> + \sum_(i | P i) F i = \sum_(i | P i) G i -> + forall i, P i -> F i = G i. +Proof. +set sumF := \sum_(i | _) _; set sumG := \sum_(i | _) _ => leFG eq_sumFG. +have posG i: P i -> 0 <= G i by move/leFG; apply: ler_trans; apply: normr_ge0. +have norm_sumG: `|sumG| = sumG by rewrite ger0_norm ?sumr_ge0. +have norm_sumF: `|sumF| = \sum_(i | P i) `|F i|. + apply/eqP; rewrite eqr_le ler_norm_sum eq_sumFG norm_sumG -subr_ge0 -sumrB. + by rewrite sumr_ge0 // => i Pi; rewrite subr_ge0 ?leFG. +have [t _ defF] := normC_sum_eq norm_sumF. +have [/(psumr_eq0P posG) G0 i Pi | nz_sumG] := eqVneq sumG 0. + by apply/eqP; rewrite G0 // -normr_eq0 eqr_le normr_ge0 -(G0 i Pi) leFG. +have t1: t = 1. + apply: (mulfI nz_sumG); rewrite mulr1 -{1}norm_sumG -eq_sumFG norm_sumF. + by rewrite mulr_suml -(eq_bigr _ defF). +have /psumr_eq0P eqFG i: P i -> 0 <= G i - F i. + by move=> Pi; rewrite subr_ge0 defF // t1 mulr1 leFG. +move=> i /eqFG/(canRL (subrK _))->; rewrite ?add0r //. +by rewrite sumrB -/sumF eq_sumFG subrr. +Qed. + +Lemma normC_sub_eq x y : + `|x - y| = `|x| - `|y| -> {t | `|t| == 1 & (x, y) = (`|x| * t, `|y| * t)}. +Proof. +rewrite -{-1}(subrK y x) => /(canLR (subrK _))/esym-Dx; rewrite Dx. +by have [t ? [Dxy Dy]] := normC_add_eq Dx; exists t; rewrite // mulrDl -Dxy -Dy. +Qed. + +End ClosedFieldTheory. + +Notation "n .-root" := (@nthroot _ n) (at level 2, format "n .-root") : ring_scope. +Notation sqrtC := 2.-root. +Notation "'i" := (@imaginaryC _) (at level 0) : ring_scope. +Notation "'Re z" := (Re z) (at level 10, z at level 8) : ring_scope. +Notation "'Im z" := (Im z) (at level 10, z at level 8) : ring_scope. + End Theory. Module RealMixin. @@ -4225,3 +4936,4 @@ Export Num.Syntax Num.PredInstances. Notation RealLeMixin := Num.RealMixin.Le. Notation RealLtMixin := Num.RealMixin.Lt. Notation RealLeAxiom R := (Num.RealMixin.Real (Phant R) (erefl _)). +Notation ImaginaryMixin := Num.ClosedField.ImaginaryMixin. diff --git a/mathcomp/character/all_character.v b/mathcomp/character/all_character.v index 936fa6c..03f1b57 100644 --- a/mathcomp/character/all_character.v +++ b/mathcomp/character/all_character.v @@ -1,7 +1,7 @@ -Require Export character. -Require Export classfun. -Require Export inertia. -Require Export integral_char. -Require Export mxabelem. -Require Export mxrepresentation. -Require Export vcharacter. +From mathcomp Require Export character. +From mathcomp Require Export classfun. +From mathcomp Require Export inertia. +From mathcomp Require Export integral_char. +From mathcomp Require Export mxabelem. +From mathcomp Require Export mxrepresentation. +From mathcomp Require Export vcharacter. diff --git a/mathcomp/character/classfun.v b/mathcomp/character/classfun.v index 4c27bd7..7473338 100644 --- a/mathcomp/character/classfun.v +++ b/mathcomp/character/classfun.v @@ -969,7 +969,8 @@ Lemma cfCauchySchwarz_sqrt phi psi : `|'[phi, psi]| <= sqrtC '[phi] * sqrtC '[psi] ?= iff ~~ free (phi :: psi). Proof. rewrite -(sqrCK (normr_ge0 _)) -sqrtCM ?qualifE ?cfnorm_ge0 //. -rewrite (mono_in_lerif ler_sqrtC) 1?rpredM ?qualifE ?normr_ge0 ?cfnorm_ge0 //. +rewrite (mono_in_lerif (@ler_sqrtC _)) 1?rpredM ?qualifE; +rewrite ?normr_ge0 ?cfnorm_ge0 //. exact: cfCauchySchwarz. Qed. diff --git a/mathcomp/field/algC.v b/mathcomp/field/algC.v index b465542..6c53127 100644 --- a/mathcomp/field/algC.v +++ b/mathcomp/field/algC.v @@ -17,6 +17,14 @@ Require Import algebraics_fundamentals. (* algebraic contents of the Fundamenta Theorem of Algebra. *) (* algC == the closed, countable field of algebraic numbers. *) (* algCeq, algCring, ..., algCnumField == structures for algC. *) +(* The ssrnum interfaces are implemented for algC as follows: *) +(* x <= y <=> (y - x) is a nonnegative real *) +(* x < y <=> (y - x) is a (strictly) positive real *) +(* `|z| == the complex norm of z, i.e., sqrtC (z * z^* ). *) +(* Creal == the subset of real numbers (:= Num.real for algC). *) +(* 'i == the imaginary number (:= sqrtC (-1)). *) +(* 'Re z == the real component of z. *) +(* 'Im z == the imaginary component of z. *) (* z^* == the complex conjugate of z (:= conjC z). *) (* sqrtC z == a nonnegative square root of z, i.e., 0 <= sqrt x if 0 <= x. *) (* n.-root z == more generally, for n > 0, an nth root of z, chosen with a *) @@ -25,15 +33,7 @@ Require Import algebraics_fundamentals. (* Note that n.-root (-1) is a primitive 2nth root of unity, *) (* an thus not equal to -1 for n odd > 1 (this will be shown in *) (* file cyclotomic.v). *) -(* The ssrnum interfaces are implemented for algC as follows: *) -(* x <= y <=> (y - x) is a nonnegative real *) -(* x < y <=> (y - x) is a (strictly) positive real *) -(* `|z| == the complex norm of z, i.e., sqrtC (z * z^* ). *) -(* Creal == the subset of real numbers (:= Num.real for algC). *) (* In addition, we provide: *) -(* 'i == the imaginary number (:= sqrtC (-1)). *) -(* 'Re z == the real component of z. *) -(* 'Im z == the imaginary component of z. *) (* Crat == the subset of rational numbers. *) (* Cint == the subset of integers. *) (* Cnat == the subset of natural integers. *) @@ -237,9 +237,8 @@ Parameter numMixin : Num.mixin_of ringType. Canonical numDomainType := NumDomainType type numMixin. Canonical numFieldType := [numFieldType of type]. -Parameter conj : {rmorphism type -> type}. -Axiom conjK : involutive conj. -Axiom normK : forall x, `|x| ^+ 2 = x * conj x. +Parameter conjMixin : Num.ClosedField.imaginary_mixin_of numDomainType. +Canonical numClosedFieldType := NumClosedFieldType type conjMixin. Axiom algebraic : integralRange (@ratr unitRingType). @@ -446,6 +445,11 @@ rewrite -(fmorph_root CtoL_rmorphism) -map_poly_comp; congr (root _ _): pu0. by apply/esym/eq_map_poly; apply: fmorph_eq_rat. Qed. +Program Definition conjMixin := + ImaginaryMixin (svalP (imaginary_exists closedFieldType)) + (fun x => esym (normK x)). +Canonical numClosedFieldType := NumClosedFieldType type conjMixin. + End Implementation. Definition divisor := Implementation.type. @@ -464,47 +468,7 @@ Local Notation ZtoC := (intr : int -> algC). Local Notation Creal := (Num.real : qualifier 0 algC). Fact algCi_subproof : {i : algC | i ^+ 2 = -1}. -Proof. exact: imaginary_exists. Qed. - -Let Re2 z := z + z^*. -Definition nnegIm z := 0 <= sval algCi_subproof * (z^* - z). -Definition argCle y z := nnegIm z ==> nnegIm y && (Re2 z <= Re2 y). - -CoInductive rootC_spec n (x : algC) : Type := - RootCspec (y : algC) of if (n > 0)%N then y ^+ n = x else y = 0 - & forall z, (n > 0)%N -> z ^+ n = x -> argCle y z. - -Fact rootC_subproof n x : rootC_spec n x. -Proof. -have realRe2 u : Re2 u \is Creal. - rewrite realEsqr expr2 {2}/Re2 -{2}[u]conjK addrC -rmorphD -normK. - by rewrite exprn_ge0 ?normr_ge0. -have argCtotal : total argCle. - move=> u v; rewrite /total /argCle. - by do 2!case: (nnegIm _) => //; rewrite ?orbT //= real_leVge. -have argCtrans : transitive argCle. - move=> u v w /implyP geZuv /implyP geZvw; apply/implyP. - by case/geZvw/andP=> /geZuv/andP[-> geRuv] /ler_trans->. -pose p := 'X^n - (x *+ (n > 0))%:P; have [r0 Dp] := closed_field_poly_normal p. -have sz_p: size p = n.+1. - rewrite size_addl ?size_polyXn // ltnS size_opp size_polyC mulrn_eq0. - by case: posnP => //; case: negP. -pose r := sort argCle r0; have r_arg: sorted argCle r by apply: sort_sorted. -have{Dp} Dp: p = \prod_(z <- r) ('X - z%:P). - rewrite Dp lead_coefE sz_p coefB coefXn coefC -mulrb -mulrnA mulnb lt0n andNb. - rewrite subr0 eqxx scale1r; apply: eq_big_perm. - by rewrite perm_eq_sym perm_sort. -have mem_rP z: (n > 0)%N -> reflect (z ^+ n = x) (z \in r). - move=> n_gt0; rewrite -root_prod_XsubC -Dp rootE !hornerE hornerXn n_gt0. - by rewrite subr_eq0; apply: eqP. -exists r`_0 => [|z n_gt0 /(mem_rP z n_gt0) r_z]. - have sz_r: size r = n by apply: succn_inj; rewrite -sz_p Dp size_prod_XsubC. - case: posnP => [n0 | n_gt0]; first by rewrite nth_default // sz_r n0. - by apply/mem_rP=> //; rewrite mem_nth ?sz_r. -case: {Dp mem_rP}r r_z r_arg => // y r1; rewrite inE => /predU1P[-> _|r1z]. - by apply/implyP=> ->; rewrite lerr. -by move/(order_path_min argCtrans)/allP->. -Qed. +Proof. exact: GRing.imaginary_exists. Qed. CoInductive getCrat_spec : Type := GetCrat_spec CtoQ of cancel QtoC CtoQ. @@ -559,13 +523,10 @@ Module Import Exports. Import Implementation Internals. Notation algC := type. -Notation conjC := conj. Delimit Scope C_scope with C. Delimit Scope C_core_scope with Cc. Delimit Scope C_expanded_scope with Cx. Open Scope C_core_scope. -Notation "x ^*" := (conjC x) (at level 2, format "x ^*") : C_core_scope. -Notation "x ^*" := x^* (only parsing) : C_scope. Canonical eqType. Canonical choiceType. @@ -583,6 +544,7 @@ Canonical fieldType. Canonical numFieldType. Canonical decFieldType. Canonical closedFieldType. +Canonical numClosedFieldType. Notation algCeq := eqType. Notation algCzmod := zmodType. @@ -591,22 +553,7 @@ Notation algCuring := unitRingType. Notation algCnum := numDomainType. Notation algCfield := fieldType. Notation algCnumField := numFieldType. - -Definition rootC n x := let: RootCspec y _ _ := rootC_subproof n x in y. -Notation "n .-root" := (rootC n) (at level 2, format "n .-root") : C_core_scope. -Notation "n .-root" := (rootC n) (only parsing) : C_scope. -Notation sqrtC := 2.-root. - -Definition algCi := sqrtC (-1). -Notation "'i" := algCi (at level 0) : C_core_scope. -Notation "'i" := 'i (only parsing) : C_scope. - -Definition algRe x := (x + x^*) / 2%:R. -Definition algIm x := 'i * (x^* - x) / 2%:R. -Notation "'Re z" := (algRe z) (at level 10, z at level 8) : C_core_scope. -Notation "'Im z" := (algIm z) (at level 10, z at level 8) : C_core_scope. -Notation "'Re z" := ('Re z) (only parsing) : C_scope. -Notation "'Im z" := ('Im z) (only parsing) : C_scope. +Notation algCnumClosedField := numClosedFieldType. Notation Creal := (@Num.Def.Rreal numDomainType). @@ -692,596 +639,27 @@ Let nz2 : 2%:R != 0 :> algC. Proof. by rewrite -!CintrE. Qed. (* Conjugation and norm. *) -Definition conjCK : involutive conjC := Algebraics.Implementation.conjK. -Definition normCK x : `|x| ^+ 2 = x * x^* := Algebraics.Implementation.normK x. Definition algC_algebraic x := Algebraics.Implementation.algebraic x. -Lemma normCKC x : `|x| ^+ 2 = x^* * x. Proof. by rewrite normCK mulrC. Qed. - -Lemma mul_conjC_ge0 x : 0 <= x * x^*. -Proof. by rewrite -normCK exprn_ge0 ?normr_ge0. Qed. - -Lemma mul_conjC_gt0 x : (0 < x * x^*) = (x != 0). -Proof. -have [->|x_neq0] := altP eqP; first by rewrite rmorph0 mulr0. -by rewrite -normCK exprn_gt0 ?normr_gt0. -Qed. - -Lemma mul_conjC_eq0 x : (x * x^* == 0) = (x == 0). -Proof. by rewrite -normCK expf_eq0 normr_eq0. Qed. - -Lemma conjC_ge0 x : (0 <= x^*) = (0 <= x). -Proof. -wlog suffices: x / 0 <= x -> 0 <= x^*. - by move=> IH; apply/idP/idP=> /IH; rewrite ?conjCK. -rewrite le0r => /predU1P[-> | x_gt0]; first by rewrite rmorph0. -by rewrite -(pmulr_rge0 _ x_gt0) mul_conjC_ge0. -Qed. - -Lemma conjC_nat n : (n%:R)^* = n%:R. Proof. exact: rmorph_nat. Qed. -Lemma conjC0 : 0^* = 0. Proof. exact: rmorph0. Qed. -Lemma conjC1 : 1^* = 1. Proof. exact: rmorph1. Qed. -Lemma conjC_eq0 x : (x^* == 0) = (x == 0). Proof. exact: fmorph_eq0. Qed. - -Lemma invC_norm x : x^-1 = `|x| ^- 2 * x^*. -Proof. -have [-> | nx_x] := eqVneq x 0; first by rewrite conjC0 mulr0 invr0. -by rewrite normCK invfM divfK ?conjC_eq0. -Qed. - (* Real number subset. *) Lemma Creal0 : 0 \is Creal. Proof. exact: rpred0. Qed. Lemma Creal1 : 1 \is Creal. Proof. exact: rpred1. Qed. Hint Resolve Creal0 Creal1. (* Trivial cannot resolve a general real0 hint. *) -Lemma CrealE x : (x \is Creal) = (x^* == x). -Proof. -rewrite realEsqr ger0_def normrX normCK. -by have [-> | /mulfI/inj_eq-> //] := eqVneq x 0; rewrite rmorph0 !eqxx. -Qed. - -Lemma CrealP {x} : reflect (x^* = x) (x \is Creal). -Proof. by rewrite CrealE; apply: eqP. Qed. - -Lemma conj_Creal x : x \is Creal -> x^* = x. -Proof. by move/CrealP. Qed. - -Lemma conj_normC z : `|z|^* = `|z|. -Proof. by rewrite conj_Creal ?normr_real. Qed. - -Lemma geC0_conj x : 0 <= x -> x^* = x. -Proof. by move=> /ger0_real/CrealP. Qed. - -Lemma geC0_unit_exp x n : 0 <= x -> (x ^+ n.+1 == 1) = (x == 1). -Proof. by move=> x_ge0; rewrite pexpr_eq1. Qed. - -(* Elementary properties of roots. *) - -Ltac case_rootC := rewrite /rootC; case: (rootC_subproof _ _). - -Lemma root0C x : 0.-root x = 0. Proof. by case_rootC. Qed. - -Lemma rootCK n : (n > 0)%N -> cancel n.-root (fun x => x ^+ n). -Proof. by case: n => //= n _ x; case_rootC. Qed. - -Lemma root1C x : 1.-root x = x. Proof. exact: (@rootCK 1). Qed. - -Lemma rootC0 n : n.-root 0 = 0. -Proof. -have [-> | n_gt0] := posnP n; first by rewrite root0C. -by have /eqP := rootCK n_gt0 0; rewrite expf_eq0 n_gt0 /= => /eqP. -Qed. - -Lemma rootC_inj n : (n > 0)%N -> injective n.-root. -Proof. by move/rootCK/can_inj. Qed. - -Lemma eqr_rootC n : (n > 0)%N -> {mono n.-root : x y / x == y}. -Proof. by move/rootC_inj/inj_eq. Qed. - -Lemma rootC_eq0 n x : (n > 0)%N -> (n.-root x == 0) = (x == 0). -Proof. by move=> n_gt0; rewrite -{1}(rootC0 n) eqr_rootC. Qed. - -(* Rectangular coordinates. *) - -Lemma sqrCi : 'i ^+ 2 = -1. Proof. exact: rootCK. Qed. - -Lemma nonRealCi : 'i \isn't Creal. -Proof. by rewrite realEsqr sqrCi oppr_ge0 ltr_geF ?ltr01. Qed. - -Lemma neq0Ci : 'i != 0. -Proof. by apply: contraNneq nonRealCi => ->; apply: real0. Qed. - -Lemma normCi : `|'i| = 1. -Proof. -apply/eqP; rewrite -(@pexpr_eq1 _ _ 2) ?normr_ge0 //. -by rewrite -normrX sqrCi normrN1. -Qed. - -Lemma invCi : 'i^-1 = - 'i. -Proof. by rewrite -div1r -[1]opprK -sqrCi mulNr mulfK ?neq0Ci. Qed. - -Lemma conjCi : 'i^* = - 'i. -Proof. by rewrite -invCi invC_norm normCi expr1n invr1 mul1r. Qed. - Lemma algCrect x : x = 'Re x + 'i * 'Im x. -Proof. -rewrite 2!mulrA -expr2 sqrCi mulN1r opprB -mulrDl addrACA subrr addr0. -by rewrite -mulr2n -mulr_natr mulfK. -Qed. - -Lemma Creal_Re x : 'Re x \is Creal. -Proof. by rewrite CrealE fmorph_div rmorph_nat rmorphD conjCK addrC. Qed. - -Lemma Creal_Im x : 'Im x \is Creal. -Proof. -rewrite CrealE fmorph_div rmorph_nat rmorphM rmorphB conjCK. -by rewrite conjCi -opprB mulrNN. -Qed. -Hint Resolve Creal_Re Creal_Im. - -Fact algRe_is_additive : additive algRe. -Proof. by move=> x y; rewrite /algRe rmorphB addrACA -opprD mulrBl. Qed. -Canonical algRe_additive := Additive algRe_is_additive. - -Fact algIm_is_additive : additive algIm. -Proof. -by move=> x y; rewrite /algIm rmorphB opprD addrACA -opprD mulrBr mulrBl. -Qed. -Canonical algIm_additive := Additive algIm_is_additive. - -Lemma Creal_ImP z : reflect ('Im z = 0) (z \is Creal). -Proof. -rewrite CrealE -subr_eq0 -(can_eq (mulKf neq0Ci)) mulr0. -by rewrite -(can_eq (divfK nz2)) mul0r; apply: eqP. -Qed. - -Lemma Creal_ReP z : reflect ('Re z = z) (z \in Creal). -Proof. -rewrite (sameP (Creal_ImP z) eqP) -(can_eq (mulKf neq0Ci)) mulr0. -by rewrite -(inj_eq (addrI ('Re z))) addr0 -algCrect eq_sym; apply: eqP. -Qed. - -Lemma algReMl : {in Creal, forall x, {morph algRe : z / x * z}}. -Proof. -by move=> x Rx z /=; rewrite /algRe rmorphM (conj_Creal Rx) -mulrDr -mulrA. -Qed. - -Lemma algReMr : {in Creal, forall x, {morph algRe : z / z * x}}. -Proof. by move=> x Rx z /=; rewrite mulrC algReMl // mulrC. Qed. - -Lemma algImMl : {in Creal, forall x, {morph algIm : z / x * z}}. -Proof. -by move=> x Rx z; rewrite /algIm rmorphM (conj_Creal Rx) -mulrBr mulrCA !mulrA. -Qed. - -Lemma algImMr : {in Creal, forall x, {morph algIm : z / z * x}}. -Proof. by move=> x Rx z /=; rewrite mulrC algImMl // mulrC. Qed. - -Lemma algRe_i : 'Re 'i = 0. Proof. by rewrite /algRe conjCi subrr mul0r. Qed. - -Lemma algIm_i : 'Im 'i = 1. -Proof. -rewrite /algIm conjCi -opprD mulrN -mulr2n mulrnAr ['i * _]sqrCi. -by rewrite mulNrn opprK divff. -Qed. - -Lemma algRe_conj z : 'Re z^* = 'Re z. -Proof. by rewrite /algRe addrC conjCK. Qed. - -Lemma algIm_conj z : 'Im z^* = - 'Im z. -Proof. by rewrite /algIm -mulNr -mulrN opprB conjCK. Qed. - -Lemma algRe_rect : {in Creal &, forall x y, 'Re (x + 'i * y) = x}. -Proof. -move=> x y Rx Ry; rewrite /= raddfD /= (Creal_ReP x Rx). -by rewrite algReMr // algRe_i mul0r addr0. -Qed. - -Lemma algIm_rect : {in Creal &, forall x y, 'Im (x + 'i * y) = y}. -Proof. -move=> x y Rx Ry; rewrite /= raddfD /= (Creal_ImP x Rx) add0r. -by rewrite algImMr // algIm_i mul1r. -Qed. - -Lemma conjC_rect : {in Creal &, forall x y, (x + 'i * y)^* = x - 'i * y}. -Proof. -by move=> x y Rx Ry; rewrite /= rmorphD rmorphM conjCi mulNr !conj_Creal. -Qed. +Proof. by rewrite [LHS]Crect. Qed. -Lemma addC_rect x1 y1 x2 y2 : - (x1 + 'i * y1) + (x2 + 'i * y2) = x1 + x2 + 'i * (y1 + y2). -Proof. by rewrite addrACA -mulrDr. Qed. +Lemma algCreal_Re x : 'Re x \is Creal. +Proof. by rewrite Creal_Re. Qed. -Lemma oppC_rect x y : - (x + 'i * y) = - x + 'i * (- y). -Proof. by rewrite mulrN -opprD. Qed. - -Lemma subC_rect x1 y1 x2 y2 : - (x1 + 'i * y1) - (x2 + 'i * y2) = x1 - x2 + 'i * (y1 - y2). -Proof. by rewrite oppC_rect addC_rect. Qed. - -Lemma mulC_rect x1 y1 x2 y2 : - (x1 + 'i * y1) * (x2 + 'i * y2) - = x1 * x2 - y1 * y2 + 'i * (x1 * y2 + x2 * y1). -Proof. -rewrite mulrDl !mulrDr mulrCA -!addrA mulrAC -mulrA; congr (_ + _). -by rewrite mulrACA -expr2 sqrCi mulN1r addrA addrC. -Qed. - -Lemma normC2_rect : - {in Creal &, forall x y, `|x + 'i * y| ^+ 2 = x ^+ 2 + y ^+ 2}. -Proof. -move=> x y Rx Ry; rewrite /= normCK rmorphD rmorphM conjCi !conj_Creal //. -by rewrite mulrC mulNr -subr_sqr exprMn sqrCi mulN1r opprK. -Qed. - -Lemma normC2_Re_Im z : `|z| ^+ 2 = 'Re z ^+ 2 + 'Im z ^+ 2. -Proof. by rewrite -normC2_rect -?algCrect. Qed. - -Lemma invC_rect : - {in Creal &, forall x y, (x + 'i * y)^-1 = (x - 'i * y) / (x ^+ 2 + y ^+ 2)}. -Proof. -by move=> x y Rx Ry; rewrite /= invC_norm conjC_rect // mulrC normC2_rect. -Qed. - -Lemma lerif_normC_Re_Creal z : `|'Re z| <= `|z| ?= iff (z \is Creal). -Proof. -rewrite -(mono_in_lerif ler_sqr); try by rewrite qualifE normr_ge0. -rewrite normCK conj_Creal // normC2_Re_Im -expr2. -rewrite addrC -lerif_subLR subrr (sameP (Creal_ImP _) eqP) -sqrf_eq0 eq_sym. -by apply: lerif_eq; rewrite -realEsqr. -Qed. - -Lemma lerif_Re_Creal z : 'Re z <= `|z| ?= iff (0 <= z). -Proof. -have ubRe: 'Re z <= `|'Re z| ?= iff (0 <= 'Re z). - by rewrite ger0_def eq_sym; apply/lerif_eq/real_ler_norm. -congr (_ <= _ ?= iff _): (lerif_trans ubRe (lerif_normC_Re_Creal z)). -apply/andP/idP=> [[zRge0 /Creal_ReP <- //] | z_ge0]. -by have Rz := ger0_real z_ge0; rewrite (Creal_ReP _ _). -Qed. - -(* Equality from polar coordinates, for the upper plane. *) -Lemma eqC_semipolar x y : - `|x| = `|y| -> 'Re x = 'Re y -> 0 <= 'Im x * 'Im y -> x = y. -Proof. -move=> eq_norm eq_Re sign_Im. -rewrite [x]algCrect [y]algCrect eq_Re; congr (_ + 'i * _). -have /eqP := congr1 (fun z => z ^+ 2) eq_norm. -rewrite !normC2_Re_Im eq_Re (can_eq (addKr _)) eqf_sqr => /pred2P[] // eq_Im. -rewrite eq_Im mulNr -expr2 oppr_ge0 real_exprn_even_le0 //= in sign_Im. -by rewrite eq_Im (eqP sign_Im) oppr0. -Qed. - -(* Nth roots. *) - -Let argCleP y z : - reflect (0 <= 'Im z -> 0 <= 'Im y /\ 'Re z <= 'Re y) (argCle y z). -Proof. -suffices dIm x: nnegIm x = (0 <= 'Im x). - rewrite /argCle !dIm ler_pmul2r ?invr_gt0 ?ltr0n //. - by apply: (iffP implyP) => geZyz /geZyz/andP. -rewrite /('Im x) pmulr_lge0 ?invr_gt0 ?ltr0n //; congr (0 <= _ * _). -case Du: algCi_subproof => [u u2N1] /=. -have/eqP := u2N1; rewrite -sqrCi eqf_sqr => /pred2P[] //. -have:= conjCi; rewrite /'i; case_rootC => /= v v2n1 min_v conj_v Duv. -have{min_v} /idPn[] := min_v u isT u2N1; rewrite negb_imply /nnegIm Du /= Duv. -rewrite rmorphN conj_v opprK -opprD mulrNN mulNr -mulr2n mulrnAr -expr2 v2n1. -by rewrite mulNrn opprK ler0n oppr_ge0 (leC_nat 2 0). -Qed. - -Lemma rootC_Re_max n x y : - (n > 0)%N -> y ^+ n = x -> 0 <= 'Im y -> 'Re y <= 'Re (n.-root%C x). -Proof. -by move=> n_gt0 yn_x leI0y; case_rootC=> z /= _ /(_ y n_gt0 yn_x)/argCleP[]. -Qed. - -Let neg_unity_root n : (n > 1)%N -> exists2 w : algC, w ^+ n = 1 & 'Re w < 0. -Proof. -move=> n_gt1; have [|w /eqP pw_0] := closed_rootP (\poly_(i < n) (1 : algC)) _. - by rewrite size_poly_eq ?oner_eq0 // -(subnKC n_gt1). -rewrite horner_poly (eq_bigr _ (fun _ _ => mul1r _)) in pw_0. -have wn1: w ^+ n = 1 by apply/eqP; rewrite -subr_eq0 subrX1 pw_0 mulr0. -suffices /existsP[i ltRwi0]: [exists i : 'I_n, 'Re (w ^+ i) < 0]. - by exists (w ^+ i) => //; rewrite exprAC wn1 expr1n. -apply: contra_eqT (congr1 algRe pw_0); rewrite negb_exists => /forallP geRw0. -rewrite raddf_sum raddf0 /= (bigD1 (Ordinal (ltnW n_gt1))) //=. -rewrite (Creal_ReP _ _) ?rpred1 // gtr_eqF ?ltr_paddr ?ltr01 //=. -by apply: sumr_ge0 => i _; rewrite real_lerNgt. -Qed. - -Lemma Im_rootC_ge0 n x : (n > 1)%N -> 0 <= 'Im (n.-root x). -Proof. -set y := n.-root x => n_gt1; have n_gt0 := ltnW n_gt1. -apply: wlog_neg; rewrite -real_ltrNge // => ltIy0. -suffices [z zn_x leI0z]: exists2 z, z ^+ n = x & 'Im z >= 0. - by rewrite /y; case_rootC => /= y1 _ /(_ z n_gt0 zn_x)/argCleP[]. -have [w wn1 ltRw0] := neg_unity_root n_gt1. -wlog leRI0yw: w wn1 ltRw0 / 0 <= 'Re y * 'Im w. - move=> IHw; have: 'Re y * 'Im w \is Creal by rewrite rpredM. - case/real_ger0P=> [|/ltrW leRIyw0]; first exact: IHw. - apply: (IHw w^*); rewrite ?algRe_conj ?algIm_conj ?mulrN ?oppr_ge0 //. - by rewrite -rmorphX wn1 rmorph1. -exists (w * y); first by rewrite exprMn wn1 mul1r rootCK. -rewrite [w]algCrect [y]algCrect mulC_rect. -by rewrite algIm_rect ?rpredD ?rpredN 1?rpredM // addr_ge0 // ltrW ?nmulr_rgt0. -Qed. - -Lemma rootC_lt0 n x : (1 < n)%N -> (n.-root x < 0) = false. -Proof. -set y := n.-root x => n_gt1; have n_gt0 := ltnW n_gt1. -apply: negbTE; apply: wlog_neg => /negbNE lt0y; rewrite ler_gtF //. -have Rx: x \is Creal by rewrite -[x](rootCK n_gt0) rpredX // ltr0_real. -have Re_y: 'Re y = y by apply/Creal_ReP; rewrite ltr0_real. -have [z zn_x leR0z]: exists2 z, z ^+ n = x & 'Re z >= 0. - have [w wn1 ltRw0] := neg_unity_root n_gt1. - exists (w * y); first by rewrite exprMn wn1 mul1r rootCK. - by rewrite algReMr ?ltr0_real // ltrW // nmulr_lgt0. -without loss leI0z: z zn_x leR0z / 'Im z >= 0. - move=> IHz; have: 'Im z \is Creal by []. - case/real_ger0P=> [|/ltrW leIz0]; first exact: IHz. - apply: (IHz z^*); rewrite ?algRe_conj ?algIm_conj ?oppr_ge0 //. - by rewrite -rmorphX zn_x conj_Creal. -by apply: ler_trans leR0z _; rewrite -Re_y ?rootC_Re_max ?ltr0_real. -Qed. - -Lemma rootC_ge0 n x : (n > 0)%N -> (0 <= n.-root x) = (0 <= x). -Proof. -set y := n.-root x => n_gt0. -apply/idP/idP=> [/(exprn_ge0 n) | x_ge0]; first by rewrite rootCK. -rewrite -(ger_lerif (lerif_Re_Creal y)). -have Ray: `|y| \is Creal by apply: normr_real. -rewrite -(Creal_ReP _ Ray) rootC_Re_max ?(Creal_ImP _ Ray) //. -by rewrite -normrX rootCK // ger0_norm. -Qed. - -Lemma rootC_gt0 n x : (n > 0)%N -> (n.-root x > 0) = (x > 0). -Proof. by move=> n_gt0; rewrite !lt0r rootC_ge0 ?rootC_eq0. Qed. - -Lemma rootC_le0 n x : (1 < n)%N -> (n.-root x <= 0) = (x == 0). -Proof. -by move=> n_gt1; rewrite ler_eqVlt rootC_lt0 // orbF rootC_eq0 1?ltnW. -Qed. - -Lemma ler_rootCl n : (n > 0)%N -> {in Num.nneg, {mono n.-root : x y / x <= y}}. -Proof. -move=> n_gt0 x x_ge0 y; have [y_ge0 | not_y_ge0] := boolP (0 <= y). - by rewrite -(ler_pexpn2r n_gt0) ?qualifE ?rootC_ge0 ?rootCK. -rewrite (contraNF (@ler_trans _ _ 0 _ _)) ?rootC_ge0 //. -by rewrite (contraNF (ler_trans x_ge0)). -Qed. - -Lemma ler_rootC n : (n > 0)%N -> {in Num.nneg &, {mono n.-root : x y / x <= y}}. -Proof. by move=> n_gt0 x y x_ge0 _; apply: ler_rootCl. Qed. - -Lemma ltr_rootCl n : (n > 0)%N -> {in Num.nneg, {mono n.-root : x y / x < y}}. -Proof. by move=> n_gt0 x x_ge0 y; rewrite !ltr_def ler_rootCl ?eqr_rootC. Qed. - -Lemma ltr_rootC n : (n > 0)%N -> {in Num.nneg &, {mono n.-root : x y / x < y}}. -Proof. by move/ler_rootC/lerW_mono_in. Qed. - -Lemma exprCK n x : (0 < n)%N -> 0 <= x -> n.-root (x ^+ n) = x. -Proof. -move=> n_gt0 x_ge0; apply/eqP. -by rewrite -(eqr_expn2 n_gt0) ?rootC_ge0 ?exprn_ge0 ?rootCK. -Qed. - -Lemma norm_rootC n x : `|n.-root x| = n.-root `|x|. -Proof. -have [-> | n_gt0] := posnP n; first by rewrite !root0C normr0. -apply/eqP; rewrite -(eqr_expn2 n_gt0) ?rootC_ge0 ?normr_ge0 //. -by rewrite -normrX !rootCK. -Qed. - -Lemma rootCX n x k : (n > 0)%N -> 0 <= x -> n.-root (x ^+ k) = n.-root x ^+ k. -Proof. -move=> n_gt0 x_ge0; apply/eqP. -by rewrite -(eqr_expn2 n_gt0) ?(exprn_ge0, rootC_ge0) // 1?exprAC !rootCK. -Qed. - -Lemma rootC1 n : (n > 0)%N -> n.-root 1 = 1. -Proof. by move/(rootCX 0)/(_ ler01). Qed. - -Lemma rootCpX n x k : (k > 0)%N -> 0 <= x -> n.-root (x ^+ k) = n.-root x ^+ k. -Proof. -by case: n => [|n] k_gt0; [rewrite !root0C expr0n gtn_eqF | apply: rootCX]. -Qed. - -Lemma rootCV n x : (n > 0)%N -> 0 <= x -> n.-root x^-1 = (n.-root x)^-1. -Proof. -move=> n_gt0 x_ge0; apply/eqP. -by rewrite -(eqr_expn2 n_gt0) ?(invr_ge0, rootC_ge0) // !exprVn !rootCK. -Qed. - -Lemma rootC_eq1 n x : (n > 0)%N -> (n.-root x == 1) = (x == 1). -Proof. by move=> n_gt0; rewrite -{1}(rootC1 n_gt0) eqr_rootC. Qed. - -Lemma rootC_ge1 n x : (n > 0)%N -> (n.-root x >= 1) = (x >= 1). -Proof. -by move=> n_gt0; rewrite -{1}(rootC1 n_gt0) ler_rootCl // qualifE ler01. -Qed. - -Lemma rootC_gt1 n x : (n > 0)%N -> (n.-root x > 1) = (x > 1). -Proof. by move=> n_gt0; rewrite !ltr_def rootC_eq1 ?rootC_ge1. Qed. - -Lemma rootC_le1 n x : (n > 0)%N -> 0 <= x -> (n.-root x <= 1) = (x <= 1). -Proof. by move=> n_gt0 x_ge0; rewrite -{1}(rootC1 n_gt0) ler_rootCl. Qed. - -Lemma rootC_lt1 n x : (n > 0)%N -> 0 <= x -> (n.-root x < 1) = (x < 1). -Proof. by move=> n_gt0 x_ge0; rewrite !ltr_neqAle rootC_eq1 ?rootC_le1. Qed. - -Lemma rootCMl n x z : 0 <= x -> n.-root (x * z) = n.-root x * n.-root z. -Proof. -rewrite le0r => /predU1P[-> | x_gt0]; first by rewrite !(mul0r, rootC0). -have [| n_gt1 | ->] := ltngtP n 1; last by rewrite !root1C. - by case: n => //; rewrite !root0C mul0r. -have [x_ge0 n_gt0] := (ltrW x_gt0, ltnW n_gt1). -have nx_gt0: 0 < n.-root x by rewrite rootC_gt0. -have Rnx: n.-root x \is Creal by rewrite ger0_real ?ltrW. -apply: eqC_semipolar; last 1 first; try apply/eqP. -- by rewrite algImMl // !(Im_rootC_ge0, mulr_ge0, rootC_ge0). -- by rewrite -(eqr_expn2 n_gt0) ?normr_ge0 // -!normrX exprMn !rootCK. -rewrite eqr_le; apply/andP; split; last first. - rewrite rootC_Re_max ?exprMn ?rootCK ?algImMl //. - by rewrite mulr_ge0 ?Im_rootC_ge0 ?ltrW. -rewrite -[n.-root _](mulVKf (negbT (gtr_eqF nx_gt0))) !(algReMl Rnx) //. -rewrite ler_pmul2l // rootC_Re_max ?exprMn ?exprVn ?rootCK ?mulKf ?gtr_eqF //. -by rewrite algImMl ?rpredV // mulr_ge0 ?invr_ge0 ?Im_rootC_ge0 ?ltrW. -Qed. - -Lemma rootCMr n x z : 0 <= x -> n.-root (z * x) = n.-root z * n.-root x. -Proof. by move=> x_ge0; rewrite mulrC rootCMl // mulrC. Qed. - -(* More properties of n.-root will be established in cyclotomic.v. *) - -(* The proper form of the Arithmetic - Geometric Mean inequality. *) - -Lemma lerif_rootC_AGM (I : finType) (A : pred I) (n := #|A|) E : - {in A, forall i, 0 <= E i} -> - n.-root (\prod_(i in A) E i) <= (\sum_(i in A) E i) / n%:R - ?= iff [forall i in A, forall j in A, E i == E j]. -Proof. -move=> Ege0; have [n0 | n_gt0] := posnP n. - rewrite n0 root0C invr0 mulr0; apply/lerif_refl/forall_inP=> i. - by rewrite (card0_eq n0). -rewrite -(mono_in_lerif (ler_pexpn2r n_gt0)) ?rootCK //=; first 1 last. -- by rewrite qualifE rootC_ge0 // prodr_ge0. -- by rewrite rpred_div ?rpred_nat ?rpred_sum. -exact: lerif_AGM. -Qed. - -(* Square root. *) - -Lemma sqrtC0 : sqrtC 0 = 0. Proof. exact: rootC0. Qed. -Lemma sqrtC1 : sqrtC 1 = 1. Proof. exact: rootC1. Qed. -Lemma sqrtCK x : sqrtC x ^+ 2 = x. Proof. exact: rootCK. Qed. -Lemma sqrCK x : 0 <= x -> sqrtC (x ^+ 2) = x. Proof. exact: exprCK. Qed. - -Lemma sqrtC_ge0 x : (0 <= sqrtC x) = (0 <= x). Proof. exact: rootC_ge0. Qed. -Lemma sqrtC_eq0 x : (sqrtC x == 0) = (x == 0). Proof. exact: rootC_eq0. Qed. -Lemma sqrtC_gt0 x : (sqrtC x > 0) = (x > 0). Proof. exact: rootC_gt0. Qed. -Lemma sqrtC_lt0 x : (sqrtC x < 0) = false. Proof. exact: rootC_lt0. Qed. -Lemma sqrtC_le0 x : (sqrtC x <= 0) = (x == 0). Proof. exact: rootC_le0. Qed. - -Lemma ler_sqrtC : {in Num.nneg &, {mono sqrtC : x y / x <= y}}. -Proof. exact: ler_rootC. Qed. -Lemma ltr_sqrtC : {in Num.nneg &, {mono sqrtC : x y / x < y}}. -Proof. exact: ltr_rootC. Qed. -Lemma eqr_sqrtC : {mono sqrtC : x y / x == y}. -Proof. exact: eqr_rootC. Qed. -Lemma sqrtC_inj : injective sqrtC. -Proof. exact: rootC_inj. Qed. -Lemma sqrtCM : {in Num.nneg &, {morph sqrtC : x y / x * y}}. -Proof. by move=> x y _; apply: rootCMr. Qed. - -Lemma sqrCK_P x : reflect (sqrtC (x ^+ 2) = x) ((0 <= 'Im x) && ~~ (x < 0)). -Proof. -apply: (iffP andP) => [[leI0x not_gt0x] | <-]; last first. - by rewrite sqrtC_lt0 Im_rootC_ge0. -have /eqP := sqrtCK (x ^+ 2); rewrite eqf_sqr => /pred2P[] // defNx. -apply: sqrCK; rewrite -real_lerNgt // in not_gt0x; apply/Creal_ImP/ler_anti; -by rewrite leI0x -oppr_ge0 -raddfN -defNx Im_rootC_ge0. -Qed. - -Lemma normC_def x : `|x| = sqrtC (x * x^*). -Proof. by rewrite -normCK sqrCK ?normr_ge0. Qed. - -Lemma norm_conjC x : `|x^*| = `|x|. -Proof. by rewrite !normC_def conjCK mulrC. Qed. - -Lemma normC_rect : - {in Creal &, forall x y, `|x + 'i * y| = sqrtC (x ^+ 2 + y ^+ 2)}. -Proof. by move=> x y Rx Ry; rewrite /= normC_def -normCK normC2_rect. Qed. - -Lemma normC_Re_Im z : `|z| = sqrtC ('Re z ^+ 2 + 'Im z ^+ 2). -Proof. by rewrite normC_def -normCK normC2_Re_Im. Qed. - -(* Norm sum (in)equalities. *) - -Lemma normC_add_eq x y : - `|x + y| = `|x| + `|y| -> - {t : algC | `|t| == 1 & (x, y) = (`|x| * t, `|y| * t)}. -Proof. -move=> lin_xy; apply: sig2_eqW; pose u z := if z == 0 then 1 else z / `|z|. -have uE z: (`|u z| = 1) * (`|z| * u z = z). - rewrite /u; have [->|nz_z] := altP eqP; first by rewrite normr0 normr1 mul0r. - by rewrite normf_div normr_id mulrCA divff ?mulr1 ?normr_eq0. -have [->|nz_x] := eqVneq x 0; first by exists (u y); rewrite uE ?normr0 ?mul0r. -exists (u x); rewrite uE // /u (negPf nz_x); congr (_ , _). -have{lin_xy} def2xy: `|x| * `|y| *+ 2 = x * y ^* + y * x ^*. - apply/(addrI (x * x^*))/(addIr (y * y^*)); rewrite -2!{1}normCK -sqrrD. - by rewrite addrA -addrA -!mulrDr -mulrDl -rmorphD -normCK lin_xy. -have def_xy: x * y^* = y * x^*. - apply/eqP; rewrite -subr_eq0 -[_ == 0](@expf_eq0 _ _ 2). - rewrite (canRL (subrK _) (subr_sqrDB _ _)) opprK -def2xy exprMn_n exprMn. - by rewrite mulrN mulrAC mulrA -mulrA mulrACA -!normCK mulNrn addNr. -have{def_xy def2xy} def_yx: `|y * x| = y * x^*. - by apply: (mulIf nz2); rewrite !mulr_natr mulrC normrM def2xy def_xy. -rewrite -{1}(divfK nz_x y) invC_norm mulrCA -{}def_yx !normrM invfM. -by rewrite mulrCA divfK ?normr_eq0 // mulrAC mulrA. -Qed. - -Lemma normC_sum_eq (I : finType) (P : pred I) (F : I -> algC) : - `|\sum_(i | P i) F i| = \sum_(i | P i) `|F i| -> - {t : algC | `|t| == 1 & forall i, P i -> F i = `|F i| * t}. -Proof. -have [i /andP[Pi nzFi] | F0] := pickP [pred i | P i & F i != 0]; last first. - exists 1 => [|i Pi]; first by rewrite normr1. - by case/nandP: (F0 i) => [/negP[]// | /negbNE/eqP->]; rewrite normr0 mul0r. -rewrite !(bigD1 i Pi) /= => norm_sumF; pose Q j := P j && (j != i). -rewrite -normr_eq0 in nzFi; set c := F i / `|F i|; exists c => [|j Pj]. - by rewrite normrM normfV normr_id divff. -have [Qj | /nandP[/negP[]// | /negbNE/eqP->]] := boolP (Q j); last first. - by rewrite mulrC divfK. -have: `|F i + F j| = `|F i| + `|F j|. - do [rewrite !(bigD1 j Qj) /=; set z := \sum_(k | _) `|_|] in norm_sumF. - apply/eqP; rewrite eqr_le ler_norm_add -(ler_add2r z) -addrA -norm_sumF addrA. - by rewrite (ler_trans (ler_norm_add _ _)) // ler_add2l ler_norm_sum. -by case/normC_add_eq=> k _ [/(canLR (mulKf nzFi)) <-]; rewrite -(mulrC (F i)). -Qed. - -Lemma normC_sum_eq1 (I : finType) (P : pred I) (F : I -> algC) : - `|\sum_(i | P i) F i| = (\sum_(i | P i) `|F i|) -> - (forall i, P i -> `|F i| = 1) -> - {t : algC | `|t| == 1 & forall i, P i -> F i = t}. -Proof. -case/normC_sum_eq=> t t1 defF normF. -by exists t => // i Pi; rewrite defF // normF // mul1r. -Qed. - -Lemma normC_sum_upper (I : finType) (P : pred I) (F G : I -> algC) : - (forall i, P i -> `|F i| <= G i) -> - \sum_(i | P i) F i = \sum_(i | P i) G i -> - forall i, P i -> F i = G i. -Proof. -set sumF := \sum_(i | _) _; set sumG := \sum_(i | _) _ => leFG eq_sumFG. -have posG i: P i -> 0 <= G i by move/leFG; apply: ler_trans; apply: normr_ge0. -have norm_sumG: `|sumG| = sumG by rewrite ger0_norm ?sumr_ge0. -have norm_sumF: `|sumF| = \sum_(i | P i) `|F i|. - apply/eqP; rewrite eqr_le ler_norm_sum eq_sumFG norm_sumG -subr_ge0 -sumrB. - by rewrite sumr_ge0 // => i Pi; rewrite subr_ge0 ?leFG. -have [t _ defF] := normC_sum_eq norm_sumF. -have [/(psumr_eq0P posG) G0 i Pi | nz_sumG] := eqVneq sumG 0. - by apply/eqP; rewrite G0 // -normr_eq0 eqr_le normr_ge0 -(G0 i Pi) leFG. -have t1: t = 1. - apply: (mulfI nz_sumG); rewrite mulr1 -{1}norm_sumG -eq_sumFG norm_sumF. - by rewrite mulr_suml -(eq_bigr _ defF). -have /psumr_eq0P eqFG i: P i -> 0 <= G i - F i. - by move=> Pi; rewrite subr_ge0 defF // t1 mulr1 leFG. -move=> i /eqFG/(canRL (subrK _))->; rewrite ?add0r //. -by rewrite sumrB -/sumF eq_sumFG subrr. -Qed. - -Lemma normC_sub_eq x y : - `|x - y| = `|x| - `|y| -> {t | `|t| == 1 & (x, y) = (`|x| * t, `|y| * t)}. -Proof. -rewrite -{-1}(subrK y x) => /(canLR (subrK _))/esym-Dx; rewrite Dx. -by have [t ? [Dxy Dy]] := normC_add_eq Dx; exists t; rewrite // mulrDl -Dxy -Dy. -Qed. +Lemma algCreal_Im x : 'Im x \is Creal. +Proof. by rewrite Creal_Im. Qed. +Hint Resolve algCreal_Re algCreal_Im. (* Integer subset. *) - (* Not relying on the undocumented interval library, for now. *) + Lemma floorC_itv x : x \is Creal -> (floorC x)%:~R <= x < (floorC x + 1)%:~R. Proof. by rewrite /floorC => Rx; case: (floorC_subproof x) => //= m; apply. Qed. diff --git a/mathcomp/field/algebraics_fundamentals.v b/mathcomp/field/algebraics_fundamentals.v index 5134a2f..4337327 100644 --- a/mathcomp/field/algebraics_fundamentals.v +++ b/mathcomp/field/algebraics_fundamentals.v @@ -259,12 +259,6 @@ by rewrite Dp map_monic; exists p; rewrite // -Dp root_minPoly. Qed. Prenex Implicits alg_integral. -Lemma imaginary_exists (C : closedFieldType) : {i : C | i ^+ 2 = -1}. -Proof. -have /sig_eqW[i Di2] := @solve_monicpoly C 2 (nth 0 [:: -1]) isT. -by exists i; rewrite Di2 big_ord_recl big_ord1 mul0r mulr1 !addr0. -Qed. - Import DefaultKeying GRing.DefaultPred. Implicit Arguments map_poly_inj [[F] [R] x1 x2]. @@ -275,7 +269,7 @@ Proof. have maxn3 n1 n2 n3: {m | [/\ n1 <= m, n2 <= m & n3 <= m]%N}. by exists (maxn n1 (maxn n2 n3)); apply/and3P; rewrite -!geq_max. have [C [/= QtoC algC]] := countable_algebraic_closure [countFieldType of rat]. -exists C; have [i Di2] := imaginary_exists C. +exists C; have [i Di2] := GRing.imaginary_exists C. pose Qfield := fieldExtType rat; pose Cmorph (L : Qfield) := {rmorphism L -> C}. have charQ (L : Qfield): [char L] =i pred0 := ftrans (char_lalg L) (char_num _). have sepQ (L : Qfield) (K E : {subfield L}): separable K E. diff --git a/mathcomp/fingroup/fingroup.v b/mathcomp/fingroup/fingroup.v index 01eea88..70553a0 100644 --- a/mathcomp/fingroup/fingroup.v +++ b/mathcomp/fingroup/fingroup.v @@ -232,7 +232,7 @@ Structure base_type : Type := PackBase { (* coercion of A * B to pred_sort in x \in A * B, or rho * tau to *) (* ffun and Funclass in (rho * tau) x, when rho tau : perm T. *) (* Therefore we define an alias of sort for argument types, and *) -(* make it the default coercion FinGroup.base_class >-> Sortclass *) +(* make it the default coercion FinGroup.base_type >-> Sortclass *) (* so that arguments of a functions whose parameters are of type, *) (* say, gT : finGroupType, can be coerced to the coercion class *) (* of arg_sort. Care should be taken, however, to declare the *) diff --git a/mathcomp/odd_order/BGappendixC.v b/mathcomp/odd_order/BGappendixC.v index a64c49a..16a0a3c 100644 --- a/mathcomp/odd_order/BGappendixC.v +++ b/mathcomp/odd_order/BGappendixC.v @@ -288,7 +288,7 @@ Proof. have [q_gt4 | q_le4] := ltnP 4 q. pose inK x := enum_rank_in (classes1 H) (x ^: H). have inK_E x: x \in H -> enum_val (inK x) = x ^: H. - by move=> Hx; rewrite enum_rankK_in ?mem_classes. + by move=> Hx; rewrite enum_rankK_in ?mem_classes. pose j := inK s; pose k := inK (s ^+ 2)%g; pose e := gring_classM_coef j j k. have cPP: abelian P by rewrite -(injm_abelian inj_sigma) ?zmod_abelian. have Hs: s \in H by rewrite -(sdprodW defH) -[s]mulg1 mem_mulg. @@ -355,18 +355,19 @@ have [q_gt4 | q_le4] := ltnP 4 q. by rewrite sub_cent1 groupX // (subsetP cPP). rewrite mulrnA -second_orthogonality_relation ?groupX // big_mkcond. by apply: ler_sum => i _; rewrite normCK; case: ifP; rewrite ?mul_conjC_ge0. - have sqrtP_gt0: 0 < sqrtC #|P|%:R by rewrite sqrtC_gt0 ?gt0CG. - have{De ub_linH'}: `|(#|P| * e)%:R - #|U|%:R ^+ 2| <= #|P|%:R * sqrtC #|P|%:R. + have sqrtP_gt0: 0 < sqrtC #|P|%:R :> algC by rewrite sqrtC_gt0 ?gt0CG. + have{De ub_linH'}: + `|(#|P| * e)%:R - #|U|%:R ^+ 2| <= #|P|%:R * sqrtC #|P|%:R :> algC. rewrite natrM De mulrCA mulrA divfK ?neq0CG // (bigID linH) /= sum_linH. rewrite mulrDr addrC addKr mulrC mulr_suml /chi_s2. rewrite (ler_trans (ler_norm_sum _ _ _)) // -ler_pdivr_mulr // mulr_suml. apply: ler_trans (ub_linH' 1%N isT); apply: ler_sum => i linH'i. rewrite ler_pdivr_mulr // degU ?divfK ?neq0CG //. rewrite normrM -normrX norm_conjC ler_wpmul2l ?normr_ge0 //. - rewrite -ler_sqr ?qualifE ?normr_ge0 ?(@ltrW _ 0) // sqrtCK. + rewrite -ler_sqr ?qualifE ?normr_ge0 ?(@ltrW _ 0) // sqrtCK. apply: ler_trans (ub_linH' 2 isT); rewrite (bigD1 i) ?ler_paddr //=. by apply: sumr_ge0 => i1 _; rewrite exprn_ge0 ?normr_ge0. - rewrite natrM real_ler_distl ?rpredB ?rpredM ?rpred_nat // => /andP[lb_Pe _]. + rewrite natrM real_ler_distl ?rpredB ?rpredM ?rpred_nat // => /andP[lb_Pe _]. rewrite -ltC_nat -(ltr_pmul2l (gt0CG P)) {lb_Pe}(ltr_le_trans _ lb_Pe) //. rewrite ltr_subr_addl (@ler_lt_trans _ ((p ^ q.-1)%:R ^+ 2)) //; last first. rewrite -!natrX ltC_nat ltn_sqr oU ltn_divRL ?dvdn_pred_predX //. diff --git a/mathcomp/odd_order/PFsection11.v b/mathcomp/odd_order/PFsection11.v index b966f25..3c4ec9f 100644 --- a/mathcomp/odd_order/PFsection11.v +++ b/mathcomp/odd_order/PFsection11.v @@ -232,7 +232,7 @@ Lemma bounded_proper_coherent H1 : (#|HU : H1| <= 2 * q * #|U : C| + 1)%N. Proof. move=> nsH1_M psH1_M' cohH1; have [nsHHU _ _ _ _] := sdprod_context defHU. -suffices: #|HU : H1|%:R - 1 <= 2%:R * #|M : HC|%:R * sqrtC #|HC : HC|%:R. +suffices: #|HU : H1|%:R - 1 <= 2%:R * #|M : HC|%:R * sqrtC #|HC : HC|%:R :> algC. rewrite indexgg sqrtC1 mulr1 -leC_nat natrD -ler_subl_addr -mulnA natrM. congr (_ <= _ * _%:R); apply/eqP; rewrite -(eqn_pmul2l (cardG_gt0 HC)). rewrite Lagrange ?normal_sub // mulnCA -(dprod_card defHC) -mulnA mulnC. diff --git a/mathcomp/odd_order/PFsection3.v b/mathcomp/odd_order/PFsection3.v index cb55ae4..9011122 100644 --- a/mathcomp/odd_order/PFsection3.v +++ b/mathcomp/odd_order/PFsection3.v @@ -1360,7 +1360,7 @@ have{oxi_00} oxi_i0 i j i0: '[xi_ i j, xi_ i0 0] = ((i == i0) && (j == 0))%:R. by rewrite cfdotC Xi0_X0j // conjC0. have [-> | nzi2] := altP (i2 =P 0); first exact: oxi_0j. have [-> | nzj2] := altP (j2 =P 0); first exact: oxi_i0. -rewrite cfdotC eq_sym; apply: canLR conjCK _; rewrite rmorph_nat. +rewrite cfdotC eq_sym; apply: canLR (@conjCK _) _; rewrite rmorph_nat. have [-> | nzi1] := altP (i1 =P 0); first exact: oxi_0j. have [-> | nzj1] := altP (j1 =P 0); first exact: oxi_i0. have ->: xi_ i1 j1 = beta i1 j1 + xi_ i1 0 + xi_ 0 j1 by rewrite /xi_ !ifN. diff --git a/mathcomp/odd_order/PFsection5.v b/mathcomp/odd_order/PFsection5.v index d318f5f..3f90da7 100644 --- a/mathcomp/odd_order/PFsection5.v +++ b/mathcomp/odd_order/PFsection5.v @@ -492,7 +492,7 @@ Definition subcoherent S tau R := (*c*) pairwise_orthogonal S, (*d*) {in S, forall xi : 'CF(L : {set gT}), [/\ {subset R xi <= 'Z[irr G]}, orthonormal (R xi) - & tau (xi - xi^*)%CF = \sum_(alpha <- R xi) alpha]} + & tau (xi - xi^*%CF) = \sum_(alpha <- R xi) alpha]} & (*e*) {in S &, forall xi phi : 'CF(L), orthogonal phi (xi :: xi^*%CF) -> orthogonal (R phi) (R xi)}]. @@ -621,7 +621,7 @@ have isoS1: {in S1, isometry [eta tau with eta1 |-> zeta1], to 'Z[irr G]}. split=> [xi eta | eta]; rewrite !in_cons /=; last first. by case: eqP => [-> | _ /isoS[/Ztau/zcharW]]. do 2!case: eqP => [-> _|_ /isoS[? ?]] //; last exact: Itau. - by apply/(can_inj conjCK); rewrite -!cfdotC. + by apply/(can_inj (@conjCK _)); rewrite -!cfdotC. have [nu Dnu IZnu] := Zisometry_of_iso freeS1 isoS1. exists nu; split=> // phi; rewrite zcharD1E => /andP[]. case/(zchar_expansion (free_uniq freeS1)) => b Zb {phi}-> phi1_0. @@ -646,7 +646,7 @@ have N_S: {subset S <= character} by move=> _ /irrS/irrP[i ->]; apply: irr_char. have Z_S: {subset S <= 'Z[irr L]} by move=> chi /N_S/char_vchar. have o1S: orthonormal S by apply: sub_orthonormal (irr_orthonormal L). have [[_ dotSS] oS] := (orthonormalP o1S, orthonormal_orthogonal o1S). -pose beta chi := tau (chi - chi^*)%CF; pose eqBP := _ =P beta _. +pose beta chi := tau (chi - chi^*%CF); pose eqBP := _ =P beta _. have Zbeta: {in S, forall chi, chi - (chi^*)%CF \in 'Z[S, L^#]}. move=> chi Schi; rewrite /= zcharD1E rpredB ?mem_zchar ?ccS //= !cfunE. by rewrite subr_eq0 conj_Cnat // Cnat_char1 ?N_S. @@ -885,7 +885,7 @@ Lemma subcoherent_norm chi psi (tau1 : {additive 'CF(L) -> 'CF(G)}) X Y : [/\ chi \in S, psi \in 'Z[irr L] & orthogonal (chi :: chi^*)%CF psi] -> let S0 := chi - psi :: chi - chi^*%CF in {in 'Z[S0], isometry tau1, to 'Z[irr G]} -> - tau1 (chi - chi^*)%CF = tau (chi - chi^*)%CF -> + tau1 (chi - chi^*%CF) = tau (chi - chi^*%CF) -> [/\ tau1 (chi - psi) = X - Y, '[X, Y] = 0 & orthogonal Y (R chi)] -> [/\ (*a*) '[chi] <= '[X] & (*b*) '[psi] <= '[Y] -> diff --git a/mathcomp/odd_order/PFsection6.v b/mathcomp/odd_order/PFsection6.v index 6d9ecfc..cbde798 100644 --- a/mathcomp/odd_order/PFsection6.v +++ b/mathcomp/odd_order/PFsection6.v @@ -83,13 +83,13 @@ Lemma coherent_seqIndD_bound (A B C D : {group gT}) : (*a*) [/\ A \proper K, B \subset D, D \subset C, C \subset K & D / B \subset 'Z(C / B)]%g -> (*b*) coherent (S A) L^# tau -> \unless coherent (S B) L^# tau, - #|K : A|%:R - 1 <= 2%:R * #|L : C|%:R * sqrtC #|C : D|%:R. + #|K : A|%:R - 1 <= 2%:R * #|L : C|%:R * sqrtC #|C : D|%:R :> algC. Proof. move=> [nsAL nsBL nsCL nsDL] [ltAK sBD sDC sCK sDbZC] cohA. have sBC := subset_trans sBD sDC; have sBK := subset_trans sBC sCK. have [sAK nsBK] := (proper_sub ltAK, normalS sBK sKL nsBL). have{sBC} [nsAK nsBC] := (normalS sAK sKL nsAL, normalS sBC sCK nsBK). -rewrite real_lerNgt ?rpredB ?ger0_real ?mulr_ge0 ?sqrtC_ge0 ?ler0n //. +rewrite real_lerNgt ?rpredB ?ger0_real ?mulr_ge0 ?sqrtC_ge0 ?ler0n ?ler01 //. apply/unless_contra; rewrite negbK -(Lagrange_index sKL sCK) natrM => lb_KA. pose S2 : seq 'CF(L) := [::]; pose S1 := S2 ++ S A; rewrite -[S A]/S1 in cohA. have ccsS1S: cfConjC_subset S1 calS by apply: seqInd_conjC_subset1. @@ -153,7 +153,7 @@ have sAbZH: (A / B \subset 'Z(H / B))%g. by apply: homg_quotientS; rewrite ?(subset_trans sHL) ?normal_norm. have ltAH: A \proper H. by rewrite properEneq sAH (contraTneq _ lbHA) // => ->; rewrite indexgg addn1. -set x := sqrtC #|H : A|%:R. +set x : algC := sqrtC #|H : A|%:R. have [nz_x x_gt0]: x != 0 /\ 0 < x by rewrite gtr_eqF sqrtC_gt0 gt0CiG. without loss{cohA} ubKA: / #|K : A|%:R - 1 <= 2%:R * #|L : H|%:R * x. have [sAK ltAK] := (subset_trans sAH sHK, proper_sub_trans ltAH sHK). diff --git a/mathcomp/odd_order/PFsection7.v b/mathcomp/odd_order/PFsection7.v index cea9319..4610829 100644 --- a/mathcomp/odd_order/PFsection7.v +++ b/mathcomp/odd_order/PFsection7.v @@ -324,7 +324,7 @@ transitivity (\sum_(x in A) \sum_(xi <- S) \sum_(mu <- S) F xi mu x). apply: eq_bigr => x Ax; rewrite part_a // sum_cfunE -mulrA mulr_suml. apply: eq_bigr => xi _; rewrite mulrA -mulr_suml rmorph_sum; congr (_ * _). rewrite mulr_sumr; apply: eq_bigr => mu _; rewrite !cfunE (cfdotC mu). - rewrite -{1}[mu x]conjCK -fmorph_div -rmorphM conjCK -4!mulrA 2!(mulrCA _^-1). + rewrite -{1}[mu x]conjCK -fmorph_div -rmorphM conjCK -3!mulrA 2!(mulrCA _^-1). by rewrite (mulrA _^-1) -invfM 2!(mulrCA (xi x)) mulrA 2!(mulrA _^*). rewrite exchange_big; apply: eq_bigr => xi _; rewrite exchange_big /=. apply: eq_big_seq => mu Smu; have Tmu := sST mu Smu. diff --git a/mathcomp/real_closed/complex.v b/mathcomp/real_closed/complex.v index 9c67f32..8ea1266 100644 --- a/mathcomp/real_closed/complex.v +++ b/mathcomp/real_closed/complex.v @@ -21,6 +21,7 @@ Import GRing.Theory Num.Theory. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +Obligation Tactic := idtac. Local Open Scope ring_scope. @@ -36,18 +37,22 @@ Local Notation sqrtr := Num.sqrt. CoInductive complex (R : Type) : Type := Complex { Re : R; Im : R }. -Definition real_complex_def (F : ringType) (phF : phant F) (x : F) := +Delimit Scope complex_scope with C. +Local Open Scope complex_scope. + +Definition real_complex_def (F : ringType) (phF : phant F) (x : F) := Complex x 0. Notation real_complex F := (@real_complex_def _ (Phant F)). Notation "x %:C" := (real_complex _ x) - (at level 2, left associativity, format "x %:C") : ring_scope. -Notation "x +i* y" := (Complex x y) : ring_scope. -Notation "x -i* y" := (Complex x (- y)) : ring_scope. -Notation "x *i " := (Complex 0 x) (at level 8, format "x *i") : ring_scope. -Notation "''i'" := (Complex 0 1) : ring_scope. + (at level 2, left associativity, format "x %:C") : complex_scope. +Notation "x +i* y" := (Complex x y) : complex_scope. +Notation "x -i* y" := (Complex x (- y)) : complex_scope. +Notation "x *i " := (Complex 0 x) (at level 8, format "x *i") : complex_scope. +Notation "''i'" := (Complex 0 1) : complex_scope. Notation "R [i]" := (complex R) (at level 2, left associativity, format "R [i]"). +(* Module ComplexInternal. *) Module ComplexEqChoice. Section ComplexEqChoice. @@ -70,11 +75,11 @@ Definition complex_choiceMixin (R : choiceType) := Definition complex_countMixin (R : countType) := PcanCountMixin (@ComplexEqChoice.complex_of_sqRK R). -Canonical Structure complex_eqType (R : eqType) := +Canonical complex_eqType (R : eqType) := EqType R[i] (complex_eqMixin R). -Canonical Structure complex_choiceType (R : choiceType) := +Canonical complex_choiceType (R : choiceType) := ChoiceType R[i] (complex_choiceMixin R). -Canonical Structure complex_countType (R : countType) := +Canonical complex_countType (R : countType) := CountType R[i] (complex_countMixin R). Lemma eq_complex : forall (R : eqType) (x y : complex R), @@ -99,19 +104,22 @@ Definition addc (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in (a + c) +i* (b + d). Definition oppc (x : R[i]) := let: a +i* b := x in (- a) +i* (- b). -Lemma addcC : commutative addc. -Proof. by move=> [a b] [c d] /=; congr (_ +i* _); rewrite addrC. Qed. -Lemma addcA : associative addc. -Proof. by move=> [a b] [c d] [e f] /=; rewrite !addrA. Qed. - -Lemma add0c : left_id C0 addc. -Proof. by move=> [a b] /=; rewrite !add0r. Qed. +Program Definition complex_zmodMixin := @ZmodMixin _ C0 oppc addc _ _ _ _. +Next Obligation. by move=> [a b] [c d] [e f] /=; rewrite !addrA. Qed. +Next Obligation. by move=> [a b] [c d] /=; congr (_ +i* _); rewrite addrC. Qed. +Next Obligation. by move=> [a b] /=; rewrite !add0r. Qed. +Next Obligation. by move=> [a b] /=; rewrite !addNr. Qed. +Canonical complex_zmodType := ZmodType R[i] complex_zmodMixin. -Lemma addNc : left_inverse C0 oppc addc. -Proof. by move=> [a b] /=; rewrite !addNr. Qed. +Definition scalec (a : R) (x : R[i]) := + let: b +i* c := x in (a * b) +i* (a * c). -Definition complex_ZmodMixin := ZmodMixin addcA addcC add0c addNc. -Canonical Structure complex_ZmodType := ZmodType R[i] complex_ZmodMixin. +Program Definition complex_lmodMixin := @LmodMixin _ _ scalec _ _ _ _. +Next Obligation. by move=> a b [c d] /=; rewrite !mulrA. Qed. +Next Obligation. by move=> [a b] /=; rewrite !mul1r. Qed. +Next Obligation. by move=> a [b c] [d e] /=; rewrite !mulrDr. Qed. +Next Obligation. by move=> [a b] c d /=; rewrite !mulrDl. Qed. +Canonical complex_lmodType := LmodType R R[i] complex_lmodMixin. Definition mulc (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in ((a * c) - (b * d)) +i* ((a * d) + (b * c)). @@ -146,9 +154,8 @@ Lemma nonzero1c : C1 != C0. Proof. by rewrite eq_complex /= oner_eq0. Qed. Definition complex_comRingMixin := ComRingMixin mulcA mulcC mul1c mulc_addl nonzero1c. -Canonical Structure complex_Ring := - Eval hnf in RingType R[i] complex_comRingMixin. -Canonical Structure complex_comRing := Eval hnf in ComRingType R[i] mulcC. +Canonical complex_ringType :=RingType R[i] complex_comRingMixin. +Canonical complex_comRingType := ComRingType R[i] mulcC. Lemma mulVc : forall x, x != C0 -> mulc (invc x) x = C1. Proof. @@ -159,19 +166,16 @@ Qed. Lemma invc0 : invc C0 = C0. Proof. by rewrite /= !mul0r oppr0. Qed. -Definition ComplexFieldUnitMixin := FieldUnitMixin mulVc invc0. -Canonical Structure complex_unitRing := - Eval hnf in UnitRingType C ComplexFieldUnitMixin. -Canonical Structure complex_comUnitRing := - Eval hnf in [comUnitRingType of R[i]]. +Definition complex_fieldUnitMixin := FieldUnitMixin mulVc invc0. +Canonical complex_unitRingType := UnitRingType C complex_fieldUnitMixin. +Canonical complex_comUnitRingType := Eval hnf in [comUnitRingType of R[i]]. -Lemma field_axiom : GRing.Field.mixin_of complex_unitRing. +Lemma field_axiom : GRing.Field.mixin_of complex_unitRingType. Proof. by []. Qed. Definition ComplexFieldIdomainMixin := (FieldIdomainMixin field_axiom). -Canonical Structure complex_iDomain := - Eval hnf in IdomainType R[i] (FieldIdomainMixin field_axiom). -Canonical Structure complex_fieldMixin := FieldType R[i] field_axiom. +Canonical complex_idomainType := IdomainType R[i] (FieldIdomainMixin field_axiom). +Canonical complex_fieldType := FieldType R[i] field_axiom. Ltac simpc := do ? [ rewrite -[(_ +i* _) - (_ +i* _)]/(_ +i* _) @@ -184,20 +188,22 @@ split; [|split=> //] => a b /=; simpc; first by rewrite subrr. by rewrite !mulr0 !mul0r addr0 subr0. Qed. -Canonical Structure real_complex_rmorphism := +Canonical real_complex_rmorphism := RMorphism real_complex_is_rmorphism. -Canonical Structure real_complex_additive := +Canonical real_complex_additive := Additive real_complex_is_rmorphism. -Lemma Re_is_additive : additive (@Re R). -Proof. by case=> a1 b1; case=> a2 b2. Qed. +Lemma Re_is_scalar : scalar (@Re R). +Proof. by move=> a [b c] [d e]. Qed. -Canonical Structure Re_additive := Additive Re_is_additive. +Canonical Re_additive := Additive Re_is_scalar. +Canonical Re_linear := Linear Re_is_scalar. -Lemma Im_is_additive : additive (@Im R). -Proof. by case=> a1 b1; case=> a2 b2. Qed. +Lemma Im_is_scalar : scalar (@Im R). +Proof. by move=> a [b c] [d e]. Qed. -Canonical Structure Im_additive := Additive Im_is_additive. +Canonical Im_additive := Additive Im_is_scalar. +Canonical Im_linear := Linear Im_is_scalar. Definition lec (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in @@ -207,7 +213,7 @@ Definition ltc (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in (d == b) && (a < c). -Definition normc (x : R[i]) : R := +Definition normc (x : R[i]) : R := let: a +i* b := x in sqrtr (a ^+ 2 + b ^+ 2). Notation normC x := (normc x)%:C. @@ -233,14 +239,10 @@ move: x y => [a b] [c d] /= /andP[/eqP -> a_ge0] /andP[/eqP -> c_ge0]. by rewrite eqxx ler_total. Qed. -(* :TODO: put in ssralg ? *) -Lemma exprM (a b : R) : (a * b) ^+ 2 = a ^+ 2 * b ^+ 2. -Proof. by rewrite mulrACA. Qed. - Lemma normcM x y : normc (x * y) = normc x * normc y. Proof. move: x y => [a b] [c d] /=; rewrite -sqrtrM ?addr_ge0 ?sqr_ge0 //. -rewrite sqrrB sqrrD mulrDl !mulrDr -!exprM. +rewrite sqrrB sqrrD mulrDl !mulrDr -!exprMn. rewrite mulrAC [b * d]mulrC !mulrA. suff -> : forall (u v w z t : R), (u - v + w) + (z + v + t) = u + w + (z + t). by rewrite addrAC !addrA. @@ -282,56 +284,51 @@ have [huv|] := ger0P (u + v); last first. by move=> /ltrW /ler_trans -> //; rewrite pmulrn_lge0 // mulr_ge0 ?sqrtr_ge0. rewrite -(@ler_pexpn2r _ 2) -?topredE //=; last first. by rewrite ?(pmulrn_lge0, mulr_ge0, sqrtr_ge0) //. -rewrite -mulr_natl !exprM !sqr_sqrtr ?(ler_paddr, sqr_ge0) //. -rewrite -mulrnDl -mulr_natl !exprM ler_pmul2l ?exprn_gt0 ?ltr0n //. -rewrite sqrrD mulrDl !mulrDr -!exprM addrAC. -rewrite [_ + (b * d) ^+ 2]addrC [X in _ <= X]addrAC -!addrA !ler_add2l. -rewrite mulrAC mulrA -mulrA mulrACA mulrC. -by rewrite -subr_ge0 addrAC -sqrrB sqr_ge0. +rewrite -mulr_natl !exprMn !sqr_sqrtr ?(ler_paddr, sqr_ge0) //. +rewrite -mulrnDl -mulr_natl !exprMn ler_pmul2l ?exprn_gt0 ?ltr0n //. +rewrite sqrrD mulrDl !mulrDr -!exprMn addrAC -!addrA ler_add2l !addrA. +rewrite [_ + (b * d) ^+ 2]addrC -addrA ler_add2l. +have: 0 <= (a * d - b * c) ^+ 2 by rewrite sqr_ge0. +by rewrite sqrrB addrAC subr_ge0 [_ * c]mulrC mulrACA [d * _]mulrC. Qed. -Definition complex_POrderedMixin := NumMixin lec_normD ltc0_add eq0_normC +Definition complex_numMixin := NumMixin lec_normD ltc0_add eq0_normC ge0_lec_total normCM lec_def ltc_def. -Canonical Structure complex_numDomainType := - NumDomainType R[i] complex_POrderedMixin. +Canonical complex_numDomainType := NumDomainType R[i] complex_numMixin. End ComplexField. End ComplexField. -Canonical complex_ZmodType (R : rcfType) := - ZmodType R[i] (ComplexField.complex_ZmodMixin R). -Canonical complex_Ring (R : rcfType) := - Eval hnf in RingType R[i] (ComplexField.complex_comRingMixin R). -Canonical complex_comRing (R : rcfType) := - Eval hnf in ComRingType R[i] (@ComplexField.mulcC R). -Canonical complex_unitRing (R : rcfType) := - Eval hnf in UnitRingType R[i] (ComplexField.ComplexFieldUnitMixin R). -Canonical complex_comUnitRing (R : rcfType) := - Eval hnf in [comUnitRingType of R[i]]. -Canonical complex_iDomain (R : rcfType) := - Eval hnf in IdomainType R[i] (FieldIdomainMixin (@ComplexField.field_axiom R)). -Canonical complex_fieldType (R : rcfType) := - FieldType R[i] (@ComplexField.field_axiom R). -Canonical complex_numDomainType (R : rcfType) := - NumDomainType R[i] (ComplexField.complex_POrderedMixin R). -Canonical complex_numFieldType (R : rcfType) := - [numFieldType of complex R]. - +Canonical ComplexField.complex_zmodType. +Canonical ComplexField.complex_lmodType. +Canonical ComplexField.complex_ringType. +Canonical ComplexField.complex_comRingType. +Canonical ComplexField.complex_unitRingType. +Canonical ComplexField.complex_comUnitRingType. +Canonical ComplexField.complex_idomainType. +Canonical ComplexField.complex_fieldType. +Canonical ComplexField.complex_numDomainType. +Canonical complex_numFieldType (R : rcfType) := [numFieldType of complex R]. Canonical ComplexField.real_complex_rmorphism. Canonical ComplexField.real_complex_additive. Canonical ComplexField.Re_additive. Canonical ComplexField.Im_additive. Definition conjc {R : ringType} (x : R[i]) := let: a +i* b := x in a -i* b. -Notation "x ^*" := (conjc x) (at level 2, format "x ^*"). +Notation "x ^*" := (conjc x) (at level 2, format "x ^*") : complex_scope. +Local Open Scope complex_scope. +Delimit Scope complex_scope with C. Ltac simpc := do ? - [ rewrite -[(_ +i* _) - (_ +i* _)]/(_ +i* _) - | rewrite -[(_ +i* _) + (_ +i* _)]/(_ +i* _) - | rewrite -[(_ +i* _) * (_ +i* _)]/(_ +i* _) - | rewrite -[(_ +i* _) <= (_ +i* _)]/((_ == _) && (_ <= _)) - | rewrite -[(_ +i* _) < (_ +i* _)]/((_ == _) && (_ < _)) - | rewrite -[`|_ +i* _|]/(sqrtr (_ + _))%:C + [ rewrite -[- (_ +i* _)%C]/(_ +i* _)%C + | rewrite -[(_ +i* _)%C - (_ +i* _)%C]/(_ +i* _)%C + | rewrite -[(_ +i* _)%C + (_ +i* _)%C]/(_ +i* _)%C + | rewrite -[(_ +i* _)%C * (_ +i* _)%C]/(_ +i* _)%C + | rewrite -[(_ +i* _)%C ^*]/(_ +i* _)%C + | rewrite -[_ *: (_ +i* _)%C]/(_ +i* _)%C + | rewrite -[(_ +i* _)%C <= (_ +i* _)%C]/((_ == _) && (_ <= _)) + | rewrite -[(_ +i* _)%C < (_ +i* _)%C]/((_ == _) && (_ < _)) + | rewrite -[`|(_ +i* _)%C|]/(sqrtr (_ + _))%:C%C | rewrite (mulrNN, mulrN, mulNr, opprB, opprD, mulr0, mul0r, subr0, sub0r, addr0, add0r, mulr1, mul1r, subrr, opprK, oppr0, eqxx) ]. @@ -341,18 +338,18 @@ Section ComplexTheory. Variable R : rcfType. -Lemma ReiNIm : forall x : R[i], Re (x * 'i) = - Im x. +Lemma ReiNIm : forall x : R[i], Re (x * 'i%C) = - Im x. Proof. by case=> a b; simpc. Qed. -Lemma ImiRe : forall x : R[i], Im (x * 'i) = Re x. +Lemma ImiRe : forall x : R[i], Im (x * 'i%C) = Re x. Proof. by case=> a b; simpc. Qed. -Lemma complexE x : x = (Re x)%:C + 'i * (Im x)%:C :> R[i]. +Lemma complexE x : x = (Re x)%:C + 'i%C * (Im x)%:C :> R[i]. Proof. by case: x => *; simpc. Qed. Lemma real_complexE x : x%:C = x +i* 0 :> R[i]. Proof. done. Qed. -Lemma sqr_i : 'i ^+ 2 = -1 :> R[i]. +Lemma sqr_i : 'i%C ^+ 2 = -1 :> R[i]. Proof. by rewrite exprS; simpc; rewrite -real_complexE rmorphN. Qed. Lemma complexI : injective (real_complex R). Proof. by move=> x y []. Qed. @@ -377,13 +374,17 @@ split=> [[a b] [c d]|] /=; first by simpc; rewrite [d - _]addrC. by split=> [[a b] [c d]|] /=; simpc. Qed. +Lemma conjc_is_scalable : scalable (@conjc R). +Proof. by move=> a [b c]; simpc. Qed. + Canonical conjc_rmorphism := RMorphism conjc_is_rmorphism. Canonical conjc_additive := Additive conjc_is_rmorphism. +Canonical conjc_linear := AddLinear conjc_is_scalable. Lemma conjcK : involutive (@conjc R). Proof. by move=> [a b] /=; rewrite opprK. Qed. -Lemma mulcJ_ge0 (x : R[i]) : 0 <= x * x ^*. +Lemma mulcJ_ge0 (x : R[i]) : 0 <= x * x^*%C. Proof. by move: x=> [a b]; simpc; rewrite mulrC addNr eqxx addr_ge0 ?sqr_ge0. Qed. @@ -391,14 +392,14 @@ Qed. Lemma conjc_real (x : R) : x%:C^* = x%:C. Proof. by rewrite /= oppr0. Qed. -Lemma ReJ_add (x : R[i]) : (Re x)%:C = (x + x^*) / 2%:R. +Lemma ReJ_add (x : R[i]) : (Re x)%:C = (x + x^*%C) / 2%:R. Proof. case: x => a b; simpc; rewrite [0 ^+ 2]mul0r addr0 /=. rewrite -!mulr2n -mulr_natr -mulrA [_ * (_ / _)]mulrA. by rewrite divff ?mulr1 // -natrM pnatr_eq0. Qed. -Lemma ImJ_sub (x : R[i]) : (Im x)%:C = (x^* - x) / 2%:R * 'i. +Lemma ImJ_sub (x : R[i]) : (Im x)%:C = (x^*%C - x) / 2%:R * 'i%C. Proof. case: x => a b; simpc; rewrite [0 ^+ 2]mul0r addr0 /=. rewrite -!mulr2n -mulr_natr -mulrA [_ * (_ / _)]mulrA. @@ -426,7 +427,7 @@ Proof. exact: (conjc_nat 1). Qed. Lemma conjc_eq0 : forall x : R[i], (x ^* == 0) = (x == 0). Proof. by move=> [a b]; rewrite !eq_complex /= eqr_oppLR oppr0. Qed. -Lemma conjc_inv: forall x : R[i], (x^-1)^* = (x^* )^-1. +Lemma conjc_inv: forall x : R[i], (x^-1)^* = (x^*%C )^-1. Proof. exact: fmorphV. Qed. Lemma complex_root_conj (p : {poly R[i]}) (x : R[i]) : @@ -448,18 +449,36 @@ Qed. Lemma normc_def (z : R[i]) : `|z| = (sqrtr ((Re z)^+2 + (Im z)^+2))%:C. Proof. by case: z. Qed. -Lemma add_Re2_Im2 (z : R[i]) : ((Re z)^+2 + (Im z)^+2)%:C = `|z|^+2. +Lemma add_Re2_Im2 (z : R[i]) : ((Re z)^+2 + (Im z)^+2)%:C = `|z|^+2. Proof. by rewrite normc_def -rmorphX sqr_sqrtr ?addr_ge0 ?sqr_ge0. Qed. -Lemma addcJ (z : R[i]) : z + z^* = 2%:R * (Re z)%:C. +Lemma addcJ (z : R[i]) : z + z^*%C = 2%:R * (Re z)%:C. Proof. by rewrite ReJ_add mulrC mulfVK ?pnatr_eq0. Qed. -Lemma subcJ (z : R[i]) : z - z^* = 2%:R * (Im z)%:C * 'i. +Lemma subcJ (z : R[i]) : z - z^*%C = 2%:R * (Im z)%:C * 'i%C. Proof. rewrite ImJ_sub mulrCA mulrA mulfVK ?pnatr_eq0 //. -by rewrite -mulrA ['i * _]sqr_i mulrN1 opprB. +by rewrite -mulrA ['i%C * _]sqr_i mulrN1 opprB. Qed. +Lemma complex_real (a b : R) : a +i* b \is Num.real = (b == 0). +Proof. +rewrite realE; simpc; rewrite [0 == _]eq_sym. +by have [] := ltrgtP 0 a; rewrite ?(andbF, andbT, orbF, orbb). +Qed. + +Lemma complex_realP (x : R[i]) : reflect (exists y, x = y%:C) (x \is Num.real). +Proof. +case: x=> [a b] /=; rewrite complex_real. +by apply: (iffP eqP) => [->|[c []//]]; exists a. +Qed. + +Lemma RRe_real (x : R[i]) : x \is Num.real -> (Re x)%:C = x. +Proof. by move=> /complex_realP [y ->]. Qed. + +Lemma RIm_real (x : R[i]) : x \is Num.real -> (Im x)%:C = 0. +Proof. by move=> /complex_realP [y ->]. Qed. + End ComplexTheory. (* Section RcfDef. *) @@ -593,13 +612,13 @@ apply/eqP/eqP=> [eqs|->]; last by rewrite sqrtc0. by rewrite -[x]sqr_sqrtc eqs exprS mul0r. Qed. -Lemma normcE x : `|x| = sqrtc (x * x^*). +Lemma normcE x : `|x| = sqrtc (x * x^*%C). Proof. case: x=> a b; simpc; rewrite [b * a]mulrC addNr sqrtc_sqrtr //. by simpc; rewrite /= addr_ge0 ?sqr_ge0. Qed. -Lemma sqr_normc (x : R[i]) : (`|x| ^+ 2) = x * x^*. +Lemma sqr_normc (x : R[i]) : (`|x| ^+ 2) = x * x^*%C. Proof. by rewrite normcE sqr_sqrtc. Qed. Lemma normc_ge_Re (x : R[i]) : `|Re x|%:C <= `|x|. @@ -607,17 +626,17 @@ Proof. by case: x => a b; simpc; rewrite -sqrtr_sqr ler_wsqrtr // ler_addl sqr_ge0. Qed. -Lemma normcJ (x : R[i]) : `|x^*| = `|x|. +Lemma normcJ (x : R[i]) : `|x^*%C| = `|x|. Proof. by case: x => a b; simpc; rewrite /= sqrrN. Qed. -Lemma invc_norm (x : R[i]) : x^-1 = `|x|^-2 * x^*. +Lemma invc_norm (x : R[i]) : x^-1 = `|x|^-2 * x^*%C. Proof. case: (altP (x =P 0)) => [->|dx]; first by rewrite rmorph0 mulr0 invr0. -apply: (mulIf dx); rewrite mulrC divff // -mulrA [_^* * _]mulrC -(sqr_normc x). +apply: (mulIf dx); rewrite mulrC divff // -mulrA [_^*%C * _]mulrC -(sqr_normc x). by rewrite mulVf // expf_neq0 ?normr_eq0. Qed. -Lemma canonical_form (a b c : R[i]) : +Lemma canonical_form (a b c : R[i]) : a != 0 -> let d := b ^+ 2 - 4%:R * a * c in let r1 := (- b - sqrtc d) / 2%:R / a in @@ -637,7 +656,7 @@ rewrite sqr_sqrtc sqrrN /d opprB addrC addrNK -2!mulrA. by rewrite mulrACA -natf_div // mul1r mulrAC divff ?mul1r. Qed. -Lemma monic_canonical_form (b c : R[i]) : +Lemma monic_canonical_form (b c : R[i]) : let d := b ^+ 2 - 4%:R * c in let r1 := (- b - sqrtc d) / 2%:R in let r2 := (- b + sqrtc d) / 2%:R in @@ -649,12 +668,12 @@ Qed. Section extramx. (* missing lemmas from matrix.v or mxalgebra.v *) -Lemma mul_mx_rowfree_eq0 (K : fieldType) (m n p: nat) - (W : 'M[K]_(m,n)) (V : 'M[K]_(n,p)) : +Lemma mul_mx_rowfree_eq0 (K : fieldType) (m n p: nat) + (W : 'M[K]_(m,n)) (V : 'M[K]_(n,p)) : row_free V -> (W *m V == 0) = (W == 0). Proof. by move=> free; rewrite -!mxrank_eq0 mxrankMfree ?mxrank_eq0. Qed. -Lemma sub_sums_genmxP (F : fieldType) (I : finType) (P : pred I) (m n : nat) +Lemma sub_sums_genmxP (F : fieldType) (I : finType) (P : pred I) (m n : nat) (A : 'M[F]_(m, n)) (B_ : I -> 'M_(m, n)) : reflect (exists u_ : I -> 'M_m, A = \sum_(i | P i) u_ i *m B_ i) (A <= \sum_(i | P i) <>)%MS. @@ -706,7 +725,7 @@ rewrite eq_mviE xpair_eqE -!val_eqE /= eq_sym andbb. rewrite ltn_eqF // subr0 mulr1 summxE big1. rewrite [w as X in X *m _]mx11_scalar => ->. by rewrite mul_scalar_mx scale0r submx0. -move=> [i' j'] /= /andP[lt_j'i']. +move=> [i' j'] /= /andP[lt_j'i']. rewrite xpair_eqE /= => neq'_ij. rewrite /= !mxvec_delta !mxE big_ord1 !mxE !eqxx !eq_mviE. rewrite !xpair_eqE /= [_ == i']eq_sym [_ == j']eq_sym (negPf neq'_ij) /=. @@ -730,7 +749,7 @@ rewrite (eq_bigr (fun _ => 1%N)); last first. by move/eqP; rewrite oner_eq0. transitivity (\sum_(i < n) (\sum_(j < n | j < i) 1))%N. by rewrite pair_big_dep. -apply: eq_bigr => [] [[|i] Hi] _ /=; first by rewrite big1. +apply: eq_bigr => [] [[|i] Hi] _ /=; first by rewrite big1. rewrite (eq_bigl _ _ (fun _ => ltnS _ _)). have [n_eq0|n_gt0] := posnP n; first by move: Hi (Hi); rewrite {1}n_eq0. rewrite -[n]prednK // big_ord_narrow_leq /=. @@ -795,13 +814,13 @@ case: sp => [|sp] in Hsp *. move: Hsp => /eqP/size_poly1P/sig2_eqW [c c_neq0 ->]. by exists ((-c)%:M); rewrite monicE lead_coefC => /eqP ->; apply: det_mx00. have addn1n n : (n + 1 = 1 + n)%N by rewrite addn1. -exists (castmx (erefl _, addn1n _) +exists (castmx (erefl _, addn1n _) (block_mx (\row_(i < sp) - p`_(sp - i)) (-p`_0)%:M 1%:M 0)). elim/poly_ind: p sp Hsp (addn1n _) => [|p c IHp] sp; first by rewrite size_poly0. rewrite size_MXaddC. have [->|p_neq0] //= := altP eqP; first by rewrite size_poly0; case: ifP. -move=> [Hsp] eq_cast. +move=> [Hsp] eq_cast. rewrite monicE lead_coefDl ?size_polyC ?size_mul ?polyX_eq0 //; last first. by rewrite size_polyX addn2 Hsp ltnS (leq_trans (leq_b1 _)). rewrite lead_coefMX -monicE => p_monic. @@ -845,7 +864,7 @@ congr (_ * 'X + c%:P * _). apply/matrixP => k l; rewrite !simp. case: splitP => k' /=; rewrite ?ord1 /bump ltnNge leq_ord add0n. case: splitP => [k'' /= |k'' -> //]; rewrite ord1 !simp => k_eq0 _. - case: splitP => l' /=; rewrite ?ord1 /bump ltnNge leq_ord add0n !simp; + case: splitP => l' /=; rewrite ?ord1 /bump ltnNge leq_ord add0n !simp; last by move/eqP; rewrite ?addn0 ltn_eqF. move<-; case: splitP => l'' /=; rewrite ?ord1 ?addn0 !simp. by move<-; rewrite subSn ?leq_ord ?coefE. @@ -853,7 +872,7 @@ congr (_ * 'X + c%:P * _). by rewrite !rmorphN ?subnn addr0. case: splitP => k'' /=; rewrite ?ord1 => -> // []; rewrite !simp. case: splitP => l' /=; rewrite /bump ltnNge leq_ord add0n !simp -?val_eqE /=; - last by rewrite ord1 addn0 => /eqP; rewrite ltn_eqF. + last by rewrite ord1 addn0 => /eqP; rewrite ltn_eqF. by case: splitP => l'' /= -> <- <-; rewrite !simp // ?ord1 ?addn0 ?ltn_eqF. move=> {IHp Hsp p_neq0 p_monic}; rewrite add0n; set s := _ ^+ _; apply: (@mulfI _ s); first by rewrite signr_eq0. @@ -958,7 +977,7 @@ Definition CommonEigenVec_def K (phK : phant K) (d r : nat) := exists2 v : 'rV_m, (v != 0) & forall f, f \in sf -> exists a, (v <= eigenspace f a)%MS. Notation CommonEigenVec K d r := (@CommonEigenVec_def _ (Phant K) d r). - + Definition Eigen1Vec_def K (phK : phant K) (d : nat) := forall (m : nat) (V : 'M[K]_m), ~~ (d %| \rank V) -> forall (f : 'M_m), (V *m f <= V)%MS -> exists a, eigenvalue f a. @@ -1028,7 +1047,7 @@ have [eqWV|neqWV] := altP (@eqmxP _ _ _ _ W 1%:M). by exists a; rewrite -eigenspace_restrict // eqWV submx1. have lt_WV : (\rank W < \rank V)%N. rewrite -[X in (_ < X)%N](@mxrank1 K) rank_ltmx //. - by rewrite ltmxEneq neqWV // submx1. + by rewrite ltmxEneq neqWV // submx1. have ltZV : (\rank Z < \rank V)%N. rewrite -[X in (_ < X)%N]rWZ -subn_gt0 addnK lt0n mxrank_eq0 -lt0mx. move: a_eigen_f' => /eigenvalueP [v /eigenspaceP] sub_vW v_neq0. @@ -1067,16 +1086,16 @@ suff: exists a, eigenvalue (restrict V f) a. by move=> [a /eigenvalue_restrict Hf]; exists a; apply: Hf. move: (\rank V) (restrict V f) => {f f_stabV V m} n f in HrV *. pose u := map_mx (@Re R) f; pose v := map_mx (@Im R) f. -have fE : f = MtoC u + 'i *: MtoC v. +have fE : f = MtoC u + 'i%C *: MtoC v. rewrite /u /v [f]lock; apply/matrixP => i j; rewrite !mxE /=. by case: (locked f i j) => a b; simpc. move: u v => u v in fE *. pose L1fun : 'M[R]_n -> _ := - 2%:R^-1 \*: (mulmxr u \+ (mulmxr v \o trmx) + 2%:R^-1 \*: (mulmxr u \+ (mulmxr v \o trmx) \+ ((mulmx (u^T)) \- (mulmx (v^T) \o trmx))). pose L1 := lin_mx [linear of L1fun]. pose L2fun : 'M[R]_n -> _ := - 2%:R^-1 \*: (((@GRing.opp _) \o (mulmxr u \o trmx) \+ mulmxr v) + 2%:R^-1 \*: (((@GRing.opp _) \o (mulmxr u \o trmx) \+ mulmxr v) \+ ((mulmx (u^T) \o trmx) \+ (mulmx (v^T)))). pose L2 := lin_mx [linear of L2fun]. have [] := @Lemma4 _ _ 1%:M _ [::L1; L2] (erefl _). @@ -1111,7 +1130,7 @@ do [move=> /(congr1 vec_mx); rewrite mxvecK linearZ /=] in g_eigenL2. move=> {L1 L2 L1fun L2fun Hg HrV}. set vg := vec_mx g in g_eigenL1 g_eigenL2. exists (a +i* b); apply/eigenvalueP. -pose w := (MtoC vg - 'i *: MtoC vg^T). +pose w := (MtoC vg - 'i%C *: MtoC vg^T). exists (nz_row w); last first. rewrite nz_row_eq0 subr_eq0; apply: contraNneq g_neq0 => Hvg. rewrite -vec_mx_eq0; apply/eqP/matrixP => i j; rewrite !mxE /=. @@ -1124,11 +1143,11 @@ rewrite (submx_trans (nz_row_sub _)) //; apply/eigenspaceP. rewrite fE [a +i* b]complexE /=. rewrite !(mulmxDr, mulmxBl, =^~scalemxAr, =^~scalemxAl) -!map_mxM. rewrite !(scalerDl, scalerDr, scalerN, =^~scalemxAr, =^~scalemxAl). -rewrite !scalerA /= mulrAC ['i * _]sqr_i ?mulN1r scaleN1r scaleNr !opprK. -rewrite [_ * 'i]mulrC -!scalerA -!map_mxZ /=. -do 2!rewrite [X in (_ - _) + X]addrC [_ - 'i *: _ + _]addrACA. +rewrite !scalerA /= mulrAC ['i%C * _]sqr_i ?mulN1r scaleN1r scaleNr !opprK. +rewrite [_ * 'i%C]mulrC -!scalerA -!map_mxZ /=. +do 2!rewrite [X in (_ - _) + X]addrC [_ - 'i%C *: _ + _]addrACA. rewrite ![- _ + _]addrC -!scalerBr -!(rmorphB, rmorphD) /=. -congr (_ + 'i *: _); congr map_mx; rewrite -[_ *: _^T]linearZ /=; +congr (_ + 'i%C *: _); congr map_mx; rewrite -[_ *: _^T]linearZ /=; rewrite -g_eigenL1 -g_eigenL2 linearZ -(scalerDr, scalerBr); do ?rewrite ?trmxK ?trmx_mul ?[(_ + _)^T]linearD ?[(- _)^T]linearN /=; rewrite -[in X in _ *: (_ + X)]addrC 1?opprD 1?opprB ?mulmxN ?mulNmx; @@ -1206,8 +1225,8 @@ move=> /(_ m.+1 1 _ f) []; last by move=> a; exists a. + by rewrite mxrank1 (contra (dvdn_leq _)) // -ltnNge ltn_expl. + by rewrite submx1. Qed. - -Lemma C_acf_axiom : GRing.ClosedField.axiom [ringType of R[i]]. + +Lemma complex_acf_axiom : GRing.ClosedField.axiom [ringType of R[i]]. Proof. move=> n c n_gt0; pose p := 'X^n - \poly_(i < n) c i. suff [x rpx] : exists x, root p x. @@ -1223,14 +1242,67 @@ have [] := Theorem7' (companion p); first by rewrite -(subnK sp_gt1) addn2. by move=> x; rewrite eigenvalue_root_char companionK //; exists x. Qed. -Definition C_decFieldMixin := closed_fields_QEMixin C_acf_axiom. -Canonical C_decField := DecFieldType R[i] C_decFieldMixin. -Canonical C_closedField := ClosedFieldType R[i] C_acf_axiom. +Definition complex_decFieldMixin := closed_fields_QEMixin complex_acf_axiom. +Canonical complex_decField := DecFieldType R[i] complex_decFieldMixin. +Canonical complex_closedField := ClosedFieldType R[i] complex_acf_axiom. + +Definition complex_numClosedFieldMixin := + ImaginaryMixin (sqr_i R) (fun x=> esym (sqr_normc x)). + +Canonical complex_numClosedFieldType := + NumClosedFieldType R[i] complex_numClosedFieldMixin. End Paper_HarmDerksen. End ComplexClosed. +(* End ComplexInternal. *) + +(* Canonical ComplexInternal.complex_eqType. *) +(* Canonical ComplexInternal.complex_choiceType. *) +(* Canonical ComplexInternal.complex_countType. *) +(* Canonical ComplexInternal.complex_ZmodType. *) +(* Canonical ComplexInternal.complex_Ring. *) +(* Canonical ComplexInternal.complex_comRing. *) +(* Canonical ComplexInternal.complex_unitRing. *) +(* Canonical ComplexInternal.complex_comUnitRing. *) +(* Canonical ComplexInternal.complex_iDomain. *) +(* Canonical ComplexInternal.complex_fieldType. *) +(* Canonical ComplexInternal.ComplexField.real_complex_rmorphism. *) +(* Canonical ComplexInternal.ComplexField.real_complex_additive. *) +(* Canonical ComplexInternal.ComplexField.Re_additive. *) +(* Canonical ComplexInternal.ComplexField.Im_additive. *) +(* Canonical ComplexInternal.complex_numDomainType. *) +(* Canonical ComplexInternal.complex_numFieldType. *) +(* Canonical ComplexInternal.conjc_rmorphism. *) +(* Canonical ComplexInternal.conjc_additive. *) +(* Canonical ComplexInternal.complex_decField. *) +(* Canonical ComplexInternal.complex_closedField. *) +(* Canonical ComplexInternal.complex_numClosedFieldType. *) + +(* Definition complex_algebraic_trans := ComplexInternal.complex_algebraic_trans. *) + +Section ComplexClosedTheory. + +Variable R : rcfType. + +Lemma complexiE : 'i%C = 'i%R :> R[i]. +Proof. by []. Qed. + +Lemma complexRe (x : R[i]) : (Re x)%:C = 'Re x. +Proof. +rewrite {1}[x]Crect raddfD /= mulrC ReiNIm rmorphB /=. +by rewrite ?RRe_real ?RIm_real ?Creal_Im ?Creal_Re // subr0. +Qed. + +Lemma complexIm (x : R[i]) : (Im x)%:C = 'Im x. +Proof. +rewrite {1}[x]Crect raddfD /= mulrC ImiRe rmorphD /=. +by rewrite ?RRe_real ?RIm_real ?Creal_Im ?Creal_Re // add0r. +Qed. + +End ComplexClosedTheory. + Definition complexalg := realalg[i]. Canonical complexalg_eqType := [eqType of complexalg]. diff --git a/mathcomp/real_closed/polyrcf.v b/mathcomp/real_closed/polyrcf.v index 949dec0..c29cb96 100644 --- a/mathcomp/real_closed/polyrcf.v +++ b/mathcomp/real_closed/polyrcf.v @@ -360,48 +360,6 @@ rewrite !mul1r mulrC -ltr_subl_addr. by rewrite (ler_lt_trans _ (He' y _)) // ler_sub_dist. Qed. -(* Todo : orderedpoly !! *) -(* Lemma deriv_expz_nat (n : nat) p : (p ^ n)^`() = (p^`() * p ^ (n.-1)) *~ n. *) -(* Proof. *) -(* elim: n => [|n ihn] /= in p *; first by rewrite expr0z derivC mul0zr. *) -(* rewrite exprSz_nat derivM ihn mulzrAr mulrCA -exprSz_nat. *) -(* by case: n {ihn}=> [|n] //; rewrite mul0zr addr0 mul1zr. *) -(* Qed. *) - -(* Definition derivCE := (derivE, deriv_expz_nat). *) - -(* Lemma size_poly_ind : forall K : {poly R} -> Prop, *) -(* K 0 -> *) -(* (forall p sp, size p = sp.+1 -> *) -(* forall q, (size q <= sp)%N -> K q -> K p) *) -(* -> forall p, K p. *) -(* Proof. *) -(* move=> K K0 ihK p. *) -(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *) -(* by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *) -(* case spSn: (size p == n.+1). *) -(* move/eqP:spSn; move/ihK=> ihKp; apply: (ihKp 0)=>//. *) -(* by rewrite size_poly0. *) -(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn. *) -(* Qed. *) - -(* Lemma size_poly_indW : forall K : {poly R} -> Prop, *) -(* K 0 -> *) -(* (forall p sp, size p = sp.+1 -> *) -(* forall q, size q = sp -> K q -> K p) *) -(* -> forall p, K p. *) -(* Proof. *) -(* move=> K K0 ihK p. *) -(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *) -(* by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *) -(* case spSn: (size p == n.+1). *) -(* move/eqP:spSn; move/ihK=> ihKp; case: n ihn spn ihKp=> [|n] ihn spn ihKp. *) -(* by apply: (ihKp 0)=>//; rewrite size_poly0. *) -(* apply: (ihKp 'X^n)=>//; first by rewrite size_polyXn. *) -(* by apply: ihn; rewrite size_polyXn. *) -(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn. *) -(* Qed. *) - Lemma poly_ltsp_roots p (rs : seq R) : (size rs >= size p)%N -> uniq rs -> all (root p) rs -> p = 0. Proof. -- cgit v1.2.3 From 3a17aed49fc44439636709dad46c3ffa736ffec5 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Thu, 25 Aug 2016 01:39:32 +0200 Subject: Factor theorem for decidable fields, (inspired by PY Strub) --- mathcomp/algebra/poly.v | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) (limited to 'mathcomp') diff --git a/mathcomp/algebra/poly.v b/mathcomp/algebra/poly.v index 1209289..7e5d204 100644 --- a/mathcomp/algebra/poly.v +++ b/mathcomp/algebra/poly.v @@ -2541,6 +2541,33 @@ Definition prim_rootP := prim_rootP. End UnityRootTheory. +Section DecField. + +Variable F : decFieldType. + +Lemma dec_factor_theorem (p : {poly F}) : p != 0 -> + {s : seq F & {q : {poly F} | p = q * \prod_(x <- s) ('X - x%:P) + /\ forall x, ~~ root q x }}. +Proof. +pose polyT (p : seq F) := (foldr (fun c f => f * 'X_0 + c%:T) (0%R)%:T p)%T. +have eval_polyT (q : {poly F}) x : GRing.eval [:: x] (polyT q) = q.[x]. + by rewrite /horner; elim: (val q) => //= ? ? ->. +elim: size {-2}p (leqnn (size p)) => [?|n IHn {p} p sp_ltSn p_neq0]. + by move=> /size_poly_leq0P->; rewrite eqxx. +have /decPcases /= := @satP F [::] ('exists 'X_0, polyT p == 0%T). +case: ifP => [_ /sig_eqW[x]|_ noroot]; last first. + exists [::], p; rewrite big_nil mulr1; split => // x. + by apply/negP=> /rootP rpx; apply noroot; exists x; rewrite eval_polyT. +rewrite eval_polyT => /rootP /factor_theorem /sig_eqW [q p_eq]. +move: p_neq0 sp_ltSn; rewrite p_eq {p_eq}. +rewrite mulf_eq0 polyXsubC_eq0 orbF => q_neq0. +rewrite size_mul ?polyXsubC_eq0 // ?size_XsubC addn2 /= ltnS => sq_le_n. +have [] // := IHn q => s [r [-> nr]]; exists (s ++ [::x]), r. +by rewrite big_cat /= big_seq1 mulrA. +Qed. + +End DecField. + Module PreClosedField. Section UseAxiom. -- cgit v1.2.3 From 76794e738bc9c2f9e26dfafab94ccfac39ce50de Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 25 Aug 2016 13:58:30 +0200 Subject: FIX: adding missing version of the ssreflect plugin that compiles with Coq v8.6. The committed files represent copies of the ssreflect plugin for Coq trunk taken from commit c353aa5 which is the last commit in which ssreflect plugin marked for Coq trunk is usable with both, Coq trunk as well as Coq v8.6. --- mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 | 6242 ++++++++++++++++++++ .../ssreflect/plugin/v8.6/ssreflect_plugin.mlpack | 2 + 2 files changed, 6244 insertions(+) create mode 100644 mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 create mode 100644 mathcomp/ssreflect/plugin/v8.6/ssreflect_plugin.mlpack (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 new file mode 100644 index 0000000..666b46e --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 @@ -0,0 +1,6242 @@ +(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* Distributed under the terms of CeCILL-B. *) + +(* This line is read by the Makefile's dist target: do not remove. *) +DECLARE PLUGIN "ssreflect_plugin" +let ssrversion = "1.6";; +let ssrAstVersion = 1;; +let () = Mltop.add_known_plugin (fun () -> + if Flags.is_verbose () && not !Flags.batch_mode then begin + Printf.printf "\nSmall Scale Reflection version %s loaded.\n" ssrversion; + Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; + Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" + end) + "ssreflect_plugin" +;; + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = CLexer.freeze () ;; + +(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Names +open Pp +open Feedback +open Pcoq +open Pcoq.Prim +open Pcoq.Constr +open Genarg +open Stdarg +open Constrarg +open Term +open Vars +open Context +open Topconstr +open Libnames +open Tactics +open Tacticals +open Termops +open Namegen +open Recordops +open Tacmach +open Coqlib +open Glob_term +open Util +open Evd +open Sigma.Notations +open Extend +open Goptions +open Tacexpr +open Tacinterp +open Pretyping +open Constr +open Tactic +open Extraargs +open Ppconstr +open Printer + +open Globnames +open Misctypes +open Decl_kinds +open Evar_kinds +open Constrexpr +open Constrexpr_ops +open Notation_term +open Notation_ops +open Locus +open Locusops + +open Compat +open Tok + +open Ssrmatching_plugin +open Ssrmatching + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(* Tentative patch from util.ml *) + +let array_fold_right_from n f v a = + let rec fold n = + if n >= Array.length v then a else f v.(n) (fold (succ n)) + in + fold n + +let array_app_tl v l = + if Array.length v = 0 then invalid_arg "array_app_tl"; + array_fold_right_from 1 (fun e l -> e::l) v l + +let array_list_of_tl v = + if Array.length v = 0 then invalid_arg "array_list_of_tl"; + array_fold_right_from 1 (fun e l -> e::l) v [] + +(* end patch *) + +module Intset = Evar.Set + +type loc = Loc.t +let dummy_loc = Loc.ghost +let errorstrm = CErrors.errorlabstrm "ssreflect" +let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg) +let anomaly s = CErrors.anomaly (str s) + +(* Compatibility with Coq 8.6 *) +let ppnl = msg_info +let msgnl = msg_info + +let mk_reldecl name obody ty = + match obody with + | None -> RelDecl.LocalAssum (name, ty) + | Some bo -> RelDecl.LocalDef (name, bo, ty) + +(** look up a name in the ssreflect internals module *) +let ssrdirpath = make_dirpath [id_of_string "ssreflect"] +let ssrqid name = make_qualid ssrdirpath (id_of_string name) +let ssrtopqid name = make_short_qualid (id_of_string name) +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) +let mkSsrRef name = + try locate_reference (ssrqid name) with Not_found -> + try locate_reference (ssrtopqid name) with Not_found -> + CErrors.error "Small scale reflection library not loaded" +let mkSsrRRef name = GRef (dummy_loc, mkSsrRef name,None), None +let mkSsrConst name env sigma = + Sigma.fresh_global env sigma (mkSsrRef name) +let pf_mkSsrConst name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (t, sigma, _) = mkSsrConst name env sigma in + let sigma = Sigma.to_evar_map sigma in + t, re_sig it sigma +let pf_fresh_global name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma,t = Evd.fresh_global env sigma name in + t, re_sig it sigma + +(** Ssreflect load check. *) + +(* To allow ssrcoq to be fully compatible with the "plain" Coq, we only *) +(* turn on its incompatible features (the new rewrite syntax, and the *) +(* reserved identifiers) when the theory library (ssreflect.v) has *) +(* has actually been required, or is being defined. Because this check *) +(* needs to be done often (for each identifier lookup), we implement *) +(* some caching, repeating the test only when the environment changes. *) +(* We check for protect_term because it is the first constant loaded; *) +(* ssr_have would ultimately be a better choice. *) +let ssr_loaded = Summary.ref ~name:"SSR:loaded" false +let is_ssr_loaded () = + !ssr_loaded || + (if CLexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; + !ssr_loaded) + +(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) +(* or if SsrDebug is Set *) +let pp_ref = ref (fun _ -> ()) +let ssr_pp s = msg_error (str"SSR: "++Lazy.force s) +let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect debugging"; + Goptions.optkey = ["SsrDebug"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = (fun b -> + Ssrmatching.debug b; + if b then pp_ref := ssr_pp else pp_ref := fun _ -> ()) } +let pp s = !pp_ref s + +(** Utils {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] +let get_index = function ArgArg i -> i | _ -> + anomaly "Uninterpreted index" +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist genv = function + | _, Some ce -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in + let ltacvars = { + Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen WithoutTypeConstraint ~ltacvars genv ce + | rc, None -> rc + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +let skip_numchars s = + let rec loop i = match s.[i] with '0'..'9' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + msg_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let prl_constr = pr_lconstr +let pr_constr = pr_constr +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit = Genarg.make0 tag in + let tag = Geninterp.Val.create tag in + let glob ist x = (ist, x) in + let subst _ x = x in + let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in + let gen_pr _ _ _ = pr in + let () = Genintern.register_intern0 wit glob in + let () = Genintern.register_subst0 wit subst in + let () = Geninterp.register_interp0 wit interp in + let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in + Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; + wit + +(** Constructors for cast type *) +let dC t = CastConv t + +(** Constructors for constr_expr *) +let mkCProp loc = CSort (loc, GProp) +let mkCType loc = CSort (loc, GType []) +let mkCVar loc id = CRef (Ident (loc, id),None) +let isCVar = function CRef (Ident _,_) -> true | _ -> false +let destCVar = function CRef (Ident (_, id),_) -> id | _ -> + anomaly "not a CRef" +let rec mkCHoles loc n = + if n <= 0 then [] else CHole (loc, None, IntroAnonymous, None) :: mkCHoles loc (n - 1) +let mkCHole loc = CHole (loc, None, IntroAnonymous, None) +let rec isCHoles = function CHole _ :: cl -> isCHoles cl | cl -> cl = [] +let mkCExplVar loc id n = + CAppExpl (loc, (None, Ident (loc, id), None), mkCHoles loc n) +let mkCLambda loc name ty t = + CLambdaN (loc, [[loc, name], Default Explicit, ty], t) +let mkCLetIn loc name bo t = + CLetIn (loc, (loc, name), bo, t) +let mkCArrow loc ty t = + CProdN (loc, [[dummy_loc,Anonymous], Default Explicit, ty], t) +let mkCCast loc t ty = CCast (loc,t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) +let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] +let rec isRHoles = function GHole _ :: cl -> isRHoles cl | cl -> cl = [] +let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) +let mkRVar id = GRef (dummy_loc, VarRef id,None) +let mkRltacVar id = GVar (dummy_loc, id) +let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) +let mkRType = GSort (dummy_loc, GType []) +let mkRProp = GSort (dummy_loc, GProp) +let mkRArrow rt1 rt2 = GProd (dummy_loc, Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = GRef (dummy_loc, ConstructRef c,None) +let mkRInd mind = GRef (dummy_loc, IndRef mind,None) +let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) + +(** Constructors for constr *) +let pf_e_type_of gl t = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, ty = Typing.type_of env sigma t in + re_sig it sigma, ty + +let mkAppRed f c = match kind_of_term f with +| Lambda (_, _, b) -> subst1 c b +| _ -> mkApp (f, [|c|]) + +let mkProt t c gl = + let prot, gl = pf_mkSsrConst "protect_term" gl in + mkApp (prot, [|t; c|]), gl + +let mkRefl t c gl = + let refl, gl = pf_fresh_global (build_coq_eq_data()).refl gl in + mkApp (refl, [|t; c|]), gl + + +(* Application to a sequence of n rels (for building eta-expansions). *) +(* The rel indices decrease down to imin (inclusive), unless n < 0, *) +(* in which case they're incresing (from imin). *) +let mkEtaApp c n imin = + if n = 0 then c else + let nargs, mkarg = + if n < 0 then -n, (fun i -> mkRel (imin + i)) else + let imax = imin + n - 1 in n, (fun i -> mkRel (imax - i)) in + mkApp (c, Array.init nargs mkarg) +(* Same, but optimizing head beta redexes *) +let rec whdEtaApp c n = + if n = 0 then c else match kind_of_term c with + | Lambda (_, _, c') -> whdEtaApp c' (n - 1) + | _ -> mkEtaApp (lift n c) n 1 +let mkType () = Universes.new_Type (Lib.cwd ()) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" + | _ -> anomaly "have: mixed G-C constr" +let loc_ofCG = function + | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s + | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm c = mk_term ' ' c + +let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty + +let map_fold_constr g f ctx acc cstr = + let array_f ctx acc x = let x, acc = f ctx acc x in acc, x in + match kind_of_term cstr with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> + cstr, acc + | Proj (x,c) -> + let c', acc = f ctx acc c in + (if c == c' then cstr else mkProj (x,c')), acc + | Cast (c,k, t) -> + let c', acc = f ctx acc c in + let t', acc = f ctx acc t in + (if c==c' && t==t' then cstr else mkCast (c', k, t')), acc + | Prod (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkProd (na, t', c')), acc + | Lambda (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkLambda (na, t', c')), acc + | LetIn (na,b,t,c) -> + let b', acc = f ctx acc b in + let t', acc = f ctx acc t in + let c', acc = f (g (na,Some b,t) ctx) acc c in + (if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')), acc + | App (c,al) -> + let c', acc = f ctx acc c in + let acc, al' = CArray.smartfoldmap (array_f ctx) acc al in + (if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al')), + acc + | Evar (e,al) -> + let acc, al' = CArray.smartfoldmap (array_f ctx) acc al in + (if Array.for_all2 (==) al al' then cstr else mkEvar (e, al')), acc + | Case (ci,p,c,bl) -> + let p', acc = f ctx acc p in + let c', acc = f ctx acc c in + let acc, bl' = CArray.smartfoldmap (array_f ctx) acc bl in + (if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else + mkCase (ci, p', c', bl')), + acc + | Fix (ln,(lna,tl,bl)) -> + let acc, tl' = CArray.smartfoldmap (array_f ctx) acc tl in + let ctx' = Array.fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc, bl' = CArray.smartfoldmap (array_f ctx') acc bl in + (if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then cstr + else mkFix (ln,(lna,tl',bl'))), acc + | CoFix(ln,(lna,tl,bl)) -> + let acc, tl' = CArray.smartfoldmap (array_f ctx) acc tl in + let ctx' = Array.fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc,bl' = CArray.smartfoldmap (array_f ctx') acc bl in + (if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then cstr + else mkCoFix (ln,(lna,tl',bl'))), acc + +let pf_merge_uc_of sigma gl = + let ucst = Evd.evar_universe_context sigma in + pf_merge_uc ucst gl + +(* }}} *) + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect profiling"; + Goptions.optkey = ["SsrProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Ssrmatching.profile b; + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers) } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +let inVersion = Libobject.declare_object { + (Libobject.default_object "SSRASTVERSION") with + Libobject.load_function = (fun _ (_,v) -> + if v <> ssrAstVersion then CErrors.error "Please recompile your .vo files"); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect version"; + Goptions.optkey = ["SsrAstVersion"]; + Goptions.optread = (fun _ -> true); + Goptions.optdepr = false; + Goptions.optwrite = (fun _ -> + Lib.add_anonymous_leaf (inVersion ssrAstVersion)) } + +let tactic_expr = Tactic.tactic_expr +let gallina_ext = Vernac_.gallina_ext +let sprintf = Printf.sprintf +let tactic_mode = G_ltac.tactic_mode + +(** 1. Utilities *) + + +let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" true +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect 1.3 compatibility flag"; + Goptions.optkey = ["SsrOldRewriteGoalsOrder"]; + Goptions.optread = (fun _ -> !ssroldreworder); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssroldreworder := b) } + +let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false + +let inHaveTCResolution = Libobject.declare_object { + (Libobject.default_object "SSRHAVETCRESOLUTION") with + Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); + Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "have type classes"; + Goptions.optkey = ["SsrHave";"NoTCResolution"]; + Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Lib.add_anonymous_leaf (inHaveTCResolution b)) } + + +(** Primitive parsing to avoid syntax conflicts with basic tactics. *) + +let accept_before_syms syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_any_id syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT _ -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_ids syms ids strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT id when List.mem id ids -> () + | _ -> raise Stream.Failure + +(** Pretty-printing utilities *) + +let pr_id = Ppconstr.pr_id +let pr_name = function Name id -> pr_id id | Anonymous -> str "_" +let pr_spc () = str " " +let pr_bar () = Pp.cut() ++ str "|" +let pr_list = prlist_with_sep + +let tacltop = (5,Ppextend.E) + +(** Tactic-level diagnosis *) + +let pf_pr_constr gl = pr_constr_env (pf_env gl) + +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) + +(* debug *) + +let pf_msg gl = + let ppgl = pr_lconstr_env (pf_env gl) (project gl) (pf_concl gl) in + msgnl (str "goal is " ++ ppgl) + +let msgtac gl = pf_msg gl; tclIDTAC gl + +(** Tactic utilities *) + +let last_goal gls = let sigma, gll = Refiner.unpackage gls in + Refiner.repackage sigma (List.nth gll (List.length gll - 1)) + +let pf_type_id gl t = id_of_string (hdchar (pf_env gl) t) + +let not_section_id id = not (is_section_variable id) + +let is_pf_var c = isVar c && not_section_id (destVar c) + +let pf_ids_of_proof_hyps gl = + let add_hyp decl ids = + let id = NamedDecl.get_id decl in + if not_section_id id then id :: ids else ids in + Context.Named.fold_outside add_hyp (pf_hyps gl) ~init:[] + +let pf_nf_evar gl e = Reductionops.nf_evar (project gl) e + +let pf_partial_solution gl t evl = + let sigma, g = project gl, sig_it gl in + let sigma = Goal.V82.partial_solution sigma g t in + re_sig (List.map (fun x -> (fst (destEvar x))) evl) sigma + +let pf_new_evar gl ty = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (extra, sigma, _) = Evarutil.new_evar env sigma ty in + let sigma = Sigma.to_evar_map sigma in + re_sig it sigma, extra + +(* Basic tactics *) + +let convert_concl_no_check t = convert_concl_no_check t DEFAULTcast +let convert_concl t = convert_concl t DEFAULTcast +let reduct_in_concl t = reduct_in_concl (t, DEFAULTcast) +let havetac id c = Proofview.V82.of_tactic (pose_proof (Name id) c) +let settac id c = letin_tac None (Name id) c None +let posetac id cl = Proofview.V82.of_tactic (settac id cl nowhere) +let basecuttac name c gl = + let hd, gl = pf_mkSsrConst name gl in + let t = mkApp (hd, [|c|]) in + let gl, _ = pf_e_type_of gl t in + Proofview.V82.of_tactic (apply t) gl +let apply_type x xs = Proofview.V82.of_tactic (apply_type x xs) + +(* we reduce head beta redexes *) +let betared env = + CClosure.create_clos_infos + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fBETA]) + env +;; +let introid name = tclTHEN (fun gl -> + let g, env = pf_concl gl, pf_env gl in + match kind_of_term g with + | App (hd, _) when isLambda hd -> + let g = CClosure.whd_val (betared env) (CClosure.inject g) in + Proofview.V82.of_tactic (convert_concl_no_check g) gl + | _ -> tclIDTAC gl) + (Proofview.V82.of_tactic (intro_mustbe_force name)) +;; + + +(** Name generation {{{ *******************************************************) + +(* Since Coq now does repeated internal checks of its external lexical *) +(* rules, we now need to carve ssreflect reserved identifiers out of *) +(* out of the user namespace. We use identifiers of the form _id_ for *) +(* this purpose, e.g., we "anonymize" an identifier id as _id_, adding *) +(* an extra leading _ if this might clash with an internal identifier. *) +(* We check for ssreflect identifiers in the ident grammar rule; *) +(* when the ssreflect Module is present this is normally an error, *) +(* but we provide a compatibility flag to reduce this to a warning. *) + +let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect identifiers"; + Goptions.optkey = ["SsrIdents"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ssr_reserved_ids); + Goptions.optwrite = (fun b -> ssr_reserved_ids := b) + } + +let is_ssr_reserved s = + let n = String.length s in n > 2 && s.[0] = '_' && s.[n - 1] = '_' + +let internal_names = ref [] +let add_internal_name pt = internal_names := pt :: !internal_names +let is_internal_name s = List.exists (fun p -> p s) !internal_names + +let ssr_id_of_string loc s = + if is_ssr_reserved s && is_ssr_loaded () then begin + if !ssr_reserved_ids then + loc_error loc ("The identifier " ^ s ^ " is reserved.") + else if is_internal_name s then + msg_warning (str ("Conflict between " ^ s ^ " and ssreflect internal names.")) + else msg_warning (str ( + "The name " ^ s ^ " fits the _xxx_ format used for anonymous variables.\n" + ^ "Scripts with explicit references to anonymous variables are fragile.")) + end; id_of_string s + +let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) + +let (!@) = Compat.to_coqloc + +GEXTEND Gram + GLOBAL: Prim.ident; + Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string !@loc s ]]; +END + +let mk_internal_id s = + let s' = sprintf "_%s_" s in + for i = 1 to String.length s do if s'.[i] = ' ' then s'.[i] <- '_' done; + add_internal_name ((=) s'); id_of_string s' + +let same_prefix s t n = + let rec loop i = i = n || s.[i] = t.[i] && loop (i + 1) in loop 0 + +let skip_digits s = + let n = String.length s in + let rec loop i = if i < n && is_digit s.[i] then loop (i + 1) else i in loop + +let mk_tagged_id t i = id_of_string (sprintf "%s%d_" t i) +let is_tagged t s = + let n = String.length s - 1 and m = String.length t in + m < n && s.[n] = '_' && same_prefix s t m && skip_digits s m = n + +let perm_tag = "_perm_Hyp_" +let _ = add_internal_name (is_tagged perm_tag) +let mk_perm_id = + let salt = ref 1 in + fun () -> salt := !salt mod 10000 + 1; mk_tagged_id perm_tag !salt + +let evar_tag = "_evar_" +let _ = add_internal_name (is_tagged evar_tag) +let mk_evar_name n = Name (mk_tagged_id evar_tag n) +let nb_evar_deps = function + | Name id -> + let s = string_of_id id in + if not (is_tagged evar_tag s) then 0 else + let m = String.length evar_tag in + (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) + | _ -> 0 + +let discharged_tag = "_discharged_" +let mk_discharged_id id = + id_of_string (sprintf "%s%s_" discharged_tag (string_of_id id)) +let has_discharged_tag s = + let m = String.length discharged_tag and n = String.length s - 1 in + m < n && s.[n] = '_' && same_prefix s discharged_tag m +let _ = add_internal_name has_discharged_tag +let is_discharged_id id = has_discharged_tag (string_of_id id) + +let wildcard_tag = "_the_" +let wildcard_post = "_wildcard_" +let mk_wildcard_id i = + id_of_string (sprintf "%s%s%s" wildcard_tag (String.ordinal i) wildcard_post) +let has_wildcard_tag s = + let n = String.length s in let m = String.length wildcard_tag in + let m' = String.length wildcard_post in + n < m + m' + 2 && same_prefix s wildcard_tag m && + String.sub s (n - m') m' = wildcard_post && + skip_digits s m = n - m' - 2 +let _ = add_internal_name has_wildcard_tag + +let max_suffix m (t, j0 as tj0) id = + let s = string_of_id id in let n = String.length s - 1 in + let dn = String.length t - 1 - n in let i0 = j0 - dn in + if not (i0 >= m && s.[n] = '_' && same_prefix s t m) then tj0 else + let rec loop i = + if i < i0 && s.[i] = '0' then loop (i + 1) else + if (if i < i0 then skip_digits s i = n else le_s_t i) then s, i else tj0 + and le_s_t i = + let ds = s.[i] and dt = t.[i + dn] in + if ds = dt then i = n || le_s_t (i + 1) else + dt < ds && skip_digits s i = n in + loop m + +let mk_anon_id t gl = + let m, si0, id0 = + let s = ref (sprintf "_%s_" t) in + if is_internal_name !s then s := "_" ^ !s; + let n = String.length !s - 1 in + let rec loop i j = + let d = !s.[i] in if not (is_digit d) then i + 1, j else + loop (i - 1) (if d = '0' then j else i) in + let m, j = loop (n - 1) n in m, (!s, j), id_of_string !s in + let gl_ids = pf_ids_of_hyps gl in + if not (List.mem id0 gl_ids) then id0 else + let s, i = List.fold_left (max_suffix m) si0 gl_ids in + let n = String.length s - 1 in + let rec loop i = + if s.[i] = '9' then (s.[i] <- '0'; loop (i - 1)) else + if i < m then (s.[n] <- '0'; s.[m] <- '1'; s ^ "_") else + (s.[i] <- Char.chr (Char.code s.[i] + 1); s) in + id_of_string (loop (n - 1)) + +(* We must not anonymize context names discharged by the "in" tactical. *) + +let ssr_anon_hyp = "Hyp" + +let anontac decl gl = + let id = match RelDecl.get_name decl with + | Name id -> + if is_discharged_id id then id else mk_anon_id (string_of_id id) gl + | _ -> mk_anon_id ssr_anon_hyp gl in + introid id gl + +let rec constr_name c = match kind_of_term c with + | Var id -> Name id + | Cast (c', _, _) -> constr_name c' + | Const (cn,_) -> Name (id_of_label (con_label cn)) + | App (c', _) -> constr_name c' + | _ -> Anonymous + +(* }}} *) + +(** Open term to lambda-term coercion {{{ ************************************) + +(* This operation takes a goal gl and an open term (sigma, t), and *) +(* returns a term t' where all the new evars in sigma are abstracted *) +(* with the mkAbs argument, i.e., for mkAbs = mkLambda then there is *) +(* some duplicate-free array args of evars of sigma such that the *) +(* term mkApp (t', args) is convertible to t. *) +(* This makes a useful shorthand for local definitions in proofs, *) +(* i.e., pose succ := _ + 1 means pose succ := fun n : nat => n + 1, *) +(* and, in context of the the 4CT library, pose mid := maps id means *) +(* pose mid := fun d : detaSet => @maps d d (@id (datum d)) *) +(* Note that this facility does not extend to set, which tries *) +(* instead to fill holes by matching a goal subterm. *) +(* The argument to "have" et al. uses product abstraction, e.g. *) +(* have Hmid: forall s, (maps id s) = s. *) +(* stands for *) +(* have Hmid: forall (d : dataSet) (s : seq d), (maps id s) = s. *) +(* We also use this feature for rewrite rules, so that, e.g., *) +(* rewrite: (plus_assoc _ 3). *) +(* will execute as *) +(* rewrite (fun n => plus_assoc n 3) *) +(* i.e., it will rewrite some subterm .. + (3 + ..) to .. + 3 + ... *) +(* The convention is also used for the argument of the congr tactic, *) +(* e.g., congr (x + _ * 1). *) + +(* Replace new evars with lambda variables, retaining local dependencies *) +(* but stripping global ones. We use the variable names to encode the *) +(* the number of dependencies, so that the transformation is reversible. *) + +let pf_abs_evars gl (sigma, c0) = + let sigma0, ucst = project gl, Evd.evar_universe_context sigma in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = List.firstn n (evar_filtered_context evi) in + let abs_dc c decl = match NamedDecl.to_tuple decl with + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma t in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let t = abs_evar n k in (k, (n, t)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0,[], ucst else + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n, _)) :: evl -> if k = k' then i, n else lookup k (i + 1) evl in + let rec get i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) get i c in + let rec loop c i = function + | (_, (n, t)) :: evl -> + loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + | [] -> c in + List.length evlist, loop (get 1 c0) 1 evlist, List.map fst evlist, ucst + + + +(* As before but if (?i : T(?j)) and (?j : P : Prop), then the lambda for i + * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all + * occurrences of evar_i are replaced by (evar_i evar_j) thanks to "app". + * + * If P can be solved by ssrautoprop (that defaults to trivial), then + * the corresponding lambda looks like (fun evar_i : T(c)) where c is + * the solution found by ssrautoprop. + *) +let ssrautoprop_tac = ref (fun gl -> assert false) + +(* Thanks to Arnaud Spiwack for this snippet *) +let call_on_evar tac e s = + let { it = gs ; sigma = s } = + tac { it = e ; sigma = s; } in + gs, s + +let pf_abs_evars_pirrel gl (sigma, c0) = + pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); + pp(lazy(str"c0= " ++ pr_constr c0)); + let sigma0 = project gl in + let c0 = Evarutil.nf_evar sigma0 (Evarutil.nf_evar sigma c0) in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = List.firstn n (evar_filtered_context evi) in + let abs_dc c decl = match NamedDecl.to_tuple decl with + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma0 (Evarutil.nf_evar sigma t) in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let k_ty = + Retyping.get_sort_family_of + (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in + let is_prop = k_ty = InProp in + let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0 else + let pr_constr t = pr_constr (Reductionops.nf_beta (project gl) t) in + pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") + (fun (k,_) -> str(Evd.string_of_existential k)) evlist)); + let evplist = + let depev = List.fold_left (fun evs (_,(_,t,_)) -> + Intset.union evs (Evarutil.undefined_evars_of_term sigma t)) Intset.empty evlist in + List.filter (fun (i,(_,_,b)) -> b && Intset.mem i depev) evlist in + let evlist, evplist, sigma = + if evplist = [] then evlist, [], sigma else + List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> + try + let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + if (ng <> []) then errorstrm (str "Should we tell the user?"); + List.filter (fun (j,_) -> j <> i) ev, evp, sigma + with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in + let c0 = Evarutil.nf_evar sigma c0 in + let evlist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evlist in + let evplist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evplist in + pp(lazy(str"c0= " ++ pr_constr c0)); + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n,_,_)) :: evl -> if k = k' then i,n else lookup k (i + 1) evl in + let rec get evlist i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get evlist i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) (get evlist) i c in + let rec app extra_args i c = match decompose_app c with + | hd, args when isRel hd && destRel hd = i -> + let j = destRel hd in + mkApp (mkRel j, Array.of_list (List.map (lift (i-1)) extra_args @ args)) + | _ -> map_constr_with_binders ((+) 1) (app extra_args) i c in + let rec loopP evlist c i = function + | (_, (n, t, _)) :: evl -> + let t = get evlist (i - 1) t in + let n = Name (id_of_string (ssr_anon_hyp ^ string_of_int n)) in + loopP evlist (mkProd (n, t, c)) (i - 1) evl + | [] -> c in + let rec loop c i = function + | (_, (n, t, _)) :: evl -> + let evs = Evarutil.undefined_evars_of_term sigma t in + let t_evplist = List.filter (fun (k,_) -> Intset.mem k evs) evplist in + let t = loopP t_evplist (get t_evplist 1 t) 1 t_evplist in + let t = get evlist (i - 1) t in + let extra_args = + List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) + (List.rev t_evplist) in + let c = if extra_args = [] then c else app extra_args 1 c in + loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + | [] -> c in + let res = loop (get evlist 1 c0) 1 evlist in + pp(lazy(str"res= " ++ pr_constr res)); + List.length evlist, res + +(* Strip all non-essential dependencies from an abstracted term, generating *) +(* standard names for the abstracted holes. *) + +let pf_abs_cterm gl n c0 = + if n <= 0 then c0 else + let noargs = [|0|] in + let eva = Array.make n noargs in + let rec strip i c = match kind_of_term c with + | App (f, a) when isRel f -> + let j = i - destRel f in + if j >= n || eva.(j) = noargs then mkApp (f, Array.map (strip i) a) else + let dp = eva.(j) in + let nd = Array.length dp - 1 in + let mkarg k = strip i a.(if k < nd then dp.(k + 1) - j else k + dp.(0)) in + mkApp (f, Array.init (Array.length a - dp.(0)) mkarg) + | _ -> map_constr_with_binders ((+) 1) strip i c in + let rec strip_ndeps j i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + let dl, c2 = strip_ndeps j (i + 1) c1 in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkProd (x, strip i t, c2) + | LetIn (x, b, t, c1) when i < j -> + let _, _, c1' = destProd c1 in + let dl, c2 = strip_ndeps j (i + 1) c1' in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkLetIn (x, strip i b, strip i t, c2) + | _ -> [], strip i c in + let rec strip_evars i c = match kind_of_term c with + | Lambda (x, t1, c1) when i < n -> + let na = nb_evar_deps x in + let dl, t2 = strip_ndeps (i + na) i t1 in + let na' = List.length dl in + eva.(i) <- Array.of_list (na - na' :: dl); + let x' = + if na' = 0 then Name (pf_type_id gl t2) else mk_evar_name na' in + mkLambda (x', t2, strip_evars (i + 1) c1) +(* if noccurn 1 c2 then lift (-1) c2 else + mkLambda (Name (pf_type_id gl t2), t2, c2) *) + | _ -> strip i c in + strip_evars 0 c0 + +(* Undo the evar abstractions. Also works for non-evar variables. *) + +let pf_unabs_evars gl ise n c0 = + if n = 0 then c0 else + let evv = Array.make n mkProp in + let nev = ref 0 in + let env0 = pf_env gl in + let nenv0 = env_size env0 in + let rec unabs i c = match kind_of_term c with + | Rel j when i - j < !nev -> evv.(i - j) + | App (f, a0) when isRel f -> + let a = Array.map (unabs i) a0 in + let j = i - destRel f in + if j >= !nev then mkApp (f, a) else + let ev, eva = destEvar evv.(j) in + let nd = Array.length eva - nenv0 in + if nd = 0 then mkApp (evv.(j), a) else + let evarg k = if k < nd then a.(nd - 1 - k) else eva.(k) in + let c' = mkEvar (ev, Array.init (nd + nenv0) evarg) in + let na = Array.length a - nd in + if na = 0 then c' else mkApp (c', Array.sub a nd na) + | _ -> map_constr_with_binders ((+) 1) unabs i c in + let push_rel = Environ.push_rel in + let rec mk_evar j env i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + mk_evar j (push_rel (RelDecl.LocalAssum (x, unabs i t)) env) (i + 1) c1 + | LetIn (x, b, t, c1) when i < j -> + let _, _, c2 = destProd c1 in + mk_evar j (push_rel (RelDecl.LocalDef (x, unabs i b, unabs i t)) env) (i + 1) c2 + | _ -> Evarutil.e_new_evar env ise (unabs i c) in + let rec unabs_evars c = + if !nev = n then unabs n c else match kind_of_term c with + | Lambda (x, t, c1) when !nev < n -> + let i = !nev in + evv.(i) <- mk_evar (i + nb_evar_deps x) env0 i t; + incr nev; unabs_evars c1 + | _ -> unabs !nev c in + unabs_evars c0 + +(* }}} *) + +(** Tactical extensions. {{{ **************************************************) + +(* The TACTIC EXTEND facility can't be used for defining new user *) +(* tacticals, because: *) +(* - the concrete syntax must start with a fixed string *) +(* We use the following workaround: *) +(* - We use the (unparsable) "YouShouldNotTypeThis" token for tacticals that *) +(* don't start with a token, then redefine the grammar and *) +(* printer using GEXTEND and set_pr_ssrtac, respectively. *) + +type ssrargfmt = ArgSsr of string | ArgCoq of argument_type | ArgSep of string + +let ssrtac_name name = { + mltac_plugin = "ssreflect_plugin"; + mltac_tactic = "ssr" ^ name; +} + +let ssrtac_entry name n = { + mltac_name = ssrtac_name name; + mltac_index = n; +} + +let set_pr_ssrtac name prec afmt = + let fmt = List.map (function + | ArgSep s -> Egramml.GramTerminal s + | ArgSsr s -> Egramml.GramTerminal s + | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in + let tacname = ssrtac_name name in () + +let ssrtac_atom loc name args = TacML (loc, ssrtac_entry name 0, args) +let ssrtac_expr = ssrtac_atom + + +let ssrevaltac ist gtac = + Proofview.V82.of_tactic (tactic_of_value ist gtac) + +(* fun gl -> let lfun = [tacarg_id, val_interp ist gl gtac] in + interp_tac_gen lfun [] ist.debug tacarg_expr gl *) + +(** Generic argument-based globbing/typing utilities *) + +let of_ftactic ftac gl = + let r = ref None in + let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in + let tac = Proofview.V82.of_tactic tac in + let { sigma = sigma } = tac gl in + let ans = match !r with + | None -> assert false (** If the tactic failed we should not reach this point *) + | Some ans -> ans + in + (sigma, ans) + +let interp_wit wit ist gl x = + let globarg = in_gen (glbwit wit) x in + let arg = interp_genarg ist globarg in + let (sigma, arg) = of_ftactic arg gl in + sigma, Value.cast (topwit wit) arg + +let interp_intro_pattern = interp_wit wit_intro_pattern + +let interp_constr = interp_wit wit_constr + +let interp_open_constr ist gl gc = + let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, NoBindings) in + (project gl, (sigma, c)) + +let interp_refine ist gl rc = + let constrvars = extract_ltac_constr_values ist (pf_env gl) in + let vars = { Pretyping.empty_lvar with + Pretyping.ltac_constrs = constrvars; ltac_genargs = ist.lfun + } in + let kind = OfType (pf_concl gl) in + let flags = { + use_typeclasses = true; + use_unif_heuristics = true; + use_hook = None; + fail_evar = false; + expand_evars = true } + in + let sigma, c = understand_ltac flags (pf_env gl) (project gl) vars kind rc in +(* pp(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) + pp(lazy(str"c@interp_refine=" ++ pr_constr c)); + (sigma, (sigma, c)) + +let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) + +(* Estimate a bound on the number of arguments of a raw constr. *) +(* This is not perfect, because the unifier may fail to *) +(* typecheck the partial application, so we use a minimum of 5. *) +(* Also, we don't handle delayed or iterated coercions to *) +(* FUNCLASS, which is probably just as well since these can *) +(* lead to infinite arities. *) + +let splay_open_constr gl (sigma, c) = + let env = pf_env gl in let t = Retyping.get_type_of env sigma c in + Reductionops.splay_prod env sigma t + +let nbargs_open_constr gl oc = + let pl, _ = splay_open_constr gl oc in List.length pl + +let interp_nbargs ist gl rc = + try + let rc6 = mkRApp rc (mkRHoles 6) in + let sigma, t = interp_open_constr ist gl (rc6, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + 6 + nbargs_open_constr gl t + with _ -> 5 + +let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) + +let isAppInd gl c = + try ignore (pf_reduce_to_atomic_ind gl c); true with _ -> false + +let interp_view_nbimps ist gl rc = + try + let sigma, t = interp_open_constr ist gl (rc, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + let pl, c = splay_open_constr gl t in + if isAppInd gl c then List.length pl else ~-(List.length pl) + with _ -> 0 + +(* }}} *) + +(** Vernacular commands: Prenex Implicits and Search {{{ **********************) + +(* This should really be implemented as an extension to the implicit *) +(* arguments feature, but unfortuately that API is sealed. The current *) +(* workaround uses a combination of notations that works reasonably, *) +(* with the following caveats: *) +(* - The pretty-printing always elides prenex implicits, even when *) +(* they are obviously needed. *) +(* - Prenex Implicits are NEVER exported from a module, because this *) +(* would lead to faulty pretty-printing and scoping errors. *) +(* - The command "Import Prenex Implicits" can be used to reassert *) +(* Prenex Implicits for all the visible constants that had been *) +(* declared as Prenex Implicits. *) + +let declare_one_prenex_implicit locality f = + let fref = + try Smartlocate.global_with_alias f + with _ -> errorstrm (pr_reference f ++ str " is not declared") in + let rec loop = function + | a :: args' when Impargs.is_status_implicit a -> + (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' + | args' when List.exists Impargs.is_status_implicit args' -> + errorstrm (str "Expected prenex implicits for " ++ pr_reference f) + | _ -> [] in + let impls = + match Impargs.implicits_of_global fref with + | [cond,impls] -> impls + | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | _ -> errorstrm (str "Multiple implicits not supported") in + match loop impls with + | [] -> + errorstrm (str "Expected some implicits for " ++ pr_reference f) + | impls -> + Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + +VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF + | [ "Prenex" "Implicits" ne_global_list(fl) ] + -> [ let locality = + Locality.make_section_locality (Locality.LocalityFixme.consume ()) in + List.iter (declare_one_prenex_implicit locality) fl ] +END + +(* Vernac grammar visibility patch *) + +GEXTEND Gram + GLOBAL: gallina_ext; + gallina_ext: + [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> + Vernacexpr.VernacUnsetOption (["Printing"; "Implicit"; "Defensive"]) + ] ] + ; +END + +(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) + +(* Main prefilter *) + +type raw_glob_search_about_item = + | RGlobSearchSubPattern of constr_expr + | RGlobSearchString of Loc.t * string * string option + +let pr_search_item = function + | RGlobSearchString (_,s,_) -> str s + | RGlobSearchSubPattern p -> pr_constr_expr p + +let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item + +let interp_search_notation loc s opt_scope = + try + let interp = Notation.interp_notation_as_global_reference loc in + let ref = interp (fun _ -> true) s opt_scope in + Search.GlobSearchSubPattern (Pattern.PRef ref) + with _ -> + let diagnosis = + try + let ntns = Notation.locate_notation pr_glob_constr s opt_scope in + let ambig = "This string refers to a complex or ambiguous notation." in + str ambig ++ str "\nTry searching with one of\n" ++ ntns + with _ -> str "This string is not part of an identifier or notation." in + CErrors.user_err_loc (loc, "interp_search_notation", diagnosis) + +let pr_ssr_search_item _ _ _ = pr_search_item + +(* Workaround the notation API that can only print notations *) + +let is_ident s = try CLexer.check_ident s; true with _ -> false + +let is_ident_part s = is_ident ("H" ^ s) + +let interp_search_notation loc tag okey = + let err msg = CErrors.user_err_loc (loc, "interp_search_notation", msg) in + let mk_pntn s for_key = + let n = String.length s in + let s' = String.make (n + 2) ' ' in + let rec loop i i' = + if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else + let j = try String.index_from s (i + 1) ' ' with _ -> n in + let m = j - i in + if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then + (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) + else if for_key && is_ident (String.sub s i m) then + (s'.[i'] <- '_'; loop (j + 1) (i' + 2)) + else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in + loop 0 1 in + let trim_ntn (pntn, m) = String.sub pntn 1 (max 0 m) in + let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let pr_and_list pr = function + | [x] -> pr x + | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x + | [] -> mt () in + let pr_sc sc = str (if sc = "" then "independently" else sc) in + let pr_scs = function + | [""] -> pr_sc "" + | scs -> str "in " ++ pr_and_list pr_sc scs in + let generator, pr_tag_sc = + let ign _ = mt () in match okey with + | Some key -> + let sc = Notation.find_delimiters_scope loc key in + let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in + Notation.pr_scope ign sc, pr_sc + | None -> Notation.pr_scopes ign, ign in + let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in + let ptag, ttag = + let ptag, m = mk_pntn tag false in + if m <= 0 then err (str "empty notation fragment"); + ptag, trim_ntn (ptag, m) in + let last = ref "" and last_sc = ref "" in + let scs = ref [] and ntns = ref [] in + let push_sc sc = match !scs with + | "" :: scs' -> scs := "" :: sc :: scs' + | scs' -> scs := sc :: scs' in + let get s _ _ = match !last with + | "Scope " -> last_sc := s; last := "" + | "Lonely notation" -> last_sc := ""; last := "" + | "\"" -> + let pntn, m = mk_pntn s true in + if String.string_contains pntn ptag then begin + let ntn = trim_ntn (pntn, m) in + match !ntns with + | [] -> ntns := [ntn]; scs := [!last_sc] + | ntn' :: _ when ntn' = ntn -> push_sc !last_sc + | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] + | _ :: ntns' when List.mem ntn ntns' -> () + | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' + end; + last := "" + | _ -> last := s in + pp_with (Format.make_formatter get (fun _ -> ())) generator; + let ntn = match !ntns with + | [] -> + err (hov 0 (qtag "in" ++ str "does not occur in any notation")) + | ntn :: ntns' when ntn = ttag -> + if ntns' <> [] then begin + let pr_ntns' = pr_and_list pr_ntn ntns' in + msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) + end; ntn + | [ntn] -> + msgnl (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + | ntns' -> + let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in + err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in + let (nvars, body), ((_, pat), osc) = match !scs with + | [sc] -> Notation.interp_notation loc ntn (None, [sc]) + | scs' -> + try Notation.interp_notation loc ntn (None, []) with _ -> + let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in + err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in + let sc = Option.default "" osc in + let _ = + let m_sc = + if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in + let ntn_pat = trim_ntn (mk_pntn pat false) in + let rbody = glob_constr_of_notation_constr loc body in + let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in + let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in + msgnl (hov 0 m) in + if List.length !scs > 1 then + let scs' = List.remove (=) sc !scs in + let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in + msg_warning (hov 4 w) + else if String.string_contains ntn " .. " then + err (pr_ntn ntn ++ str " is an n-ary notation"); + let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in + let rec sub () = function + | NVar x when List.mem_assoc x nvars -> GPatVar (loc, (false, x)) + | c -> + glob_constr_of_notation_constr_with_binders loc (fun _ x -> (), x) sub () c in + let _, npat = Patternops.pattern_of_glob_constr (sub () body) in + Search.GlobSearchSubPattern npat + +ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem + PRINTED BY pr_ssr_search_item + | [ string(s) ] -> [ RGlobSearchString (loc,s,None) ] + | [ string(s) "%" preident(key) ] -> [ RGlobSearchString (loc,s,Some key) ] + | [ constr_pattern(p) ] -> [ RGlobSearchSubPattern p ] +END + +let pr_ssr_search_arg _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in + pr_list spc pr_item + +ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list + PRINTED BY pr_ssr_search_arg + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] + | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] + | [ ] -> [ [] ] +END + +(* Main type conclusion pattern filter *) + +let rec splay_search_pattern na = function + | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp + | Pattern.PLetIn (_, _, bp) -> splay_search_pattern na bp + | Pattern.PRef hr -> hr, na + | _ -> CErrors.error "no head constant in head search pattern" + +let coerce_search_pattern_to_sort hpat = + let env = Global.env () and sigma = Evd.empty in + let mkPApp fp n_imps args = + let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in + Pattern.PApp (fp, args') in + let hr, na = splay_search_pattern 0 hpat in + let dc, ht = + Reductionops.splay_prod env sigma (Universes.unsafe_type_of_global hr) in + let np = List.length dc in + if np < na then CErrors.error "too many arguments in head search pattern" else + let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in + let warn () = + msg_warning (str "Listing only lemmas with conclusion matching " ++ + pr_constr_pattern hpat') in + if isSort ht then begin warn (); true, hpat' end else + let filter_head, coe_path = + try + let _, cp = + Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + warn (); + true, cp + with _ -> false, [] in + let coerce hp coe_index = + let coe = Classops.get_coercion_value coe_index in + try + let coe_ref = reference_of_constr coe in + let n_imps = Option.get (Classops.hide_coercion coe_ref) in + mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] + with _ -> + errorstrm (str "need explicit coercion " ++ pr_constr coe ++ spc () + ++ str "to interpret head search pattern as type") in + filter_head, List.fold_left coerce hpat' coe_path + +let rec interp_head_pat hpat = + let filter_head, p = coerce_search_pattern_to_sort hpat in + let rec loop c = match kind_of_term c with + | Cast (c', _, _) -> loop c' + | Prod (_, _, c') -> loop c' + | LetIn (_, _, _, c') -> loop c' + | _ -> Constr_matching.is_matching (Global.env()) Evd.empty p c in + filter_head, loop + +let all_true _ = true + +let rec interp_search_about args accu = match args with +| [] -> accu +| (flag, arg) :: rem -> + fun gr env typ -> + let ans = Search.search_about_filter arg gr env typ in + (if flag then ans else not ans) && interp_search_about rem accu gr env typ + +let interp_search_arg arg = + let arg = List.map (fun (x,arg) -> x, match arg with + | RGlobSearchString (loc,s,key) -> + if is_ident_part s then Search.GlobSearchString s else + interp_search_notation loc s key + | RGlobSearchSubPattern p -> + try + let intern = Constrintern.intern_constr_pattern in + Search.GlobSearchSubPattern (snd (intern (Global.env()) p)) + with e -> let e = CErrors.push e in iraise (ExplainErr.process_vernac_interp_error e)) arg in + let hpat, a1 = match arg with + | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' + | (true, Search.GlobSearchSubPattern p) :: a' -> + let filter_head, p = interp_head_pat p in + if filter_head then p, a' else all_true, arg + | _ -> all_true, arg in + let is_string = + function (_, Search.GlobSearchString _) -> true | _ -> false in + let a2, a3 = List.partition is_string a1 in + interp_search_about (a2 @ a3) (fun gr env typ -> hpat typ) + +(* Module path postfilter *) + +let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m + +let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc + +let pr_ssr_modlocs _ _ _ ml = + if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs + | [ ] -> [ [] ] +END + +GEXTEND Gram + GLOBAL: ssr_modlocs; + modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; +END + +let interp_modloc mr = + let interp_mod (_, mr) = + let (loc, qid) = qualid_of_reference mr in + try Nametab.full_name_module qid with Not_found -> + CErrors.user_err_loc (loc, "interp_modloc", str "No Module " ++ pr_qualid qid) in + let mr_out, mr_in = List.partition fst mr in + let interp_bmod b = function + | [] -> fun _ _ _ -> true + | rmods -> Search.module_filter (List.map interp_mod rmods, b) in + let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in + fun gr env typ -> is_in gr env typ && is_out gr env typ + +(* The unified, extended vernacular "Search" command *) + +let ssrdisplaysearch gr env t = + let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + msg_info (hov 2 pr_res ++ fnl ()) + +VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY +| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> + [ let hpat = interp_search_arg a in + let in_mod = interp_modloc mr in + let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in + let display gr env typ = + if post_filter gr env typ then ssrdisplaysearch gr env typ + in + Search.generic_search None display ] +END + +(* }}} *) + +(** Alternative notations for "match" and anonymous arguments. {{{ ************) + +(* Syntax: *) +(* if is then ... else ... *) +(* if is [in ..] return ... then ... else ... *) +(* let: := in ... *) +(* let: [in ...] := return ... in ... *) +(* The scope of a top-level 'as' in the pattern extends over the *) +(* 'return' type (dependent if/let). *) +(* Note that the optional "in ..." appears next to the *) +(* rather than the in then "let:" syntax. The alternative *) +(* would lead to ambiguities in, e.g., *) +(* let: p1 := (*v---INNER LET:---v *) *) +(* let: p2 := let: p3 := e3 in k return t in k2 in k1 return t' *) +(* in b (*^--ALTERNATIVE INNER LET--------^ *) *) + +(* Caveat : There is no pretty-printing support, since this would *) +(* require a modification to the Coq kernel (adding a new match *) +(* display style -- why aren't these strings?); also, the v8.1 *) +(* pretty-printer only allows extension hooks for printing *) +(* integer or string literals. *) +(* Also note that in the v8 grammar "is" needs to be a keyword; *) +(* as this can't be done from an ML extension file, the new *) +(* syntax will only work when ssreflect.v is imported. *) + +let no_ct = None, None and no_rt = None in +let aliasvar = function + | [_, [CPatAlias (loc, _, id)]] -> Some (loc,Name id) + | _ -> None in +let mk_cnotype mp = aliasvar mp, None in +let mk_ctype mp t = aliasvar mp, Some t in +let mk_rtype t = Some t in +let mk_dthen loc (mp, ct, rt) c = (loc, mp, c), ct, rt in +let mk_let loc rt ct mp c1 = + CCases (loc, LetPatternStyle, rt, ct, [loc, mp, c1]) in +let mk_pat c (na, t) = (c, na, t) in +GEXTEND Gram + GLOBAL: binder_constr; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; + ssr_mpat: [[ p = pattern -> [!@loc, [p]] ]]; + ssr_dpat: [ + [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt + | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt + | mp = ssr_mpat -> mp, no_ct, no_rt + ] ]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen !@loc dp c ]]; + ssr_elsepat: [[ "else" -> [!@loc, [CPatAtom (!@loc, None)]] ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> !@loc, mp, c ]]; + binder_constr: [ + [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in CCases (!@loc, MatchStyle, rt, [mk_pat c ct], [b1; b2]) + | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in + let b1, b2 = + let (l1, p1, r1), (l2, p2, r2) = b1, b2 in (l1, p1, r2), (l2, p2, r1) in + CCases (!@loc, MatchStyle, rt, [mk_pat c ct], [b1; b2]) + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> + mk_let (!@loc) no_rt [mk_pat c no_ct] mp c1 + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let (!@loc) rt [mk_pat c (mk_cnotype mp)] mp c1 + | "let"; ":"; mp = ssr_mpat; "in"; t = pattern; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let (!@loc) rt [mk_pat c (mk_ctype mp t)] mp c1 + ] ]; +END + +GEXTEND Gram + GLOBAL: closed_binder; + closed_binder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + [LocalRawAssum ([!@loc, Anonymous], Default Explicit, c)] + ] ]; +END +(* }}} *) + +(** Tacticals (+, -, *, done, by, do, =>, first, and last). {{{ ***************) + +(** Bracketing tactical *) + +(* The tactic pretty-printer doesn't know that some extended tactics *) +(* are actually tacticals. To prevent it from improperly removing *) +(* parentheses we override the parsing rule for bracketed tactic *) +(* expressions so that the pretty-print always reflects the input. *) +(* (Removing user-specified parentheses is dubious anyway). *) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> !@loc, Tacexp tac ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; +END + +(** The internal "done" and "ssrautoprop" tactics. *) + +(* For additional flexibility, "done" and "ssrautoprop" are *) +(* defined in Ltac. *) +(* Although we provide a default definition in ssreflect, *) +(* we look up the definition dynamically at each call point, *) +(* to allow for user extensions. "ssrautoprop" defaults to *) +(* trivial. *) + +let donetac gl = + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "done")) + with Not_found -> try Nametab.locate_tactic (ssrqid "done") + with Not_found -> CErrors.error "The ssreflect library was not loaded" in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + +let prof_donetac = mk_profiler "donetac";; +let donetac gl = prof_donetac.profile donetac gl;; + +let ssrautoprop gl = + try + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "ssrautoprop")) + with Not_found -> Nametab.locate_tactic (ssrqid "ssrautoprop") in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + with Not_found -> Proofview.V82.of_tactic (Auto.full_trivial []) gl + +let () = ssrautoprop_tac := ssrautoprop + +let tclBY tac = tclTHEN tac donetac + +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + +(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) +let pr_ssrtacarg _ _ prt = prt tacltop +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END +GEXTEND Gram + GLOBAL: ssrtacarg; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; +END + +(* Lexically closed tactic for tacticals. *) +let pr_ssrtclarg _ _ prt tac = prt tacltop tac +ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg + PRINTED BY pr_ssrtclarg +| [ ssrtacarg(tac) ] -> [ tac ] +END +let eval_tclarg ist tac = ssrevaltac ist tac + +let pr_ortacs prt = + let rec pr_rec = function + | [None] -> spc() ++ str "|" ++ spc() + | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | [] -> mt() in + function + | [None] -> spc() + | None :: tacs -> pr_rec tacs + | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | [] -> mt() +let pr_ssrortacs _ _ = pr_ortacs + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] +| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] +| [ ssrtacarg(tac) ] -> [ [Some tac] ] +| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] +| [ "|" ] -> [ [None; None] ] +END + +let pr_hintarg prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") + | false, [Some tac] -> prt tacltop tac + | _, _ -> mt() + +let pr_ssrhintarg _ _ = pr_hintarg + +let mk_hint tac = false, [Some tac] +let mk_orhint tacs = true, tacs +let nullhint = true, [] +let nohint = false, [] + +ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg +| [ "[" "]" ] -> [ nullhint ] +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +END + +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +END + +let hinttac ist is_by (is_or, atacs) = + let dtac = if is_by then donetac else tclIDTAC in + let mktac = function + | Some atac -> tclTHEN (ssrevaltac ist atac) dtac + | _ -> dtac in + match List.map mktac atacs with + | [] -> if is_or then dtac else tclIDTAC + | [tac] -> tac + | tacs -> tclFIRST tacs + +(** The "-"/"+"/"*" tacticals. *) + +(* These are just visual cues to flag the beginning of the script for *) +(* new subgoals, when indentation is not appropriate (typically after *) +(* tactics that generate more than two subgoals). *) + +TACTIC EXTEND ssrtclplus +| [ "YouShouldNotTypeThis" "+" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclplus" 5 [ArgSep "+ "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclminus +| [ "YouShouldNotTypeThis" "-" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclminus" 5 [ArgSep "- "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclstar +| [ "YouShouldNotTypeThis" "*" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclstar" 5 [ArgSep "- "; ArgSsr "tclarg"] + +let gen_tclarg tac = TacGeneric (in_gen (rawwit wit_ssrtclarg) tac) + +GEXTEND Gram + GLOBAL: tactic tactic_mode; + tactic: [ + [ "+"; tac = ssrtclarg -> ssrtac_expr !@loc "tclplus" [gen_tclarg tac] + | "-"; tac = ssrtclarg -> ssrtac_expr !@loc "tclminus" [gen_tclarg tac] + | "*"; tac = ssrtclarg -> ssrtac_expr !@loc "tclstar" [gen_tclarg tac] + ] ]; + tactic_mode: [ + [ "+"; tac = G_vernac.subgoal_command -> tac None + | "-"; tac = G_vernac.subgoal_command -> tac None + | "*"; tac = G_vernac.subgoal_command -> tac None + ] ]; +END + +(** The "by" tactical. *) + +let pr_hint prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg +let pr_ssrhint _ _ = pr_hint + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint +| [ ] -> [ nohint ] +END + +TACTIC EXTEND ssrtclby +| [ "by" ssrhintarg(tac) ] -> [ Proofview.V82.tactic (hinttac ist true tac) ] +END + +(* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) +(* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) + +GEXTEND Gram + GLOBAL: ssrhint simple_tactic; + ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; +END +(* }}} *) + +(** Bound assumption argument *) + +(* The Ltac API does have a type for assumptions but it is level-dependent *) +(* and therefore impratical to use for complex arguments, so we substitute *) +(* our own to have a uniform representation. Also, we refuse to intern *) +(* idents that match global/section constants, since this would lead to *) +(* fragile Ltac scripts. *) + +type ssrhyp = SsrHyp of loc * identifier + +let hyp_id (SsrHyp (_, id)) = id +let pr_hyp (SsrHyp (_, id)) = pr_id id +let pr_ssrhyp _ _ _ = pr_hyp + +let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp + +let hyp_err loc msg id = + CErrors.user_err_loc (loc, "ssrhyp", str msg ++ pr_id id) + +let intern_hyp ist (SsrHyp (loc, id) as hyp) = + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) (loc, id)) in + if not_section_id id then hyp else + hyp_err loc "Can't clear section hypothesis " id + +let interp_hyp ist gl (SsrHyp (loc, id)) = + let s, id' = interp_wit wit_var ist gl (loc, id) in + if not_section_id id' then s, SsrHyp (loc, id') else + hyp_err loc "Can't clear section hypothesis " id' + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp + INTERPRETED BY interp_hyp + GLOBALIZED BY intern_hyp + | [ ident(id) ] -> [ SsrHyp (loc, id) ] +END + +type ssrhyp_or_id = Hyp of ssrhyp | Id of ssrhyp + +let hoik f = function Hyp x -> f x | Id x -> f x +let hoi_id = hoik hyp_id +let pr_hoi = hoik pr_hyp +let pr_ssrhoi _ _ _ = pr_hoi + +let wit_ssrhoirep = add_genarg "ssrhoirep" pr_hoi + +let intern_ssrhoi ist = function + | Hyp h -> Hyp (intern_hyp ist h) + | Id (SsrHyp (_, id)) as hyp -> + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_ident) id) in + hyp + +let interp_ssrhoi ist gl = function + | Hyp h -> let s, h' = interp_hyp ist gl h in s, Hyp h' + | Id (SsrHyp (loc, id)) -> + let s, id' = interp_wit wit_ident ist gl id in + s, Id (SsrHyp (loc, id')) + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Hyp (SsrHyp(loc, id)) ] +END +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Id (SsrHyp(loc, id)) ] +END + +type ssrhyps = ssrhyp list + +let pr_hyps = pr_list pr_spc pr_hyp +let pr_ssrhyps _ _ _ = pr_hyps +let hyps_ids = List.map hyp_id + +let rec check_hyps_uniq ids = function + | SsrHyp (loc, id) :: _ when List.mem id ids -> + hyp_err loc "Duplicate assumption " id + | SsrHyp (_, id) :: hyps -> check_hyps_uniq (id :: ids) hyps + | [] -> () + +let check_hyp_exists hyps (SsrHyp(_, id)) = + try ignore(Context.Named.lookup id hyps) + with Not_found -> errorstrm (str"No assumption is named " ++ pr_id id) + +let interp_hyps ist gl ghyps = + let hyps = List.map snd (List.map (interp_hyp ist gl) ghyps) in + check_hyps_uniq [] hyps; Tacmach.project gl, hyps + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps + INTERPRETED BY interp_hyps + | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +END + +(** Terms parsing. {{{ ********************************************************) + +(* Because we allow wildcards in term references, we need to stage the *) +(* interpretation of terms so that it occurs at the right time during *) +(* the execution of the tactic (e.g., so that we don't report an error *) +(* for a term that isn't actually used in the execution). *) +(* The term representation tracks whether the concrete initial term *) +(* started with an opening paren, which might avoid a conflict between *) +(* the ssrreflect term syntax and Gallina notation. *) + +(* kinds of terms *) + +type ssrtermkind = char (* print flag *) + +let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' + +let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +(* terms *) +let pr_ssrterm _ _ _ = pr_term +let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c +let intern_term ist sigma env (_, c) = glob_constr ist env c +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let force_term ist gl (_, c) = interp_constr ist gl c +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacintern.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c +let interp_ssrterm _ gl t = Tacmach.project gl, t + +ARGUMENT EXTEND ssrterm + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm + RAW_PRINTED BY pr_ssrterm + GLOB_PRINTED BY pr_ssrterm +| [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: ssrterm; + ssrterm: [[ k = ssrtermkind; c = constr -> mk_term k c ]]; +END +(* }}} *) + +(** The "in" pseudo-tactical {{{ **********************************************) + +(* We can't make "in" into a general tactical because this would create a *) +(* crippling conflict with the ltac let .. in construct. Hence, we add *) +(* explicitly an "in" suffix to all the extended tactics for which it is *) +(* relevant (including move, case, elim) and to the extended do tactical *) +(* below, which yields a general-purpose "in" of the form do [...] in ... *) + +(* This tactical needs to come before the intro tactics because the latter *) +(* must take precautions in order not to interfere with the discharged *) +(* assumptions. This is especially difficult for discharged "let"s, which *) +(* the default simpl and unfold tactics would erase blindly. *) + +(** Clear switch *) + +type ssrclear = ssrhyps + +let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr + +let pr_ssrclear _ _ _ = pr_clear mt + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +END + +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear +| [ ssrclear_ne(clr) ] -> [ clr ] +| [ ] -> [ [] ] +END + +let cleartac clr = check_hyps_uniq [] clr; Proofview.V82.of_tactic (clear (hyps_ids clr)) + +(* type ssrwgen = ssrclear * ssrhyp * string *) + +let pr_wgen = function + | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id + | (clr, Some((id,k),Some p)) -> + spc() ++ pr_clear mt clr ++ str"(" ++ str k ++ pr_hoi id ++ str ":=" ++ + pr_cpattern p ++ str ")" + | (clr, None) -> spc () ++ pr_clear mt clr +let pr_ssrwgen _ _ _ = pr_wgen + +(* no globwith for char *) +ARGUMENT EXTEND ssrwgen + TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option + PRINTED BY pr_ssrwgen +| [ ssrclear_ne(clr) ] -> [ clr, None ] +| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] +| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] +| [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id," "),Some p) ] +| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] +| [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +| [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +END + +type ssrclseq = InGoal | InHyps + | InHypsGoal | InHypsSeqGoal | InSeqGoal | InHypsSeq | InAll | InAllHyps + +let pr_clseq = function + | InGoal | InHyps -> mt () + | InSeqGoal -> str "|- *" + | InHypsSeqGoal -> str " |- *" + | InHypsGoal -> str " *" + | InAll -> str "*" + | InHypsSeq -> str " |-" + | InAllHyps -> str "* |-" + +let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq +let pr_clausehyps = pr_list pr_spc pr_wgen +let pr_ssrclausehyps _ _ _ = pr_clausehyps + +ARGUMENT EXTEND ssrclausehyps +TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ] -> [ [hyp] ] +END + +(* type ssrclauses = ssrahyps * ssrclseq *) + +let pr_clauses (hyps, clseq) = + if clseq = InGoal then mt () + else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq +let pr_ssrclauses _ _ _ = pr_clauses + +ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq + PRINTED BY pr_ssrclauses + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] + | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] + | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] + | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] + | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] + | [ "in" "*" ] -> [ [], InAll ] + | [ "in" "*" "|-" ] -> [ [], InAllHyps ] + | [ ] -> [ [], InGoal ] +END + +let nohide = mkRel 0 +let hidden_goal_tag = "the_hidden_goal" + +(* Reduction that preserves the Prod/Let spine of the "in" tactical. *) + +let inc_safe n = if n = 0 then n else n + 1 +let rec safe_depth c = match kind_of_term c with +| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth c' + 1 +| LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth c') +| _ -> 0 + +let red_safe r e s c0 = + let rec red_to e c n = match kind_of_term c with + | Prod (x, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (RelDecl.LocalAssum (x, t')) e in + mkProd (x, t', red_to e' c' (n - 1)) + | LetIn (x, b, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (RelDecl.LocalAssum (x, t')) e in + mkLetIn (x, r e s b, t', red_to e' c' (n - 1)) + | _ -> r e s c in + red_to e c0 (safe_depth c0) + +let check_wgen_uniq gens = + let clears = List.flatten (List.map fst gens) in + check_hyps_uniq [] clears; + let ids = CList.map_filter + (function (_,Some ((id,_),_)) -> Some (hoi_id id) | _ -> None) gens in + let rec check ids = function + | id :: _ when List.mem id ids -> + errorstrm (str"Duplicate generalization " ++ pr_id id) + | id :: hyps -> check (id :: ids) hyps + | [] -> () in + check [] ids + +let pf_clauseids gl gens clseq = + let keep_clears = List.map (fun (x, _) -> x, None) in + if gens <> [] then (check_wgen_uniq gens; gens) else + if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else + CErrors.error "assumptions should be named explicitly" + +let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false + +let hidetacs clseq idhide cl0 = + if not (hidden_clseq clseq) then [] else + [posetac idhide cl0; + Proofview.V82.of_tactic (convert_concl_no_check (mkVar idhide))] + +let discharge_hyp (id', (id, mode)) gl = + let cl' = subst_var id (pf_concl gl) in + match NamedDecl.to_tuple (pf_get_hyp gl id), mode with + | (_, None, t), _ | (_, Some _, t), "(" -> + apply_type (mkProd (Name id', t, cl')) [mkVar id] gl + | (_, Some v, t), _ -> + Proofview.V82.of_tactic (convert_concl (mkLetIn (Name id', v, t, cl'))) gl + +let endclausestac id_map clseq gl_id cl0 gl = + let not_hyp' id = not (List.mem_assoc id id_map) in + let orig_id id = try List.assoc id id_map with _ -> id in + let dc, c = Term.decompose_prod_assum (pf_concl gl) in + let hide_goal = hidden_clseq clseq in + let c_hidden = hide_goal && c = mkVar gl_id in + let rec fits forced = function + | (id, _) :: ids, decl :: dc' when RelDecl.get_name decl = Name id -> + fits true (ids, dc') + | ids, dc' -> + forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in + let rec unmark c = match kind_of_term c with + | Var id when hidden_clseq clseq && id = gl_id -> cl0 + | Prod (Name id, t, c') when List.mem_assoc id id_map -> + mkProd (Name (orig_id id), unmark t, unmark c') + | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') + | _ -> map_constr unmark c in + let utac hyp = + Proofview.V82.of_tactic + (convert_hyp_no_check (NamedDecl.map_constr unmark hyp)) in + let utacs = List.map utac (pf_hyps gl) in + let ugtac gl' = + Proofview.V82.of_tactic + (convert_concl_no_check (unmark (pf_concl gl'))) gl' in + let ctacs = if hide_goal then [Proofview.V82.of_tactic (clear [gl_id])] else [] in + let mktac itacs = tclTHENLIST (itacs @ utacs @ ugtac :: ctacs) in + let itac (_, id) = Proofview.V82.of_tactic (introduction id) in + if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else + let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in + if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else + CErrors.error "tampering with discharged assumptions of \"in\" tactical" + +let is_id_constr c = match kind_of_term c with + | Lambda(_,_,c) when isRel c -> 1 = destRel c + | _ -> false + +let red_product_skip_id env sigma c = match kind_of_term c with + | App(hd,args) when Array.length args = 1 && is_id_constr hd -> args.(0) + | _ -> try Tacred.red_product env sigma c with _ -> c + +let abs_wgen keep_let ist f gen (gl,args,c) = + let sigma, env = project gl, pf_env gl in + let evar_closed t p = + if occur_existential t then + CErrors.user_err_loc (loc_of_cpattern p,"ssreflect", + pr_constr_pat t ++ + str" contains holes and matches no subterm of the goal") in + match gen with + | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> + let x = hoi_id x in + let _, bo, ty = NamedDecl.to_tuple (pf_get_hyp gl x) in + gl, + (if bo <> None then args else mkVar x :: args), + mkProd_or_LetIn (mk_reldecl (Name (f x)) bo ty) (subst_var x c) + | _, Some ((x, _), None) -> + let x = hoi_id x in + gl, mkVar x :: args, mkProd (Name (f x),pf_get_hyp_typ gl x, subst_var x c) + | _, Some ((x, "@"), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + let ut = red_product_skip_id env sigma t in + let gl, ty = pf_type_of gl t in + pf_merge_uc ucst gl, args, mkLetIn(Name (f x), ut, ty, c) + | _, Some ((x, _), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + let gl, ty = pf_type_of gl t in + pf_merge_uc ucst gl, t :: args, mkProd(Name (f x), ty, c) + | _ -> gl, args, c + +let clr_of_wgen gen clrs = match gen with + | clr, Some ((x, _), None) -> + let x = hoi_id x in + cleartac clr :: cleartac [SsrHyp(Loc.ghost,x)] :: clrs + | clr, _ -> cleartac clr :: clrs + +let tclCLAUSES ist tac (gens, clseq) gl = + if clseq = InGoal || clseq = InSeqGoal then tac gl else + let clr_gens = pf_clauseids gl gens clseq in + let clear = tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag gl in + let cl0 = pf_concl gl in + let dtac gl = + let c = pf_concl gl in + let gl, args, c = + List.fold_right (abs_wgen true ist mk_discharged_id) gens (gl,[], c) in + apply_type c args gl in + let endtac = + let id_map = CList.map_filter (function + | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) + | _, None -> None) gens in + endclausestac id_map clseq gl_id cl0 in + tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl +(* }}} *) + +(** Simpl switch *) + +type ssrsimpl = Simpl | Cut | SimplCut | Nop + +let pr_simpl = function + | Simpl -> str "/=" + | Cut -> str "//" + | SimplCut -> str "//=" + | Nop -> mt () + +let pr_ssrsimpl _ _ _ = pr_simpl + +let wit_ssrsimplrep = add_genarg "ssrsimplrep" pr_simpl + +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ "/=" ] -> [ Simpl ] +| [ "//" ] -> [ Cut ] +| [ "//=" ] -> [ SimplCut ] +END + +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ ssrsimpl_ne(sim) ] -> [ sim ] +| [ ] -> [ Nop ] +END + +(* We must avoid zeta-converting any "let"s created by the "in" tactical. *) + +let safe_simpltac gl = + let cl' = red_safe Tacred.simpl (pf_env gl) (project gl) (pf_concl gl) in + Proofview.V82.of_tactic (convert_concl_no_check cl') gl + +let simpltac = function + | Simpl -> safe_simpltac + | Cut -> tclTRY donetac + | SimplCut -> tclTHEN safe_simpltac (tclTRY donetac) + | Nop -> tclIDTAC + +(** Rewriting direction *) + +let pr_dir = function L2R -> str "->" | R2L -> str "<-" +let pr_rwdir = function L2R -> mt() | R2L -> str "-" + +let rewritetac dir c = + (* Due to the new optional arg ?tac, application shouldn't be too partial *) + Proofview.V82.of_tactic begin + Equality.general_rewrite (dir = L2R) AllOccurrences true false c + end + +let wit_ssrdir = add_genarg "ssrdir" pr_dir + +let dir_org = function L2R -> 1 | R2L -> 2 + +(** Indexes *) + +(* Since SSR indexes are always positive numbers, we use the 0 value *) +(* to encode an omitted index. We reuse the in or_var type, but we *) +(* supply our own interpretation function, which checks for non *) +(* positive values, and allows the use of constr numerals, so that *) +(* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) + +type ssrindex = int or_var + +let pr_index = function + | ArgVar (_, id) -> pr_id id + | ArgArg n when n > 0 -> int n + | _ -> mt () +let pr_ssrindex _ _ _ = pr_index + +let noindex = ArgArg 0 +let allocc = Some(false,[]) + +let check_index loc i = + if i > 0 then i else loc_error loc "Index not positive" +let mk_index loc = function ArgArg i -> ArgArg (check_index loc i) | iv -> iv + +let interp_index ist gl idx = + Tacmach.project gl, + match idx with + | ArgArg _ -> idx + | ArgVar (loc, id) -> + let i = + try + let v = Id.Map.find id ist.lfun in + begin match Value.to_int v with + | Some i -> i + | None -> + begin match Value.to_constr v with + | Some c -> + let rc = Detyping.detype false [] (pf_env gl) (project gl) c in + begin match Notation.uninterp_prim_token rc with + | _, Numeral bigi -> int_of_string (Bigint.to_string bigi) + | _ -> raise Not_found + end + | None -> raise Not_found + end end + with _ -> loc_error loc "Index not a number" in + ArgArg (check_index loc i) + +ARGUMENT EXTEND ssrindex TYPED AS ssrindex PRINTED BY pr_ssrindex + INTERPRETED BY interp_index +| [ int_or_var(i) ] -> [ mk_index loc i ] +END + +(** Occurrence switch *) + +(* The standard syntax of complemented occurrence lists involves a single *) +(* initial "-", e.g., {-1 3 5}. An initial *) +(* "+" may be used to indicate positive occurrences (the default). The *) +(* "+" is optional, except if the list of occurrences starts with a *) +(* variable or is empty (to avoid confusion with a clear switch). The *) +(* empty positive switch "{+}" selects no occurrences, while the empty *) +(* negative switch "{-}" selects all occurrences explicitly; this is the *) +(* default, but "{-}" prevents the implicit clear, and can be used to *) +(* force dependent elimination -- see ndefectelimtac below. *) + +type ssrocc = occ + +let pr_occ = function + | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | None -> str "{}" + +let pr_ssrocc _ _ _ = pr_occ + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc +| [ natural(n) natural_list(occ) ] -> [ + Some (false, List.map (check_index loc) (n::occ)) ] +| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] +| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +END + +let pf_mkprod gl c ?(name=constr_name c) cl = + let gl, t = pf_type_of gl c in + if name <> Anonymous || noccurn 1 cl then gl, mkProd (name, t, cl) else + gl, mkProd (Name (pf_type_id gl t), t, cl) + +let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (subst_term c cl) + +(** Discharge occ switch (combined occurrence / clear switch *) + +type ssrdocc = ssrclear option * ssrocc option + +let mkocc occ = None, occ +let noclr = mkocc None +let mkclr clr = Some clr, None +let nodocc = mkclr [] + +let pr_docc = function + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear mt clr + +let pr_ssrdocc _ _ _ = pr_docc + +ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +END + +(** View hint database and View application. {{{ ******************************) + +(* There are three databases of lemmas used to mediate the application *) +(* of reflection lemmas: one for forward chaining, one for backward *) +(* chaining, and one for secondary backward chaining. *) + +(* View hints *) + +let rec isCxHoles = function (CHole _, None) :: ch -> isCxHoles ch | _ -> false + +let pr_raw_ssrhintref prc _ _ = function + | CAppExpl (_, (None, r,x), args) when isCHoles args -> + prc (CRef (r,x)) ++ str "|" ++ int (List.length args) + | CApp (_, (_, CRef _), _) as c -> prc c + | CApp (_, (_, c), args) when isCxHoles args -> + prc c ++ str "|" ++ int (List.length args) + | c -> prc c + +let pr_rawhintref = function + | GApp (_, f, args) when isRHoles args -> + pr_glob_constr f ++ str "|" ++ int (List.length args) + | c -> pr_glob_constr c + +let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c + +let pr_ssrhintref prc _ _ = prc + +let mkhintref loc c n = match c with + | CRef (r,x) -> CAppExpl (loc, (None, r, x), mkCHoles loc n) + | _ -> mkAppC (c, mkCHoles loc n) + +ARGUMENT EXTEND ssrhintref + PRINTED BY pr_ssrhintref + RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref + GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref + | [ constr(c) ] -> [ c ] + | [ constr(c) "|" natural(n) ] -> [ mkhintref loc c n ] +END + +(* View purpose *) + +let pr_viewpos = function + | 0 -> str " for move/" + | 1 -> str " for apply/" + | 2 -> str " for apply//" + | _ -> mt () + +let pr_ssrviewpos _ _ _ = pr_viewpos + +ARGUMENT EXTEND ssrviewpos TYPED AS int PRINTED BY pr_ssrviewpos + | [ "for" "move" "/" ] -> [ 0 ] + | [ "for" "apply" "/" ] -> [ 1 ] + | [ "for" "apply" "/" "/" ] -> [ 2 ] + | [ "for" "apply" "//" ] -> [ 2 ] + | [ ] -> [ 3 ] +END + +let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc + | [ ssrviewpos(i) ] -> [ i ] +END + +(* The table and its display command *) + +let viewtab : glob_constr list array = Array.make 3 [] + +let _ = + let init () = Array.fill viewtab 0 3 [] in + let freeze _ = Array.copy viewtab in + let unfreeze vt = Array.blit vt 0 viewtab 0 3 in + Summary.declare_summary "ssrview" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let mapviewpos f n k = if n < 3 then f n else for i = 0 to k - 1 do f i done + +let print_view_hints i = + let pp_viewname = str "Hint View" ++ pr_viewpos i ++ str " " in + let pp_hints = pr_list spc pr_rawhintref viewtab.(i) in + ppnl (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + +VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY +| [ "Print" "Hint" "View" ssrviewpos(i) ] -> [ mapviewpos print_view_hints i 3 ] +END + +(* Populating the table *) + +let cache_viewhint (_, (i, lvh)) = + let mem_raw h = List.exists (Glob_ops.glob_constr_eq h) in + let add_hint h hdb = if mem_raw h hdb then hdb else h :: hdb in + viewtab.(i) <- List.fold_right add_hint lvh viewtab.(i) + +let subst_viewhint ( subst, (i, lvh as ilvh)) = + let lvh' = List.smartmap (Detyping.subst_glob_constr subst) lvh in + if lvh' == lvh then ilvh else i, lvh' + +let classify_viewhint x = Libobject.Substitute x + +let in_viewhint = + Libobject.declare_object {(Libobject.default_object "VIEW_HINTS") with + Libobject.open_function = (fun i o -> if i = 1 then cache_viewhint o); + Libobject.cache_function = cache_viewhint; + Libobject.subst_function = subst_viewhint; + Libobject.classify_function = classify_viewhint } + +let glob_view_hints lvh = + List.map (Constrintern.intern_constr (Global.env ())) lvh + +let add_view_hints lvh i = Lib.add_anonymous_leaf (in_viewhint (i, lvh)) + +VERNAC COMMAND EXTEND HintView CLASSIFIED AS SIDEFF + | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> + [ mapviewpos (add_view_hints (glob_view_hints lvh)) n 2 ] +END + +(** Views *) + +(* Views for the "move" and "case" commands are actually open *) +(* terms, but this is handled by interp_view, which is called *) +(* by interp_casearg. We use lists, to support the *) +(* "double-view" feature of the apply command. *) + +(* type ssrview = ssrterm list *) + +let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) + +let pr_ssrview _ _ _ = pr_view + +ARGUMENT EXTEND ssrview TYPED AS ssrterm list + PRINTED BY pr_ssrview +| [ "/" constr(c) ] -> [ [mk_term ' ' c] ] +| [ "/" constr(c) ssrview(w) ] -> [ (mk_term ' ' c) :: w ] +END + +(* There are two ways of "applying" a view to term: *) +(* 1- using a view hint if the view is an instance of some *) +(* (reflection) inductive predicate. *) +(* 2- applying the view if it coerces to a function, adding *) +(* implicit arguments. *) +(* They require guessing the view hints and the number of *) +(* implicits, respectively, which we do by brute force. *) + +let view_error s gv = + errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) + +let interp_view ist si env sigma gv rid = + match intern_term ist sigma env gv with + | GApp (loc, GHole _, rargs) -> + let rv = GApp (loc, rid, rargs) in + snd (interp_open_constr ist (re_sig si sigma) (rv, None)) + | rv -> + let interp rc rargs = + interp_open_constr ist (re_sig si sigma) (mkRApp rc rargs, None) in + let rec simple_view rargs n = + if n < 0 then view_error "use" gv else + try interp rv rargs with _ -> simple_view (mkRHole :: rargs) (n - 1) in + let view_nbimps = interp_view_nbimps ist (re_sig si sigma) rv in + let view_args = [mkRApp rv (mkRHoles view_nbimps); rid] in + let rec view_with = function + | [] -> simple_view [rid] (interp_nbargs ist (re_sig si sigma) rv) + | hint :: hints -> try interp hint view_args with _ -> view_with hints in + snd (view_with (if view_nbimps < 0 then [] else viewtab.(0))) + +let top_id = mk_internal_id "top assumption" + +let with_view ist si env gl0 c name cl prune = + let c2r ist x = { ist with lfun = + Id.Map.add top_id (Value.of_constr x) ist.lfun } in + let rec loop (sigma, c') = function + | f :: view -> + let rid, ist = match kind_of_term c' with + | Var id -> mkRVar id, ist + | _ -> mkRltacVar top_id, c2r ist c' in + loop (interp_view ist si env sigma f rid) view + | [] -> + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + let c' = Reductionops.nf_evar sigma c' in + let n, c', _, ucst = pf_abs_evars gl0 (sigma, c') in + let c' = if not prune then c' else pf_abs_cterm gl0 n c' in + let gl0 = pf_merge_uc ucst gl0 in + let gl0, ap = pf_abs_prod name gl0 c' (prod_applist cl [c]) in + ap, c', pf_merge_uc_of sigma gl0 + in loop + +let pf_with_view ist gl (prune, view) cl c = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + with_view ist si env gl c (constr_name c) cl prune (sigma, c) view +(* }}} *) + +(** Extended intro patterns {{{ ***********************************************) + +type ssrtermrep = char * glob_constr_and_expr +type ssripat = + | IpatSimpl of ssrclear * ssrsimpl + | IpatId of identifier + | IpatWild + | IpatCase of ssripats list + | IpatRw of ssrocc * ssrdir + | IpatAll + | IpatAnon + | IpatView of ssrtermrep list + | IpatNoop + | IpatNewHidden of identifier list +and ssripats = ssripat list + +let remove_loc = snd + +let rec ipat_of_intro_pattern = function + | IntroNaming (IntroIdentifier id) -> IpatId id + | IntroAction IntroWildcard -> IpatWild + | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> + IpatCase + (List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat)) + | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> + IpatCase + [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)] + | IntroNaming IntroAnonymous -> IpatAnon + | IntroAction (IntroRewrite b) -> IpatRw (allocc, if b then L2R else R2L) + | IntroNaming (IntroFresh id) -> IpatAnon + | IntroAction (IntroApplyOn _) -> (* to do *) CErrors.error "TO DO" + | IntroAction (IntroInjection ips) -> + IpatCase [List.map ipat_of_intro_pattern (List.map remove_loc ips)] + | IntroForthcoming _ -> (* Unable to determine which kind of ipat interp_introid could return [HH] *) + assert false + +let rec pr_ipat = function + | IpatId id -> pr_id id + | IpatSimpl (clr, sim) -> pr_clear mt clr ++ pr_simpl sim + | IpatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") + | IpatRw (occ, dir) -> pr_occ occ ++ pr_dir dir + | IpatAll -> str "*" + | IpatWild -> str "_" + | IpatAnon -> str "?" + | IpatView v -> pr_view v + | IpatNoop -> str "-" + | IpatNewHidden l -> str "[:" ++ pr_list spc pr_id l ++ str "]" +and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat +and pr_ipats ipats = pr_list spc pr_ipat ipats + +let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat + +let pr_ssripat _ _ _ = pr_ipat +let pr_ssripats _ _ _ = pr_ipats +let pr_ssriorpat _ _ _ = pr_iorpat + +let intern_ipat ist ipat = + let rec check_pat = function + | IpatSimpl (clr, _) -> ignore (List.map (intern_hyp ist) clr) + | IpatCase iorpat -> List.iter (List.iter check_pat) iorpat + | _ -> () in + check_pat ipat; ipat + +let intern_ipats ist = List.map (intern_ipat ist) + +let interp_introid ist gl id = + try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (dummy_loc, id)))))) + with _ -> snd(snd (interp_intro_pattern ist gl (dummy_loc,IntroNaming (IntroIdentifier id)))) + +let rec add_intro_pattern_hyps (loc, ipat) hyps = match ipat with + | IntroNaming (IntroIdentifier id) -> + if not_section_id id then SsrHyp (loc, id) :: hyps else + hyp_err loc "Can't delete section hypothesis " id + | IntroAction IntroWildcard -> hyps + | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> + List.fold_right (List.fold_right add_intro_pattern_hyps) iorpat hyps + | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> + List.fold_right add_intro_pattern_hyps iandpat hyps + | IntroNaming IntroAnonymous -> [] + | IntroNaming (IntroFresh _) -> [] + | IntroAction (IntroRewrite _) -> hyps + | IntroAction (IntroInjection ips) -> List.fold_right add_intro_pattern_hyps ips hyps + | IntroAction (IntroApplyOn (c,pat)) -> add_intro_pattern_hyps pat hyps + | IntroForthcoming _ -> + (* As in ipat_of_intro_pattern, was unable to determine which kind + of ipat interp_introid could return [HH] *) assert false + +let rec interp_ipat ist gl = + let ltacvar id = Id.Map.mem id ist.lfun in + let rec interp = function + | IpatId id when ltacvar id -> + ipat_of_intro_pattern (interp_introid ist gl id) + | IpatSimpl (clr, sim) -> + let add_hyps (SsrHyp (loc, id) as hyp) hyps = + if not (ltacvar id) then hyp :: hyps else + add_intro_pattern_hyps (loc, (interp_introid ist gl id)) hyps in + let clr' = List.fold_right add_hyps clr [] in + check_hyps_uniq [] clr'; IpatSimpl (clr', sim) + | IpatCase iorpat -> IpatCase (List.map (List.map interp) iorpat) + | IpatNewHidden l -> + IpatNewHidden + (List.map (function + | IntroNaming (IntroIdentifier id) -> id + | _ -> assert false) + (List.map (interp_introid ist gl) l)) + | ipat -> ipat in + interp + +let interp_ipats ist gl l = project gl, List.map (interp_ipat ist gl) l + +let pushIpatRw = function + | pats :: orpat -> (IpatRw (allocc, L2R) :: pats) :: orpat + | [] -> [] + +let pushIpatNoop = function + | pats :: orpat -> (IpatNoop :: pats) :: orpat + | [] -> [] + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats + INTERPRETED BY interp_ipats + GLOBALIZED BY intern_ipats + | [ "_" ] -> [ [IpatWild] ] + | [ "*" ] -> [ [IpatAll] ] + | [ ident(id) ] -> [ [IpatId id] ] + | [ "?" ] -> [ [IpatAnon] ] + | [ ssrsimpl_ne(sim) ] -> [ [IpatSimpl ([], sim)] ] + | [ ssrdocc(occ) "->" ] -> [ match occ with + | None, occ -> [IpatRw (occ, L2R)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, L2R)]] + | [ ssrdocc(occ) "<-" ] -> [ match occ with + | None, occ -> [IpatRw (occ, R2L)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, R2L)]] + | [ ssrdocc(occ) ] -> [ match occ with + | Some cl, _ -> check_hyps_uniq [] cl; [IpatSimpl (cl, Nop)] + | _ -> loc_error loc "Only identifiers are allowed here"] + | [ "->" ] -> [ [IpatRw (allocc, L2R)] ] + | [ "<-" ] -> [ [IpatRw (allocc, R2L)] ] + | [ "-" ] -> [ [IpatNoop] ] + | [ "-/" "=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/" "/" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-//" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-/" "/=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//" "=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ ssrview(v) ] -> [ [IpatView v] ] + | [ "[" ":" ident_list(idl) "]" ] -> [ [IpatNewHidden idl] ] +END + +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + | [ ] -> [ [] ] +END + +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIpatNoop orpat ] +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] +| [ ssripats(pats) ] -> [ [pats] ] +END + +let reject_ssrhid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "[" -> + (match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD ":" -> raise Stream.Failure + | _ -> ()) + | _ -> () + +let test_nohidden = Gram.Entry.of_parser "test_ssrhid" reject_ssrhid + +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> [ IpatCase x ] +END + +GEXTEND Gram + GLOBAL: ssrcpat; + ssrcpat: [[ test_nohidden; "["; iorpat = ssriorpat; "]" -> IpatCase iorpat ]]; +END + +GEXTEND Gram + GLOBAL: ssripat; + ssripat: [[ pat = ssrcpat -> [pat] ]]; +END + +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] +END + +(* subsets of patterns *) +let check_ssrhpats loc w_binders ipats = + let err_loc s = CErrors.user_err_loc (loc, "ssreflect", s) in + let clr, ipats = + let rec aux clr = function + | IpatSimpl (cl, Nop) :: tl -> aux (clr @ cl) tl + | IpatSimpl (cl, sim) :: tl -> clr @ cl, IpatSimpl ([], sim) :: tl + | tl -> clr, tl + in aux [] ipats in + let simpl, ipats = + match List.rev ipats with + | IpatSimpl ([],_) as s :: tl -> [s], List.rev tl + | _ -> [], ipats in + if simpl <> [] && not w_binders then + err_loc (str "No s-item allowed here: " ++ pr_ipats simpl); + let ipat, binders = + let rec loop ipat = function + | [] -> ipat, [] + | ( IpatId _| IpatAnon| IpatCase _| IpatRw _ as i) :: tl -> + if w_binders then + if simpl <> [] && tl <> [] then + err_loc(str"binders XOR s-item allowed here: "++pr_ipats(tl@simpl)) + else if not (List.for_all (function IpatId _ -> true | _ -> false) tl) + then err_loc (str "Only binders allowed here: " ++ pr_ipats tl) + else ipat @ [i], tl + else + if tl = [] then ipat @ [i], [] + else err_loc (str "No binder or s-item allowed here: " ++ pr_ipats tl) + | hd :: tl -> loop (ipat @ [hd]) tl + in loop [] ipats in + ((clr, ipat), binders), simpl + +let single loc = + function [x] -> x | _ -> loc_error loc "Only one intro pattern is allowed" + +let pr_hpats (((clr, ipat), binders), simpl) = + pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl +let pr_ssrhpats _ _ _ = pr_hpats +let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x + +ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat +PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +END + +ARGUMENT EXTEND ssrhpats_wtransp + TYPED AS bool * (((ssrclear * ssripat) * ssripat) * ssripat) + PRINTED BY pr_ssrhpats_wtransp + | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] + | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] +END + +ARGUMENT EXTEND ssrhpats_nobs +TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +END + +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "->" ] -> [ IpatRw (allocc, L2R) ] + | [ "<-" ] -> [ IpatRw (allocc, R2L) ] +END + +type ssrintros = ssripats + +let pr_intros sep intrs = + if intrs = [] then mt() else sep () ++ str "=> " ++ pr_ipats intrs +let pr_ssrintros _ _ _ = pr_intros mt + +ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat + PRINTED BY pr_ssrintros + | [ "=>" ssripats_ne(pats) ] -> [ pats ] +END + +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros + | [ ssrintros_ne(intrs) ] -> [ intrs ] + | [ ] -> [ [] ] +END + +let injecteq_id = mk_internal_id "injection equation" + +let pf_nb_prod gl = nb_prod (pf_concl gl) + +let rev_id = mk_internal_id "rev concl" + +let revtoptac n0 gl = + let n = pf_nb_prod gl - n0 in + let dc, cl = decompose_prod_n n (pf_concl gl) in + let dc' = dc @ [Name rev_id, compose_prod (List.rev dc) cl] in + let f = compose_lam dc' (mkEtaApp (mkRel (n + 1)) (-n) 1) in + refine (mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + +let equality_inj l b id c gl = + let msg = ref "" in + try Proofview.V82.of_tactic (Equality.inj l b None c) gl + with + | Compat.Exc_located(_,CErrors.UserError (_,s)) + | CErrors.UserError (_,s) + when msg := Pp.string_of_ppcmds s; + !msg = "Not a projectable equality but a discriminable one." || + !msg = "Nothing to inject." -> + msg_warning (str !msg); + discharge_hyp (id, (id, "")) gl + +let injectidl2rtac id c gl = + tclTHEN (equality_inj None true id c) (revtoptac (pf_nb_prod gl)) gl + +let injectl2rtac c = match kind_of_term c with +| Var id -> injectidl2rtac id (mkVar id, NoBindings) +| _ -> + let id = injecteq_id in + tclTHENLIST [havetac id c; injectidl2rtac id (mkVar id, NoBindings); Proofview.V82.of_tactic (clear [id])] + +let is_injection_case c gl = + let gl, cty = pf_type_of gl c in + let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in + eq_gr (IndRef mind) (build_coq_eq ()) + +let perform_injection c gl = + let gl, cty = pf_type_of gl c in + let mind, t = pf_reduce_to_quantified_ind gl cty in + let dc, eqt = decompose_prod t in + if dc = [] then injectl2rtac c gl else + if not (closed0 eqt) then + CErrors.error "can't decompose a quantified equality" else + let cl = pf_concl gl in let n = List.length dc in + let c_eq = mkEtaApp c n 2 in + let cl1 = mkLambda (Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let id = injecteq_id in + let id_with_ebind = (mkVar id, NoBindings) in + let injtac = tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + tclTHENLAST (Proofview.V82.of_tactic (apply (compose_lam dc cl1))) injtac gl + +let simplest_newcase_ref = ref (fun t gl -> assert false) +let simplest_newcase x gl = !simplest_newcase_ref x gl + +let ssrscasetac c gl = + if is_injection_case c gl then perform_injection c gl + else simplest_newcase c gl + +let intro_all gl = + let dc, _ = Term.decompose_prod_assum (pf_concl gl) in + tclTHENLIST (List.map anontac (List.rev dc)) gl + +let rec intro_anon gl = + try anontac (List.hd (fst (Term.decompose_prod_n_assum 1 (pf_concl gl)))) gl + with err0 -> try tclTHEN (Proofview.V82.of_tactic red_in_concl) intro_anon gl with _ -> raise err0 + (* with _ -> CErrors.error "No product even after reduction" *) + +let with_top tac = + tclTHENLIST [introid top_id; tac (mkVar top_id); Proofview.V82.of_tactic (clear [top_id])] + +let rec mapLR f = function [] -> [] | x :: s -> let y = f x in y :: mapLR f s + +let wild_ids = ref [] + +let new_wild_id () = + let i = 1 + List.length !wild_ids in + let id = mk_wildcard_id i in + wild_ids := id :: !wild_ids; + id + +let clear_wilds wilds gl = + Proofview.V82.of_tactic (clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl))) gl + +let clear_with_wilds wilds clr0 gl = + let extend_clr clr nd = + let id = NamedDecl.get_id nd in + if List.mem id clr || not (List.mem id wilds) then clr else + let vars = global_vars_set_of_decl (pf_env gl) nd in + let occurs id' = Idset.mem id' vars in + if List.exists occurs clr then id :: clr else clr in + Proofview.V82.of_tactic (clear (Context.Named.fold_inside extend_clr ~init:clr0 (pf_hyps gl))) gl + +let tclTHENS_nonstrict tac tacl taclname gl = + let tacres = tac gl in + let n_gls = List.length (sig_it tacres) in + let n_tac = List.length tacl in + if n_gls = n_tac then tclTHENS (fun _ -> tacres) tacl gl else + if n_gls = 0 then tacres else + let pr_only n1 n2 = if n1 < n2 then str "only " else mt () in + let pr_nb n1 n2 name = + pr_only n1 n2 ++ int n1 ++ str (" " ^ String.plural n1 name) in + errorstrm (pr_nb n_tac n_gls taclname ++ spc () + ++ str "for " ++ pr_nb n_gls n_tac "subgoal") + +(* Forward reference to extended rewrite *) +let ipat_rewritetac = ref (fun _ -> rewritetac) + +let rec is_name_in_ipats name = function + | IpatSimpl(clr,_) :: tl -> + List.exists (function SsrHyp(_,id) -> id = name) clr + || is_name_in_ipats name tl + | IpatId id :: tl -> id = name || is_name_in_ipats name tl + | IpatCase l :: tl -> is_name_in_ipats name (List.flatten l @ tl) + | _ :: tl -> is_name_in_ipats name tl + | [] -> false + +let move_top_with_view = ref (fun _ -> assert false) + +let rec nat_of_n n = + if n = 0 then mkConstruct path_of_O + else mkApp (mkConstruct path_of_S, [|nat_of_n (n-1)|]) + +let ssr_abstract_id = Summary.ref "~name:SSR:abstractid" 0 + +let mk_abstract_id () = incr ssr_abstract_id; nat_of_n !ssr_abstract_id + +let ssrmkabs id gl = + let env, concl = pf_env gl, pf_concl gl in + let step = { run = begin fun sigma -> + let Sigma ((abstract_proof, abstract_ty), sigma, p) = + let Sigma ((ty, _), sigma, p1) = + Evarutil.new_type_evar env sigma Evd.univ_flexible_alg in + let Sigma (ablock, sigma, p2) = mkSsrConst "abstract_lock" env sigma in + let Sigma (lock, sigma, p3) = Evarutil.new_evar env sigma ablock in + let Sigma (abstract, sigma, p4) = mkSsrConst "abstract" env sigma in + let abstract_ty = mkApp(abstract, [|ty;mk_abstract_id ();lock|]) in + let Sigma (m, sigma, p5) = Evarutil.new_evar env sigma abstract_ty in + Sigma ((m, abstract_ty), sigma, p1 +> p2 +> p3 +> p4 +> p5) in + let sigma, kont = + let rd = RelDecl.LocalAssum (Name id, abstract_ty) in + let Sigma (ev, sigma, _) = Evarutil.new_evar (Environ.push_rel rd env) sigma concl in + let sigma = Sigma.to_evar_map sigma in + (sigma, ev) + in + pp(lazy(pr_constr concl)); + let term = mkApp (mkLambda(Name id,abstract_ty,kont) ,[|abstract_proof|]) in + let sigma, _ = Typing.type_of env sigma term in + Sigma.Unsafe.of_pair (term, sigma) + end } in + Proofview.V82.of_tactic + (Proofview.tclTHEN + (Tactics.New.refine step) + (Proofview.tclFOCUS 1 3 Proofview.shelve)) gl + +let ssrmkabstac ids = + List.fold_right (fun id tac -> tclTHENFIRST (ssrmkabs id) tac) ids tclIDTAC + +(* introstac: for "move" and "clear", tclEQINTROS: for "case" and "elim" *) +(* This block hides the spaghetti-code needed to implement the only two *) +(* tactics that should be used to process intro patters. *) +(* The difficulty is that we don't want to always rename, but we can *) +(* compute needeed renamings only at runtime, so we theread a tree like *) +(* imperativestructure so that outer renamigs are inherited by inner *) +(* ipts and that the cler performed at the end of ipatstac clears hyps *) +(* eventually renamed at runtime. *) +(* TODO: hide wild_ids in this block too *) +let introstac, tclEQINTROS = + let rec map_acc_k f k = function + | [] -> (* tricky: we save wilds now, we get to_cler (aka k) later *) + let clear_ww = clear_with_wilds !wild_ids in + [fun gl -> clear_ww (hyps_ids (List.flatten (List.map (!) k))) gl] + | x :: xs -> let k, x = f k xs x in x :: map_acc_k f k xs in + let rename force to_clr rest clr gl = + let hyps = pf_hyps gl in + pp(lazy(str"rename " ++ pr_clear spc clr)); + let () = if not force then List.iter (check_hyp_exists hyps) clr in + if List.exists (fun x -> force || is_name_in_ipats (hyp_id x) rest) clr then + let ren_clr, ren = + List.split (List.map (fun x -> let x = hyp_id x in + let x' = mk_anon_id (string_of_id x) gl in + SsrHyp (dummy_loc, x'), (x, x')) clr) in + let () = to_clr := ren_clr in + Proofview.V82.of_tactic (rename_hyp ren) gl + else + let () = to_clr := clr in + tclIDTAC gl in + let rec ipattac ?ist k rest = function + | IpatWild -> k, introid (new_wild_id ()) + | IpatCase iorpat -> k, tclIORPAT ?ist k (with_top ssrscasetac) iorpat + | IpatRw (occ, dir) -> k, with_top (!ipat_rewritetac occ dir) + | IpatId id -> k, introid id + | IpatNewHidden idl -> k, ssrmkabstac idl + | IpatSimpl (clr, sim) -> + let to_clr = ref [] in + to_clr :: k, tclTHEN (rename false to_clr rest clr) (simpltac sim) + | IpatAll -> k, intro_all + | IpatAnon -> k, intro_anon + | IpatNoop -> k, tclIDTAC + | IpatView v -> match ist with + | None -> anomaly "ipattac with no ist but view" + | Some ist -> match rest with + | (IpatCase _ | IpatRw _)::_ -> + let to_clr = ref [] in let top_id = ref top_id in + to_clr :: k, + tclTHEN + (!move_top_with_view false top_id (false,v) ist) + (fun gl -> + rename true to_clr rest [SsrHyp (dummy_loc, !top_id)]gl) + | _ -> k, !move_top_with_view true (ref top_id) (true,v) ist + and tclIORPAT ?ist k tac = function + | [[]] -> tac + | orp -> + tclTHENS_nonstrict tac (mapLR (ipatstac ?ist k) orp) "intro pattern" + and ipatstac ?ist k ipats = + tclTHENLIST (map_acc_k (ipattac ?ist) k ipats) in + let introstac ?ist ipats = + wild_ids := []; + let tac = ipatstac ?ist [] ipats in + tclTHENLIST [tac; clear_wilds !wild_ids] in + let tclEQINTROS ?ist tac eqtac ipats = + wild_ids := []; + let rec split_itacs to_clr tac' = function + | (IpatSimpl _ as spat) :: ipats' -> + let to_clr, tac = ipattac ?ist to_clr ipats' spat in + split_itacs to_clr (tclTHEN tac' tac) ipats' + | IpatCase iorpat :: ipats' -> + to_clr, tclIORPAT ?ist to_clr tac' iorpat, ipats' + | ipats' -> to_clr, tac', ipats' in + let to_clr, tac1, ipats' = split_itacs [] tac ipats in + let tac2 = ipatstac ?ist to_clr ipats' in + tclTHENLIST [tac1; eqtac; tac2; clear_wilds !wild_ids] in + introstac, tclEQINTROS +;; + +let rec eqmoveipats eqpat = function + | (IpatSimpl _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats + | (IpatAll :: _ | []) as ipats -> IpatAnon :: eqpat :: ipats + | ipat :: ipats -> ipat :: eqpat :: ipats + +(* General case *) +let tclINTROS ist tac ipats = + tclEQINTROS ~ist (tac ist) tclIDTAC ipats + +(** The "=>" tactical *) + +let ssrintros_sep = + let atom_sep = function + (* | TacSplit (_, [NoBindings]) -> mt *) + (* | TacExtend (_, "ssrapply", []) -> mt *) + | _ -> spc in + function + | TacId [] -> mt + | TacArg (_, Tacexp _) -> mt + | TacArg (_, Reference _) -> mt + | TacAtom (_, atom) -> atom_sep atom + | _ -> spc + +let pr_ssrintrosarg _ _ prt (tac, ipats) = + prt tacltop tac ++ pr_intros spc ipats + +ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros + PRINTED BY pr_ssrintrosarg +| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +END + +TACTIC EXTEND ssrtclintros +| [ "YouShouldNotTypeThis" ssrintrosarg(arg) ] -> + [ let tac, intros = arg in + Proofview.V82.tactic (tclINTROS ist (fun ist -> ssrevaltac ist tac) intros) ] +END +set_pr_ssrtac "tclintros" 0 [ArgSsr "introsarg"] + +let tclintros_expr loc tac ipats = + let args = [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in + ssrtac_expr loc "tclintros" args + +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr !@loc tac intros + ] ]; +END +(* }}} *) + +(** Multipliers {{{ ***********************************************************) + +(* modality *) + +type ssrmmod = May | Must | Once + +let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () + +let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod) +GEXTEND Gram + GLOBAL: ssrmmod; + ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; +END + +(* tactical *) + +let tclID tac = tac + +let tclDOTRY n tac = + if n <= 0 then tclIDTAC else + let rec loop i gl = + if i = n then tclTRY tac gl else + tclTRY (tclTHEN tac (loop (i + 1))) gl in + loop 1 + +let tclDO n tac = + let prefix i = str"At iteration " ++ int i ++ str": " in + let tac_err_at i gl = + try tac gl + with + | CErrors.UserError (l, s) as e -> + let _, info = CErrors.push e in + let e' = CErrors.UserError (l, prefix i ++ s) in + Util.iraise (e', info) + | Compat.Exc_located(loc, CErrors.UserError (l, s)) -> + raise (Compat.Exc_located(loc, CErrors.UserError (l, prefix i ++ s))) in + let rec loop i gl = + if i = n then tac_err_at i gl else + (tclTHEN (tac_err_at i) (loop (i + 1))) gl in + loop 1 + +let tclMULT = function + | 0, May -> tclREPEAT + | 1, May -> tclTRY + | n, May -> tclDOTRY n + | 0, Must -> tclAT_LEAST_ONCE + | n, Must when n > 1 -> tclDO n + | _ -> tclID + +(** The "do" tactical. ********************************************************) + +(* +type ssrdoarg = ((ssrindex * ssrmmod) * ssrhint) * ssrclauses +*) + +let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses + +ARGUMENT EXTEND ssrdoarg + TYPED AS ((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses + PRINTED BY pr_ssrdoarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssrdotac ist (((n, m), tac), clauses) = + let mul = get_index n, m in + tclCLAUSES ist (tclMULT mul (hinttac ist false tac)) clauses + +TACTIC EXTEND ssrtcldo +| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> [ Proofview.V82.tactic (ssrdotac ist arg) ] +END +set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +let ssrdotac_expr loc n m tac clauses = + let arg = ((n, m), tac), clauses in + ssrtac_expr loc "tcldo" [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrdoarg) arg)] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrdotac: [ + [ tac = tactic_expr LEVEL "3" -> mk_hint tac + | tacs = ssrortacarg -> tacs + ] ]; + tactic_expr: LEVEL "3" [ RIGHTA + [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr !@loc noindex m tac clauses + | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> + ssrdotac_expr !@loc noindex Once tac clauses + | IDENT "do"; n = int_or_var; m = ssrmmod; + tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr !@loc (mk_index !@loc n) m tac clauses + ] ]; +END +(* }}} *) + +(** The "first" and "last" tacticals. {{{ *************************************) + +(* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) + +let pr_seqtacarg prt = function + | (is_first, []), _ -> str (if is_first then "first" else "last") + | tac, Some dtac -> + hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) + | tac, _ -> pr_hintarg prt tac + +let pr_ssrseqarg _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac + +(* We must parse the index separately to resolve the conflict with *) +(* an unindexed tactic. *) +ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) + PRINTED BY pr_ssrseqarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let sq_brace_tacnames = + ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] + (* "by" is a keyword *) +let accept_ssrseqvar strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> + accept_before_syms_or_ids ["["] ["first";"last"] strm + | _ -> raise Stream.Failure + +let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar + +let swaptacarg (loc, b) = (b, []), Some (TacId []) + +let check_seqtacarg dir arg = match snd arg, dir with + | ((true, []), Some (TacAtom (loc, _))), L2R -> + loc_error loc "expected \"last\"" + | ((false, []), Some (TacAtom (loc, _))), R2L -> + loc_error loc "expected \"first\"" + | _, _ -> arg + +let ssrorelse = Gram.entry_create "ssrorelse" +GEXTEND Gram + GLOBAL: ssrorelse ssrseqarg; + ssrseqidx: [ + [ test_ssrseqvar; id = Prim.ident -> ArgVar (!@loc, id) + | n = Prim.natural -> ArgArg (check_index !@loc n) + ] ]; + ssrswap: [[ IDENT "first" -> !@loc, true | IDENT "last" -> !@loc, false ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrseqarg: [ + [ arg = ssrswap -> noindex, swaptacarg arg + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) + | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg + | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + ] ]; +END + +let tclPERM perm tac gls = + let subgls = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let subgll' = perm subgll in + Refiner.repackage sigma subgll' +(* +let tclPERM perm tac gls = + let mkpft n g r = + {Proof_type.open_subgoals = n; Proof_type.goal = g; Proof_type.ref = r} in + let mkleaf g = mkpft 0 g None in + let mkprpft n g pr a = mkpft n g (Some (Proof_type.Prim pr, a)) in + let mkrpft n g c = mkprpft n g (Proof_type.Refine c) in + let mkipft n g = + let mki pft (id, _, _ as d) = + let g' = {g with evar_concl = mkNamedProd_or_LetIn d g.evar_concl} in + mkprpft n g' (Proof_type.Intro id) [pft] in + List.fold_left mki in + let gl = Refiner.sig_it gls in + let mkhyp subgl = + let rec chop_section = function + | (x, _, _ as d) :: e when not_section_id x -> d :: chop_section e + | _ -> [] in + let lhyps = Environ.named_context_of_val subgl.evar_hyps in + mk_perm_id (), subgl, chop_section lhyps in + let mkpfvar (hyp, subgl, lhyps) = + let mkarg args (lhyp, body, _) = + if body = None then mkVar lhyp :: args else args in + mkrpft 0 subgl (applist (mkVar hyp, List.fold_left mkarg [] lhyps)) [] in + let mkpfleaf (_, subgl, lhyps) = mkipft 1 gl (mkleaf subgl) lhyps in + let mkmeta _ = Evarutil.mk_new_meta () in + let mkhypdecl (hyp, subgl, lhyps) = + hyp, None, it_mkNamedProd_or_LetIn subgl.evar_concl lhyps in + let subgls, v as res0 = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let n = List.length subgll in if n = 0 then res0 else + let hyps = List.map mkhyp subgll in + let hyp_decls = List.map mkhypdecl (List.rev (perm hyps)) in + let c = applist (mkmeta (), List.map mkmeta subgll) in + let pft0 = mkipft 0 gl (v (List.map mkpfvar hyps)) hyp_decls in + let pft1 = mkrpft n gl c (pft0 :: List.map mkpfleaf (perm hyps)) in + let subgll', v' = Refiner.frontier pft1 in + Refiner.repackage sigma subgll', v' +*) + +let tclREV tac gl = tclPERM List.rev tac gl + +let rot_hyps dir i hyps = + let n = List.length hyps in + if i = 0 then List.rev hyps else + if i > n then CErrors.error "Not enough subgoals" else + let rec rot i l_hyps = function + | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' + | hyps' -> hyps' @ (List.rev l_hyps) in + rot (match dir with L2R -> i | R2L -> n - i) [] hyps + +let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) = + let i = get_index ivar in + let evtac = ssrevaltac ist in + let tac1 = evtac atac1 in + if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else + let evotac = function Some atac -> evtac atac | _ -> tclIDTAC in + let tac3 = evotac atac3 in + let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in + match dir, mk_pad (i - 1), List.map evotac atacs2 with + | L2R, [], [tac2] when atac3 = None -> tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + +(* We can't actually parse the direction separately because this *) +(* would introduce conflicts with the basic ltac syntax. *) +let pr_ssrseqdir _ _ _ = function + | L2R -> str ";" ++ spc () ++ str "first " + | R2L -> str ";" ++ spc () ++ str "last " + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +TACTIC EXTEND ssrtclseq +| [ "YouShouldNotTypeThis" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> + [ Proofview.V82.tactic (tclSEQAT ist tac dir arg) ] +END +set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +let tclseq_expr loc tac dir arg = + let arg1 = in_gen (rawwit wit_ssrtclarg) tac in + let arg2 = in_gen (rawwit wit_ssrseqdir) dir in + let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in + ssrtac_expr loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric x) [arg1; arg2; arg3]) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssr_first: [ + [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr !@loc tac ipats + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + ] ]; + ssr_first_else: [ + [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) + | tac = ssr_first -> tac ]]; + tactic_expr: LEVEL "4" [ LEFTA + [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + TacThen (tac1, tac2) + | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + tclseq_expr !@loc tac L2R arg + | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + tclseq_expr !@loc tac R2L arg + ] ]; +END +(* }}} *) + +(** 5. Bookkeeping tactics (clear, move, case, elim) *) + +(* post-interpretation of terms *) +let all_ok _ _ = true + +let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = + let sigma, ct as t = interp_term ist gl t in + let sigma, _ as t = + let env = pf_env gl in + if not resolve_typeclasses then t + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma ct in + let n, c, abstracted_away, ucst = pf_abs_evars gl t in + List.fold_left Evd.remove sigma abstracted_away, pf_abs_cterm gl n c, ucst, n + +let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = + let n_binders = ref 0 in + let ty = match ty with + | a, (t, None) -> + let rec force_type = function + | GProd (l, x, k, s, t) -> incr n_binders; GProd (l, x, k, s, force_type t) + | GLetIn (l, x, v, t) -> incr n_binders; GLetIn (l, x, v, force_type t) + | ty -> mkRCast ty mkRType in + a, (force_type t, None) + | _, (_, Some ty) -> + let rec force_type = function + | CProdN (l, abs, t) -> + n_binders := !n_binders + List.length (List.flatten (List.map pi1 abs)); + CProdN (l, abs, force_type t) + | CLetIn (l, n, v, t) -> incr n_binders; CLetIn (l, n, v, force_type t) + | ty -> mkCCast dummy_loc ty (mkCType dummy_loc) in + mk_term ' ' (force_type ty) in + let strip_cast (sigma, t) = + let rec aux t = match kind_of_type t with + | CastType (t, ty) when !n_binders = 0 && isSort ty -> t + | ProdType(n,s,t) -> decr n_binders; mkProd (n, s, aux t) + | LetInType(n,v,ty,t) -> decr n_binders; mkLetIn (n, v, ty, aux t) + | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in + sigma, aux t in + let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let ty = + let env = pf_env gl in + if not resolve_typeclasses then ty + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma cty in + let n, c, _, ucst = pf_abs_evars gl ty in + let lam_c = pf_abs_cterm gl n c in + let ctx, c = decompose_lam_n n lam_c in + n, compose_prod ctx c, lam_c, ucst +;; + +let whd_app f args = Reductionops.whd_betaiota Evd.empty (mkApp (f, args)) + +let pr_cargs a = + str "[" ++ pr_list pr_spc pr_constr (Array.to_list a) ++ str "]" + +let pp_term gl t = + let t = Reductionops.nf_evar (project gl) t in pr_constr t +let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> + hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs + +let fake_pmatcher_end () = + mkProp, L2R, (Evd.empty, Evd.empty_evar_universe_context, mkProp) + +(* TASSI: given (c : ty), generates (c ??? : ty[???/...]) with m evars *) +exception NotEnoughProducts +let prof_saturate_whd = mk_profiler "saturate.whd";; +let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m += + let rec loop ty args sigma n = + if n = 0 then + let args = List.rev args in + (if beta then Reductionops.whd_beta sigma else fun x -> x) + (mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma + else match kind_of_type ty with + | ProdType (_, src, tgt) -> + let sigma = create_evar_defs sigma in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (x, sigma, _) = + Evarutil.new_evar env sigma + (if bi_types then Reductionops.nf_betaiota (Sigma.to_evar_map sigma) src else src) in + let sigma = Sigma.to_evar_map sigma in + loop (subst1 x tgt) ((m - n,x) :: args) sigma (n-1) + | CastType (t, _) -> loop t args sigma n + | LetInType (_, v, _, t) -> loop (subst1 v t) args sigma n + | SortType _ -> assert false + | AtomicType _ -> + let ty = + prof_saturate_whd.profile + (Reductionops.whd_all env sigma) ty in + match kind_of_type ty with + | ProdType _ -> loop ty args sigma n + | _ -> raise NotEnoughProducts + in + loop ty [] sigma m + +let pf_saturate ?beta ?bi_types gl c ?ty m = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let t, ty, args, sigma = saturate ?beta ?bi_types env sigma c ?ty m in + t, ty, args, re_sig si sigma + +(** Rewrite redex switch *) + +(** Generalization (discharge) item *) + +(* An item is a switch + term pair. *) + +(* type ssrgen = ssrdocc * ssrterm *) + +let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt + +let pr_ssrgen _ _ _ = pr_gen + +ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen +| [ ssrdocc(docc) cpattern(dt) ] -> [ docc, dt ] +| [ cpattern(dt) ] -> [ nodocc, dt ] +END + +let has_occ ((_, occ), _) = occ <> None +let hyp_of_var v = SsrHyp (dummy_loc, destVar v) + +let interp_clr = function +| Some clr, (k, c) + when (k = ' ' || k = '@') && is_pf_var c -> hyp_of_var c :: clr +| Some clr, _ -> clr +| None, _ -> [] + +(* XXX the k of the redex should percolate out *) +let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = + let pat = interp_cpattern ist gl t None in (* UGLY API *) + let cl, env, sigma = pf_concl gl, pf_env gl, project gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern env pat, cl in + let clr = interp_clr (oclr, (tag_of_cpattern t, c)) in + if not(occur_existential c) then + if tag_of_cpattern t = '@' then + if not (isVar c) then + errorstrm (str "@ can be used with variables only") + else match NamedDecl.to_tuple (pf_get_hyp gl (destVar c)) with + | _, None, _ -> errorstrm (str "@ can be used with let-ins only") + | name, Some bo, ty -> true, pat, mkLetIn (Name name,bo,ty,cl),c,clr,ucst,gl + else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl + else if to_ind && occ = None then + let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in + let ucst = Evd.union_evar_universe_context ucst ucst' in + if nv = 0 then anomaly "occur_existential but no evars" else + let gl, pty = pf_type_of gl p in + false, pat, mkProd (constr_name c, pty, pf_concl gl), p, clr,ucst,gl + else loc_error (loc_of_cpattern t) "generalized term didn't match" + +let genclrtac cl cs clr = + let tclmyORELSE tac1 tac2 gl = + try tac1 gl + with e when CErrors.noncritical e -> tac2 e gl in + (* apply_type may give a type error, but the useful message is + * the one of clear. You type "move: x" and you get + * "x is used in hyp H" instead of + * "The term H has type T x but is expected to have type T x0". *) + tclTHEN + (tclmyORELSE + (apply_type cl cs) + (fun type_err gl -> + tclTHEN + (tclTHEN (Proofview.V82.of_tactic (elim_type (build_coq_False ()))) (cleartac clr)) + (fun gl -> raise type_err) + gl)) + (cleartac clr) + +let gentac ist gen gl = +(* pp(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) + let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux ist gl false gen in + pp(lazy(str"c@gentac=" ++ pr_constr c)); + let gl = pf_merge_uc ucst gl in + if conv + then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (cleartac clr) gl + else genclrtac cl [c] clr gl + +let pf_interp_gen ist gl to_ind gen = + let _, _, a, b, c, ucst,gl = pf_interp_gen_aux ist gl to_ind gen in + a, b ,c, pf_merge_uc ucst gl + +(** Generalization (discharge) sequence *) + +(* A discharge sequence is represented as a list of up to two *) +(* lists of d-items, plus an ident list set (the possibly empty *) +(* final clear switch). The main list is empty iff the command *) +(* is defective, and has length two if there is a sequence of *) +(* dependent terms (and in that case it is the first of the two *) +(* lists). Thus, the first of the two lists is never empty. *) + +(* type ssrgens = ssrgen list *) +(* type ssrdgens = ssrgens list * ssrclear *) + +let gens_sep = function [], [] -> mt | _ -> spc + +let pr_dgens pr_gen (gensl, clr) = + let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in + match gensl with + | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr + | [deps; gens] -> prdeps deps ++ prgens " " gens ++ pr_clear spc clr + | [gens] -> prgens ": " gens ++ pr_clear spc clr + | _ -> pr_clear pr_spc clr + +let pr_ssrdgens _ _ _ = pr_dgens pr_gen + +let cons_gen gen = function + | gens :: gensl, clr -> (gen :: gens) :: gensl, clr + | _ -> anomaly "missing gen list" + +let cons_dep (gensl, clr) = + if List.length gensl = 1 then ([] :: gensl, clr) else + CErrors.error "multiple dependents switches '/'" + +ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear + PRINTED BY pr_ssrdgens +| [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkclr clr, dt) dgens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> + [ [[]], clr ] +| [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkocc occ, dt) dgens ] +| [ "/" ssrdgens_tl(dgens) ] -> + [ cons_dep dgens ] +| [ cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (nodocc, dt) dgens ] +| [ ] -> + [ [[]], [] ] +END + +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +END + +let genstac (gens, clr) ist = + tclTHENLIST (cleartac clr :: List.rev_map (gentac ist) gens) + +(* Common code to handle generalization lists along with the defective case *) + +let with_defective maintac deps clr ist gl = + let top_id = + match kind_of_type (pf_concl gl) with + | ProdType (Name id, _, _) + when has_discharged_tag (string_of_id id) -> id + | _ -> top_id in + let top_gen = mkclr clr, cpattern_of_id top_id in + tclTHEN (introid top_id) (maintac deps top_gen ist) gl + +let with_dgens (gensl, clr) maintac ist = match gensl with + | [deps; []] -> with_defective maintac deps clr ist + | [deps; gen :: gens] -> + tclTHEN (genstac (gens, clr) ist) (maintac deps gen ist) + | [gen :: gens] -> tclTHEN (genstac (gens, clr) ist) (maintac [] gen ist) + | _ -> with_defective maintac [] clr ist + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then CErrors.error "first_goal"; + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +let with_deps deps0 maintac cl0 cs0 clr0 ist gl0 = + let rec loop gl cl cs clr args clrs = function + | [] -> + let n = List.length args in + maintac (if n > 0 then applist (to_lambda n cl, args) else cl) clrs ist gl0 + | dep :: deps -> + let gl' = first_goal (genclrtac cl cs clr gl) in + let cl', c', clr',gl' = pf_interp_gen ist gl' false dep in + loop gl' cl' [c'] clr' (c' :: args) (clr' :: clrs) deps in + loop gl0 cl0 cs0 clr0 cs0 [clr0] (List.rev deps0) + +(** Equations *) + +(* argument *) + +type ssreqid = ssripat option + +let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () +let pr_ssreqid _ _ _ = pr_eqid + +(* We must use primitive parsing here to avoid conflicts with the *) +(* basic move, case, and elim tactics. *) +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssreqid strm = + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.IDENT _ -> accept_before_syms [":"] strm + | Tok.KEYWORD ":" -> () + | Tok.KEYWORD pat when List.mem pat ["_"; "?"; "->"; "<-"] -> + accept_before_syms [":"] strm + | _ -> raise Stream.Failure + +let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid + +GEXTEND Gram + GLOBAL: ssreqid; + ssreqpat: [ + [ id = Prim.ident -> IpatId id + | "_" -> IpatWild + | "?" -> IpatAnon + | occ = ssrdocc; "->" -> (match occ with + | None, occ -> IpatRw (occ, L2R) + | _ -> loc_error !@loc "Only occurrences are allowed here") + | occ = ssrdocc; "<-" -> (match occ with + | None, occ -> IpatRw (occ, R2L) + | _ -> loc_error !@loc "Only occurrences are allowed here") + | "->" -> IpatRw (allocc, L2R) + | "<-" -> IpatRw (allocc, R2L) + ]]; + ssreqid: [ + [ test_ssreqid; pat = ssreqpat -> Some pat + | test_ssreqid -> None + ]]; +END + +(* creation *) + +let mkEq dir cl c t n gl = + let eqargs = [|t; c; c|] in eqargs.(dir_org dir) <- mkRel n; + let eq, gl = pf_fresh_global (build_coq_eq()) gl in + let refl, gl = mkRefl t c gl in + mkArrow (mkApp (eq, eqargs)) (lift 1 cl), refl, gl + +let pushmoveeqtac cl c gl = + let x, t, cl1 = destProd cl in + let cl2, eqc, gl = mkEq R2L cl1 c t 1 gl in + apply_type (mkProd (x, t, cl2)) [c; eqc] gl + +let pushcaseeqtac cl gl = + let cl1, args = destApplication cl in + let n = Array.length args in + let dc, cl2 = decompose_lam_n n cl1 in + let _, t = List.nth dc (n - 1) in + let cl3, eqc, gl = mkEq R2L cl2 args.(0) t n gl in + let gl, clty = pf_type_of gl cl in + let prot, gl = mkProt clty cl3 gl in + let cl4 = mkApp (compose_lam dc prot, args) in + let gl, _ = pf_e_type_of gl cl4 in + tclTHEN (apply_type cl4 [eqc]) + (Proofview.V82.of_tactic (convert_concl cl4)) gl + +let pushelimeqtac gl = + let _, args = destApplication (pf_concl gl) in + let x, t, _ = destLambda args.(1) in + let cl1 = mkApp (args.(1), Array.sub args 2 (Array.length args - 2)) in + let cl2, eqc, gl = mkEq L2R cl1 args.(2) t 1 gl in + tclTHEN (apply_type (mkProd (x, t, cl2)) [args.(2); eqc]) + (Proofview.V82.of_tactic intro) gl + +(** Bookkeeping (discharge-intro) argument *) + +(* Since all bookkeeping ssr commands have the same discharge-intro *) +(* argument format we use a single grammar entry point to parse them. *) +(* the entry point parses only non-empty arguments to avoid conflicts *) +(* with the basic Coq tactics. *) + +(* type ssrarg = ssrview * (ssreqid * (ssrdgens * ssripats)) *) + +let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats + +ARGUMENT EXTEND ssrarg TYPED AS ssrview * (ssreqid * (ssrdgens * ssrintros)) + PRINTED BY pr_ssrarg +| [ ssrview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ view, (eqid, (dgens, ipats)) ] +| [ ssrview(view) ssrclear(clr) ssrintros(ipats) ] -> + [ view, (None, (([], clr), ipats)) ] +| [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ [], (eqid, (dgens, ipats)) ] +| [ ssrclear_ne(clr) ssrintros(ipats) ] -> + [ [], (None, (([], clr), ipats)) ] +| [ ssrintros_ne(ipats) ] -> + [ [], (None, (([], []), ipats)) ] +END + +(** The "clear" tactic *) + +(* We just add a numeric version that clears the n top assumptions. *) + +let poptac ist n = introstac ~ist (List.init n (fun _ -> IpatWild)) + +TACTIC EXTEND ssrclear + | [ "clear" natural(n) ] -> [ Proofview.V82.tactic (poptac ist n) ] +END + +(** The "move" tactic *) + +let rec improper_intros = function + | IpatSimpl _ :: ipats -> improper_intros ipats + | (IpatId _ | IpatAnon | IpatCase _ | IpatAll) :: _ -> false + | _ -> true + +let check_movearg = function + | view, (eqid, _) when view <> [] && eqid <> None -> + CErrors.error "incompatible view and equation in move tactic" + | view, (_, (([gen :: _], _), _)) when view <> [] && has_occ gen -> + CErrors.error "incompatible view and occurrence switch in move tactic" + | _, (_, ((dgens, _), _)) when List.length dgens > 1 -> + CErrors.error "dependents switch `/' in move tactic" + | _, (eqid, (_, ipats)) when eqid <> None && improper_intros ipats -> + CErrors.error "no proper intro pattern for equation in move tactic" + | arg -> arg + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_movearg arg ] +END + +let viewmovetac_aux clear name_ref (_, vl as v) _ gen ist gl = + let cl, c, clr, gl, gen_pat = + let _, gen_pat, a, b, c, ucst, gl = pf_interp_gen_aux ist gl false gen in + a, b ,c, pf_merge_uc ucst gl, gen_pat in + let cl, c, gl = if vl = [] then cl, c, gl else pf_with_view ist gl v cl c in + let clr = if clear then clr else [] in + name_ref := (match id_of_pattern gen_pat with Some id -> id | _ -> top_id); + genclrtac cl [c] clr gl + +let () = move_top_with_view := + (fun c r v -> with_defective (viewmovetac_aux c r v) [] []) + +let viewmovetac v deps gen ist gl = + viewmovetac_aux true (ref top_id) v deps gen ist gl + +let eqmovetac _ gen ist gl = + let cl, c, _, gl = pf_interp_gen ist gl false gen in pushmoveeqtac cl c gl + +let movehnftac gl = match kind_of_term (pf_concl gl) with + | Prod _ | LetIn _ -> tclIDTAC gl + | _ -> Proofview.V82.of_tactic hnf_in_concl gl + +let ssrmovetac ist = function + | _::_ as view, (_, (dgens, ipats)) -> + let dgentac = with_dgens dgens (viewmovetac (true, view)) ist in + tclTHEN dgentac (introstac ~ist ipats) + | _, (Some pat, (dgens, ipats)) -> + let dgentac = with_dgens dgens eqmovetac ist in + tclTHEN dgentac (introstac ~ist (eqmoveipats pat ipats)) + | _, (_, (([gens], clr), ipats)) -> + let gentac = genstac (gens, clr) ist in + tclTHEN gentac (introstac ~ist ipats) + | _, (_, ((_, clr), ipats)) -> + tclTHENLIST [movehnftac; cleartac clr; introstac ~ist ipats] + +TACTIC EXTEND ssrmove +| [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> + [ Proofview.V82.tactic (tclTHEN (ssrmovetac ist arg) (introstac ~ist [pat])) ] +| [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrmovetac ist arg) clauses) ] +| [ "move" ssrrpat(pat) ] -> [ Proofview.V82.tactic (introstac ~ist [pat]) ] +| [ "move" ] -> [ Proofview.V82.tactic (movehnftac) ] +END + +(* TASSI: given the type of an elimination principle, it finds the higher order + * argument (index), it computes it's arity and the arity of the eliminator and + * checks if the eliminator is recursive or not *) +let analyze_eliminator elimty env sigma = + let rec loop ctx t = match kind_of_type t with + | AtomicType (hd, args) when isRel hd -> + ctx, destRel hd, not (noccurn 1 t), Array.length args + | CastType (t, _) -> loop ctx t + | ProdType (x, ty, t) -> loop (RelDecl.LocalAssum (x, ty) :: ctx) t + | LetInType (x,b,ty,t) -> loop (RelDecl.LocalDef (x, b, ty) :: ctx) (subst1 b t) + | _ -> + let env' = Environ.push_rel_context ctx env in + let t' = Reductionops.whd_all env' sigma t in + if not (Term.eq_constr t t') then loop ctx t' else + errorstrm (str"The eliminator has the wrong shape."++spc()++ + str"A (applied) bound variable was expected as the conclusion of "++ + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_constr elimty) in + let ctx, pred_id, elim_is_dep, n_pred_args = loop [] elimty in + let n_elim_args = Context.Rel.nhyps ctx in + let is_rec_elim = + let count_occurn n term = + let count = ref 0 in + let rec occur_rec n c = match kind_of_term c with + | Rel m -> if m = n then incr count + | _ -> iter_constr_with_binders succ occur_rec n c + in + occur_rec n term; !count in + let occurr2 n t = count_occurn n t > 1 in + not (List.for_all_i + (fun i (_,rd) -> pred_id <= i || not (occurr2 (pred_id - i) rd)) + 1 (assums_of_rel_context ctx)) + in + n_elim_args - pred_id, n_elim_args, is_rec_elim, elim_is_dep, n_pred_args + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac gl = + let c, gl = pf_mkSsrConst "protect_term" gl in + let prot, _ = destConst c in + onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + Proofview.V82.of_tactic (reduct_option + (Reductionops.clos_norm_flags + (CClosure.RedFlags.mkflags + [CClosure.RedFlags.fBETA; + CClosure.RedFlags.fCONST prot; + CClosure.RedFlags.fMATCH; + CClosure.RedFlags.fFIX; + CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) + allHypsAndConcl gl + +let dependent_apply_error = + try CErrors.error "Could not fill dependent hole in \"apply\"" with err -> err + +(* TASSI: Sometimes Coq's apply fails. According to my experience it may be + * related to goals that are products and with beta redexes. In that case it + * guesses the wrong number of implicit arguments for your lemma. What follows + * is just like apply, but with a user-provided number n of implicits. + * + * Refine.refine function that handles type classes and evars but fails to + * handle "dependently typed higher order evars". + * + * Refiner.refiner that does not handle metas with a non ground type but works + * with dependently typed higher order metas. *) +let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = + if with_evars then + let refine gl = + let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in +(* pp(lazy(str"sigma@saturate=" ++ pr_evar_map None (project gl))); *) + let gl = pf_unify_HO gl ty (pf_concl gl) in + let gs = CList.map_filter (fun (_, e) -> + if isEvar (pf_nf_evar gl e) then Some e else None) + args in + pf_partial_solution gl t gs + in + Proofview.(V82.of_tactic + (tclTHEN (V82.tactic refine) + (if with_shelve then shelve_unifiable else tclUNIT ()))) gl + else + let t, gl = if n = 0 then t, gl else + let sigma, si = project gl, sig_it gl in + let rec loop sigma bo args = function (* saturate with metas *) + | 0 -> mkApp (t, Array.of_list (List.rev args)), re_sig si sigma + | n -> match kind_of_term bo with + | Lambda (_, ty, bo) -> + if not (closed0 ty) then raise dependent_apply_error; + let m = Evarutil.new_meta () in + loop (meta_declare m ty sigma) bo ((mkMeta m)::args) (n-1) + | _ -> assert false + in loop sigma t [] n in + pp(lazy(str"Refiner.refiner " ++ pr_constr t)); + Refiner.refiner (Proof_type.Refine t) gl + +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = + let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in + let uct = Evd.evar_universe_context (fst oc) in + let n, oc = pf_abs_evars_pirrel gl oc in + let gl = pf_unsafe_merge_uc uct gl in + let oc = if not first_goes_last || n <= 1 then oc else + let l, c = decompose_lam oc in + if not (List.for_all_i (fun i (_,t) -> closedn ~-i t) (1-n) l) then oc else + compose_lam (let xs,y = List.chop (n-1) l in y @ xs) + (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) + in + pp(lazy(str"after: " ++ pr_constr oc)); + try applyn ~with_evars ~with_shelve:true ?beta n oc gl + with e when CErrors.noncritical e -> raise dependent_apply_error + +let pf_fresh_inductive_instance ind gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + indu, re_sig it sigma + +(** The "case" and "elim" tactic *) + +(* A case without explicit dependent terms but with both a view and an *) +(* occurrence switch and/or an equation is treated as dependent, with the *) +(* viewed term as the dependent term (the occurrence switch would be *) +(* meaningless otherwise). When both a view and explicit dependents are *) +(* present, it is forbidden to put a (meaningless) occurrence switch on *) +(* the viewed term. *) + +(* This is both elim and case (defaulting to the former). If ~elim is omitted + * the standard eliminator is chosen. The code is made of 4 parts: + * 1. find the eliminator if not given as ~elim and analyze it + * 2. build the patterns to be matched against the conclusion, looking at + * (occ, c), deps and the pattern inferred from the type of the eliminator + * 3. build the new predicate matching the patterns, and the tactic to + * generalize the equality in case eqid is not None + * 4. build the tactic handle intructions and clears as required in ipats and + * by eqid *) +let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = + (* some sanity checks *) + let oc, orig_clr, occ, c_gen, gl = match what with + | `EConstr(_,_,t) when isEvar t -> + anomaly "elim called on a constr evar" + | `EGen _ when ist = None -> + anomaly "no ist and non simple elimination" + | `EGen (_, g) when elim = None && is_wildcard g -> + errorstrm(str"Indeterminate pattern and no eliminator") + | `EGen ((Some clr,occ), g) when is_wildcard g -> + None, clr, occ, None, gl + | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None,gl + | `EGen ((_, occ), p as gen) -> + let _, c, clr,gl = pf_interp_gen (Option.get ist) gl true gen in + Some c, clr, occ, Some p,gl + | `EConstr (clr, occ, c) -> Some c, clr, occ, None,gl in + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in + pp(lazy(str(if is_case then "==CASE==" else "==ELIM=="))); + (* Utils of local interest only *) + let iD s ?t gl = let t = match t with None -> pf_concl gl | Some x -> x in + pp(lazy(str s ++ pr_constr t)); tclIDTAC gl in + let eq, gl = pf_fresh_global (build_coq_eq ()) gl in + let protectC, gl = pf_mkSsrConst "protect_term" gl in + let fire_subst gl t = Reductionops.nf_evar (project gl) t in + let fire_sigma sigma t = Reductionops.nf_evar sigma t in + let is_undef_pat = function + | sigma, T t -> + (match kind_of_term (fire_sigma sigma t) with Evar _ -> true | _ -> false) + | _ -> false in + let match_pat env p occ h cl = + let sigma0 = project orig_gl in + pp(lazy(str"matching: " ++ pr_occ occ ++ pp_pattern p)); + let (c,ucst), cl = + fill_occ_pattern ~raise_NoMatch:true env sigma0 cl p occ h in + pp(lazy(str" got: " ++ pr_constr c)); + c, cl, ucst in + let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env (project gl) t n in + Evd.merge_universe_context sigma ucst, T t in + let unif_redex gl (sigma, r as p) t = (* t is a hint for the redex of p *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env sigma t n in + let sigma = Evd.merge_universe_context sigma ucst in + match r with + | X_In_T (e, p) -> sigma, E_As_X_In_T (t, e, p) + | _ -> + try unify_HO env sigma t (fst (redex_of_pattern env p)), r + with e when CErrors.noncritical e -> p in + (* finds the eliminator applies it to evars and c saturated as needed *) + (* obtaining "elim ??? (c ???)". pred is the higher order evar *) + (* cty is None when the user writes _ (hence we can't make a pattern *) + let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + match elim with + | Some elim -> + let gl, elimty = pf_e_type_of gl elim in + let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args = + analyze_eliminator elimty env (project gl) in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let elimty = Reductionops.whd_all env (project gl) elimty in + let cty, gl = + if Option.is_empty oc then None, gl + else + let c = Option.get oc in let gl, c_ty = pf_type_of gl c in + let pc = match c_gen with + | Some p -> interp_cpattern (Option.get ist) orig_gl p None + | _ -> mkTpat gl c in + Some(c, c_ty, pc), gl in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + | None -> + let c = Option.get oc in let gl, c_ty = pf_type_of gl c in + let ((kn, i) as ind, _ as indu), unfolded_c_ty = + pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let gl, elim = + if not is_case then + let t, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + gl, t + else + pf_eapply (fun env sigma () -> + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (ind, sigma, _) = Indrec.build_case_analysis_scheme env sigma indu true sort in + let sigma = Sigma.to_evar_map sigma in + (sigma, ind)) gl () in + let gl, elimty = pf_type_of gl elim in + let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args = + analyze_eliminator elimty env (project gl) in + let rctx = fst (decompose_prod_assum unfolded_c_ty) in + let n_c_args = Context.Rel.length rctx in + let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let pc = match n_c_args, c_gen with + | 0, Some p -> interp_cpattern (Option.get ist) orig_gl p None + | _ -> mkTpat gl c in + let cty = Some (c, c_ty, pc) in + let elimty = Reductionops.whd_all env (project gl) elimty in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + in + pp(lazy(str"elim= "++ pr_constr_pat elim)); + pp(lazy(str"elimty= "++ pr_constr_pat elimty)); + let inf_deps_r = match kind_of_type elimty with + | AtomicType (_, args) -> List.rev (Array.to_list args) + | _ -> assert false in + let saturate_until gl c c_ty f = + let rec loop n = try + let c, c_ty, _, gl = pf_saturate gl c ~ty:c_ty n in + let gl' = f c c_ty gl in + Some (c, c_ty, gl, gl') + with + | NotEnoughProducts -> None + | e when CErrors.noncritical e -> loop (n+1) in loop 0 in + (* Here we try to understand if the main pattern/term the user gave is + * the first pattern to be matched (i.e. if elimty ends in P t1 .. tn, + * weather tn is the t the user wrote in 'elim: t' *) + let c_is_head_p, gl = match cty with + | None -> true, gl (* The user wrote elim: _ *) + | Some (c, c_ty, _) -> + let res = + (* we try to see if c unifies with the last arg of elim *) + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let gl, arg_ty = pf_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + match res with + | Some x -> x + | None -> + (* we try to see if c unifies with the last inferred pattern *) + let inf_arg = List.hd inf_deps_r in + let gl, inf_arg_ty = pf_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> true, gl + | None -> + errorstrm (str"Unable to apply the eliminator to the term"++ + spc()++pr_constr c++spc()++str"or to unify it's type with"++ + pr_constr inf_arg_ty) in + pp(lazy(str"c_is_head_p= " ++ bool c_is_head_p)); + let gl, predty = pf_type_of gl pred in + (* Patterns for the inductive types indexes to be bound in pred are computed + * looking at the ones provided by the user and the inferred ones looking at + * the type of the elimination principle *) + let pp_pat (_,p,_,occ) = pr_occ occ ++ pp_pattern p in + let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (fire_subst gl t) in + let patterns, clr, gl = + let rec loop patterns clr i = function + | [],[] -> patterns, clr, gl + | ((oclr, occ), t):: deps, inf_t :: inf_deps -> + let ist = match ist with Some x -> x | None -> assert false in + let p = interp_cpattern ist orig_gl t None in + let clr_t = + interp_clr (oclr,(tag_of_cpattern t,fst (redex_of_pattern env p)))in + (* if we are the index for the equation we do not clear *) + let clr_t = if deps = [] && eqid <> None then [] else clr_t in + let p = if is_undef_pat p then mkTpat gl inf_t else p in + loop (patterns @ [i, p, inf_t, occ]) + (clr_t @ clr) (i+1) (deps, inf_deps) + | [], c :: inf_deps -> + pp(lazy(str"adding inf pattern " ++ pr_constr_pat c)); + loop (patterns @ [i, mkTpat gl c, c, allocc]) + clr (i+1) ([], inf_deps) + | _::_, [] -> errorstrm (str "Too many dependent abstractions") in + let deps, head_p, inf_deps_r = match what, c_is_head_p, cty with + | `EConstr _, _, None -> anomaly "Simple elim with no term" + | _, false, _ -> deps, [], inf_deps_r + | `EGen gen, true, None -> deps @ [gen], [], inf_deps_r + | _, true, Some (c, _, pc) -> + let occ = if occ = None then allocc else occ in + let inf_p, inf_deps_r = List.hd inf_deps_r, List.tl inf_deps_r in + deps, [1, pc, inf_p, occ], inf_deps_r in + let patterns, clr, gl = + loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in + head_p @ patterns, Util.List.uniquize clr, gl + in + pp(lazy(pp_concat (str"patterns=") (List.map pp_pat patterns))); + pp(lazy(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + (* Predicate generation, and (if necessary) tactic to generalize the + * equation asked by the user *) + let elim_pred, gen_eq_tac, clr, gl = + let error gl t inf_t = errorstrm (str"The given pattern matches the term"++ + spc()++pp_term gl t++spc()++str"while the inferred pattern"++ + spc()++pr_constr_pat (fire_subst gl inf_t)++spc()++ str"doesn't") in + let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = + let p = unif_redex gl p inf_t in + if is_undef_pat p then + let () = pp(lazy(str"postponing " ++ pp_pattern p)) in + cl, gl, post @ [h, p, inf_t, occ] + else try + let c, cl, ucst = match_pat env p occ h cl in + let gl = pf_merge_uc ucst gl in + let gl = try pf_unify_HO gl inf_t c with _ -> error gl c inf_t in + cl, gl, post + with + | NoMatch | NoProgress -> + let e, ucst = redex_of_pattern env p in + let gl = pf_merge_uc ucst gl in + let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in + let e, _, _, gl = pf_saturate ~beta:true gl e n in + let gl = try pf_unify_HO gl inf_t e with _ -> error gl e inf_t in + cl, gl, post + in + let rec match_all concl gl patterns = + let concl, gl, postponed = + List.fold_left match_or_postpone (concl, gl, []) patterns in + if postponed = [] then concl, gl + else if List.length postponed = List.length patterns then + errorstrm (str "Some patterns are undefined even after all"++spc()++ + str"the defined ones matched") + else match_all concl gl postponed in + let concl, gl = match_all concl gl patterns in + let pred_rctx, _ = decompose_prod_assum (fire_subst gl predty) in + let concl, gen_eq_tac, clr, gl = match eqid with + | Some (IpatId _) when not is_rec -> + let k = List.length deps in + let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in + let gl, t = pf_type_of gl c in + let gen_eq_tac, gl = + let refl = mkApp (eq, [|t; c; c|]) in + let new_concl = mkArrow refl (lift 1 (pf_concl orig_gl)) in + let new_concl = fire_subst gl new_concl in + let erefl, gl = mkRefl t c gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [erefl], gl in + let rel = k + if c_is_head_p then 1 else 0 in + let src, gl = mkProt mkProp (mkApp (eq,[|t; c; mkRel rel|])) gl in + let concl = mkArrow src (lift 1 concl) in + let clr = if deps <> [] then clr else [] in + concl, gen_eq_tac, clr, gl + | _ -> concl, tclIDTAC, clr, gl in + let mk_lam t r = mkLambda_or_LetIn r t in + let concl = List.fold_left mk_lam concl pred_rctx in + let gl, concl = + if eqid <> None && is_rec then + let gl, concls = pf_type_of gl concl in + let concl, gl = mkProt concls concl gl in + let gl, _ = pf_e_type_of gl concl in + gl, concl + else gl, concl in + concl, gen_eq_tac, clr, gl in + let gl, pty = pf_e_type_of gl elim_pred in + pp(lazy(str"elim_pred=" ++ pp_term gl elim_pred)); + pp(lazy(str"elim_pred_ty=" ++ pp_term gl pty)); + let gl = pf_unify_HO gl pred elim_pred in + let elim = fire_subst gl elim in + let gl, _ = pf_e_type_of gl elim in + (* check that the patterns do not contain non instantiated dependent metas *) + let () = + let evars_of_term = Evarutil.undefined_evars_of_term (project gl) in + let patterns = List.map (fun (_,_,t,_) -> fire_subst gl t) patterns in + let patterns_ev = List.map evars_of_term patterns in + let ev = List.fold_left Intset.union Intset.empty patterns_ev in + let ty_ev = Intset.fold (fun i e -> + let ex = i in + let i_ty = Evd.evar_concl (Evd.find (project gl) ex) in + Intset.union e (evars_of_term i_ty)) + ev Intset.empty in + let inter = Intset.inter ev ty_ev in + if not (Intset.is_empty inter) then begin + let i = Intset.choose inter in + let pat = List.find (fun t -> Intset.mem i (evars_of_term t)) patterns in + errorstrm(str"Pattern"++spc()++pr_constr_pat pat++spc()++ + str"was not completely instantiated and one of its variables"++spc()++ + str"occurs in the type of another non-instantiated pattern variable"); + end + in + (* the elim tactic, with the eliminator and the predicated we computed *) + let elim = project gl, elim in + let elim_tac gl = + tclTHENLIST [refine_with ~with_evars:false elim; cleartac clr] gl in + (* handling of following intro patterns and equation introduction if any *) + let elim_intro_tac gl = + let intro_eq = + match eqid with + | Some (IpatId ipat) when not is_rec -> + let rec intro_eq gl = match kind_of_type (pf_concl gl) with + | ProdType (_, src, tgt) -> + (match kind_of_type src with + | AtomicType (hd, _) when Term.eq_constr hd protectC -> + tclTHENLIST [unprotecttac; introid ipat] gl + | _ -> tclTHENLIST [ iD "IA"; introstac [IpatAnon]; intro_eq] gl) + |_ -> errorstrm (str "Too many names in intro pattern") in + intro_eq + | Some (IpatId ipat) -> + let name gl = mk_anon_id "K" gl in + let intro_lhs gl = + let elim_name = match orig_clr, what with + | [SsrHyp(_, x)], _ -> x + | _, `EConstr(_,_,t) when isVar t -> destVar t + | _ -> name gl in + if is_name_in_ipats elim_name ipats then introid (name gl) gl + else introid elim_name gl + in + let rec gen_eq_tac gl = + let concl = pf_concl gl in + let ctx, last = decompose_prod_assum concl in + let args = match kind_of_type last with + | AtomicType (hd, args) -> assert(Term.eq_constr hd protectC); args + | _ -> assert false in + let case = args.(Array.length args-1) in + if not(closed0 case) then tclTHEN (introstac [IpatAnon]) gen_eq_tac gl + else + let gl, case_ty = pf_type_of gl case in + let refl = mkApp (eq, [|lift 1 case_ty; mkRel 1; lift 1 case|]) in + let new_concl = fire_subst gl + (mkProd (Name (name gl), case_ty, mkArrow refl (lift 2 concl))) in + let erefl, gl = mkRefl case_ty case gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [case;erefl] gl in + tclTHENLIST [gen_eq_tac; intro_lhs; introid ipat] + | _ -> tclIDTAC in + let unprot = if eqid <> None && is_rec then unprotecttac else tclIDTAC in + tclEQINTROS ?ist elim_tac (tclTHENLIST [intro_eq; unprot]) ipats gl + in + tclTHENLIST [gen_eq_tac; elim_intro_tac] orig_gl +;; + +let simplest_newelim x= ssrelim ~is_case:false [] (`EConstr ([],None,x)) None [] +let simplest_newcase x= ssrelim ~is_case:true [] (`EConstr ([],None,x)) None [] +let _ = simplest_newcase_ref := simplest_newcase + +let check_casearg = function +| view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> + CErrors.error "incompatible view and occurrence switch in dependent case tactic" +| arg -> arg + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_casearg arg ] +END + +let ssrcasetac ist (view, (eqid, (dgens, ipats))) = + let ndefectcasetac view eqid ipats deps ((_, occ), _ as gen) ist gl = + let simple = (eqid = None && deps = [] && occ = None) in + let cl, c, clr, gl = pf_interp_gen ist gl true gen in + let _, vc, gl = + if view = [] then c, c, gl else pf_with_view ist gl (false, view) cl c in + if simple && is_injection_case vc gl then + tclTHENLIST [perform_injection vc; cleartac clr; introstac ~ist ipats] gl + else + (* macro for "case/v E: x" ---> "case E: x / (v x)" *) + let deps, clr, occ = + if view <> [] && eqid <> None && deps = [] then [gen], [], None + else deps, clr, occ in + ssrelim ~is_case:true ~ist deps (`EConstr (clr,occ, vc)) eqid ipats gl + in + with_dgens dgens (ndefectcasetac view eqid ipats) ist + +TACTIC EXTEND ssrcase +| [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrcasetac ist arg) clauses) ] +| [ "case" ] -> [ Proofview.V82.tactic (with_top ssrscasetac) ] +END + +(** The "elim" tactic *) + +(* Elim views are elimination lemmas, so the eliminated term is not addded *) +(* to the dependent terms as for "case", unless it actually occurs in the *) +(* goal, the "all occurrences" {+} switch is used, or the equation switch *) +(* is used and there are no dependents. *) + +let ssrelimtac ist (view, (eqid, (dgens, ipats))) = + let ndefectelimtac view eqid ipats deps gen ist gl = + let elim = match view with [v] -> Some (snd(force_term ist gl v)) | _ -> None in + ssrelim ~ist deps (`EGen gen) ?elim eqid ipats gl + in + with_dgens dgens (ndefectelimtac view eqid ipats) ist + +TACTIC EXTEND ssrelim +| [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrelimtac ist arg) clauses) ] +| [ "elim" ] -> [ Proofview.V82.tactic (with_top simplest_newelim) ] +END + +(** 6. Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt +let pr_ssragen _ _ _ = pr_agen +let pr_ssragens _ _ _ = pr_dgens pr_agen + +ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] +| [ ssrterm(dt) ] -> [ nodocc, dt ] +END + +ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear +PRINTED BY pr_ssragens +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (mkclr clr, dt) agens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] +| [ ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (nodocc, dt) agens ] +| [ ] -> [ [[]], [] ] +END + +let mk_applyarg views agens intros = views, (None, (agens, intros)) + +let pr_ssraarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_agen dgens ++ pri ipats + +ARGUMENT EXTEND ssrapplyarg +TYPED AS ssrview * (ssreqid * (ssragens * ssrintros)) +PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg [] (cons_gen gen dgens) intros ] +| [ ssrclear_ne(clr) ssrintros(intros) ] -> + [ mk_applyarg [] ([], clr) intros ] +| [ ssrintros_ne(intros) ] -> + [ mk_applyarg [] ([], []) intros ] +| [ ssrview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg view (cons_gen gen dgens) intros ] +| [ ssrview(view) ssrclear(clr) ssrintros(intros) ] -> + [ mk_applyarg view ([], clr) intros ] +END + +let interp_agen ist gl ((goclr, _), (k, gc)) (clr, rcs) = +(* pp(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) + let rc = glob_constr ist (pf_env gl) gc in + let rcs' = rc :: rcs in + match goclr with + | None -> clr, rcs' + | Some ghyps -> + let clr' = snd (interp_hyps ist gl ghyps) @ clr in + if k <> ' ' then clr', rcs' else + match rc with + | GVar (loc, id) when not_section_id id -> SsrHyp (loc, id) :: clr', rcs' + | GRef (loc, VarRef id, _) when not_section_id id -> + SsrHyp (loc, id) :: clr', rcs' + | _ -> clr', rcs' + +let interp_agens ist gl gagens = + match List.fold_right (interp_agen ist gl) gagens ([], []) with + | clr, rlemma :: args -> + let n = interp_nbargs ist gl rlemma - List.length args in + let rec loop i = + if i > n then + errorstrm (str "Cannot apply lemma " ++ pf_pr_glob_constr gl rlemma) + else + try interp_refine ist gl (mkRApp rlemma (mkRHoles i @ args)) + with _ -> loop (i + 1) in + clr, loop 0 + | _ -> assert false + +let apply_rconstr ?ist t gl = +(* pp(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) + let n = match ist, t with + | None, (GVar (_, id) | GRef (_, VarRef id,_)) -> pf_nbargs gl (mkVar id) + | Some ist, _ -> interp_nbargs ist gl t + | _ -> anomaly "apply_rconstr without ist and not RVar" in + let mkRlemma i = mkRApp t (mkRHoles i) in + let cl = pf_concl gl in + let rec loop i = + if i > n then + errorstrm (str"Cannot apply lemma "++pf_pr_glob_constr gl t) + else try pf_match gl (mkRlemma i) (OfType cl) with _ -> loop (i + 1) in + refine_with (loop 0) gl + +let mkRAppView ist gl rv gv = + let nb_view_imps = interp_view_nbimps ist gl rv in + mkRApp rv (mkRHoles (abs nb_view_imps)) + +let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; + +let refine_interp_apply_view i ist gl gv = + let pair i = List.map (fun x -> i, x) in + let rv = pf_intern_term ist gl gv in + let v = mkRAppView ist gl rv gv in + let interp_with (i, hint) = + interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in + let interp_with x = prof_apply_interp_with.profile interp_with x in + let rec loop = function + | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) + | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + loop (pair i viewtab.(i) @ if i = 2 then pair 1 viewtab.(1) else []) + +let apply_top_tac gl = + tclTHENLIST [introid top_id; apply_rconstr (mkRVar top_id); Proofview.V82.of_tactic (clear [top_id])] gl + +let inner_ssrapplytac gviews ggenl gclr ist gl = + let _, clr = interp_hyps ist gl gclr in + let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in + let ggenl, tclGENTAC = + if gviews <> [] && ggenl <> [] then + let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g) (List.hd ggenl) in + [], tclTHEN (genstac (ggenl,[]) ist) + else ggenl, tclTHEN tclIDTAC in + tclGENTAC (fun gl -> + match gviews, ggenl with + | v :: tl, [] -> + let dbl = if List.length tl = 1 then 2 else 1 in + tclTHEN + (List.fold_left (fun acc v -> tclTHENLAST acc (vtac v dbl)) (vtac v 1) tl) + (cleartac clr) gl + | [], [agens] -> + let clr', (sigma, lemma) = interp_agens ist gl agens in + let gl = pf_merge_uc_of sigma gl in + tclTHENLIST [cleartac clr; refine_with ~beta:true lemma; cleartac clr'] gl + | _, _ -> tclTHEN apply_top_tac (cleartac clr) gl) gl + +let ssrapplytac ist (views, (_, ((gens, clr), intros))) = + tclINTROS ist (inner_ssrapplytac views gens clr) intros + +TACTIC EXTEND ssrapply +| [ "apply" ssrapplyarg(arg) ] -> [ Proofview.V82.tactic (ssrapplytac ist arg) ] +| [ "apply" ] -> [ Proofview.V82.tactic apply_top_tac ] +END + +(** The "exact" tactic *) + +let mk_exactarg views dgens = mk_applyarg views dgens [] + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ] -> + [ mk_exactarg [] (cons_gen gen dgens) ] +| [ ssrview(view) ssrclear(clr) ] -> + [ mk_exactarg view ([], clr) ] +| [ ssrclear_ne(clr) ] -> + [ mk_exactarg [] ([], clr) ] +END + +let vmexacttac pf = + Proofview.Goal.nf_enter { enter = begin fun gl -> + exact_no_check (mkCast (pf, VMcast, Tacmach.New.pf_concl gl)) + end } + +TACTIC EXTEND ssrexact +| [ "exact" ssrexactarg(arg) ] -> [ Proofview.V82.tactic (tclBY (ssrapplytac ist arg)) ] +| [ "exact" ] -> [ Proofview.V82.tactic (tclORELSE donetac (tclBY apply_top_tac)) ] +| [ "exact" "<:" lconstr(pf) ] -> [ vmexacttac pf ] +END + +(** The "congr" tactic *) + +(* type ssrcongrarg = open_constr * (int * constr) *) + +let pr_ssrcongrarg _ _ _ ((n, f), dgens) = + (if n <= 0 then mt () else str " " ++ int n) ++ + str " " ++ pr_term f ++ pr_dgens pr_gen dgens + +ARGUMENT EXTEND ssrcongrarg TYPED AS (int * ssrterm) * ssrdgens + PRINTED BY pr_ssrcongrarg +| [ natural(n) constr(c) ssrdgens(dgens) ] -> [ (n, mk_term ' ' c), dgens ] +| [ natural(n) constr(c) ] -> [ (n, mk_term ' ' c),([[]],[]) ] +| [ constr(c) ssrdgens(dgens) ] -> [ (0, mk_term ' ' c), dgens ] +| [ constr(c) ] -> [ (0, mk_term ' ' c), ([[]],[]) ] +END + +let rec mkRnat n = + if n <= 0 then GRef (dummy_loc, glob_O, None) else + mkRApp (GRef (dummy_loc, glob_S, None)) [mkRnat (n - 1)] + +let interp_congrarg_at ist gl n rf ty m = + pp(lazy(str"===interp_congrarg_at===")); + let congrn, _ = mkSsrRRef "nary_congruence" in + let args1 = mkRnat n :: mkRHoles n @ [ty] in + let args2 = mkRHoles (3 * n) in + let rec loop i = + if i + n > m then None else + try + let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in + pp(lazy(str"rt=" ++ pr_glob_constr rt)); + Some (interp_refine ist gl rt) + with _ -> loop (i + 1) in + loop 0 + +let pattern_id = mk_internal_id "pattern value" + +let congrtac ((n, t), ty) ist gl = + pp(lazy(str"===congr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + let sigma, _ as it = interp_term ist gl t in + let gl = pf_merge_uc_of sigma gl in + let _, f, _, _ucst = pf_abs_evars gl it in + let ist' = {ist with lfun = + Id.Map.add pattern_id (Value.of_constr f) Id.Map.empty } in + let rf = mkRltacVar pattern_id in + let m = pf_nbargs gl f in + let _, cf = if n > 0 then + match interp_congrarg_at ist' gl n rf ty m with + | Some cf -> cf + | None -> errorstrm (str "No " ++ int n ++ str "-congruence with " + ++ pr_term t) + else let rec loop i = + if i > m then errorstrm (str "No congruence with " ++ pr_term t) + else match interp_congrarg_at ist' gl i rf ty m with + | Some cf -> cf + | None -> loop (i + 1) in + loop 1 in + tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic reflexivity)) gl + +let newssrcongrtac arg ist gl = + pp(lazy(str"===newcongr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + (* utils *) + let fs gl t = Reductionops.nf_evar (project gl) t in + let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = + match try Some (pf_unify_HO gl_c (pf_concl gl) c) with _ -> None with + | Some gl_c -> + tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + (t_ok (proj gl_c)) gl + | None -> t_fail () gl in + let mk_evar gl ty = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let sigma = create_evar_defs sigma in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (x, sigma, _) = Evarutil.new_evar env sigma ty in + let sigma = Sigma.to_evar_map sigma in + x, re_sig si sigma in + let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in + let ssr_congr lr = mkApp (arr, lr) in + (* here thw two cases: simple equality or arrow *) + let equality, _, eq_args, gl' = + let eq, gl = pf_fresh_global (build_coq_eq ()) gl in + pf_saturate gl eq 3 in + tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) + (fun ty -> congrtac (arg, Detyping.detype false [] (pf_env gl) (project gl) ty) ist) + (fun () -> + let lhs, gl' = mk_evar gl mkProp in let rhs, gl' = mk_evar gl' mkProp in + let arrow = mkArrow lhs (lift 1 rhs) in + tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) + (fun lr -> tclTHEN (Proofview.V82.of_tactic (apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) + (fun _ _ -> errorstrm (str"Conclusion is not an equality nor an arrow"))) + gl +;; + +TACTIC EXTEND ssrcongr +| [ "congr" ssrcongrarg(arg) ] -> +[ let arg, dgens = arg in + Proofview.V82.tactic begin + match dgens with + | [gens], clr -> tclTHEN (genstac (gens,clr) ist) (newssrcongrtac arg ist) + | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") + end] +END + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Coq rewrite compatibility flag *) + +let ssr_strict_match = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "strict redex matching"; + Goptions.optkey = ["Match"; "Strict"]; + Goptions.optread = (fun () -> !ssr_strict_match); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_strict_match := b) } + +(** Rewrite multiplier *) + +type ssrmult = int * ssrmmod + +let notimes = 0 +let nomult = 1, Once + +let pr_mult (n, m) = + if n > 0 && m <> Once then int n ++ pr_mmod m else pr_mmod m + +let pr_ssrmult _ _ _ = pr_mult + +ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult + | [ natural(n) ssrmmod(m) ] -> [ check_index loc n, m ] + | [ ssrmmod(m) ] -> [ notimes, m ] +END + +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult + | [ ssrmult_ne(m) ] -> [ m ] + | [ ] -> [ nomult ] +END + +(** Rewrite clear/occ switches *) + +let pr_rwocc = function + | None, None -> mt () + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear_ne clr + +let pr_ssrrwocc _ _ _ = pr_rwocc + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc +| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +| [ ] -> [ noclr ] +END + +(** Rewrite rules *) + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +(* type ssrrule = ssrwkind * ssrterm *) + +let pr_rwkind = function + | RWred s -> pr_simpl s + | RWdef -> str "/" + | RWeq -> mt () + +let wit_ssrrwkind = add_genarg "ssrrwkind" pr_rwkind + +let pr_rule = function + | RWred s, _ -> pr_simpl s + | RWdef, r-> str "/" ++ pr_term r + | RWeq, r -> pr_term r + +let pr_ssrrule _ _ _ = pr_rule + +let noruleterm loc = mk_term ' ' (mkCProp loc) + +ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule + | [ ssrsimpl_ne(s) ] -> [ RWred s, noruleterm loc ] + | [ "/" ssrterm(t) ] -> [ RWdef, t ] + | [ ssrterm(t) ] -> [ RWeq, t ] +END + +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule + | [ ssrrule_ne(r) ] -> [ r ] + | [ ] -> [ RWred Nop, noruleterm loc ] +END + +(** Rewrite arguments *) + +(* type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * ssrpattern) * ssrrule) *) + +let pr_option f = function None -> mt() | Some x -> f x +let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_rwarg ((d, m), ((docc, rx), r)) = + pr_rwdir d ++ pr_mult m ++ pr_rwocc docc ++ pr_pattern_squarep rx ++ pr_rule r + +let pr_ssrrwarg _ _ _ = pr_rwarg + +let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) = + if rt <> RWeq then begin + if rt = RWred Nop && not (m = nomult && occ = None && rx = None) + && (clr = None || clr = Some []) then + anomaly "Improper rewrite clear switch"; + if d = R2L && rt <> RWdef then + CErrors.error "Right-to-left switch on simplification"; + if n <> 1 && rt = RWred Cut then + CErrors.error "Bad or useless multiplier"; + if occ <> None && rx = None && rt <> RWdef then + CErrors.error "Missing redex for simplification occurrence" + end; (d, m), ((docc, rx), r) + +let norwmult = L2R, nomult +let norwocc = noclr, None + +(* +let pattern_ident = Prim.pattern_ident in +GEXTEND Gram +GLOBAL: pattern_ident; +pattern_ident: +[[c = pattern_ident -> (CRef (Ident (loc,c)), NoBindings)]]; +END +*) + +ARGUMENT EXTEND ssrpattern_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] + | [ ] -> [ None ] +END + +ARGUMENT EXTEND ssrpattern_ne_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +END + + +ARGUMENT EXTEND ssrrwarg + TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + PRINTED BY pr_ssrrwarg + | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (R2L, m) (docc, rx) r ] + | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) + [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (L2R, m) (docc, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkclr clr, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> + [ mk_rwarg norwmult (mkclr clr, None) r ] + | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkocc occ, rx) r ] + | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (nodocc, rx) r ] + | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (noclr, rx) r ] + | [ ssrrule_ne(r) ] -> + [ mk_rwarg norwmult norwocc r ] +END + +let simplintac occ rdx sim gl = + let simptac gl = + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ _ = red_safe Tacred.simpl env sigma0 c in + Proofview.V82.of_tactic + (convert_concl_no_check (eval_pattern env0 sigma0 concl0 rdx occ simp)) + gl in + match sim with + | Simpl -> simptac gl + | SimplCut -> tclTHEN simptac (tclTRY donetac) gl + | _ -> simpltac sim gl + +let rec get_evalref c = match kind_of_term c with + | Var id -> EvalVarRef id + | Const (k,_) -> EvalConstRef k + | App (c', _) -> get_evalref c' + | Cast (c', _, _) -> get_evalref c' + | _ -> errorstrm (str "The term " ++ pr_constr c ++ str " is not unfoldable") + +(* Strip a pattern generated by a prenex implicit to its constant. *) +let strip_unfold_term ((sigma, t) as p) kt = match kind_of_term t with + | App (f, a) when kt = ' ' && Array.for_all isEvar a && isConst f -> + (sigma, f), true + | Const _ | Var _ -> p, true + | _ -> p, false + +let unfoldintac occ rdx t (kt,_) gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let (sigma, t), const = strip_unfold_term t kt in + let body env t c = + Tacred.unfoldn [OnlyOccurrences [1], get_evalref t] env sigma0 c in + let easy = occ = None && rdx = None in + let red_flags = if easy then CClosure.betaiotazeta else CClosure.betaiota in + let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in + let unfold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ise, u = mk_tpattern env0 sigma0 (ise,t) all_ok L2R t in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + (fun env c _ h -> + try find_T env c h (fun env c _ _ -> body env t c) + with NoMatch when easy -> c + | NoMatch | NoProgress -> errorstrm (str"No occurrence of " + ++ pr_constr_pat t ++ spc() ++ str "in " ++ pr_constr c)), + (fun () -> try end_T () with + | NoMatch when easy -> fake_pmatcher_end () + | NoMatch -> anomaly "unfoldintac") + | _ -> + (fun env (c as orig_c) _ h -> + if const then + let rec aux c = + match kind_of_term c with + | Const _ when Term.eq_constr c t -> body env t t + | App (f,a) when Term.eq_constr f t -> mkApp (body env f f,a) + | _ -> let c = Reductionops.whd_betaiotazeta sigma0 c in + match kind_of_term c with + | Const _ when Term.eq_constr c t -> body env t t + | App (f,a) when Term.eq_constr f t -> mkApp (body env f f,a) + | Const f -> aux (body env c c) + | App (f, a) -> aux (mkApp (body env f f, a)) + | _ -> errorstrm (str "The term "++pr_constr orig_c++ + str" contains no " ++ pr_constr t ++ str" even after unfolding") + in aux c + else + try body env t (fs (unify_HO env sigma c t) t) + with _ -> errorstrm (str "The term " ++ + pr_constr c ++spc()++ str "does not unify with " ++ pr_constr_pat t)), + fake_pmatcher_end in + let concl = + try beta env0 (eval_pattern env0 sigma0 concl0 rdx occ unfold) + with Option.IsNone -> errorstrm (str"Failed to unfold " ++ pr_constr_pat t) in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) gl +;; + +let foldtac occ rdx ft gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let sigma, t = ft in + let fold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ut = red_product_skip_id env0 sigma t in + let ise, ut = mk_tpattern env0 sigma0 (ise,t) all_ok L2R ut in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[ut]) in + (fun env c _ h -> try find_T env c h (fun env t _ _ -> t) with NoMatch ->c), + (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) + | _ -> + (fun env c _ h -> try let sigma = unify_HO env sigma c t in fs sigma t + with _ -> errorstrm (str "fold pattern " ++ pr_constr_pat t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat c)), + fake_pmatcher_end in + let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) gl +;; + +let converse_dir = function L2R -> R2L | R2L -> L2R + +let rw_progress rhs lhs ise = not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) + +(* Coq has a more general form of "equation" (any type with a single *) +(* constructor with no arguments with_rect_r elimination lemmas). *) +(* However there is no clear way of determining the LHS and RHS of *) +(* such a generic Leibnitz equation -- short of inspecting the type *) +(* of the elimination lemmas. *) + +let rec strip_prod_assum c = match kind_of_term c with + | Prod (_, _, c') -> strip_prod_assum c' + | LetIn (_, v, _, c') -> strip_prod_assum (subst1 v c) + | Cast (c', _, _) -> strip_prod_assum c' + | _ -> c + +let rule_id = mk_internal_id "rewrite rule" + +exception PRtype_error +exception PRindetermined_rhs of constr + +let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +(* pp(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) + let env = pf_env gl in + let beta = Reductionops.clos_norm_flags CClosure.beta env sigma in + let sigma, p = + let sigma = create_evar_defs sigma in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (ev, sigma, _) = Evarutil.new_evar env sigma (beta (subst1 new_rdx pred)) in + let sigma = Sigma.to_evar_map sigma in + (sigma, ev) + in + let pred = mkNamedLambda pattern_id rdx_ty pred in + let elim, gl = + let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + if dir = R2L then elim, gl else (* taken from Coq's rewrite *) + let elim, _ = destConst elim in + let mp,dp,l = repr_con (constant_of_kn (canonical_con elim)) in + let l' = label_of_id (Nameops.add_suffix (id_of_label l) "_r") in + let c1' = Global.constant_of_delta_kn (canonical_con (make_con mp dp l')) in + mkConst c1', gl in + let proof = mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in + (* We check the proof is well typed *) + let sigma, proof_ty = + try Typing.type_of env sigma proof with _ -> raise PRtype_error in + pp(lazy(str"pirrel_rewrite proof term of type: " ++ pr_constr proof_ty)); + try refine_with + ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + with _ -> + (* we generate a msg like: "Unable to find an instance for the variable" *) + let c = Reductionops.nf_evar sigma c in + let hd_ty, miss = match kind_of_term c with + | App (hd, args) -> + let hd_ty = Retyping.get_type_of env sigma hd in + let names = let rec aux t = function 0 -> [] | n -> + let t = Reductionops.whd_all env sigma t in + match kind_of_type t with + | ProdType (name, _, t) -> name :: aux t (n-1) + | _ -> assert false in aux hd_ty (Array.length args) in + hd_ty, Util.List.map_filter (fun (t, name) -> + let evs = Intset.elements (Evarutil.undefined_evars_of_term sigma t) in + let open_evs = List.filter (fun k -> + InProp <> Retyping.get_sort_family_of + env sigma (Evd.evar_concl (Evd.find sigma k))) + evs in + if open_evs <> [] then Some name else None) + (List.combine (Array.to_list args) names) + | _ -> anomaly "rewrite rule not an application" in + errorstrm (Himsg.explain_refiner_error (Logic.UnresolvedBindings miss)++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_constr hd_ty)) +;; + +let is_const_ref c r = isConst c && eq_gr (ConstRef (fst(destConst c))) r +let is_construct_ref c r = + isConstruct c && eq_gr (ConstructRef (fst(destConstruct c))) r +let is_ind_ref c r = isInd c && eq_gr (IndRef (fst(destInd c))) r + +let rwcltac cl rdx dir sr gl = + let n, r_n,_, ucst = pf_abs_evars gl sr in + let r_n' = pf_abs_cterm gl n r_n in + let r' = subst_var pattern_id r_n' in + let gl = pf_unsafe_merge_uc ucst gl in + let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in +(* pp(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) + pp(lazy(str"r@rwcltac=" ++ pr_constr (snd sr))); + let cvtac, rwtac, gl = + if closed0 r' then + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, build_coq_eq () in + let sigma, c_ty = Typing.type_of env sigma c in + pp(lazy(str"c_ty@rwcltac=" ++ pr_constr c_ty)); + match kind_of_type (Reductionops.whd_all env sigma c_ty) with + | AtomicType(e, a) when is_ind_ref e c_eq -> + let new_rdx = if dir = L2R then a.(2) else a.(1) in + pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + | _ -> + let cl' = mkApp (mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + let sigma, _ = Typing.type_of env sigma cl' in + let gl = pf_merge_uc_of sigma gl in + Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl + else + let dc, r2 = decompose_lam_n n r' in + let r3, _, r3t = + try destCast r2 with _ -> + errorstrm (str "no cast from " ++ pr_constr_pat (snd sr) + ++ str " to " ++ pr_constr r2) in + let cl' = mkNamedProd rule_id (compose_prod dc r3t) (lift 1 cl) in + let cl'' = mkNamedProd pattern_id rdxt cl' in + let itacs = [introid pattern_id; introid rule_id] in + let cltac = Proofview.V82.of_tactic (clear [pattern_id; rule_id]) in + let rwtacs = [rewritetac dir (mkVar rule_id); cltac] in + apply_type cl'' [rdx; compose_lam dc r3], tclTHENLIST (itacs @ rwtacs), gl + in + let cvtac' _ = + try cvtac gl with + | PRtype_error -> + if occur_existential (pf_concl gl) + then errorstrm (str "Rewriting impacts evars") + else errorstrm (str "Dependent type error in rewrite of " + ++ pf_pr_constr gl (project gl) (mkNamedLambda pattern_id rdxt cl)) + | CErrors.UserError _ as e -> raise e + | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); + in + tclTHEN cvtac' rwtac gl + +let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; +let rwcltac cl rdx dir sr gl = + prof_rwcltac.profile (rwcltac cl rdx dir sr) gl +;; + + +let lz_coq_prod = + let prod = lazy (build_prod ()) in fun () -> Lazy.force prod + +let lz_setoid_relation = + let sdir = ["Classes"; "RelationClasses"] in + let last_srel = ref (Environ.empty_env, None) in + fun env -> match !last_srel with + | env', srel when env' == env -> srel + | _ -> + let srel = + try Some (coq_constant "Class_setoid" sdir "RewriteRelation") + with _ -> None in + last_srel := (env, srel); srel + +let ssr_is_setoid env = + match lz_setoid_relation env with + | None -> fun _ _ _ -> false + | Some srel -> + fun sigma r args -> + Rewrite.is_applied_rewrite_relation env + sigma [] (mkApp (r, args)) <> None + +let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; + +let closed0_check cl p gl = + if closed0 cl then + errorstrm (str"No occurrence of redex "++pf_pr_constr gl (project gl) p) + +let rwprocess_rule dir rule gl = + let env = pf_env gl in + let coq_prod = lz_coq_prod () in + let is_setoid = ssr_is_setoid env in + let r_sigma, rules = + let rec loop d sigma r t0 rs red = + let t = + if red = 1 then Tacred.hnf_constr env sigma t0 + else Reductionops.whd_betaiotazeta sigma t0 in + pp(lazy(str"rewrule="++pr_constr_pat t)); + match kind_of_term t with + | Prod (_, xt, at) -> + let sigma = create_evar_defs sigma in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (x, sigma, _) = Evarutil.new_evar env sigma xt in + let ise = Sigma.to_evar_map sigma in + loop d ise (mkApp (r, [|x|])) (subst1 x at) rs 0 + | App (pr, a) when is_ind_ref pr coq_prod.Coqlib.typ -> + let sr sigma = match kind_of_term (Tacred.hnf_constr env sigma r) with + | App (c, ra) when is_construct_ref c coq_prod.Coqlib.intro -> + fun i -> ra.(i + 1), sigma + | _ -> let ra = Array.append a [|r|] in + function 1 -> + let sigma, pi1 = Evd.fresh_global env sigma coq_prod.Coqlib.proj1 in + mkApp (pi1, ra), sigma + | _ -> + let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in + mkApp (pi2, ra), sigma in + if Term.eq_constr a.(0) (build_coq_True ()) then + let s, sigma = sr sigma 2 in + loop (converse_dir d) sigma s a.(1) rs 0 + else + let s, sigma = sr sigma 2 in + let sigma, rs2 = loop d sigma s a.(1) rs 0 in + let s, sigma = sr sigma 1 in + loop d sigma s a.(0) rs2 0 + | App (r_eq, a) when Hipattern.match_with_equality_type t != None -> + let indu = destInd r_eq and rhs = Array.last a in + let np = Inductiveops.inductive_nparamdecls (fst indu) in + let ind_ct = Inductiveops.type_of_constructors env indu in + let lhs0 = last_arg (strip_prod_assum ind_ct.(0)) in + let rdesc = match kind_of_term lhs0 with + | Rel i -> + let lhs = a.(np - i) in + let lhs, rhs = if d = L2R then lhs, rhs else rhs, lhs in +(* msgnl (str "RW: " ++ pr_rwdir d ++ str " " ++ pr_constr_pat r ++ str " : " + ++ pr_constr_pat lhs ++ str " ~> " ++ pr_constr_pat rhs); *) + d, r, lhs, rhs +(* + let l_i, r_i = if d = L2R then i, 1 - ndep else 1 - ndep, i in + let lhs = a.(np - l_i) and rhs = a.(np - r_i) in + let a' = Array.copy a in let _ = a'.(np - l_i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (r_eq, a')) in + (d, r', lhs, rhs) +*) + | _ -> + let lhs = substl (array_list_of_tl (Array.sub a 0 np)) lhs0 in + let lhs, rhs = if d = R2L then lhs, rhs else rhs, lhs in + let d' = if Array.length a = 1 then d else converse_dir d in + d', r, lhs, rhs in + sigma, rdesc :: rs + | App (s_eq, a) when is_setoid sigma s_eq a -> + let np = Array.length a and i = 3 - dir_org d in + let lhs = a.(np - i) and rhs = a.(np + i - 3) in + let a' = Array.copy a in let _ = a'.(np - i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (s_eq, a')) in + sigma, (d, r', lhs, rhs) :: rs + | _ -> + if red = 0 then loop d sigma r t rs 1 + else errorstrm (str "not a rewritable relation: " ++ pr_constr_pat t + ++ spc() ++ str "in rule " ++ pr_constr_pat (snd rule)) + in + let sigma, r = rule in + let t = Retyping.get_type_of env sigma r in + loop dir sigma r t [] 0 + in + r_sigma, rules + +let rwrxtac occ rdx_pat dir rule gl = + let env = pf_env gl in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find_rule rdx = + let rec rwtac = function + | [] -> + errorstrm (str "pattern " ++ pr_constr_pat rdx ++ + str " does not match " ++ pr_dir_side dir ++ + str " of " ++ pr_constr_pat (snd rule)) + | (d, r, lhs, rhs) :: rs -> + try + let ise = unify_HO env (create_evar_defs r_sigma) lhs rdx in + if not (rw_progress rhs rdx ise) then raise NoMatch else + d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) + with _ -> rwtac rs in + rwtac rules in + let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let find_R, conclude = match rdx_pat with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let upats_origin = dir, snd rule in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env sigma0 (sigma,r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in + (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), + fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> + let r = ref None in + (fun env c _ h -> do_once r (fun () -> find_rule c, c); mkRel h), + (fun concl -> closed0_check concl e gl; assert_done r) in + let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in + let (d, r), rdx = conclude concl in + let r = Evd.merge_universe_context (pi1 r) (pi2 r), pi3 r in + rwcltac concl rdx d r gl +;; + +let prof_rwxrtac = mk_profiler "rwrxtac";; +let rwrxtac occ rdx_pat dir rule gl = + prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl +;; + +let ssrinstancesofrule ist dir arg gl = + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let rule = interp_term ist gl arg in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find, conclude = + let upats_origin = dir, snd rule in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env sigma0 (sigma,r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + ppnl (str"BEGIN INSTANCES"); + try + while true do + ignore(find env0 concl0 1 ~k:print) + done; raise NoMatch + with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl + +TACTIC EXTEND ssrinstofruleL2R +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> [ Proofview.V82.tactic (ssrinstancesofrule ist L2R arg) ] +END +TACTIC EXTEND ssrinstofruleR2L +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> [ Proofview.V82.tactic (ssrinstancesofrule ist R2L arg) ] +END + +(* Resolve forward reference *) +let _ = + ipat_rewritetac := fun occ dir c gl -> rwrxtac occ None dir (project gl, c) gl + +let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + let fail = ref false in + let interp_rpattern ist gl gc = + try interp_rpattern ist gl gc + with _ when snd mult = May -> fail := true; project gl, T mkProp in + let interp gc gl = + try interp_term ist gl gc + with _ when snd mult = May -> fail := true; (project gl, mkProp) in + let rwtac gl = + let rx = Option.map (interp_rpattern ist gl) grx in + let t = interp gt gl in + (match kind with + | RWred sim -> simplintac occ rx sim + | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt + | RWeq -> rwrxtac occ rx dir t) gl in + let ctac = cleartac (interp_clr (oclr, (fst gt, snd (interp gt gl)))) in + if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list *) + +let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY pr_ssrrwargs + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect rewrite"; + Goptions.optkey = ["SsrRewrite"]; + Goptions.optread = (fun _ -> !ssr_rw_syntax); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } + +let test_ssr_rw_syntax = + let test strm = + if not !ssr_rw_syntax then raise Stream.Failure else + if is_ssr_loaded () then () else + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | _ -> raise Stream.Failure in + Gram.Entry.of_parser "test_ssr_rw_syntax" test + +GEXTEND Gram + GLOBAL: ssrrwargs; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a ]]; +END + +(** The "rewrite" tactic *) + +let ssrrewritetac ist rwargs = + tclTHENLIST (List.map (rwargtac ist) rwargs) + +TACTIC EXTEND ssrrewrite + | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrrewritetac ist args) clauses) ] +END + +(** The "unlock" tactic *) + +let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t +let pr_ssrunlockarg _ _ _ = pr_unlockarg + +ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm + PRINTED BY pr_ssrunlockarg + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] + | [ ssrterm(t) ] -> [ None, t ] +END + +let pr_ssrunlockargs _ _ _ args = pr_list spc pr_unlockarg args + +ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list + PRINTED BY pr_ssrunlockargs + | [ ssrunlockarg_list(args) ] -> [ args ] +END + +let unfoldtac occ ko t kt gl = + let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term t kt)) in + let cl' = subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref c] gl c) cl in + let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in + Proofview.V82.of_tactic + (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + +let unlocktac ist args gl = + let utac (occ, gt) gl = + unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in + let locked, gl = pf_mkSsrConst "locked" gl in + let key, gl = pf_mkSsrConst "master_key" gl in + let ktacs = [ + (fun gl -> unfoldtac None None (project gl,locked) '(' gl); + simplest_newcase key ] in + tclTHENLIST (List.map utac args @ ktacs) gl + +TACTIC EXTEND ssrunlock + | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> +[ Proofview.V82.tactic (tclCLAUSES ist (unlocktac ist args) clauses) ] +END + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) + +(** Defined identifier *) + +type ssrfwdid = identifier + +let pr_ssrfwdid _ _ _ id = pr_spc () ++ pr_id id + +(* We use a primitive parser for the head identifier of forward *) +(* tactis to avoid syntactic conflicts with basic Coq tactics. *) +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdid + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssrfwdid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm + | _ -> raise Stream.Failure + + +let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid + +GEXTEND Gram + GLOBAL: ssrfwdid; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + END + + + +(** Definition value formatting *) + +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) + +type 'term ssrbind = + | Bvar of name + | Bdecl of name list * 'term + | Bdef of name * 'term option * 'term + | Bstruct of name + | Bcast of 'term + +let pr_binder prl = function + | Bvar x -> + pr_name x + | Bdecl (xs, t) -> + str "(" ++ pr_list pr_spc pr_name xs ++ str " : " ++ prl t ++ str ")" + | Bdef (x, None, v) -> + str "(" ++ pr_name x ++ str " := " ++ prl v ++ str ")" + | Bdef (x, Some t, v) -> + str "(" ++ pr_name x ++ str " : " ++ prl t ++ + str " := " ++ prl v ++ str ")" + | Bstruct x -> + str "{struct " ++ pr_name x ++ str "}" + | Bcast t -> + str ": " ++ prl t + +type 'term ssrbindval = 'term ssrbind list * 'term + +type ssrbindfmt = + | BFvar + | BFdecl of int (* #xs *) + | BFcast (* final cast *) + | BFdef of bool (* has cast? *) + | BFrec of bool * bool (* has struct? * has cast? *) + +let rec mkBstruct i = function + | Bvar x :: b -> + if i = 0 then [Bstruct x] else mkBstruct (i - 1) b + | Bdecl (xs, _) :: b -> + let i' = i - List.length xs in + if i' < 0 then [Bstruct (List.nth xs i)] else mkBstruct i' b + | _ :: b -> mkBstruct i b + | [] -> [] + +let rec format_local_binders h0 bl0 = match h0, bl0 with + | BFvar :: h, LocalRawAssum ([_, x], _, _) :: bl -> + Bvar x :: format_local_binders h bl + | BFdecl _ :: h, LocalRawAssum (lxs, _, t) :: bl -> + Bdecl (List.map snd lxs, t) :: format_local_binders h bl + | BFdef false :: h, LocalRawDef ((_, x), v) :: bl -> + Bdef (x, None, v) :: format_local_binders h bl + | BFdef true :: h, + LocalRawDef ((_, x), CCast (_, v, CastConv t)) :: bl -> + Bdef (x, Some t, v) :: format_local_binders h bl + | _ -> [] + +let rec format_constr_expr h0 c0 = match h0, c0 with + | BFvar :: h, CLambdaN (_, [[_, x], _, _], c) -> + let bs, c' = format_constr_expr h c in + Bvar x :: bs, c' + | BFdecl _:: h, CLambdaN (_, [lxs, _, t], c) -> + let bs, c' = format_constr_expr h c in + Bdecl (List.map snd lxs, t) :: bs, c' + | BFdef false :: h, CLetIn(_, (_, x), v, c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, CLetIn(_, (_, x), CCast (_, v, CastConv t), c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], CCast (_, c, CastConv t) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, + CFix (_, _, [_, (Some locn, CStructRec), bl, t, c]) -> + let bs = format_local_binders h bl in + let bstr = if has_str then [Bstruct (Name (snd locn))] else [] in + bs @ bstr @ (if has_cast then [Bcast t] else []), c + | BFrec (_, has_cast) :: h, CCoFix (_, _, [_, bl, t, c]) -> + format_local_binders h bl @ (if has_cast then [Bcast t] else []), c + | _, c -> + [], c + +let rec format_glob_decl h0 d0 = match h0, d0 with + | BFvar :: h, (x, _, None, _) :: d -> + Bvar x :: format_glob_decl h d + | BFdecl 1 :: h, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl h d + | BFdecl n :: h, (x, _, None, t) :: d when n > 1 -> + begin match format_glob_decl (BFdecl (n - 1) :: h) d with + | Bdecl (xs, _) :: bs -> Bdecl (x :: xs, t) :: bs + | bs -> Bdecl ([x], t) :: bs + end + | BFdef false :: h, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl h d + | BFdef true:: h, (x, _, Some (GCast (_, v, CastConv t)), _) :: d -> + Bdef (x, Some t, v) :: format_glob_decl h d + | _, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl [] d + | _, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl [] d + | _, [] -> [] + +let rec format_glob_constr h0 c0 = match h0, c0 with + | BFvar :: h, GLambda (_, x, _, _, c) -> + let bs, c' = format_glob_constr h c in + Bvar x :: bs, c' + | BFdecl 1 :: h, GLambda (_, x, _, t, c) -> + let bs, c' = format_glob_constr h c in + Bdecl ([x], t) :: bs, c' + | BFdecl n :: h, GLambda (_, x, _, t, c) when n > 1 -> + begin match format_glob_constr (BFdecl (n - 1) :: h) c with + | Bdecl (xs, _) :: bs, c' -> Bdecl (x :: xs, t) :: bs, c' + | _ -> [Bdecl ([x], t)], c + end + | BFdef false :: h, GLetIn(_, x, v, c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, GLetIn(_, x, GCast (_, v, CastConv t), c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], GCast (_, c, CastConv t) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, GRec (_, f, _, bl, t, c) + when Array.length c = 1 -> + let bs = format_glob_decl h bl.(0) in + let bstr = match has_str, f with + | true, GFix ([|Some i, GStructRec|], _) -> mkBstruct i bs + | _ -> [] in + bs @ bstr @ (if has_cast then [Bcast t.(0)] else []), c.(0) + | _, c -> + [], c + +(** Forward chaining argument *) + +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) + +type ssrfwdkind = FwdHint of string * bool | FwdHave | FwdPose + +type ssrfwdfmt = ssrfwdkind * ssrbindfmt list + +let pr_fwdkind = function + | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () +let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk + +let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt + +(* type ssrfwd = ssrfwdfmt * ssrterm *) + +let mkFwdVal fk c = ((fk, []), mk_term ' ' c) +let mkssrFwdVal fk c = ((fk, []), (c,None)) + +let mkFwdCast fk loc t c = ((fk, [BFcast]), mk_term ' ' (CCast (loc, c, dC t))) +let mkssrFwdCast fk loc t c = ((fk, [BFcast]), (c, Some t)) + +let mkFwdHint s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,false)) loc t (mkCHole loc) +let mkFwdHintNoTC s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,true)) loc t (mkCHole loc) + +let pr_gen_fwd prval prc prlc fk (bs, c) = + let prc s = str s ++ spc () ++ prval prc prlc c in + match fk, bs with + | FwdHint (s,_), [Bcast t] -> str s ++ spc () ++ prlc t + | FwdHint (s,_), _ -> prc (s ^ "(* typeof *)") + | FwdHave, [Bcast t] -> str ":" ++ spc () ++ prlc t ++ prc " :=" + | _, [] -> prc " :=" + | _, _ -> spc () ++ pr_list spc (pr_binder prlc) bs ++ prc " :=" + +let pr_fwd_guarded prval prval' = function +| (fk, h), (_, (_, Some c)) -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| (fk, h), (_, (c, None)) -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +let pr_unguarded prc prlc = prlc + +let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded +let pr_ssrfwd _ _ _ = pr_fwd + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ssrterm) PRINTED BY pr_ssrfwd + | [ ":=" lconstr(c) ] -> [ mkFwdVal FwdPose c ] + | [ ":" lconstr (t) ":=" lconstr(c) ] -> [ mkFwdCast FwdPose loc t c ] +END + +(** Independent parsing for binders *) + +(* The pose, pose fix, and pose cofix tactics use these internally to *) +(* parse argument fragments. *) + +let pr_ssrbvar prc _ _ v = prc v + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar +| [ ident(id) ] -> [ mkCVar loc id ] +| [ "_" ] -> [ mkCHole loc ] +END + +let bvar_lname = function + | CRef (Ident (loc, id), _) -> loc, Name id + | c -> constr_loc c, Anonymous + +let pr_ssrbinder prc _ _ (_, c) = prc c + +ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder + | [ ssrbvar(bv) ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,mkCHole xloc],mkCHole loc) ] + | [ "(" ssrbvar(bv) ")" ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,mkCHole xloc],mkCHole loc) ] + | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> + [ let x = bvar_lname bv in + (FwdPose, [BFdecl 1]), + CLambdaN (loc, [[x], Default Explicit, t], mkCHole loc) ] + | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> + [ let xs = List.map bvar_lname (bv :: bvs) in + let n = List.length xs in + (FwdPose, [BFdecl n]), + CLambdaN (loc, [xs, Default Explicit, t], mkCHole loc) ] + | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> + [ let loc' = Loc.join_loc (constr_loc t) (constr_loc v) in + let v' = CCast (loc', v, dC t) in + (FwdPose,[BFdef true]), CLetIn (loc,bvar_lname id, v',mkCHole loc) ] + | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef false]), CLetIn (loc,bvar_lname id, v,mkCHole loc) ] +END + +GEXTEND Gram + GLOBAL: ssrbinder; + ssrbinder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + let loc = !@loc in + (FwdPose, [BFvar]), + CLambdaN (loc,[[loc,Anonymous],Default Explicit,c],mkCHole loc) ] + ]; +END + +let rec binders_fmts = function + | ((_, h), _) :: bs -> h @ binders_fmts bs + | _ -> [] + +let push_binders c2 bs = + let loc2 = constr_loc c2 in let mkloc loc1 = Loc.join_loc loc1 loc2 in + let rec loop ty c = function + | (_, CLambdaN (loc1, b, _)) :: bs when ty -> + CProdN (mkloc loc1, b, loop ty c bs) + | (_, CLambdaN (loc1, b, _)) :: bs -> + CLambdaN (mkloc loc1, b, loop ty c bs) + | (_, CLetIn (loc1, x, v, _)) :: bs -> + CLetIn (mkloc loc1, x, v, loop ty c bs) + | [] -> c + | _ -> anomaly "binder not a lambda nor a let in" in + match c2 with + | CCast (x, ct, CastConv cty) -> + (CCast (x, loop false ct bs, CastConv (loop true cty bs))) + | ct -> loop false ct bs + +let rec fix_binders = function + | (_, CLambdaN (_, [xs, _, t], _)) :: bs -> + LocalRawAssum (xs, Default Explicit, t) :: fix_binders bs + | (_, CLetIn (_, x, v, _)) :: bs -> + LocalRawDef (x, v) :: fix_binders bs + | _ -> [] + +let pr_ssrstruct _ _ _ = function + | Some id -> str "{struct " ++ pr_id id ++ str "}" + | None -> mt () + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct +| [ "{" "struct" ident(id) "}" ] -> [ Some id ] +| [ ] -> [ None ] +END + +(** The "pose" tactic *) + +(* The plain pose form. *) + +let bind_fwd bs = function + | (fk, h), (ck, (rc, Some c)) -> + (fk,binders_fmts bs @ h), (ck,(rc,Some (push_binders c bs))) + | fwd -> fwd + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +END + +(* The pose fix form. *) + +let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd + +let bvar_locid = function + | CRef (Ident (loc, id), _) -> loc, id + | _ -> CErrors.error "Missing identifier after \"(co)fix\"" + + +ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd + | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> + [ let (_, id) as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let lb = fix_binders bs in + let has_struct, i = + let rec loop = function + (l', Name id') :: _ when Option.equal Id.equal sid (Some id') -> true, (l', id') + | [l', Name id'] when sid = None -> false, (l', id') + | _ :: bn -> loop bn + | [] -> CErrors.error "Bad structural argument" in + loop (names_of_local_assums lb) in + let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in + let fix = CFix (loc, lid, [lid, (Some i, CStructRec), lb, t', c']) in + id, ((fk, h'), (ck, (rc, Some fix))) ] +END + + +(* The pose cofix form. *) + +let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd + | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> + [ let _, id as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let h' = BFrec (false, has_cast) :: binders_fmts bs in + let cofix = CCoFix (loc, lid, [lid, fix_binders bs, t', c']) in + id, ((fk, h'), (ck, (rc, Some cofix))) + ] +END + +let ssrposetac ist (id, (_, t)) gl = + let sigma, t, ucst, _ = pf_abs_ssrterm ist gl t in + posetac id t (pf_merge_uc ucst gl) + + +let prof_ssrposetac = mk_profiler "ssrposetac";; +let ssrposetac arg gl = prof_ssrposetac.profile (ssrposetac arg) gl;; + +TACTIC EXTEND ssrpose +| [ "pose" ssrfixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrcofixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ Proofview.V82.tactic (ssrposetac ist (id, fwd)) ] +END + +(** The "set" tactic *) + +(* type ssrsetfwd = ssrfwd * ssrdocc *) + +let guard_setrhs s i = s.[i] = '{' + +let pr_setrhs occ prc prlc c = + if occ = nodocc then pr_guarded guard_setrhs prlc c else pr_docc occ ++ prc c + +let pr_fwd_guarded prval prval' = function +| (fk, h), (_, (_, Some c)) -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| (fk, h), (_, (c, None)) -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +(* This does not print the type, it should be fixed... *) +let pr_ssrsetfwd _ _ _ (((fk,_),(t,_)), docc) = + pr_gen_fwd (fun _ _ -> pr_cpattern) + (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) + +ARGUMENT EXTEND ssrsetfwd +TYPED AS (ssrfwdfmt * (lcpattern * ssrterm option)) * ssrdocc +PRINTED BY pr_ssrsetfwd +| [ ":" lconstr(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, mkocc occ ] +| [ ":" lconstr(t) ":=" lcpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, nodocc ] +| [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdVal FwdPose c, mkocc occ ] +| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] +END + +let ssrsettac ist id ((_, (pat, pty)), (_, occ)) gl = + let pat = interp_cpattern ist gl pat (Option.map snd pty) in + let cl, sigma, env = pf_concl gl, project gl, pf_env gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in + if occur_existential c then errorstrm(str"The pattern"++spc()++ + pr_constr_pat c++spc()++str"did not match and has holes."++spc()++ + str"Did you mean pose?") else + let c, (gl, cty) = match kind_of_term c with + | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) + | _ -> c, pf_type_of gl c in + let cl' = mkLetIn (Name id, c, cty, cl) in + let gl = pf_merge_uc ucst gl in + tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + +TACTIC EXTEND ssrset +| [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrsettac ist id fwd) clauses) ] +END + +(** The "have" tactic *) + +(* type ssrhavefwd = ssrfwd * ssrhint *) + +let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd +| [ ":" lconstr(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] +| [ ":" lconstr(t) ":=" lconstr(c) ] -> [ mkFwdCast FwdHave loc t c, nohint ] +| [ ":" lconstr(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] +| [ ":=" lconstr(c) ] -> [ mkFwdVal FwdHave c, nohint ] +END + +let intro_id_to_binder = List.map (function + | IpatId id -> + let xloc, _ as x = bvar_lname (mkCVar dummy_loc id) in + (FwdPose, [BFvar]), + CLambdaN (dummy_loc, [[x], Default Explicit, mkCHole xloc], + mkCHole dummy_loc) + | _ -> anomaly "non-id accepted as binder") + +let binder_to_intro_id = List.map (function + | (FwdPose, [BFvar]), CLambdaN (_,[ids,_,_],_) + | (FwdPose, [BFdecl _]), CLambdaN (_,[ids,_,_],_) -> + List.map (function (_, Name id) -> IpatId id | _ -> IpatAnon) ids + | (FwdPose, [BFdef _]), CLetIn (_,(_,Name id),_,_) -> [IpatId id] + | (FwdPose, [BFdef _]), CLetIn (_,(_,Anonymous),_,_) -> [IpatAnon] + | _ -> anomaly "ssrbinder is not a binder") + +let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwdwbinders + TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) + PRINTED BY pr_ssrhavefwdwbinders +| [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> + [ let tr, pats = trpats in + let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let hint = bind_fwd allbs (fst fwd), snd fwd in + tr, ((((clr, pats), allbinders), simpl), hint) ] +END + +(* Tactic. *) + +let is_Evar_or_CastedMeta x = + isEvar_or_Meta x || + (isCast x && isEvar_or_Meta (pi1 (destCast x))) + +let occur_existential_or_casted_meta c = + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Not_found + | Cast (m,_,_) when isMeta m -> raise Not_found + | _ -> iter_constr occrec c + in try occrec c; false with Not_found -> true + +let examine_abstract id gl = + let gl, tid = pf_type_of gl id in + let abstract, gl = pf_mkSsrConst "abstract" gl in + if not (isApp tid) || not (Term.eq_constr (fst(destApp tid)) abstract) then + errorstrm(strbrk"not an abstract constant: "++pr_constr id); + let _, args_id = destApp tid in + if Array.length args_id <> 3 then + errorstrm(strbrk"not a proper abstract constant: "++pr_constr id); + if not (is_Evar_or_CastedMeta args_id.(2)) then + errorstrm(strbrk"abstract constant "++pr_constr id++str" already used"); + tid, args_id + +let pf_find_abstract_proof check_lock gl abstract_n = + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let l = Evd.fold_undefined (fun e ei l -> + match kind_of_term ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) + when (not check_lock || + (occur_existential_or_casted_meta (fire gl ty) && + is_Evar_or_CastedMeta (fire gl lock))) && + Term.eq_constr hd abstract && Term.eq_constr n abstract_n -> e::l + | _ -> l) (project gl) [] in + match l with + | [e] -> e + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" not found in the evar map exactly once. "++ + strbrk"Did you tamper with it?") + +let unfold cl = + let module R = Reductionops in let module F = CClosure.RedFlags in + reduct_in_concl (R.clos_norm_flags (F.mkflags + (List.map (fun c -> F.fCONST (fst (destConst c))) cl @ + [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) + +let havegentac ist t gl = + let sigma, c, ucst, _ = pf_abs_ssrterm ist gl t in + let gl = pf_merge_uc ucst gl in + let gl, cty = pf_type_of gl c in + apply_type (mkArrow cty (pf_concl gl)) [c] gl + +let havetac ist + (transp,((((clr, pats), binders), simpl), (((fk, _), t), hint))) + suff namefst gl += + let concl = pf_concl gl in + let skols, pats = + List.partition (function IpatNewHidden _ -> true | _ -> false) pats in + let itac_mkabs = introstac ~ist skols in + let itac_c = introstac ~ist (IpatSimpl(clr,Nop) :: pats) in + let itac, id, clr = introstac ~ist pats, tclIDTAC, cleartac clr in + let binderstac n = + let rec aux = function 0 -> [] | n -> IpatAnon :: aux (n-1) in + tclTHEN (if binders <> [] then introstac ~ist (aux n) else tclIDTAC) + (introstac ~ist binders) in + let simpltac = introstac ~ist simpl in + let fixtc = + not !ssrhaveNOtcresolution && + match fk with FwdHint(_,true) -> false | _ -> true in + let hint = hinttac ist true hint in + let cuttac t gl = + if transp then + let have_let, gl = pf_mkSsrConst "ssr_have_let" gl in + let step = mkApp (have_let, [|concl;t|]) in + let gl, _ = pf_e_type_of gl step in + applyn ~with_evars:true ~with_shelve:false 2 step gl + else basecuttac "ssr_have" t gl in + (* Introduce now abstract constants, so that everything sees them *) + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let unlock_abs (idty,args_id) gl = + let gl, _ = pf_e_type_of gl idty in + pf_unify_HO gl args_id.(2) abstract_key in + tclTHENFIRST itac_mkabs (fun gl -> + let mkt t = mk_term ' ' t in + let mkl t = (' ', (t, None)) in + let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in + let interp_ty gl rtc t = + let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a,b,u in + let ct, cty, hole, loc = match t with + | _, (_, Some (CCast (loc, ct, CastConv cty))) -> + mkt ct, mkt cty, mkt (mkCHole dummy_loc), loc + | _, (_, Some ct) -> + mkt ct, mkt (mkCHole dummy_loc), mkt (mkCHole dummy_loc), dummy_loc + | _, (GCast (loc, ct, CastConv cty), None) -> + mkl ct, mkl cty, mkl mkRHole, loc + | _, (t, None) -> mkl t, mkl mkRHole, mkl mkRHole, dummy_loc in + let gl, cut, sol, itac1, itac2 = + match fk, namefst, suff with + | FwdHave, true, true -> + errorstrm (str"Suff have does not accept a proof term") + | FwdHave, false, true -> + let cty = combineCG cty hole (mkCArrow loc) mkRArrow in + let _,t,uc,_ = interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + let gl = pf_merge_uc uc gl in + let gl, ty = pf_type_of gl t in + let ctx, _ = decompose_prod_n 1 ty in + let assert_is_conv gl = + try Proofview.V82.of_tactic (convert_concl (compose_prod ctx concl)) gl + with _ -> errorstrm (str "Given proof term is not of type " ++ + pr_constr (mkArrow (mkVar (id_of_string "_")) concl)) in + gl, ty, tclTHEN assert_is_conv (Proofview.V82.of_tactic (apply t)), id, itac_c + | FwdHave, false, false -> + let skols = List.flatten (List.map (function + | IpatNewHidden ids -> ids + | _ -> assert false) skols) in + let skols_args = + List.map (fun id -> examine_abstract (mkVar id) gl) skols in + let gl = List.fold_right unlock_abs skols_args gl in + let sigma, t, uc, n_evars = + interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + if skols <> [] && n_evars <> 0 then + CErrors.error ("Automatic generalization of unresolved implicit "^ + "arguments together with abstract variables is "^ + "not supported"); + let gl = re_sig (sig_it gl) (Evd.merge_universe_context sigma uc) in + let gs = + List.map (fun (_,a) -> + pf_find_abstract_proof false gl a.(1)) skols_args in + let tacopen_skols gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff (gs @ [g]) in + let gl, ty = pf_e_type_of gl t in + gl, ty, Proofview.V82.of_tactic (apply t), id, + tclTHEN (tclTHEN itac_c simpltac) + (tclTHEN tacopen_skols (fun gl -> + let abstract, gl = pf_mkSsrConst "abstract" gl in + Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl)) + | _,true,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, mkArrow ty concl, hint, itac, clr + | _,false,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, mkArrow ty concl, hint, id, itac_c + | _, false, false -> + let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, cty, tclTHEN (binderstac n) hint, id, tclTHEN itac_c simpltac + | _, true, false -> assert false in + tclTHENS (cuttac cut) [ tclTHEN sol itac1; itac2 ] gl) + gl +;; + +(* to extend the abstract value one needs: + Utility lemma to partially instantiate an abstract constant type. + Lemma use_abstract T n l (x : abstract T n l) : T. + Proof. by case: l x. Qed. +*) +let ssrabstract ist gens (*last*) gl = + let main _ (_,cid) ist gl = +(* + let proj1, proj2, prod = + let pdata = build_prod () in + pdata.Coqlib.proj1, pdata.Coqlib.proj2, pdata.Coqlib.typ in +*) + let concl, env = pf_concl gl, pf_env gl in + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let cid_interpreted = interp_cpattern ist gl cid None in + let id = mkVar (Option.get (id_of_pattern cid_interpreted)) in + let idty, args_id = examine_abstract id gl in + let abstract_n = args_id.(1) in + let abstract_proof = pf_find_abstract_proof true gl abstract_n in + let gl, proof = + let pf_unify_HO gl a b = + try pf_unify_HO gl a b + with _ -> errorstrm(strbrk"The abstract variable "++pr_constr id++ + strbrk" cannot abstract this goal. Did you generalize it?") in + let rec find_hole p t = + match kind_of_term t with + | Evar _ (*when last*) -> pf_unify_HO gl concl t, p + | Meta _ (*when last*) -> pf_unify_HO gl concl t, p + | Cast(m,_,_) when isEvar_or_Meta m (*when last*) -> pf_unify_HO gl concl t, p +(* + | Evar _ -> + let sigma, it = project gl, sig_it gl in + let sigma, ty = Evarutil.new_type_evar sigma env in + let gl = re_sig it sigma in + let p = mkApp (proj2,[|ty;concl;p|]) in + let concl = mkApp(prod,[|ty; concl|]) in + pf_unify_HO gl concl t, p + | App(hd, [|left; right|]) when Term.eq_constr hd prod -> + find_hole (mkApp (proj1,[|left;right;p|])) left +*) + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" has an unexpected shape. Did you tamper with it?") + in + find_hole + ((*if last then*) id + (*else mkApp(mkSsrConst "use_abstract",Array.append args_id [|id|])*)) + (fire gl args_id.(0)) in + let gl = (*if last then*) pf_unify_HO gl abstract_key args_id.(2) (*else gl*) in + let gl, _ = pf_e_type_of gl idty in + let proof = fire gl proof in +(* if last then *) + let tacopen gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff [ g; abstract_proof ] in + tclTHENS tacopen [tclSOLVE [Proofview.V82.of_tactic (apply proof)]; Proofview.V82.of_tactic (unfold[abstract;abstract_key])] gl +(* else apply proof gl *) + in + let introback ist (gens, _) = + introstac ~ist + (List.map (fun (_,cp) -> match id_of_pattern (interp_cpattern ist gl cp None) with + | None -> IpatAnon + | Some id -> IpatId id) + (List.tl (List.hd gens))) in + tclTHEN (with_dgens gens main ist) (introback ist gens) gl + +(* The standard TACTIC EXTEND does not work for abstract *) +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "3" + [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> + ssrtac_expr !@loc "abstract" + [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] ]]; +END +TACTIC EXTEND ssrabstract +| [ "abstract" ssrdgens(gens) ] -> [ + if List.length (fst gens) <> 1 then + errorstrm (str"dependents switches '/' not allowed here"); + Proofview.V82.tactic (ssrabstract ist gens) ] +END + +let prof_havetac = mk_profiler "havetac";; +let havetac arg a b gl = prof_havetac.profile (havetac arg a b) gl;; + +TACTIC EXTEND ssrhave +| [ "have" ssrhavefwdwbinders(fwd) ] -> + [ Proofview.V82.tactic (havetac ist fwd false false) ] +END + +TACTIC EXTEND ssrhavesuff +| [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrhavesuffices +| [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrsuffhave +| [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +TACTIC EXTEND ssrsufficeshave +| [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +(** The "suffice" tactic *) + +let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrsufffwd + TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders +| [ ssrhpats(pats) ssrbinder_list(bs) ":" lconstr(t) ssrhint(hint) ] -> + [ let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let fwd = mkFwdHint ":" t in + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] +END + +let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = + let htac = tclTHEN (introstac ~ist pats) (hinttac ist true hint) in + let c = match c with + | (a, (b, Some (CCast (_, _, CastConv cty)))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv cty), None)) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" in + let ctac gl = + let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in + basecuttac "ssr_suff" ty gl in + tclTHENS ctac [htac; tclTHEN (cleartac clr) (introstac ~ist (binders@simpl))] + +TACTIC EXTEND ssrsuff +| [ "suff" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +TACTIC EXTEND ssrsuffices +| [ "suffices" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +(** The "wlog" (Without Loss Of Generality) tactic *) + +(* type ssrwlogfwd = ssrwgen list * ssrfwd *) + +let pr_ssrwlogfwd _ _ _ (gens, t) = + str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t + +ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd + PRINTED BY pr_ssrwlogfwd +| [ ":" ssrwgen_list(gens) "/" lconstr(t) ] -> [ gens, mkFwdHint "/" t] +END + +let destProd_or_LetIn c = + match kind_of_term c with + | Prod (n,ty,c) -> RelDecl.LocalAssum (n, ty), c + | LetIn (n,bo,ty,c) -> RelDecl.LocalDef (n, bo, ty), c + | _ -> raise DestKO + +let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = + let mkabs gen = abs_wgen false ist (fun x -> x) gen in + let mkclr gen clrs = clr_of_wgen gen clrs in + let mkpats = function + | _, Some ((x, _), _) -> fun pats -> IpatId (hoi_id x) :: pats + | _ -> fun x -> x in + let ct = match ct with + | (a, (b, Some (CCast (_, _, CastConv cty)))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv cty), None)) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" in + let cut_implies_goal = not (suff || ghave <> `NoGen) in + let c, args, ct, gl = + let gens = List.filter (function _, Some _ -> true | _ -> false) gens in + let concl = pf_concl gl in + let c = mkProp in + let c = if cut_implies_goal then mkArrow c concl else c in + let gl, args, c = List.fold_right mkabs gens (gl,[],c) in + let env, _ = + List.fold_left (fun (env, c) _ -> + let rd, c = destProd_or_LetIn c in + Environ.push_rel rd env, c) (pf_env gl, c) gens in + let sigma = project gl in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (ev, sigma, _) = Evarutil.new_evar env sigma Term.mkProp in + let sigma = Sigma.to_evar_map sigma in + let k, _ = Term.destEvar ev in + let fake_gl = {Evd.it = k; Evd.sigma = sigma} in + let _, ct, _, uc = pf_interp_ty ist fake_gl ct in + let rec var2rel c g s = match kind_of_term c, g with + | Prod(Anonymous,_,c), [] -> mkProd(Anonymous, Vars.subst_vars s ct, c) + | Sort _, [] -> Vars.subst_vars s ct + | LetIn(Name id as n,b,ty,c), _::g -> mkLetIn (n,b,ty,var2rel c g (id::s)) + | Prod(Name id as n,ty,c), _::g -> mkProd (n,ty,var2rel c g (id::s)) + | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_constr c) in + let c = var2rel c gens [] in + let rec pired c = function + | [] -> c + | t::ts as args -> match kind_of_term c with + | Prod(_,_,c) -> pired (subst1 t c) ts + | LetIn(id,b,ty,c) -> mkLetIn (id,b,ty,pired c args) + | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_constr c) in + c, args, pired c args, pf_merge_uc uc gl in + let tacipat pats = introstac ~ist pats in + let tacigens = + tclTHEN + (tclTHENLIST(List.rev(List.fold_right mkclr gens [cleartac clr0]))) + (introstac ~ist (List.fold_right mkpats gens [])) in + let hinttac = hinttac ist true hint in + let cut_kind, fst_goal_tac, snd_goal_tac = + match suff, ghave with + | true, `NoGen -> "ssr_wlog", tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, tclTHEN tacigens (tacipat pats) + | true, `Gen _ -> assert false + | false, `Gen id -> + if gens = [] then errorstrm(str"gen have requires some generalizations"); + let clear0 = cleartac clr0 in + let id, name_general_hyp, cleanup, pats = match id, pats with + | None, (IpatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, _ -> None, tclIDTAC, clear0, pats + | Some (Some id),_ -> Some id, introid id, clear0, pats + | Some _,_ -> + let id = mk_anon_id "tmp" gl in + Some id, introid id, tclTHEN clear0 (Proofview.V82.of_tactic (clear [id])), pats in + let tac_specialize = match id with + | None -> tclIDTAC + | Some id -> + if pats = [] then tclIDTAC else + let args = Array.of_list args in + pp(lazy(str"specialized="++pr_constr (mkApp (mkVar id,args)))); + pp(lazy(str"specialized_ty="++pr_constr ct)); + tclTHENS (basecuttac "ssr_have" ct) + [Proofview.V82.of_tactic (apply (mkApp (mkVar id,args))); tclIDTAC] in + "ssr_have", + (if hint = nohint then tacigens else hinttac), + tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + in + tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + +TACTIC EXTEND ssrwlog +| [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwlogs +| [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwlogss +| [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutloss +| [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlosss +| [ "without" "loss" "suff" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlossss +| [ "without" "loss" "suffices" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +(* Generally have *) +let pr_idcomma _ _ _ = function + | None -> mt() + | Some None -> str"_, " + | Some (Some id) -> pr_id id ++ str", " + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma + | [ ] -> [ None ] +END + +let accept_idcomma strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm + | _ -> raise Stream.Failure + +let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma + +GEXTEND Gram + GLOBAL: ssr_idcomma; + ssr_idcomma: [ [ test_idcomma; + ip = [ id = IDENT -> Some (id_of_string id) | "_" -> None ]; "," -> + Some ip + ] ]; +END + +let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) + +TACTIC EXTEND ssrgenhave +| [ "gen" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +TACTIC EXTEND ssrgenhave2 +| [ "generally" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +(** Canonical Structure alias *) + +GEXTEND Gram + GLOBAL: gallina_ext; + + gallina_ext: + (* Canonical structure *) + [[ IDENT "Canonical"; qid = Constr.global -> + Vernacexpr.VernacCanonical (AN qid) + | IDENT "Canonical"; ntn = Prim.by_notation -> + Vernacexpr.VernacCanonical (ByNotation ntn) + | IDENT "Canonical"; qid = Constr.global; + d = G_vernac.def_body -> + let s = coerce_reference_to_id qid in + Vernacexpr.VernacDefinition + ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure), + ((dummy_loc,s),None),(d )) + ]]; +END + +(** 9. Keyword compatibility fixes. *) + +(* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) +(* identifiers used as keywords. This is incompatible with ssreflect.v *) +(* which makes "by" and "of" true keywords, because of technicalities *) +(* in the internal lexer-parser API of Coq. We patch this here by *) +(* adding new parsing rules that recognize the new keywords. *) +(* To make matters worse, the Coq grammar for tactics fails to *) +(* export the non-terminals we need to patch. Fortunately, the CamlP5 *) +(* API provides a backdoor access (with loads of Obj.magic trickery). *) + +(* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) +(* longer and thus comment out. Such comments are marked with v8.3 *) + +GEXTEND Gram + GLOBAL: Tactic.hypident; + Tactic.hypident: [ + [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> id, InHypTypeOnly + | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> id, InHypValueOnly + ] ]; +END + +GEXTEND Gram + GLOBAL: hloc; +hloc: [ + [ "in"; "("; "Type"; "of"; id = ident; ")" -> + HypLocation ((dummy_loc,id), InHypTypeOnly) + | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> + HypLocation ((dummy_loc,id), InHypValueOnly) + ] ]; +END + +GEXTEND Gram + GLOBAL: Tactic.constr_eval; + Tactic.constr_eval: [ + [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] + ]; +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = CLexer.unfreeze frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/v8.6/ssreflect_plugin.mlpack b/mathcomp/ssreflect/plugin/v8.6/ssreflect_plugin.mlpack new file mode 100644 index 0000000..006b70f --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.6/ssreflect_plugin.mlpack @@ -0,0 +1,2 @@ +Ssrmatching +Ssreflect -- cgit v1.2.3 From 9c4f68936e33c93cf179eec6e996062bec918915 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 26 Aug 2016 16:34:53 +0200 Subject: fix compilation wrt. commit 69388fc in Coq trunk --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 6fa7235..ee13c15 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -2093,7 +2093,7 @@ let abs_wgen keep_let ist f gen (gl,args,c) = let decl = pf_get_hyp gl x in gl, (if NamedDecl.is_local_def decl then args else mkVar x :: args), - mkProd_or_LetIn (decl |> NamedDecl.to_rel |> RelDecl.set_name (Name (f x))) + mkProd_or_LetIn (decl |> NamedDecl.to_rel_decl |> RelDecl.set_name (Name (f x))) (subst_var x c) | _, Some ((x, _), None) -> let x = hoi_id x in -- cgit v1.2.3 From 806b05dc5c3a1594231225df0e8e9e28441d8736 Mon Sep 17 00:00:00 2001 From: Enrico Date: Wed, 7 Sep 2016 17:57:19 +0200 Subject: abstract_context utility lemma --- mathcomp/ssreflect/ssreflect.v | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/ssreflect.v b/mathcomp/ssreflect/ssreflect.v index 38a8013..6750142 100644 --- a/mathcomp/ssreflect/ssreflect.v +++ b/mathcomp/ssreflect/ssreflect.v @@ -422,3 +422,13 @@ End ApplyIff. Hint View for move/ iffLRn|2 iffRLn|2 iffLR|2 iffRL|2. Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. +(* To focus non-ssreflect tactics on a subterm, eg vm_compute. *) +(* Usage: *) +(* elim/abstract_context: (pattern) => G defG. *) +(* vm_compute; rewrite {}defG {G}. *) +(* Note that vm_cast are not stored in the proof term, so *) +(* set here := pattern; vm_compute in (value of here) *) +(* blows up at Qed time. *) +Lemma abstract_context T (P : T -> Type) x : + (forall Q, Q = P -> Q x) -> P x. +Proof. by move=> /(_ P); apply. Qed. -- cgit v1.2.3 From 2209e0bce7eeda751f87806a3e77a0c520017a88 Mon Sep 17 00:00:00 2001 From: Enrico Date: Wed, 7 Sep 2016 18:02:09 +0200 Subject: fix comment --- mathcomp/ssreflect/ssreflect.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/ssreflect.v b/mathcomp/ssreflect/ssreflect.v index 6750142..cd405fa 100644 --- a/mathcomp/ssreflect/ssreflect.v +++ b/mathcomp/ssreflect/ssreflect.v @@ -426,7 +426,8 @@ Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. (* Usage: *) (* elim/abstract_context: (pattern) => G defG. *) (* vm_compute; rewrite {}defG {G}. *) -(* Note that vm_cast are not stored in the proof term, so *) +(* Note that vm_cast are not stored in the proof term *) +(* for reductions occuring in the context, hence *) (* set here := pattern; vm_compute in (value of here) *) (* blows up at Qed time. *) Lemma abstract_context T (P : T -> Type) x : -- cgit v1.2.3 From 9513eeb058f620d8a062c183253212da4b4566d3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 16 Sep 2016 10:47:23 +0200 Subject: Fix compilation after change in CErrors API. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index ee13c15..6559504 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -99,8 +99,8 @@ module Intset = Evar.Set type loc = Loc.t let dummy_loc = Loc.ghost -let errorstrm = CErrors.errorlabstrm "ssreflect" -let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg) +let errorstrm msg = CErrors.user_err ~hdr:"ssreflect" msg +let loc_error loc msg = CErrors.user_err ~loc ~hdr:msg (str msg) let anomaly s = CErrors.anomaly (str s) (* Compatibility with Coq 8.6 *) @@ -1222,7 +1222,7 @@ let interp_search_notation loc s opt_scope = let ambig = "This string refers to a complex or ambiguous notation." in str ambig ++ str "\nTry searching with one of\n" ++ ntns with _ -> str "This string is not part of an identifier or notation." in - CErrors.user_err_loc (loc, "interp_search_notation", diagnosis) + CErrors.user_err ~loc ~hdr:"interp_search_notation" diagnosis let pr_ssr_search_item _ _ _ = pr_search_item @@ -1233,7 +1233,7 @@ let is_ident s = try CLexer.check_ident s; true with _ -> false let is_ident_part s = is_ident ("H" ^ s) let interp_search_notation loc tag okey = - let err msg = CErrors.user_err_loc (loc, "interp_search_notation", msg) in + let err msg = CErrors.user_err ~loc ~hdr:"interp_search_notation" msg in let mk_pntn s for_key = let n = String.length s in let s' = String.make (n + 2) ' ' in @@ -1454,7 +1454,7 @@ let interp_modloc mr = let interp_mod (_, mr) = let (loc, qid) = qualid_of_reference mr in try Nametab.full_name_module qid with Not_found -> - CErrors.user_err_loc (loc, "interp_modloc", str "No Module " ++ pr_qualid qid) in + CErrors.user_err ~loc ~hdr:"interp_modloc" (str "No Module " ++ pr_qualid qid) in let mr_out, mr_in = List.partition fst mr in let interp_bmod b = function | [] -> fun _ _ _ -> true @@ -1760,7 +1760,7 @@ let pr_ssrhyp _ _ _ = pr_hyp let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp let hyp_err loc msg id = - CErrors.user_err_loc (loc, "ssrhyp", str msg ++ pr_id id) + CErrors.user_err ~loc ~hdr:"ssrhyp" (str msg ++ pr_id id) let intern_hyp ist (SsrHyp (loc, id) as hyp) = let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) (loc, id)) in @@ -2084,8 +2084,8 @@ let abs_wgen keep_let ist f gen (gl,args,c) = let sigma, env = project gl, pf_env gl in let evar_closed t p = if occur_existential t then - CErrors.user_err_loc (loc_of_cpattern p,"ssreflect", - pr_constr_pat t ++ + CErrors.user_err ~loc:(loc_of_cpattern p) ~hdr:"ssreflect" + (pr_constr_pat t ++ str" contains holes and matches no subterm of the goal") in match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> @@ -2689,7 +2689,7 @@ END (* subsets of patterns *) let check_ssrhpats loc w_binders ipats = - let err_loc s = CErrors.user_err_loc (loc, "ssreflect", s) in + let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in let clr, ipats = let rec aux clr = function | IpatSimpl (cl, Nop) :: tl -> aux (clr @ cl) tl -- cgit v1.2.3 From 88b1305ed18f783c7ec8e16ae8da1f932303742c Mon Sep 17 00:00:00 2001 From: thery Date: Thu, 15 Sep 2016 17:39:55 +0200 Subject: Refactoring of binonial Variable renaming from 'C(m,n) to 'C(n,m) Renaming theorem mul_Sm_binn to mul_bin_diag Adding theorems mul_bin_left mul_bin_right --- mathcomp/odd_order/PFsection9.v | 2 +- mathcomp/ssreflect/binomial.v | 63 ++++++++++++++++++++++------------------- 2 files changed, 35 insertions(+), 30 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/odd_order/PFsection9.v b/mathcomp/odd_order/PFsection9.v index 63e10bb..e7f82bc 100644 --- a/mathcomp/odd_order/PFsection9.v +++ b/mathcomp/odd_order/PFsection9.v @@ -1953,7 +1953,7 @@ have [gtS4alpha s4gt0]: (size S4)%:R > '[alpha] /\ (size S4 > 0)%N. rewrite ltn_pmul2r ?expn_gt0 ?a_gt0 // -doubleS. by rewrite -(prednK q_gt0) expnS mul2n leq_double ltn_expl. rewrite mulnA leq_pmul2r ?expn_gt0 ?a_gt0 // -(subnKC q_gt2). - rewrite mulnCA mulnA addSn -mul_Sm_binm bin1 -mulnA leq_pmul2l //. + rewrite mulnCA mulnA addSn -mul_bin_diag bin1 -mulnA leq_pmul2l //. by rewrite mulnS -addSnnS leq_addr. rewrite Dp -Da_p mul2n (addnC a.*2) expnDn -(subnKC q_gt2) !addSn add0n. rewrite 3!big_ord_recl big_ord_recr /= !exp1n /= bin1 binn !mul1n /bump /=. diff --git a/mathcomp/ssreflect/binomial.v b/mathcomp/ssreflect/binomial.v index a136bfd..79d488e 100644 --- a/mathcomp/ssreflect/binomial.v +++ b/mathcomp/ssreflect/binomial.v @@ -193,16 +193,14 @@ Lemma binS n m : 'C(n.+1, m.+1) = 'C(n, m.+1) + 'C(n, m). Proof. by []. Qed. Lemma bin1 n : 'C(n, 1) = n. Proof. by elim: n => //= n IHn; rewrite binS bin0 IHn addn1. Qed. -Lemma bin_gt0 m n : (0 < 'C(m, n)) = (n <= m). +Lemma bin_gt0 n m : (0 < 'C(n, m)) = (m <= n). Proof. -elim: m n => [|m IHm] [|n] //. -by rewrite binS addn_gt0 !IHm orbC ltn_neqAle andKb. +by elim: n m => [|n IHn] [|m] //; rewrite addn_gt0 !IHn orbC ltn_neqAle andKb. Qed. -Lemma leq_bin2l m1 m2 n : m1 <= m2 -> 'C(m1, n) <= 'C(m2, n). +Lemma leq_bin2l n1 n2 m : n1 <= n2 -> 'C(n1, m) <= 'C(n2, m). Proof. -elim: m1 m2 n => [m2 | m1 IHm [|m2] //] [|n] le_m12; rewrite ?bin0 //. -by rewrite !binS leq_add // IHm. +by elim: n1 n2 m => [|n1 IHn] [|n2] [|n] le_n12 //; rewrite leq_add ?IHn. Qed. Lemma bin_small n m : n < m -> 'C(n, m) = 0. @@ -211,32 +209,30 @@ Proof. by rewrite ltnNge -bin_gt0; case: posnP. Qed. Lemma binn n : 'C(n, n) = 1. Proof. by elim: n => [|n IHn] //; rewrite binS bin_small. Qed. -Lemma mul_Sm_binm m n : m.+1 * 'C(m, n) = n.+1 * 'C(m.+1, n.+1). +(* Multiply to move diagonally down and right in the Pascal triangle. *) +Lemma mul_bin_diag n m : n * 'C(n.-1, m) = m.+1 * 'C(n, m.+1). Proof. -elim: m n => [|m IHm] [|n] //; first by rewrite bin0 bin1 muln1 mul1n. -by rewrite mulSn {2}binS mulnDr addnCA !IHm -mulnDr. +rewrite [RHS]mulnC; elim: n m => [|[|n] IHn] [|m] //=; first by rewrite bin1. +by rewrite mulSn [in _ * _]binS mulnDr addnCA !IHn -mulnS -mulnDl -binS. Qed. -Lemma bin_fact m n : n <= m -> 'C(m, n) * (n`! * (m - n)`!) = m`!. +Lemma bin_fact n m : m <= n -> 'C(n, m) * (m`! * (n - m)`!) = n`!. Proof. -move/subnKC; move: (m - n) => m0 <-{m}. -elim: n => [|n IHn]; first by rewrite bin0 !mul1n. -by rewrite -mulnA mulnCA mulnA -mul_Sm_binm -mulnA IHn. +elim: n m => [|n IHn] [|m] // le_m_n; first by rewrite bin0 !mul1n. +by rewrite !factS -!mulnA mulnCA mulnA -mul_bin_diag -mulnA IHn. Qed. -(* In fact the only exception is n = 0 and m = 1 *) -Lemma bin_factd n m : 0 < n -> 'C(n, m) = n`! %/ (m`! * (n - m)`!). +(* In fact the only exception for bin_factd is n = 0 and m = 1 *) +Lemma bin_factd n m : 0 < n -> 'C(n, m) = n`! %/ (m`! * (n - m)`!). Proof. -move=> n_gt0; have [/bin_fact <-|lt_n_m] := leqP m n. - by rewrite mulnK // muln_gt0 !fact_gt0. -by rewrite bin_small // divnMA !divn_small ?fact_gt0 // fact_smonotone. +have [/bin_fact<-|*] := leqP m n; first by rewrite mulnK ?muln_gt0 ?fact_gt0. +by rewrite divnMA bin_small ?divn_small ?fact_gt0 ?fact_smonotone. Qed. Lemma bin_ffact n m : 'C(n, m) * m`! = n ^_ m. Proof. -apply/eqP; have [lt_n_m | le_m_n] := ltnP n m. - by rewrite bin_small ?ffact_small. -by rewrite -(eqn_pmul2r (fact_gt0 (n - m))) ffact_fact // -mulnA bin_fact. +have [lt_n_m | le_m_n] := ltnP n m; first by rewrite bin_small ?ffact_small. +by rewrite ffact_factd // -(bin_fact le_m_n) mulnA mulnK ?fact_gt0. Qed. Lemma bin_ffactd n m : 'C(n, m) = n ^_ m %/ m`!. @@ -244,26 +240,35 @@ Proof. by rewrite -bin_ffact mulnK ?fact_gt0. Qed. Lemma bin_sub n m : m <= n -> 'C(n, n - m) = 'C(n, m). Proof. -move=> le_m_n; apply/eqP; move/eqP: (bin_fact (leq_subr m n)). -by rewrite subKn // -(bin_fact le_m_n) !mulnA mulnAC !eqn_pmul2r // fact_gt0. +by move=> le_m_n; rewrite !bin_ffactd !ffact_factd ?leq_subr // divnAC subKn. Qed. +(* Multiply to move down in the Pascal triangle. *) +Lemma mul_bin_down n m : n * 'C(n.-1, m) = (n - m) * 'C(n, m). +Proof. +case: n => //= n; have [lt_n_m | le_m_n] := ltnP n m. + by rewrite (eqnP lt_n_m) mulnC bin_small. +by rewrite -!['C(_, m)]bin_sub ?leqW ?subSn ?mul_bin_diag. +Qed. + +(* Multiply to move left in the Pascal triangle. *) +Lemma mul_bin_left n m : m.+1 * 'C(n, m.+1) = (n - m) * 'C(n, m). +Proof. by rewrite -mul_bin_diag mul_bin_down. Qed. + Lemma binSn n : 'C(n.+1, n) = n.+1. Proof. by rewrite -bin_sub ?leqnSn // subSnn bin1. Qed. Lemma bin2 n : 'C(n, 2) = (n * n.-1)./2. -Proof. -by case: n => //= n; rewrite -{3}[n]bin1 mul_Sm_binm mul2n half_double. -Qed. +Proof. by rewrite -[n.-1]bin1 mul_bin_diag -divn2 mulKn. Qed. Lemma bin2odd n : odd n -> 'C(n, 2) = n * n.-1./2. Proof. by case: n => // n oddn; rewrite bin2 -!divn2 muln_divA ?dvdn2. Qed. Lemma prime_dvd_bin k p : prime p -> 0 < k < p -> p %| 'C(p, k). Proof. -move=> p_pr /andP[k_gt0 lt_k_p]; have def_p := ltn_predK lt_k_p. -have: p %| p * 'C(p.-1, k.-1) by rewrite dvdn_mulr. -by rewrite -def_p mul_Sm_binm def_p prednK // Euclid_dvdM // gtnNdvd. +move=> p_pr /andP[k_gt0 lt_k_p]. +suffices /Gauss_dvdr<-: coprime p (p - k) by rewrite -mul_bin_down dvdn_mulr. +by rewrite prime_coprime // dvdn_subr 1?ltnW // gtnNdvd. Qed. Lemma triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2). -- cgit v1.2.3 From 3bf6fbc4d339545b0eace0689adfec048f1c8530 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 20 Sep 2016 12:35:11 +0200 Subject: [field] Remove unnecessary `Program Definition` Simple `Definition` should work fine here. This avoids the problem: `Error: Library Coq.Program.Tactics has to be required first.` in math-comp versions that depends on a minimal (or no) Coq stdlib. Tested on 8.5/8.6 --- mathcomp/field/algC.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/field/algC.v b/mathcomp/field/algC.v index 6c53127..cbcbc3a 100644 --- a/mathcomp/field/algC.v +++ b/mathcomp/field/algC.v @@ -445,8 +445,8 @@ rewrite -(fmorph_root CtoL_rmorphism) -map_poly_comp; congr (root _ _): pu0. by apply/esym/eq_map_poly; apply: fmorph_eq_rat. Qed. -Program Definition conjMixin := - ImaginaryMixin (svalP (imaginary_exists closedFieldType)) +Definition conjMixin := + ImaginaryMixin (svalP (imaginary_exists closedFieldType)) (fun x => esym (normK x)). Canonical numClosedFieldType := NumClosedFieldType type conjMixin. -- cgit v1.2.3 From a774d904dee59d4f78e0543f4cf06adbaf0e6f0f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 22 Sep 2016 09:09:47 +0200 Subject: fix compilation wrt. commit 699b70c in Coq trunk --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 6559504..1250f7e 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -52,7 +52,7 @@ open Tacexpr open Tacinterp open Pretyping open Constr -open Tactic +open Pltac open Extraargs open Ppconstr open Printer @@ -471,7 +471,7 @@ let _ = Goptions.optwrite = (fun _ -> Lib.add_anonymous_leaf (inVersion ssrAstVersion)) } -let tactic_expr = Tactic.tactic_expr +let tactic_expr = Pltac.tactic_expr let gallina_ext = Vernac_.gallina_ext let sprintf = Printf.sprintf let tactic_mode = G_ltac.tactic_mode @@ -5703,7 +5703,7 @@ ARGUMENT EXTEND ssrhavefwdwbinders tr, ((((clr, pats), allbinders), simpl), hint) ] END -(* Tactic. *) +(* Pltac. *) let is_Evar_or_CastedMeta x = isEvar_or_Meta x || @@ -6205,8 +6205,8 @@ END (* longer and thus comment out. Such comments are marked with v8.3 *) GEXTEND Gram - GLOBAL: Tactic.hypident; - Tactic.hypident: [ + GLOBAL: Pltac.hypident; + Pltac.hypident: [ [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> id, InHypTypeOnly | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> id, InHypValueOnly ] ]; @@ -6223,8 +6223,8 @@ hloc: [ END GEXTEND Gram - GLOBAL: Tactic.constr_eval; - Tactic.constr_eval: [ + GLOBAL: Pltac.constr_eval; + Pltac.constr_eval: [ [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] ]; END -- cgit v1.2.3 From 489d80b737ee5f3a2f936abbf2d9bd441d4ef124 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 23 Sep 2016 15:12:23 +0200 Subject: FIX: compilation wrt. commit 9c35248 on Coq trunk branch. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 1250f7e..5fe1ea5 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -29,7 +29,7 @@ open Pcoq.Prim open Pcoq.Constr open Genarg open Stdarg -open Constrarg +open Stdarg open Term open Vars open Context -- cgit v1.2.3 From 75f0abfa4979cd0050399093fd07e7c952de49b4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 24 Sep 2016 13:33:28 +0200 Subject: Fix ML compilation after Ltac refactoring. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 5fe1ea5..398c0c3 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -29,7 +29,7 @@ open Pcoq.Prim open Pcoq.Constr open Genarg open Stdarg -open Stdarg +open Tacarg open Term open Vars open Context @@ -45,6 +45,7 @@ open Coqlib open Glob_term open Util open Evd +open Proofview.Notations open Sigma.Notations open Extend open Goptions -- cgit v1.2.3 From c558aba6eb7efdde0319348e0ad978b7d4412970 Mon Sep 17 00:00:00 2001 From: Erik Martin-Dorel Date: Tue, 27 Sep 2016 15:53:04 +0200 Subject: Add a typing colon in the output of the Search ssreflect vernacular. --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 398c0c3..0b46980 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -1466,7 +1466,7 @@ let interp_modloc mr = (* The unified, extended vernacular "Search" command *) let ssrdisplaysearch gr env t = - let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in msg_info (hov 2 pr_res ++ fnl ()) VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY diff --git a/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 index b5cd80a..3ce494f 100644 --- a/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 @@ -1447,7 +1447,7 @@ let interp_modloc mr = (* The unified, extended vernacular "Search" command *) let ssrdisplaysearch gr env t = - let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env t in + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env t in msg (hov 2 pr_res ++ fnl ()) VERNAC COMMAND EXTEND SsrSearchPattern diff --git a/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 index 85a6fef..8409bfb 100644 --- a/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 @@ -1436,7 +1436,7 @@ let interp_modloc mr = (* The unified, extended vernacular "Search" command *) let ssrdisplaysearch gr env t = - let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in msg_info (hov 2 pr_res ++ fnl ()) VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY diff --git a/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 index 666b46e..15fc5e5 100644 --- a/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 @@ -1470,7 +1470,7 @@ let interp_modloc mr = (* The unified, extended vernacular "Search" command *) let ssrdisplaysearch gr env t = - let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in msg_info (hov 2 pr_res ++ fnl ()) VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY -- cgit v1.2.3 From b0c734bcd978459e323c42acbde6c4a6d0f8b566 Mon Sep 17 00:00:00 2001 From: Assia Mahboubi Date: Wed, 5 Oct 2016 11:24:55 +0200 Subject: Generalization in the type of contra_eq/contra_neq. Thanks B. Grégoire for this suggestion. --- mathcomp/ssreflect/eqtype.v | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/eqtype.v b/mathcomp/ssreflect/eqtype.v index 85e531c..62a455b 100644 --- a/mathcomp/ssreflect/eqtype.v +++ b/mathcomp/ssreflect/eqtype.v @@ -177,8 +177,8 @@ Hint Resolve eq_refl eq_sym. Section Contrapositives. -Variable T : eqType. -Implicit Types (A : pred T) (b : bool) (x : T). +Variables (T1 T2 : eqType). +Implicit Types (A : pred T1) (b : bool) (x : T1) (z : T2). Lemma contraTeq b x y : (x != y -> ~~ b) -> b -> x = y. Proof. by move=> imp hyp; apply/eqP; apply: contraTT hyp. Qed. @@ -207,10 +207,10 @@ Proof. by move=> imp /eqP; apply: contraTF. Qed. Lemma contra_eqT b x y : (~~ b -> x != y) -> x = y -> b. Proof. by move=> imp /eqP; apply: contraLR. Qed. -Lemma contra_eq x1 y1 x2 y2 : (x2 != y2 -> x1 != y1) -> x1 = y1 -> x2 = y2. +Lemma contra_eq z1 z2 x1 x2 : (x1 != x2 -> z1 != z2) -> z1 = z2 -> x1 = x2. Proof. by move=> imp /eqP; apply: contraTeq. Qed. -Lemma contra_neq x1 y1 x2 y2 : (x2 = y2 -> x1 = y1) -> x1 != y1 -> x2 != y2. +Lemma contra_neq z1 z2 x1 x2 : (x1 = x2 -> z1 = z2) -> z1 != z2 -> x1 != x2. Proof. by move=> imp; apply: contraNneq => /imp->. Qed. Lemma memPn A x : reflect {in A, forall y, y != x} (x \notin A). @@ -230,8 +230,8 @@ Proof. by rewrite eq_sym; apply: ifN. Qed. End Contrapositives. -Implicit Arguments memPn [T A x]. -Implicit Arguments memPnC [T A x]. +Implicit Arguments memPn [T1 A x]. +Implicit Arguments memPnC [T1 A x]. Theorem eq_irrelevance (T : eqType) x y : forall e1 e2 : x = y :> T, e1 = e2. Proof. -- cgit v1.2.3 From 958599031dc67394cacdd29720b8ab56abd47dc2 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 12 Oct 2016 15:00:22 +0200 Subject: changing "ssreflect.ml4" so that we avoid triggering bugs in camlp5's "pr_o.cmo" plugin --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 0b46980..93a1ba7 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -1139,7 +1139,7 @@ let interp_view_nbimps ist gl rc = let si = sig_it gl in let gl = re_sig si sigma in let pl, c = splay_open_constr gl t in - if isAppInd gl c then List.length pl else ~-(List.length pl) + if isAppInd gl c then List.length pl else (-(List.length pl)) with _ -> 0 (* }}} *) -- cgit v1.2.3 From fb7060ca71082911284ff6b388c3c45ef07c2723 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 13 Oct 2016 14:46:16 +0200 Subject: Make: avoid >> Make, pass args to coq_makefile instead (#77) --- mathcomp/ssreflect/Makefile.coq-makefile | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/Makefile.coq-makefile b/mathcomp/ssreflect/Makefile.coq-makefile index d815286..e4f12ad 100644 --- a/mathcomp/ssreflect/Makefile.coq-makefile +++ b/mathcomp/ssreflect/Makefile.coq-makefile @@ -1,23 +1,22 @@ define coqmakefile (echo "Generating Makefile.coq for Coq $(V) with COQBIN=$(COQBIN)";\ if [ "$$OS" = "Windows_NT" ]; then LN=cp; else LN="ln -sf"; fi;\ + MLLIB=ssreflect_plugin.mlpack;\ + EXTRA=;\ case $(V) in\ v8.5*|v8.4*)\ $$LN $(1)/plugin/$(V)/ssrmatching.mli .;\ $$LN $(1)/plugin/$(V)/ssrmatching.ml4 .;\ - echo ssrmatching.mli >> Make;\ - echo ssrmatching.ml4 >> Make;\ $$LN $(1)/plugin/$(V)/ssrmatching.v .;\ - echo ssrmatching.v >> Make;\ $$LN $(1)/plugin/$(V)/ssreflect_plugin.mllib .;\ - echo ssreflect_plugin.mllib >> Make;\ + EXTRA="ssrmatching.mli ssrmatching.ml4 ssrmatching.v";\ + MLLIB=ssreflect_plugin.mllib;\ ;;\ *)\ $$LN $(1)/plugin/$(V)/ssreflect_plugin.mlpack .;\ - echo ssreflect_plugin.mlpack >> Make;\ ;;\ esac;\ $$LN $(1)/plugin/$(V)/ssreflect.ml4 .;\ - $(COQBIN)coq_makefile -f Make -o Makefile.coq) + $(COQBIN)coq_makefile -f Make $$MLLIB $$EXTRA -o Makefile.coq) endef -- cgit v1.2.3 From d762ebb5a8c5191d49a75aa89ec34966de00eb9b Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Thu, 25 Aug 2016 17:44:06 +0200 Subject: better ltngtP --- mathcomp/real_closed/polyorder.v | 5 +---- mathcomp/solvable/abelian.v | 2 +- mathcomp/ssreflect/ssrnat.v | 31 +++++++++++++++++++++++-------- 3 files changed, 25 insertions(+), 13 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/real_closed/polyorder.v b/mathcomp/real_closed/polyorder.v index f18ec89..2da4dc9 100644 --- a/mathcomp/real_closed/polyorder.v +++ b/mathcomp/real_closed/polyorder.v @@ -108,10 +108,7 @@ Qed. Lemma muP p x n : p != 0 -> (('X - x%:P)^+n %| p) && ~~(('X - x%:P)^+n.+1 %| p) = (n == \mu_x p). Proof. -move=> hp0; rewrite !root_le_mu//; case: (ltngtP n (\mu_x p))=> hn. -+ by rewrite ltnW//=. -+ by rewrite leqNgt hn. -+ by rewrite hn leqnn. +by move=> hp0; rewrite !root_le_mu//; case: (ltngtP n (\mu_x p)). Qed. Lemma mu_gt0 p x : p != 0 -> (0 < \mu_x p)%N = root p x. diff --git a/mathcomp/solvable/abelian.v b/mathcomp/solvable/abelian.v index e608c4f..45168a0 100644 --- a/mathcomp/solvable/abelian.v +++ b/mathcomp/solvable/abelian.v @@ -1745,7 +1745,7 @@ pose cnt_p k := count [pred x : gT | logn p #[x] > k]. have cnt_b b: \big[dprod/1]_(x <- b) <[x]> = G -> count [pred x | #[x] == p ^ k.+1]%N b = cnt_p k b - cnt_p k.+1 b. - move/p_bG; elim: b => //= _ b IHb /andP[/p_natP[j ->] /IHb-> {IHb}]. - rewrite eqn_leq !leq_exp2l ?prime_gt1 // -eqn_leq pfactorK // leqNgt. + rewrite eqn_leq !leq_exp2l ?prime_gt1 // -eqn_leq pfactorK //. case: ltngtP => // _ {j}; rewrite subSn // add0n; elim: b => //= y b IHb. by rewrite leq_add // ltn_neqAle; case: (~~ _). by rewrite !cnt_b // /cnt_p !(@count_logn_dprod_cycle _ _ _ G). diff --git a/mathcomp/ssreflect/ssrnat.v b/mathcomp/ssreflect/ssrnat.v index 9b9f6a5..0cf70a8 100644 --- a/mathcomp/ssreflect/ssrnat.v +++ b/mathcomp/ssreflect/ssrnat.v @@ -441,15 +441,18 @@ CoInductive eqn0_xor_gt0 n : bool -> bool -> Set := Lemma posnP n : eqn0_xor_gt0 n (n == 0) (0 < n). Proof. by case: n; constructor. Qed. -CoInductive compare_nat m n : bool -> bool -> bool -> Set := - | CompareNatLt of m < n : compare_nat m n true false false - | CompareNatGt of m > n : compare_nat m n false true false - | CompareNatEq of m = n : compare_nat m n false false true. +CoInductive compare_nat m n : bool -> bool -> bool -> bool -> bool -> bool -> Set := + | CompareNatLt of m < n : compare_nat m n true false true false false false + | CompareNatGt of m > n : compare_nat m n false true false true false false + | CompareNatEq of m = n : compare_nat m n true true false false true true. -Lemma ltngtP m n : compare_nat m n (m < n) (n < m) (m == n). +Lemma ltngtP m n : compare_nat m n (m <= n) (n <= m) (m < n) (n < m) (n == m) (m == n). Proof. -rewrite ltn_neqAle eqn_leq; case: ltnP; first by constructor. -by rewrite leq_eqVlt orbC; case: leqP; constructor; first apply/eqnP. +rewrite !ltn_neqAle [_ == m]eq_sym; case: ltnP => [mn|]. + by rewrite ltnW // gtn_eqF //; constructor. +rewrite leq_eqVlt; case: ltnP; rewrite ?(orbT, orbF) => //= lt_nm eq_mn. + by rewrite ltn_eqF //; constructor. +by rewrite eq_mn; constructor; apply/eqP. Qed. (* Monotonicity lemmas *) @@ -562,7 +565,7 @@ Lemma maxnC : commutative maxn. Proof. by move=> m n; rewrite /maxn; case ltngtP. Qed. Lemma maxnE m n : maxn m n = m + (n - m). -Proof. by rewrite /maxn addnC; case: leqP => [/eqnP-> | /ltnW/subnK]. Qed. +Proof. by rewrite /maxn addnC; case: leqP => [/eqnP->|/ltnW/subnK]. Qed. Lemma maxnAC : right_commutative maxn. Proof. by move=> m n p; rewrite !maxnE -!addnA !subnDA -!maxnE maxnC. Qed. @@ -1591,3 +1594,15 @@ Ltac nat_congr := first apply: (congr1 (addn X1) _); symmetry end ]. + +Module mc_1_6. + +CoInductive compare_nat m n : bool -> bool -> bool -> Set := + | CompareNatLt of m < n : compare_nat m n true false false + | CompareNatGt of m > n : compare_nat m n false true false + | CompareNatEq of m = n : compare_nat m n false false true. + +Lemma ltngtP m n : compare_nat m n (m < n) (n < m) (m == n). +Proof. by case: ltngtP; constructor. Qed. + +End mc_1_6. -- cgit v1.2.3 From 3c8d3225c0e230dcc5e7b40440200888082d9b17 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Wed, 7 Sep 2016 19:27:57 +0200 Subject: wip shorter proof dec factor theorems --- mathcomp/algebra/poly.v | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/algebra/poly.v b/mathcomp/algebra/poly.v index 7e5d204..64d6327 100644 --- a/mathcomp/algebra/poly.v +++ b/mathcomp/algebra/poly.v @@ -2545,22 +2545,21 @@ Section DecField. Variable F : decFieldType. -Lemma dec_factor_theorem (p : {poly F}) : p != 0 -> +Lemma dec_factor_theorem (p : {poly F}) : {s : seq F & {q : {poly F} | p = q * \prod_(x <- s) ('X - x%:P) - /\ forall x, ~~ root q x }}. + /\ (q != 0 -> forall x, ~~ root q x)}}. Proof. pose polyT (p : seq F) := (foldr (fun c f => f * 'X_0 + c%:T) (0%R)%:T p)%T. have eval_polyT (q : {poly F}) x : GRing.eval [:: x] (polyT q) = q.[x]. by rewrite /horner; elim: (val q) => //= ? ? ->. -elim: size {-2}p (leqnn (size p)) => [?|n IHn {p} p sp_ltSn p_neq0]. - by move=> /size_poly_leq0P->; rewrite eqxx. +elim: size {-2}p (leqnn (size p)) => {p} [p|n IHn p]. + by move=> /size_poly_leq0P->; exists [::], 0; rewrite mul0r eqxx. have /decPcases /= := @satP F [::] ('exists 'X_0, polyT p == 0%T). case: ifP => [_ /sig_eqW[x]|_ noroot]; last first. - exists [::], p; rewrite big_nil mulr1; split => // x. + exists [::], p; rewrite big_nil mulr1; split => // p_neq0 x. by apply/negP=> /rootP rpx; apply noroot; exists x; rewrite eval_polyT. -rewrite eval_polyT => /rootP /factor_theorem /sig_eqW [q p_eq]. -move: p_neq0 sp_ltSn; rewrite p_eq {p_eq}. -rewrite mulf_eq0 polyXsubC_eq0 orbF => q_neq0. +rewrite eval_polyT => /rootP /factor_theorem /sig_eqW [q ->]. +have [->|q_neq0] := eqVneq q 0; first by exists [::], 0; rewrite !mul0r eqxx. rewrite size_mul ?polyXsubC_eq0 // ?size_XsubC addn2 /= ltnS => sq_le_n. have [] // := IHn q => s [r [-> nr]]; exists (s ++ [::x]), r. by rewrite big_cat /= big_seq1 mulrA. @@ -2617,15 +2616,12 @@ Proof. exact: PreClosedField.closed_nonrootP. Qed. Lemma closed_field_poly_normal p : {r : seq F | p = lead_coef p *: \prod_(z <- r) ('X - z%:P)}. Proof. -apply: sig_eqW; elim: {p}_.+1 {-2}p (ltnSn (size p)) => // n IHn p le_p_n. -have [/size1_polyC-> | p_gt1] := leqP (size p) 1. - by exists nil; rewrite big_nil lead_coefC alg_polyC. -have [|x /factor_theorem[q Dp]] := closed_rootP p _; first by rewrite gtn_eqF. -have nz_p: p != 0 by rewrite -size_poly_eq0 -(subnKC p_gt1). -have:= nz_p; rewrite Dp mulf_eq0 lead_coefM => /norP[nz_q nz_Xx]. -rewrite ltnS polySpred // Dp size_mul // size_XsubC addn2 in le_p_n. -have [r {1}->] := IHn q le_p_n; exists (x :: r). -by rewrite lead_coefXsubC mulr1 big_cons -scalerAl mulrC. +apply: sig_eqW; have [r [q [->]]] /= := dec_factor_theorem p. +have [->|] := altP eqP; first by exists [::]; rewrite mul0r lead_coef0 scale0r. +have [[x rqx ? /(_ isT x) /negP /(_ rqx)] //|] := altP (closed_rootP q). +rewrite negbK => /size_poly1P [c c_neq0-> _ _]; exists r. +rewrite mul_polyC lead_coefZ (monicP _) ?mulr1 //. +by rewrite monic_prod => // i; rewrite monicXsubC. Qed. End ClosedField. -- cgit v1.2.3 From 71e62259c3a7420ff4c635768564792d1fd38ceb Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 24 Oct 2016 14:21:26 +0200 Subject: removing the need of bracket to delimit ssrpatternarg --- mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 | 46 ++++++++++++++++++++++---- 1 file changed, 40 insertions(+), 6 deletions(-) (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 index fc0b573..64770ea 100644 --- a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 +++ b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 @@ -878,7 +878,36 @@ let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp let wit_rpatternty = add_genarg "rpatternty" pr_pattern -ARGUMENT EXTEND rpattern TYPED AS rpatternty PRINTED BY pr_rpattern +let glob_ssrterm gs = function + | k, (_, Some c) -> k, + let x = Tacintern.intern_constr gs c in + fst x, Some c + | ct -> ct + +let glob_rpattern s p = + match p with + | T t -> T (glob_ssrterm s t) + | In_T t -> In_T (glob_ssrterm s t) + | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t) + | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t) + | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) + | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) + +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c + +let subst_rpattern s = function + | T t -> T (subst_ssrterm s t) + | In_T t -> In_T (subst_ssrterm s t) + | X_In_T(x,t) -> X_In_T (x,subst_ssrterm s t) + | In_X_In_T(x,t) -> In_X_In_T (x,subst_ssrterm s t) + | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) + | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) + +ARGUMENT EXTEND rpattern + TYPED AS rpatternty + PRINTED BY pr_rpattern + GLOBALIZED BY glob_rpattern + SUBSTITUTED BY subst_rpattern | [ lconstr(c) ] -> [ T (mk_lterm c) ] | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ] | [ lconstr(x) "in" lconstr(c) ] -> @@ -1264,12 +1293,17 @@ let is_wildcard = function | _ -> false (* "ssrpattern" *) -let pr_ssrpatternarg _ _ _ cpat = pr_rpattern cpat +let pr_ssrpatternarg _ _ _ (_,cpat) = pr_rpattern cpat +let pr_ssrpatternarg_glob _ _ _ cpat = pr_rpattern cpat +let interp_ssrpatternarg ist gl p = project gl, (ist, p) ARGUMENT EXTEND ssrpatternarg - TYPED AS rpattern PRINTED BY pr_ssrpatternarg -| [ "[" rpattern(pat) "]" ] -> [ pat ] + INTERPRETED BY interp_ssrpatternarg + GLOBALIZED BY glob_rpattern + RAW_TYPED AS rpattern RAW_PRINTED BY pr_ssrpatternarg_glob + GLOB_TYPED AS rpattern GLOB_PRINTED BY pr_ssrpatternarg_glob +| [ rpattern(pat) ] -> [ pat ] END let pf_merge_uc uc gl = @@ -1278,8 +1312,8 @@ let pf_merge_uc uc gl = let pf_unsafe_merge_uc uc gl = re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc) -let ssrpatterntac ist arg gl = - let pat = interp_rpattern ist gl arg in +let ssrpatterntac _ist (arg_ist,arg) gl = + let pat = interp_rpattern arg_ist gl arg in let sigma0 = project gl in let concl0 = pf_concl gl in let (t, uc), concl_x = -- cgit v1.2.3 From 2a8af6f6b80c82a5f07cae220427cccc30ef8dac Mon Sep 17 00:00:00 2001 From: Assia Mahboubi Date: Mon, 7 Nov 2016 15:40:31 +0100 Subject: update copyright banner --- mathcomp/algebra/finalg.v | 2 +- mathcomp/algebra/fraction.v | 2 +- mathcomp/algebra/intdiv.v | 2 +- mathcomp/algebra/interval.v | 2 +- mathcomp/algebra/matrix.v | 2 +- mathcomp/algebra/mxalgebra.v | 2 +- mathcomp/algebra/mxpoly.v | 2 +- mathcomp/algebra/poly.v | 2 +- mathcomp/algebra/polyXY.v | 2 +- mathcomp/algebra/polydiv.v | 2 +- mathcomp/algebra/rat.v | 2 +- mathcomp/algebra/ring_quotient.v | 2 +- mathcomp/algebra/ssralg.v | 2 +- mathcomp/algebra/ssrint.v | 2 +- mathcomp/algebra/ssrnum.v | 2 +- mathcomp/algebra/vector.v | 2 +- mathcomp/algebra/zmodp.v | 2 +- mathcomp/attic/algnum_basic.v | 2 +- mathcomp/attic/amodule.v | 2 +- mathcomp/attic/fib.v | 2 +- mathcomp/attic/forms.v | 2 +- mathcomp/attic/galgebra.v | 2 +- mathcomp/attic/multinom.v | 2 +- mathcomp/attic/quote.v | 2 +- mathcomp/attic/tutorial.v | 2 +- mathcomp/character/character.v | 2 +- mathcomp/character/classfun.v | 2 +- mathcomp/character/inertia.v | 2 +- mathcomp/character/integral_char.v | 2 +- mathcomp/character/mxabelem.v | 2 +- mathcomp/character/mxrepresentation.v | 2 +- mathcomp/character/vcharacter.v | 2 +- mathcomp/field/algC.v | 2 +- mathcomp/field/algebraics_fundamentals.v | 2 +- mathcomp/field/algnum.v | 2 +- mathcomp/field/closed_field.v | 2 +- mathcomp/field/countalg.v | 2 +- mathcomp/field/cyclotomic.v | 2 +- mathcomp/field/falgebra.v | 2 +- mathcomp/field/fieldext.v | 2 +- mathcomp/field/finfield.v | 2 +- mathcomp/field/galois.v | 2 +- mathcomp/field/separable.v | 2 +- mathcomp/fingroup/action.v | 2 +- mathcomp/fingroup/automorphism.v | 2 +- mathcomp/fingroup/fingroup.v | 2 +- mathcomp/fingroup/gproduct.v | 2 +- mathcomp/fingroup/morphism.v | 2 +- mathcomp/fingroup/perm.v | 2 +- mathcomp/fingroup/presentation.v | 2 +- mathcomp/fingroup/quotient.v | 2 +- mathcomp/odd_order/BGappendixAB.v | 2 +- mathcomp/odd_order/BGappendixC.v | 2 +- mathcomp/odd_order/BGsection1.v | 2 +- mathcomp/odd_order/BGsection10.v | 2 +- mathcomp/odd_order/BGsection11.v | 2 +- mathcomp/odd_order/BGsection12.v | 2 +- mathcomp/odd_order/BGsection13.v | 2 +- mathcomp/odd_order/BGsection14.v | 2 +- mathcomp/odd_order/BGsection15.v | 2 +- mathcomp/odd_order/BGsection16.v | 2 +- mathcomp/odd_order/BGsection2.v | 2 +- mathcomp/odd_order/BGsection3.v | 2 +- mathcomp/odd_order/BGsection4.v | 2 +- mathcomp/odd_order/BGsection5.v | 2 +- mathcomp/odd_order/BGsection6.v | 2 +- mathcomp/odd_order/BGsection7.v | 2 +- mathcomp/odd_order/BGsection8.v | 2 +- mathcomp/odd_order/BGsection9.v | 2 +- mathcomp/odd_order/PFsection1.v | 2 +- mathcomp/odd_order/PFsection10.v | 2 +- mathcomp/odd_order/PFsection11.v | 2 +- mathcomp/odd_order/PFsection12.v | 2 +- mathcomp/odd_order/PFsection13.v | 2 +- mathcomp/odd_order/PFsection14.v | 2 +- mathcomp/odd_order/PFsection2.v | 2 +- mathcomp/odd_order/PFsection3.v | 2 +- mathcomp/odd_order/PFsection4.v | 2 +- mathcomp/odd_order/PFsection5.v | 2 +- mathcomp/odd_order/PFsection6.v | 2 +- mathcomp/odd_order/PFsection7.v | 2 +- mathcomp/odd_order/PFsection8.v | 2 +- mathcomp/odd_order/PFsection9.v | 2 +- mathcomp/odd_order/stripped_odd_order_theorem.v | 2 +- mathcomp/odd_order/wielandt_fixpoint.v | 2 +- mathcomp/real_closed/bigenough.v | 2 +- mathcomp/real_closed/cauchyreals.v | 2 +- mathcomp/real_closed/complex.v | 2 +- mathcomp/real_closed/mxtens.v | 2 +- mathcomp/real_closed/ordered_qelim.v | 2 +- mathcomp/real_closed/polyorder.v | 2 +- mathcomp/real_closed/polyrcf.v | 2 +- mathcomp/real_closed/qe_rcf.v | 2 +- mathcomp/real_closed/qe_rcf_th.v | 2 +- mathcomp/real_closed/realalg.v | 2 +- mathcomp/solvable/abelian.v | 2 +- mathcomp/solvable/alt.v | 2 +- mathcomp/solvable/burnside_app.v | 2 +- mathcomp/solvable/center.v | 2 +- mathcomp/solvable/commutator.v | 2 +- mathcomp/solvable/cyclic.v | 2 +- mathcomp/solvable/extraspecial.v | 2 +- mathcomp/solvable/extremal.v | 2 +- mathcomp/solvable/finmodule.v | 2 +- mathcomp/solvable/frobenius.v | 2 +- mathcomp/solvable/gfunctor.v | 2 +- mathcomp/solvable/gseries.v | 2 +- mathcomp/solvable/hall.v | 2 +- mathcomp/solvable/jordanholder.v | 2 +- mathcomp/solvable/maximal.v | 2 +- mathcomp/solvable/nilpotent.v | 2 +- mathcomp/solvable/pgroup.v | 2 +- mathcomp/solvable/primitive_action.v | 2 +- mathcomp/solvable/sylow.v | 2 +- mathcomp/ssreflect/bigop.v | 2 +- mathcomp/ssreflect/binomial.v | 2 +- mathcomp/ssreflect/choice.v | 2 +- mathcomp/ssreflect/div.v | 2 +- mathcomp/ssreflect/eqtype.v | 2 +- mathcomp/ssreflect/finfun.v | 2 +- mathcomp/ssreflect/fingraph.v | 2 +- mathcomp/ssreflect/finset.v | 2 +- mathcomp/ssreflect/fintype.v | 2 +- mathcomp/ssreflect/generic_quotient.v | 2 +- mathcomp/ssreflect/path.v | 2 +- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 4 ++-- mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli | 2 +- mathcomp/ssreflect/plugin/v8.4/ssrmatching.v | 2 +- mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 | 4 ++-- mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli | 2 +- mathcomp/ssreflect/plugin/v8.5/ssrmatching.v | 2 +- mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 | 4 ++-- mathcomp/ssreflect/prime.v | 2 +- mathcomp/ssreflect/seq.v | 2 +- mathcomp/ssreflect/ssrbool.v | 2 +- mathcomp/ssreflect/ssreflect.v | 2 +- mathcomp/ssreflect/ssrfun.v | 2 +- mathcomp/ssreflect/ssrmatching.v | 1 + mathcomp/ssreflect/ssrnat.v | 2 +- mathcomp/ssreflect/tuple.v | 2 +- mathcomp/ssrmatching.v | 1 + mathcomp/ssrtest/absevarprop.v | 2 +- mathcomp/ssrtest/binders.v | 2 +- mathcomp/ssrtest/binders_of.v | 2 +- mathcomp/ssrtest/caseview.v | 2 +- mathcomp/ssrtest/congr.v | 2 +- mathcomp/ssrtest/deferclear.v | 2 +- mathcomp/ssrtest/dependent_type_err.v | 2 +- mathcomp/ssrtest/elim.v | 2 +- mathcomp/ssrtest/elim2.v | 2 +- mathcomp/ssrtest/elim_pattern.v | 2 +- mathcomp/ssrtest/first_n.v | 2 +- mathcomp/ssrtest/gen_have.v | 2 +- mathcomp/ssrtest/gen_pattern.v | 2 +- mathcomp/ssrtest/have_TC.v | 2 +- mathcomp/ssrtest/have_transp.v | 2 +- mathcomp/ssrtest/have_view_idiom.v | 2 +- mathcomp/ssrtest/havesuff.v | 2 +- mathcomp/ssrtest/if_isnt.v | 2 +- mathcomp/ssrtest/indetLHS.v | 2 +- mathcomp/ssrtest/intro_beta.v | 2 +- mathcomp/ssrtest/intro_noop.v | 2 +- mathcomp/ssrtest/ipatalternation.v | 2 +- mathcomp/ssrtest/ltac_have.v | 2 +- mathcomp/ssrtest/ltac_in.v | 2 +- mathcomp/ssrtest/move_after.v | 2 +- mathcomp/ssrtest/multiview.v | 2 +- mathcomp/ssrtest/occarrow.v | 2 +- mathcomp/ssrtest/patnoX.v | 2 +- mathcomp/ssrtest/rewpatterns.v | 2 +- mathcomp/ssrtest/set_lamda.v | 2 +- mathcomp/ssrtest/set_pattern.v | 2 +- mathcomp/ssrtest/ssrsyntax1.v | 2 +- mathcomp/ssrtest/ssrsyntax2.v | 2 +- mathcomp/ssrtest/tc.v | 2 +- mathcomp/ssrtest/testmx.v | 2 +- mathcomp/ssrtest/typeof.v | 2 +- mathcomp/ssrtest/unkeyed.v | 2 +- mathcomp/ssrtest/view_case.v | 2 +- mathcomp/ssrtest/wlog_suff.v | 2 +- mathcomp/ssrtest/wlogletin.v | 2 +- mathcomp/ssrtest/wlong_intro.v | 2 +- 185 files changed, 188 insertions(+), 186 deletions(-) create mode 120000 mathcomp/ssreflect/ssrmatching.v create mode 120000 mathcomp/ssrmatching.v (limited to 'mathcomp') diff --git a/mathcomp/algebra/finalg.v b/mathcomp/algebra/finalg.v index 1c98465..0cf29b2 100644 --- a/mathcomp/algebra/finalg.v +++ b/mathcomp/algebra/finalg.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/fraction.v b/mathcomp/algebra/fraction.v index cfa13ed..8cf811a 100644 --- a/mathcomp/algebra/fraction.v +++ b/mathcomp/algebra/fraction.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/intdiv.v b/mathcomp/algebra/intdiv.v index 2871ff5..7c99443 100644 --- a/mathcomp/algebra/intdiv.v +++ b/mathcomp/algebra/intdiv.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/interval.v b/mathcomp/algebra/interval.v index 6806094..56dec94 100644 --- a/mathcomp/algebra/interval.v +++ b/mathcomp/algebra/interval.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/matrix.v b/mathcomp/algebra/matrix.v index 4469266..2aa117d 100644 --- a/mathcomp/algebra/matrix.v +++ b/mathcomp/algebra/matrix.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/mxalgebra.v b/mathcomp/algebra/mxalgebra.v index 38dc17d..ec1b4ec 100644 --- a/mathcomp/algebra/mxalgebra.v +++ b/mathcomp/algebra/mxalgebra.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/mxpoly.v b/mathcomp/algebra/mxpoly.v index f64ad9a..1301a94 100644 --- a/mathcomp/algebra/mxpoly.v +++ b/mathcomp/algebra/mxpoly.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/poly.v b/mathcomp/algebra/poly.v index 64d6327..22caa4a 100644 --- a/mathcomp/algebra/poly.v +++ b/mathcomp/algebra/poly.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/polyXY.v b/mathcomp/algebra/polyXY.v index a2acd5f..82a4afb 100644 --- a/mathcomp/algebra/polyXY.v +++ b/mathcomp/algebra/polyXY.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/polydiv.v b/mathcomp/algebra/polydiv.v index 1782d95..b5e1068 100644 --- a/mathcomp/algebra/polydiv.v +++ b/mathcomp/algebra/polydiv.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/rat.v b/mathcomp/algebra/rat.v index 9a38f5b..d004748 100644 --- a/mathcomp/algebra/rat.v +++ b/mathcomp/algebra/rat.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/ring_quotient.v b/mathcomp/algebra/ring_quotient.v index 1b9433e..8d8eaaf 100644 --- a/mathcomp/algebra/ring_quotient.v +++ b/mathcomp/algebra/ring_quotient.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/ssralg.v b/mathcomp/algebra/ssralg.v index 887fa9b..9d93608 100644 --- a/mathcomp/algebra/ssralg.v +++ b/mathcomp/algebra/ssralg.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/ssrint.v b/mathcomp/algebra/ssrint.v index a8b9a04..eb66940 100644 --- a/mathcomp/algebra/ssrint.v +++ b/mathcomp/algebra/ssrint.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/ssrnum.v b/mathcomp/algebra/ssrnum.v index 47d73e6..219f804 100644 --- a/mathcomp/algebra/ssrnum.v +++ b/mathcomp/algebra/ssrnum.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/vector.v b/mathcomp/algebra/vector.v index e1d721e..da6dc59 100644 --- a/mathcomp/algebra/vector.v +++ b/mathcomp/algebra/vector.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/algebra/zmodp.v b/mathcomp/algebra/zmodp.v index 543b9e5..ec9750a 100644 --- a/mathcomp/algebra/zmodp.v +++ b/mathcomp/algebra/zmodp.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/algnum_basic.v b/mathcomp/attic/algnum_basic.v index 334a3e5..48adbb3 100644 --- a/mathcomp/attic/algnum_basic.v +++ b/mathcomp/attic/algnum_basic.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/amodule.v b/mathcomp/attic/amodule.v index 1a0371f..f4f80d0 100644 --- a/mathcomp/attic/amodule.v +++ b/mathcomp/attic/amodule.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/fib.v b/mathcomp/attic/fib.v index ab43137..def96bb 100644 --- a/mathcomp/attic/fib.v +++ b/mathcomp/attic/fib.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/forms.v b/mathcomp/attic/forms.v index cd7fa23..3ea6ab1 100644 --- a/mathcomp/attic/forms.v +++ b/mathcomp/attic/forms.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/galgebra.v b/mathcomp/attic/galgebra.v index 2b34dca..5e12b38 100644 --- a/mathcomp/attic/galgebra.v +++ b/mathcomp/attic/galgebra.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/multinom.v b/mathcomp/attic/multinom.v index cc9d9d8..175da6c 100644 --- a/mathcomp/attic/multinom.v +++ b/mathcomp/attic/multinom.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/quote.v b/mathcomp/attic/quote.v index ff2d191..cdf73bc 100644 --- a/mathcomp/attic/quote.v +++ b/mathcomp/attic/quote.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/attic/tutorial.v b/mathcomp/attic/tutorial.v index 9733cc8..332d841 100644 --- a/mathcomp/attic/tutorial.v +++ b/mathcomp/attic/tutorial.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/character/character.v b/mathcomp/character/character.v index 89c7697..0738b14 100644 --- a/mathcomp/character/character.v +++ b/mathcomp/character/character.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/character/classfun.v b/mathcomp/character/classfun.v index 7473338..54cbc41 100644 --- a/mathcomp/character/classfun.v +++ b/mathcomp/character/classfun.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/character/inertia.v b/mathcomp/character/inertia.v index f06ae9e..3890fdd 100644 --- a/mathcomp/character/inertia.v +++ b/mathcomp/character/inertia.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/character/integral_char.v b/mathcomp/character/integral_char.v index 4320307..ad2980f 100644 --- a/mathcomp/character/integral_char.v +++ b/mathcomp/character/integral_char.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/character/mxabelem.v b/mathcomp/character/mxabelem.v index aa14808..c178d75 100644 --- a/mathcomp/character/mxabelem.v +++ b/mathcomp/character/mxabelem.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/character/mxrepresentation.v b/mathcomp/character/mxrepresentation.v index 7eef614..6dd4eec 100644 --- a/mathcomp/character/mxrepresentation.v +++ b/mathcomp/character/mxrepresentation.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/character/vcharacter.v b/mathcomp/character/vcharacter.v index a1bc40e..5b1ff05 100644 --- a/mathcomp/character/vcharacter.v +++ b/mathcomp/character/vcharacter.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/algC.v b/mathcomp/field/algC.v index cbcbc3a..2e8ce3f 100644 --- a/mathcomp/field/algC.v +++ b/mathcomp/field/algC.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/algebraics_fundamentals.v b/mathcomp/field/algebraics_fundamentals.v index 4337327..405a5d9 100644 --- a/mathcomp/field/algebraics_fundamentals.v +++ b/mathcomp/field/algebraics_fundamentals.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/algnum.v b/mathcomp/field/algnum.v index c52f871..c75bead 100644 --- a/mathcomp/field/algnum.v +++ b/mathcomp/field/algnum.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/closed_field.v b/mathcomp/field/closed_field.v index 9302f56..8a2e304 100644 --- a/mathcomp/field/closed_field.v +++ b/mathcomp/field/closed_field.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/countalg.v b/mathcomp/field/countalg.v index 527b7af..46ce3a3 100644 --- a/mathcomp/field/countalg.v +++ b/mathcomp/field/countalg.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/cyclotomic.v b/mathcomp/field/cyclotomic.v index 4e810b6..80bdf50 100644 --- a/mathcomp/field/cyclotomic.v +++ b/mathcomp/field/cyclotomic.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/falgebra.v b/mathcomp/field/falgebra.v index 317819c..58eccc2 100644 --- a/mathcomp/field/falgebra.v +++ b/mathcomp/field/falgebra.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/fieldext.v b/mathcomp/field/fieldext.v index 5fefc49..234183e 100644 --- a/mathcomp/field/fieldext.v +++ b/mathcomp/field/fieldext.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/finfield.v b/mathcomp/field/finfield.v index ebf69e7..2421b16 100644 --- a/mathcomp/field/finfield.v +++ b/mathcomp/field/finfield.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/galois.v b/mathcomp/field/galois.v index 2b8c382..17fefe6 100644 --- a/mathcomp/field/galois.v +++ b/mathcomp/field/galois.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/field/separable.v b/mathcomp/field/separable.v index cbe959b..e8b8944 100644 --- a/mathcomp/field/separable.v +++ b/mathcomp/field/separable.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/action.v b/mathcomp/fingroup/action.v index 6ce38b9..1bde1f7 100644 --- a/mathcomp/fingroup/action.v +++ b/mathcomp/fingroup/action.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/automorphism.v b/mathcomp/fingroup/automorphism.v index 5e52e5e..8813b45 100644 --- a/mathcomp/fingroup/automorphism.v +++ b/mathcomp/fingroup/automorphism.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/fingroup.v b/mathcomp/fingroup/fingroup.v index 70553a0..550aaaa 100644 --- a/mathcomp/fingroup/fingroup.v +++ b/mathcomp/fingroup/fingroup.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/gproduct.v b/mathcomp/fingroup/gproduct.v index a8d2fb2..4ee2bc8 100644 --- a/mathcomp/fingroup/gproduct.v +++ b/mathcomp/fingroup/gproduct.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/morphism.v b/mathcomp/fingroup/morphism.v index f4790e6..9f0a900 100644 --- a/mathcomp/fingroup/morphism.v +++ b/mathcomp/fingroup/morphism.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/perm.v b/mathcomp/fingroup/perm.v index 2f85d78..a306475 100644 --- a/mathcomp/fingroup/perm.v +++ b/mathcomp/fingroup/perm.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/presentation.v b/mathcomp/fingroup/presentation.v index afe33fa..ad712ee 100644 --- a/mathcomp/fingroup/presentation.v +++ b/mathcomp/fingroup/presentation.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/fingroup/quotient.v b/mathcomp/fingroup/quotient.v index 3fb0774..242b4b7 100644 --- a/mathcomp/fingroup/quotient.v +++ b/mathcomp/fingroup/quotient.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGappendixAB.v b/mathcomp/odd_order/BGappendixAB.v index f1ec1b2..cb104f4 100644 --- a/mathcomp/odd_order/BGappendixAB.v +++ b/mathcomp/odd_order/BGappendixAB.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGappendixC.v b/mathcomp/odd_order/BGappendixC.v index 16a0a3c..f8b9137 100644 --- a/mathcomp/odd_order/BGappendixC.v +++ b/mathcomp/odd_order/BGappendixC.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection1.v b/mathcomp/odd_order/BGsection1.v index 79bb387..7539af3 100644 --- a/mathcomp/odd_order/BGsection1.v +++ b/mathcomp/odd_order/BGsection1.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection10.v b/mathcomp/odd_order/BGsection10.v index 6c8e91b..5a61e25 100644 --- a/mathcomp/odd_order/BGsection10.v +++ b/mathcomp/odd_order/BGsection10.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection11.v b/mathcomp/odd_order/BGsection11.v index fa3cd65..fe41e8d 100644 --- a/mathcomp/odd_order/BGsection11.v +++ b/mathcomp/odd_order/BGsection11.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection12.v b/mathcomp/odd_order/BGsection12.v index a266ed3..1dc8454 100644 --- a/mathcomp/odd_order/BGsection12.v +++ b/mathcomp/odd_order/BGsection12.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection13.v b/mathcomp/odd_order/BGsection13.v index 13b7dcb..e90be7f 100644 --- a/mathcomp/odd_order/BGsection13.v +++ b/mathcomp/odd_order/BGsection13.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection14.v b/mathcomp/odd_order/BGsection14.v index 18d4b08..2e3f523 100644 --- a/mathcomp/odd_order/BGsection14.v +++ b/mathcomp/odd_order/BGsection14.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection15.v b/mathcomp/odd_order/BGsection15.v index 553feda..06d7eb9 100644 --- a/mathcomp/odd_order/BGsection15.v +++ b/mathcomp/odd_order/BGsection15.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection16.v b/mathcomp/odd_order/BGsection16.v index 32850e4..737a92d 100644 --- a/mathcomp/odd_order/BGsection16.v +++ b/mathcomp/odd_order/BGsection16.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection2.v b/mathcomp/odd_order/BGsection2.v index 9008cf8..5d7a899 100644 --- a/mathcomp/odd_order/BGsection2.v +++ b/mathcomp/odd_order/BGsection2.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection3.v b/mathcomp/odd_order/BGsection3.v index 03455c3..007aaf4 100644 --- a/mathcomp/odd_order/BGsection3.v +++ b/mathcomp/odd_order/BGsection3.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection4.v b/mathcomp/odd_order/BGsection4.v index a9b519a..217f151 100644 --- a/mathcomp/odd_order/BGsection4.v +++ b/mathcomp/odd_order/BGsection4.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection5.v b/mathcomp/odd_order/BGsection5.v index 50f8e21..bf84a99 100644 --- a/mathcomp/odd_order/BGsection5.v +++ b/mathcomp/odd_order/BGsection5.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection6.v b/mathcomp/odd_order/BGsection6.v index 6d2df4d..e344b98 100644 --- a/mathcomp/odd_order/BGsection6.v +++ b/mathcomp/odd_order/BGsection6.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection7.v b/mathcomp/odd_order/BGsection7.v index 6af8f7d..71e800e 100644 --- a/mathcomp/odd_order/BGsection7.v +++ b/mathcomp/odd_order/BGsection7.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection8.v b/mathcomp/odd_order/BGsection8.v index 9ced163..db378f3 100644 --- a/mathcomp/odd_order/BGsection8.v +++ b/mathcomp/odd_order/BGsection8.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/BGsection9.v b/mathcomp/odd_order/BGsection9.v index 3baa270..f649e84 100644 --- a/mathcomp/odd_order/BGsection9.v +++ b/mathcomp/odd_order/BGsection9.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection1.v b/mathcomp/odd_order/PFsection1.v index 7c74766..1d784ed 100644 --- a/mathcomp/odd_order/PFsection1.v +++ b/mathcomp/odd_order/PFsection1.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection10.v b/mathcomp/odd_order/PFsection10.v index 18fbf8c..11b3b20 100644 --- a/mathcomp/odd_order/PFsection10.v +++ b/mathcomp/odd_order/PFsection10.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection11.v b/mathcomp/odd_order/PFsection11.v index 3c4ec9f..c37633f 100644 --- a/mathcomp/odd_order/PFsection11.v +++ b/mathcomp/odd_order/PFsection11.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection12.v b/mathcomp/odd_order/PFsection12.v index fa5a453..fcc35bf 100644 --- a/mathcomp/odd_order/PFsection12.v +++ b/mathcomp/odd_order/PFsection12.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection13.v b/mathcomp/odd_order/PFsection13.v index 1ab2aee..18e8606 100644 --- a/mathcomp/odd_order/PFsection13.v +++ b/mathcomp/odd_order/PFsection13.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection14.v b/mathcomp/odd_order/PFsection14.v index 5c43caa..c634ec1 100644 --- a/mathcomp/odd_order/PFsection14.v +++ b/mathcomp/odd_order/PFsection14.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection2.v b/mathcomp/odd_order/PFsection2.v index 04c4eba..f92bb16 100644 --- a/mathcomp/odd_order/PFsection2.v +++ b/mathcomp/odd_order/PFsection2.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection3.v b/mathcomp/odd_order/PFsection3.v index 9011122..eb5ccf8 100644 --- a/mathcomp/odd_order/PFsection3.v +++ b/mathcomp/odd_order/PFsection3.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection4.v b/mathcomp/odd_order/PFsection4.v index 01ca8a5..c897e84 100644 --- a/mathcomp/odd_order/PFsection4.v +++ b/mathcomp/odd_order/PFsection4.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection5.v b/mathcomp/odd_order/PFsection5.v index 3f90da7..636c48c 100644 --- a/mathcomp/odd_order/PFsection5.v +++ b/mathcomp/odd_order/PFsection5.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection6.v b/mathcomp/odd_order/PFsection6.v index cbde798..b32a57d 100644 --- a/mathcomp/odd_order/PFsection6.v +++ b/mathcomp/odd_order/PFsection6.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection7.v b/mathcomp/odd_order/PFsection7.v index 4610829..455681c 100644 --- a/mathcomp/odd_order/PFsection7.v +++ b/mathcomp/odd_order/PFsection7.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection8.v b/mathcomp/odd_order/PFsection8.v index fd085f6..d4ffa46 100644 --- a/mathcomp/odd_order/PFsection8.v +++ b/mathcomp/odd_order/PFsection8.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/PFsection9.v b/mathcomp/odd_order/PFsection9.v index e7f82bc..0cd1109 100644 --- a/mathcomp/odd_order/PFsection9.v +++ b/mathcomp/odd_order/PFsection9.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/stripped_odd_order_theorem.v b/mathcomp/odd_order/stripped_odd_order_theorem.v index 05c24a9..19b9d0b 100644 --- a/mathcomp/odd_order/stripped_odd_order_theorem.v +++ b/mathcomp/odd_order/stripped_odd_order_theorem.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/odd_order/wielandt_fixpoint.v b/mathcomp/odd_order/wielandt_fixpoint.v index 4f40c11..3a9a099 100644 --- a/mathcomp/odd_order/wielandt_fixpoint.v +++ b/mathcomp/odd_order/wielandt_fixpoint.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/bigenough.v b/mathcomp/real_closed/bigenough.v index 621f53f..90e46e8 100644 --- a/mathcomp/real_closed/bigenough.v +++ b/mathcomp/real_closed/bigenough.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/cauchyreals.v b/mathcomp/real_closed/cauchyreals.v index 1986cb9..9d2dff3 100644 --- a/mathcomp/real_closed/cauchyreals.v +++ b/mathcomp/real_closed/cauchyreals.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/complex.v b/mathcomp/real_closed/complex.v index 8ea1266..ef32266 100644 --- a/mathcomp/real_closed/complex.v +++ b/mathcomp/real_closed/complex.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/mxtens.v b/mathcomp/real_closed/mxtens.v index ace09a6..5189369 100644 --- a/mathcomp/real_closed/mxtens.v +++ b/mathcomp/real_closed/mxtens.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/ordered_qelim.v b/mathcomp/real_closed/ordered_qelim.v index 7c7bd6a..f5d0b38 100644 --- a/mathcomp/real_closed/ordered_qelim.v +++ b/mathcomp/real_closed/ordered_qelim.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/polyorder.v b/mathcomp/real_closed/polyorder.v index 2da4dc9..f84abb6 100644 --- a/mathcomp/real_closed/polyorder.v +++ b/mathcomp/real_closed/polyorder.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/polyrcf.v b/mathcomp/real_closed/polyrcf.v index c29cb96..9e73204 100644 --- a/mathcomp/real_closed/polyrcf.v +++ b/mathcomp/real_closed/polyrcf.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/qe_rcf.v b/mathcomp/real_closed/qe_rcf.v index 82b5ea5..e1b3b97 100644 --- a/mathcomp/real_closed/qe_rcf.v +++ b/mathcomp/real_closed/qe_rcf.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/qe_rcf_th.v b/mathcomp/real_closed/qe_rcf_th.v index 6f50f36..3aebce4 100644 --- a/mathcomp/real_closed/qe_rcf_th.v +++ b/mathcomp/real_closed/qe_rcf_th.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/real_closed/realalg.v b/mathcomp/real_closed/realalg.v index 6f9cd8e..69fb9c4 100644 --- a/mathcomp/real_closed/realalg.v +++ b/mathcomp/real_closed/realalg.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/abelian.v b/mathcomp/solvable/abelian.v index 45168a0..d6dac93 100644 --- a/mathcomp/solvable/abelian.v +++ b/mathcomp/solvable/abelian.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/alt.v b/mathcomp/solvable/alt.v index f32a590..f43c89a 100644 --- a/mathcomp/solvable/alt.v +++ b/mathcomp/solvable/alt.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/burnside_app.v b/mathcomp/solvable/burnside_app.v index f5f337a..638276c 100644 --- a/mathcomp/solvable/burnside_app.v +++ b/mathcomp/solvable/burnside_app.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/center.v b/mathcomp/solvable/center.v index 7189758..d63c302 100644 --- a/mathcomp/solvable/center.v +++ b/mathcomp/solvable/center.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/commutator.v b/mathcomp/solvable/commutator.v index 674825a..f3e0779 100644 --- a/mathcomp/solvable/commutator.v +++ b/mathcomp/solvable/commutator.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/cyclic.v b/mathcomp/solvable/cyclic.v index 03c8bfb..8073449 100644 --- a/mathcomp/solvable/cyclic.v +++ b/mathcomp/solvable/cyclic.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/extraspecial.v b/mathcomp/solvable/extraspecial.v index 0df60e6..9d158cc 100644 --- a/mathcomp/solvable/extraspecial.v +++ b/mathcomp/solvable/extraspecial.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/extremal.v b/mathcomp/solvable/extremal.v index 5f9545d..342eeae 100644 --- a/mathcomp/solvable/extremal.v +++ b/mathcomp/solvable/extremal.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/finmodule.v b/mathcomp/solvable/finmodule.v index e1462be..97b2ebc 100644 --- a/mathcomp/solvable/finmodule.v +++ b/mathcomp/solvable/finmodule.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/frobenius.v b/mathcomp/solvable/frobenius.v index e2dba42..e4a716d 100644 --- a/mathcomp/solvable/frobenius.v +++ b/mathcomp/solvable/frobenius.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/gfunctor.v b/mathcomp/solvable/gfunctor.v index 40292a3..fc8385d 100644 --- a/mathcomp/solvable/gfunctor.v +++ b/mathcomp/solvable/gfunctor.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/gseries.v b/mathcomp/solvable/gseries.v index 73170ee..fe83ada 100644 --- a/mathcomp/solvable/gseries.v +++ b/mathcomp/solvable/gseries.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/hall.v b/mathcomp/solvable/hall.v index b706879..d59964b 100644 --- a/mathcomp/solvable/hall.v +++ b/mathcomp/solvable/hall.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/jordanholder.v b/mathcomp/solvable/jordanholder.v index 5d4d195..6a8de0e 100644 --- a/mathcomp/solvable/jordanholder.v +++ b/mathcomp/solvable/jordanholder.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/maximal.v b/mathcomp/solvable/maximal.v index 098a325..4255bd9 100644 --- a/mathcomp/solvable/maximal.v +++ b/mathcomp/solvable/maximal.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/nilpotent.v b/mathcomp/solvable/nilpotent.v index 520d691..954be43 100644 --- a/mathcomp/solvable/nilpotent.v +++ b/mathcomp/solvable/nilpotent.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/pgroup.v b/mathcomp/solvable/pgroup.v index fb28f3d..f3e19b3 100644 --- a/mathcomp/solvable/pgroup.v +++ b/mathcomp/solvable/pgroup.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/primitive_action.v b/mathcomp/solvable/primitive_action.v index 712f492..ae60ce0 100644 --- a/mathcomp/solvable/primitive_action.v +++ b/mathcomp/solvable/primitive_action.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/solvable/sylow.v b/mathcomp/solvable/sylow.v index 01d80e0..32f86f1 100644 --- a/mathcomp/solvable/sylow.v +++ b/mathcomp/solvable/sylow.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/bigop.v b/mathcomp/ssreflect/bigop.v index 5fed5bb..c5d2ef3 100644 --- a/mathcomp/ssreflect/bigop.v +++ b/mathcomp/ssreflect/bigop.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/binomial.v b/mathcomp/ssreflect/binomial.v index 79d488e..d683768 100644 --- a/mathcomp/ssreflect/binomial.v +++ b/mathcomp/ssreflect/binomial.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/choice.v b/mathcomp/ssreflect/choice.v index 4146634..a696bbd 100644 --- a/mathcomp/ssreflect/choice.v +++ b/mathcomp/ssreflect/choice.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/div.v b/mathcomp/ssreflect/div.v index 8179f57..723946d 100644 --- a/mathcomp/ssreflect/div.v +++ b/mathcomp/ssreflect/div.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/eqtype.v b/mathcomp/ssreflect/eqtype.v index 62a455b..e11fd9f 100644 --- a/mathcomp/ssreflect/eqtype.v +++ b/mathcomp/ssreflect/eqtype.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/finfun.v b/mathcomp/ssreflect/finfun.v index 09f94f0..e00ddef 100644 --- a/mathcomp/ssreflect/finfun.v +++ b/mathcomp/ssreflect/finfun.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/fingraph.v b/mathcomp/ssreflect/fingraph.v index 54dde32..5a87c6c 100644 --- a/mathcomp/ssreflect/fingraph.v +++ b/mathcomp/ssreflect/fingraph.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/finset.v b/mathcomp/ssreflect/finset.v index 6fa29ff..feac3ab 100644 --- a/mathcomp/ssreflect/finset.v +++ b/mathcomp/ssreflect/finset.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/fintype.v b/mathcomp/ssreflect/fintype.v index 94fa2d8..215c69b 100644 --- a/mathcomp/ssreflect/fintype.v +++ b/mathcomp/ssreflect/fintype.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/generic_quotient.v b/mathcomp/ssreflect/generic_quotient.v index d78e0d8..5533832 100644 --- a/mathcomp/ssreflect/generic_quotient.v +++ b/mathcomp/ssreflect/generic_quotient.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) (* -*- coding : utf-8 -*- *) diff --git a/mathcomp/ssreflect/path.v b/mathcomp/ssreflect/path.v index ec81f81..f5eb77b 100644 --- a/mathcomp/ssreflect/path.v +++ b/mathcomp/ssreflect/path.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index 93a1ba7..f4e2ac8 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) (* This line is read by the Makefile's dist target: do not remove. *) @@ -8,7 +8,7 @@ let ssrAstVersion = 1;; let () = Mltop.add_known_plugin (fun () -> if Flags.is_verbose () && not !Flags.batch_mode then begin Printf.printf "\nSmall Scale Reflection version %s loaded.\n" ssrversion; - Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; + Printf.printf "Copyright 2005-2016 Microsoft Corporation and INRIA.\n"; Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" end) "ssreflect_plugin" diff --git a/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 index 3ce494f..cc4e896 100644 --- a/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) (* This line is read by the Makefile's dist target: do not remove. *) diff --git a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 index 08f1780..ffbfdfd 100644 --- a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 +++ b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) (* Defining grammar rules with "xx" in it automatically declares keywords too, diff --git a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli index a12f53b..5edc0a6 100644 --- a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli +++ b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) open Genarg diff --git a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.v b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.v index 311d494..369ffaf 100644 --- a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.v +++ b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Set Implicit Arguments. diff --git a/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 index 8409bfb..1c16fa9 100644 --- a/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) (* This line is read by the Makefile's dist target: do not remove. *) @@ -8,7 +8,7 @@ let ssrAstVersion = 1;; let () = Mltop.add_known_plugin (fun () -> if Flags.is_verbose () && not !Flags.batch_mode then begin Printf.printf "\nSmall Scale Reflection version %s loaded.\n" ssrversion; - Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; + Printf.printf "Copyright 2005-2016 Microsoft Corporation and INRIA.\n"; Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" end) "ssreflect_plugin" diff --git a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 index 64770ea..084aee9 100644 --- a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 +++ b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) (* Defining grammar rules with "xx" in it automatically declares keywords too, diff --git a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli index 74a603e..84700d6 100644 --- a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli +++ b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) open Genarg diff --git a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.v b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.v index 311d494..369ffaf 100644 --- a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.v +++ b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Set Implicit Arguments. diff --git a/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 index 15fc5e5..1e122ea 100644 --- a/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) (* This line is read by the Makefile's dist target: do not remove. *) @@ -8,7 +8,7 @@ let ssrAstVersion = 1;; let () = Mltop.add_known_plugin (fun () -> if Flags.is_verbose () && not !Flags.batch_mode then begin Printf.printf "\nSmall Scale Reflection version %s loaded.\n" ssrversion; - Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; + Printf.printf "Copyright 2005-2016 Microsoft Corporation and INRIA.\n"; Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" end) "ssreflect_plugin" diff --git a/mathcomp/ssreflect/prime.v b/mathcomp/ssreflect/prime.v index 6b9720b..5c6acce 100644 --- a/mathcomp/ssreflect/prime.v +++ b/mathcomp/ssreflect/prime.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/seq.v b/mathcomp/ssreflect/seq.v index 6c8e23e..b622543 100644 --- a/mathcomp/ssreflect/seq.v +++ b/mathcomp/ssreflect/seq.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/ssrbool.v b/mathcomp/ssreflect/ssrbool.v index 9049608..bb8606f 100644 --- a/mathcomp/ssreflect/ssrbool.v +++ b/mathcomp/ssreflect/ssrbool.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/ssreflect.v b/mathcomp/ssreflect/ssreflect.v index cd405fa..079bf72 100644 --- a/mathcomp/ssreflect/ssreflect.v +++ b/mathcomp/ssreflect/ssreflect.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import Bool. (* For bool_scope delimiter 'bool'. *) Require Import ssrmatching. diff --git a/mathcomp/ssreflect/ssrfun.v b/mathcomp/ssreflect/ssrfun.v index 32b84ad..48cf417 100644 --- a/mathcomp/ssreflect/ssrfun.v +++ b/mathcomp/ssreflect/ssrfun.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import ssreflect. diff --git a/mathcomp/ssreflect/ssrmatching.v b/mathcomp/ssreflect/ssrmatching.v new file mode 120000 index 0000000..0bf52be --- /dev/null +++ b/mathcomp/ssreflect/ssrmatching.v @@ -0,0 +1 @@ +./plugin/v8.5/ssrmatching.v \ No newline at end of file diff --git a/mathcomp/ssreflect/ssrnat.v b/mathcomp/ssreflect/ssrnat.v index 0cf70a8..4b9523f 100644 --- a/mathcomp/ssreflect/ssrnat.v +++ b/mathcomp/ssreflect/ssrnat.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssreflect/tuple.v b/mathcomp/ssreflect/tuple.v index a6a154f..7023bb4 100644 --- a/mathcomp/ssreflect/tuple.v +++ b/mathcomp/ssreflect/tuple.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrmatching.v b/mathcomp/ssrmatching.v new file mode 120000 index 0000000..4533fbb --- /dev/null +++ b/mathcomp/ssrmatching.v @@ -0,0 +1 @@ +ssreflect/plugin/v8.5/ssrmatching.v \ No newline at end of file diff --git a/mathcomp/ssrtest/absevarprop.v b/mathcomp/ssrtest/absevarprop.v index 0d2e192..b8ae7d6 100644 --- a/mathcomp/ssrtest/absevarprop.v +++ b/mathcomp/ssrtest/absevarprop.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/binders.v b/mathcomp/ssrtest/binders.v index 7350e38..32e351f 100644 --- a/mathcomp/ssrtest/binders.v +++ b/mathcomp/ssrtest/binders.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/binders_of.v b/mathcomp/ssrtest/binders_of.v index 465d290..2a88502 100644 --- a/mathcomp/ssrtest/binders_of.v +++ b/mathcomp/ssrtest/binders_of.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/caseview.v b/mathcomp/ssrtest/caseview.v index e1d21b1..478f573 100644 --- a/mathcomp/ssrtest/caseview.v +++ b/mathcomp/ssrtest/caseview.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/congr.v b/mathcomp/ssrtest/congr.v index faca4f0..2a7b824 100644 --- a/mathcomp/ssrtest/congr.v +++ b/mathcomp/ssrtest/congr.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/deferclear.v b/mathcomp/ssrtest/deferclear.v index 312eed8..849a7c9 100644 --- a/mathcomp/ssrtest/deferclear.v +++ b/mathcomp/ssrtest/deferclear.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/dependent_type_err.v b/mathcomp/ssrtest/dependent_type_err.v index f845a73..ef2dc9d 100644 --- a/mathcomp/ssrtest/dependent_type_err.v +++ b/mathcomp/ssrtest/dependent_type_err.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/elim.v b/mathcomp/ssrtest/elim.v index 028d589..bc8701e 100644 --- a/mathcomp/ssrtest/elim.v +++ b/mathcomp/ssrtest/elim.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/elim2.v b/mathcomp/ssrtest/elim2.v index 0eff79d..55c7a81 100644 --- a/mathcomp/ssrtest/elim2.v +++ b/mathcomp/ssrtest/elim2.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/elim_pattern.v b/mathcomp/ssrtest/elim_pattern.v index 35ade86..24bd0fb 100644 --- a/mathcomp/ssrtest/elim_pattern.v +++ b/mathcomp/ssrtest/elim_pattern.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/first_n.v b/mathcomp/ssrtest/first_n.v index 3d99a0f..126f8a5 100644 --- a/mathcomp/ssrtest/first_n.v +++ b/mathcomp/ssrtest/first_n.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/gen_have.v b/mathcomp/ssrtest/gen_have.v index 2ccfb2e..d08cabe 100644 --- a/mathcomp/ssrtest/gen_have.v +++ b/mathcomp/ssrtest/gen_have.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/gen_pattern.v b/mathcomp/ssrtest/gen_pattern.v index 732fca8..eb4aee8 100644 --- a/mathcomp/ssrtest/gen_pattern.v +++ b/mathcomp/ssrtest/gen_pattern.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/have_TC.v b/mathcomp/ssrtest/have_TC.v index 75381ca..c95b224 100644 --- a/mathcomp/ssrtest/have_TC.v +++ b/mathcomp/ssrtest/have_TC.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/have_transp.v b/mathcomp/ssrtest/have_transp.v index 4a0b2ff..fec720c 100644 --- a/mathcomp/ssrtest/have_transp.v +++ b/mathcomp/ssrtest/have_transp.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/have_view_idiom.v b/mathcomp/ssrtest/have_view_idiom.v index 1287870..07cfa11 100644 --- a/mathcomp/ssrtest/have_view_idiom.v +++ b/mathcomp/ssrtest/have_view_idiom.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/havesuff.v b/mathcomp/ssrtest/havesuff.v index 36d8735..f97f445 100644 --- a/mathcomp/ssrtest/havesuff.v +++ b/mathcomp/ssrtest/havesuff.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/if_isnt.v b/mathcomp/ssrtest/if_isnt.v index 883c996..08e242e 100644 --- a/mathcomp/ssrtest/if_isnt.v +++ b/mathcomp/ssrtest/if_isnt.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/indetLHS.v b/mathcomp/ssrtest/indetLHS.v index f394b17..edaf128 100644 --- a/mathcomp/ssrtest/indetLHS.v +++ b/mathcomp/ssrtest/indetLHS.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/intro_beta.v b/mathcomp/ssrtest/intro_beta.v index f9d241a..6b1b96d 100644 --- a/mathcomp/ssrtest/intro_beta.v +++ b/mathcomp/ssrtest/intro_beta.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/intro_noop.v b/mathcomp/ssrtest/intro_noop.v index 5310e2e..9b75bcf 100644 --- a/mathcomp/ssrtest/intro_noop.v +++ b/mathcomp/ssrtest/intro_noop.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/ipatalternation.v b/mathcomp/ssrtest/ipatalternation.v index 1732328..65f3760 100644 --- a/mathcomp/ssrtest/ipatalternation.v +++ b/mathcomp/ssrtest/ipatalternation.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/ltac_have.v b/mathcomp/ssrtest/ltac_have.v index a5923d9..1b30951 100644 --- a/mathcomp/ssrtest/ltac_have.v +++ b/mathcomp/ssrtest/ltac_have.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/ltac_in.v b/mathcomp/ssrtest/ltac_in.v index 43c5755..06d8dc7 100644 --- a/mathcomp/ssrtest/ltac_in.v +++ b/mathcomp/ssrtest/ltac_in.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/move_after.v b/mathcomp/ssrtest/move_after.v index d5fc4db..a6c455c 100644 --- a/mathcomp/ssrtest/move_after.v +++ b/mathcomp/ssrtest/move_after.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/multiview.v b/mathcomp/ssrtest/multiview.v index 9cf4cd0..57a26ff 100644 --- a/mathcomp/ssrtest/multiview.v +++ b/mathcomp/ssrtest/multiview.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/occarrow.v b/mathcomp/ssrtest/occarrow.v index 4765702..927473f 100644 --- a/mathcomp/ssrtest/occarrow.v +++ b/mathcomp/ssrtest/occarrow.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/patnoX.v b/mathcomp/ssrtest/patnoX.v index 0d21c4f..a879b37 100644 --- a/mathcomp/ssrtest/patnoX.v +++ b/mathcomp/ssrtest/patnoX.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/rewpatterns.v b/mathcomp/ssrtest/rewpatterns.v index 4af3648..95c3c00 100644 --- a/mathcomp/ssrtest/rewpatterns.v +++ b/mathcomp/ssrtest/rewpatterns.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/set_lamda.v b/mathcomp/ssrtest/set_lamda.v index f004346..6366130 100644 --- a/mathcomp/ssrtest/set_lamda.v +++ b/mathcomp/ssrtest/set_lamda.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/set_pattern.v b/mathcomp/ssrtest/set_pattern.v index 86de57c..25b6967 100644 --- a/mathcomp/ssrtest/set_pattern.v +++ b/mathcomp/ssrtest/set_pattern.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/ssrsyntax1.v b/mathcomp/ssrtest/ssrsyntax1.v index 5eabcc3..9116ba2 100644 --- a/mathcomp/ssrtest/ssrsyntax1.v +++ b/mathcomp/ssrtest/ssrsyntax1.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require mathcomp.ssreflect.ssreflect. Require Import Arith. diff --git a/mathcomp/ssrtest/ssrsyntax2.v b/mathcomp/ssrtest/ssrsyntax2.v index b3537ad..5e174a2 100644 --- a/mathcomp/ssrtest/ssrsyntax2.v +++ b/mathcomp/ssrtest/ssrsyntax2.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssrtest.ssrsyntax1. Require Import Arith. diff --git a/mathcomp/ssrtest/tc.v b/mathcomp/ssrtest/tc.v index 871d6ad..7a95b66 100644 --- a/mathcomp/ssrtest/tc.v +++ b/mathcomp/ssrtest/tc.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/testmx.v b/mathcomp/ssrtest/testmx.v index 0fc8d5e..95c62bd 100644 --- a/mathcomp/ssrtest/testmx.v +++ b/mathcomp/ssrtest/testmx.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/typeof.v b/mathcomp/ssrtest/typeof.v index f336a46..f2cb1d4 100644 --- a/mathcomp/ssrtest/typeof.v +++ b/mathcomp/ssrtest/typeof.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. diff --git a/mathcomp/ssrtest/unkeyed.v b/mathcomp/ssrtest/unkeyed.v index 39e0c23..5ab6eba 100644 --- a/mathcomp/ssrtest/unkeyed.v +++ b/mathcomp/ssrtest/unkeyed.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/view_case.v b/mathcomp/ssrtest/view_case.v index 974b916..e9104a9 100644 --- a/mathcomp/ssrtest/view_case.v +++ b/mathcomp/ssrtest/view_case.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/wlog_suff.v b/mathcomp/ssrtest/wlog_suff.v index adb1874..bc931e1 100644 --- a/mathcomp/ssrtest/wlog_suff.v +++ b/mathcomp/ssrtest/wlog_suff.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/wlogletin.v b/mathcomp/ssrtest/wlogletin.v index 841edaf..1553621 100644 --- a/mathcomp/ssrtest/wlogletin.v +++ b/mathcomp/ssrtest/wlogletin.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp diff --git a/mathcomp/ssrtest/wlong_intro.v b/mathcomp/ssrtest/wlong_intro.v index 61e069e..836dd4b 100644 --- a/mathcomp/ssrtest/wlong_intro.v +++ b/mathcomp/ssrtest/wlong_intro.v @@ -1,4 +1,4 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Require Import mathcomp.ssreflect.ssreflect. From mathcomp -- cgit v1.2.3 From 23e57fb47874331c5feaace883513b7abecdff28 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 8 Nov 2016 10:53:17 +0100 Subject: fix compilation on 8.6 and trunk --- mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 2 +- mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 | 2 +- mathcomp/ssreflect/ssrmatching.v | 1 - mathcomp/ssrmatching.v | 1 - 4 files changed, 2 insertions(+), 4 deletions(-) delete mode 120000 mathcomp/ssreflect/ssrmatching.v delete mode 120000 mathcomp/ssrmatching.v (limited to 'mathcomp') diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 index f4e2ac8..72161e7 100644 --- a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -1093,7 +1093,7 @@ let interp_refine ist gl rc = let kind = OfType (pf_concl gl) in let flags = { use_typeclasses = true; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = None; fail_evar = false; expand_evars = true } diff --git a/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 index 1e122ea..6aaa79b 100644 --- a/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 +++ b/mathcomp/ssreflect/plugin/v8.6/ssreflect.ml4 @@ -1097,7 +1097,7 @@ let interp_refine ist gl rc = let kind = OfType (pf_concl gl) in let flags = { use_typeclasses = true; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = None; fail_evar = false; expand_evars = true } diff --git a/mathcomp/ssreflect/ssrmatching.v b/mathcomp/ssreflect/ssrmatching.v deleted file mode 120000 index 0bf52be..0000000 --- a/mathcomp/ssreflect/ssrmatching.v +++ /dev/null @@ -1 +0,0 @@ -./plugin/v8.5/ssrmatching.v \ No newline at end of file diff --git a/mathcomp/ssrmatching.v b/mathcomp/ssrmatching.v deleted file mode 120000 index 4533fbb..0000000 --- a/mathcomp/ssrmatching.v +++ /dev/null @@ -1 +0,0 @@ -ssreflect/plugin/v8.5/ssrmatching.v \ No newline at end of file -- cgit v1.2.3