coq-8.4pl3/0002750000175000017500000000000012255245642011622 5ustar stephstephcoq-8.4pl3/tactics/0002750000175000017500000000000012255245502013247 5ustar stephstephcoq-8.4pl3/tactics/btermdn.ml0000640000175000017500000001074312255245502015240 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* struct module Term_dn = Termdn.Make(Z) module X = struct type t = constr_pattern*int let compare = Pervasives.compare end module Y = struct type t = Term_dn.term_label let compare x y = let make_name n = match n with | Term_dn.GRLabel(ConstRef con) -> Term_dn.GRLabel(ConstRef(constant_of_kn(canonical_con con))) | Term_dn.GRLabel(IndRef (kn,i)) -> Term_dn.GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) | Term_dn.GRLabel(ConstructRef ((kn,i),j ))-> Term_dn.GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) | k -> k in Pervasives.compare (make_name x) (make_name y) end module Dn = Dn.Make(X)(Y)(Z) type t = Dn.t let create = Dn.create let decomp = let rec decrec acc c = match kind_of_term c with | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f | Cast (c1,_,_) -> decrec acc c1 | _ -> (c,acc) in decrec [] let constr_val_discr t = let c, l = decomp t in match kind_of_term c with | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) | Const _ -> Dn.Everything | _ -> Dn.Nothing let constr_val_discr_st (idpred,cpred) t = let c, l = decomp t in match kind_of_term c with | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) | Sort _ -> Dn.Label(Term_dn.SortLabel, []) | Evar _ -> Dn.Everything | _ -> Dn.Nothing let bounded_constr_pat_discr_st st (t,depth) = if depth = 0 then None else match Term_dn.constr_pat_discr_st st t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) let bounded_constr_val_discr_st st (t,depth) = if depth = 0 then Dn.Nothing else match constr_val_discr_st st t with | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) | Dn.Nothing -> Dn.Nothing | Dn.Everything -> Dn.Everything let bounded_constr_pat_discr (t,depth) = if depth = 0 then None else match Term_dn.constr_pat_discr t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) let bounded_constr_val_discr (t,depth) = if depth = 0 then Dn.Nothing else match constr_val_discr t with | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) | Dn.Nothing -> Dn.Nothing | Dn.Everything -> Dn.Everything let add = function | None -> (fun dn (c,v) -> Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) | Some st -> (fun dn (c,v) -> Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let rmv = function | None -> (fun dn (c,v) -> Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) | Some st -> (fun dn (c,v) -> Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let lookup = function | None -> (fun dn t -> List.map (fun ((c,_),v) -> (c,v)) (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))) | Some st -> (fun dn t -> List.map (fun ((c,_),v) -> (c,v)) (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth))) let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn end coq-8.4pl3/tactics/extratactics.ml40000640000175000017500000006452512255245502016376 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ admit_as_an_axiom ] END let replace_in_clause_maybe_by (sigma1,c1) c2 in_hyp tac = Refiner.tclWITHHOLES false (replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp)) sigma1 (Option.map Tacinterp.eval_tactic tac) let replace_multi_term dir_opt (sigma,c) in_hyp = Refiner.tclWITHHOLES false (replace_multi_term dir_opt c) sigma (glob_in_arg_hyp_to_clause in_hyp) TACTIC EXTEND replace ["replace" open_constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ] -> [ replace_in_clause_maybe_by c1 c2 in_hyp tac ] END TACTIC EXTEND replace_term_left [ "replace" "->" open_constr(c) in_arg_hyp(in_hyp) ] -> [ replace_multi_term (Some true) c in_hyp] END TACTIC EXTEND replace_term_right [ "replace" "<-" open_constr(c) in_arg_hyp(in_hyp) ] -> [replace_multi_term (Some false) c in_hyp] END TACTIC EXTEND replace_term [ "replace" open_constr(c) in_arg_hyp(in_hyp) ] -> [ replace_multi_term None c in_hyp ] END let induction_arg_of_quantified_hyp = function | AnonHyp n -> ElimOnAnonHyp n | NamedHyp id -> ElimOnIdent (Util.dummy_loc,id) (* Versions *_main must come first!! so that "1" is interpreted as a ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a ElimOnIdent and not as "constr" *) let elimOnConstrWithHoles tac with_evars c = Refiner.tclWITHHOLES with_evars (tac with_evars) c.sigma (Some (ElimOnConstr c.it)) TACTIC EXTEND simplify_eq_main | [ "simplify_eq" constr_with_bindings(c) ] -> [ elimOnConstrWithHoles dEq false c ] END TACTIC EXTEND simplify_eq [ "simplify_eq" ] -> [ dEq false None ] | [ "simplify_eq" quantified_hypothesis(h) ] -> [ dEq false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND esimplify_eq_main | [ "esimplify_eq" constr_with_bindings(c) ] -> [ elimOnConstrWithHoles dEq true c ] END TACTIC EXTEND esimplify_eq | [ "esimplify_eq" ] -> [ dEq true None ] | [ "esimplify_eq" quantified_hypothesis(h) ] -> [ dEq true (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND discriminate_main | [ "discriminate" constr_with_bindings(c) ] -> [ elimOnConstrWithHoles discr_tac false c ] END TACTIC EXTEND discriminate | [ "discriminate" ] -> [ discr_tac false None ] | [ "discriminate" quantified_hypothesis(h) ] -> [ discr_tac false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND ediscriminate_main | [ "ediscriminate" constr_with_bindings(c) ] -> [ elimOnConstrWithHoles discr_tac true c ] END TACTIC EXTEND ediscriminate | [ "ediscriminate" ] -> [ discr_tac true None ] | [ "ediscriminate" quantified_hypothesis(h) ] -> [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ] END let h_discrHyp id gl = h_discriminate_main {it = Term.mkVar id,NoBindings; sigma = Refiner.project gl} gl TACTIC EXTEND injection_main | [ "injection" constr_with_bindings(c) ] -> [ elimOnConstrWithHoles (injClause []) false c ] END TACTIC EXTEND injection | [ "injection" ] -> [ injClause [] false None ] | [ "injection" quantified_hypothesis(h) ] -> [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_main | [ "einjection" constr_with_bindings(c) ] -> [ elimOnConstrWithHoles (injClause []) true c ] END TACTIC EXTEND einjection | [ "einjection" ] -> [ injClause [] true None ] | [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND injection_as_main | [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> [ elimOnConstrWithHoles (injClause ipat) false c ] END TACTIC EXTEND injection_as | [ "injection" "as" simple_intropattern_list(ipat)] -> [ injClause ipat false None ] | [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> [ injClause ipat false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_as_main | [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> [ elimOnConstrWithHoles (injClause ipat) true c ] END TACTIC EXTEND einjection_as | [ "einjection" "as" simple_intropattern_list(ipat)] -> [ injClause ipat true None ] | [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> [ injClause ipat true (Some (induction_arg_of_quantified_hyp h)) ] END let h_injHyp id gl = h_injection_main { it = Term.mkVar id,NoBindings; sigma = Refiner.project gl } gl TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] | [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] -> [ rewriteInHyp b c id ] END TACTIC EXTEND cut_rewrite | [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] -> [ cutRewriteInHyp b eqn id ] END (**********************************************************************) (* Contradiction *) open Contradiction TACTIC EXTEND absurd [ "absurd" constr(c) ] -> [ absurd c ] END let onSomeWithHoles tac = function | None -> tac None | Some c -> Refiner.tclWITHHOLES false tac c.sigma (Some c.it) TACTIC EXTEND contradiction [ "contradiction" constr_with_bindings_opt(c) ] -> [ onSomeWithHoles contradiction c ] END (**********************************************************************) (* AutoRewrite *) open Autorewrite let pr_orient _prc _prlc _prt = function | true -> Pp.mt () | false -> Pp.str " <-" let pr_orient_string _prc _prlc _prt (orient, s) = pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string | [ orient(r) preident(i) ] -> [ r, i ] END TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] -> [ auto_multi_rewrite l (glob_in_arg_hyp_to_clause cl) ] | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] -> [ let cl = glob_in_arg_hyp_to_clause cl in auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl ] END TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) ] -> [ auto_multi_rewrite ~conds:AllMatches l (glob_in_arg_hyp_to_clause cl) ] | [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] -> [ let cl = glob_in_arg_hyp_to_clause cl in auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ] END (**********************************************************************) (* Rewrite star *) let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) = let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in Refiner. tclWITHHOLES false (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings)) sigma true let occurrences_of = function | n::_ as nl when n < 0 -> (false,List.map abs nl) | nl -> if List.exists (fun n -> n < 0) nl then error "Illegal negative occurrence number."; (true,nl) TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> [ rewrite_star (Some id) o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> [ rewrite_star (Some id) o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> [ rewrite_star (Some id) o Termops.all_occurrences c tac ] | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> [ rewrite_star None o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> [ rewrite_star None o Termops.all_occurrences c tac ] END (**********************************************************************) (* Hint Rewrite *) let add_rewrite_hint name ort t lcsr = let env = Global.env() and sigma = Evd.empty in let f c = Topconstr.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in add_rew_rules name (List.map f lcsr) VERNAC COMMAND EXTEND HintRewrite [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] -> [ add_rewrite_hint b o (Tacexpr.TacId []) l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident(b) ] -> [ add_rewrite_hint b o t l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> [ add_rewrite_hint "core" o (Tacexpr.TacId []) l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> [ add_rewrite_hint "core" o t l ] END (**********************************************************************) (* Hint Resolve *) open Term open Coqlib let project_hint pri l2r c = let env = Global.env() in let c = Constrintern.interp_constr Evd.empty env c in let t = Retyping.get_type_of env Evd.empty c in let t = Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in let sign,ccl = decompose_prod_assum t in let (a,b) = match snd (decompose_app ccl) with | [a;b] -> (a,b) | _ -> assert false in let p = if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in (pri,true,Auto.PathAny,c) let add_hints_iff l2r lc n bl = Auto.add_hints true bl (Auto.HintsResolveEntry (List.map (project_hint n l2r) lc)) VERNAC COMMAND EXTEND HintResolveIffLR [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ add_hints_iff true lc n bl ] | [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) ] -> [ add_hints_iff true lc n ["core"] ] END VERNAC COMMAND EXTEND HintResolveIffRL [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ add_hints_iff false lc n bl ] | [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) ] -> [ add_hints_iff false lc n ["core"] ] END (**********************************************************************) (* Refine *) open Refine TACTIC EXTEND refine [ "refine" casted_open_constr(c) ] -> [ refine c ] END let refine_tac = h_refine (**********************************************************************) (* Inversion lemmas (Leminv) *) open Inv open Leminv VERNAC COMMAND EXTEND DeriveInversionClear [ "Derive" "Inversion_clear" ident(na) hyp(id) ] -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_clear_tac ] | [ "Derive" "Inversion_clear" natural(n) ident(na) hyp(id) ] -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_clear_tac ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] -> [ add_inversion_lemma_exn na c (Glob_term.GProp Term.Null) false inv_clear_tac ] END open Term open Glob_term VERNAC COMMAND EXTEND DeriveInversion | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] -> [ add_inversion_lemma_exn na c s false inv_tac ] | [ "Derive" "Inversion" ident(na) "with" constr(c) ] -> [ add_inversion_lemma_exn na c (GProp Null) false inv_tac ] | [ "Derive" "Inversion" ident(na) hyp(id) ] -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_tac ] | [ "Derive" "Inversion" natural(n) ident(na) hyp(id) ] -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversion | [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] -> [ add_inversion_lemma_exn na c s true dinv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversionClear | [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] END (**********************************************************************) (* Subst *) TACTIC EXTEND subst | [ "subst" ne_var_list(l) ] -> [ subst l ] | [ "subst" ] -> [ fun gl -> subst_all gl ] END let simple_subst_tactic_flags = { only_leibniz = true; rewrite_dependent_proof = false } TACTIC EXTEND simple_subst | [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags ] END open Evar_tactics (**********************************************************************) (* Evar creation *) TACTIC EXTEND evar [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] | [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] END open Tacexpr open Tacticals TACTIC EXTEND instantiate [ "instantiate" "(" integer(i) ":=" glob(c) ")" hloc(hl) ] -> [instantiate i c hl ] | [ "instantiate" ] -> [ tclNORMEVAR ] END (**********************************************************************) (** Nijmegen "step" tactic for setoid rewriting *) open Tactics open Tactics open Libnames open Glob_term open Summary open Libobject open Lib (* Registered lemmas are expected to be of the form x R y -> y == z -> x R z (in the right table) x R y -> x == z -> z R y (in the left table) *) let transitivity_right_table = ref [] let transitivity_left_table = ref [] (* [step] tries to apply a rewriting lemma; then apply [tac] intended to complete to proof of the last hypothesis (assumed to state an equality) *) let step left x tac = let l = List.map (fun lem -> tclTHENLAST (apply_with_bindings (lem, ImplicitBindings [x])) tac) !(if left then transitivity_left_table else transitivity_right_table) in tclFIRST l (* Main function to push lemmas in persistent environment *) let cache_transitivity_lemma (_,(left,lem)) = if left then transitivity_left_table := lem :: !transitivity_left_table else transitivity_right_table := lem :: !transitivity_right_table let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) let inTransitivity : bool * constr -> obj = declare_object {(default_object "TRANSITIVITY-STEPS") with cache_function = cache_transitivity_lemma; open_function = (fun i o -> if i=1 then cache_transitivity_lemma o); subst_function = subst_transitivity_lemma; classify_function = (fun o -> Substitute o) } (* Synchronisation with reset *) let freeze () = !transitivity_left_table, !transitivity_right_table let unfreeze (l,r) = transitivity_left_table := l; transitivity_right_table := r let init () = transitivity_left_table := []; transitivity_right_table := [] let _ = declare_summary "transitivity-steps" { freeze_function = freeze; unfreeze_function = unfreeze; init_function = init } (* Main entry points *) let add_transitivity_lemma left lem = let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) TACTIC EXTEND stepl | ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ] | ["stepl" constr(c) ] -> [ step true c tclIDTAC ] END TACTIC EXTEND stepr | ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ] | ["stepr" constr(c) ] -> [ step false c tclIDTAC ] END VERNAC COMMAND EXTEND AddStepl | [ "Declare" "Left" "Step" constr(t) ] -> [ add_transitivity_lemma true t ] END VERNAC COMMAND EXTEND AddStepr | [ "Declare" "Right" "Step" constr(t) ] -> [ add_transitivity_lemma false t ] END VERNAC COMMAND EXTEND ImplicitTactic | [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ] END (**********************************************************************) (*spiwack : Vernac commands for retroknowledge *) VERNAC COMMAND EXTEND RetroknowledgeRegister | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in Global.register f tc tb ] END (**********************************************************************) (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs | ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] END TACTIC EXTEND dep_generalize_eqs | ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] END TACTIC EXTEND generalize_eqs_vars | ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] END TACTIC EXTEND dep_generalize_eqs_vars | ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] END (** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated during dependent induction. For internal use. *) TACTIC EXTEND specialize_eqs [ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] END (**********************************************************************) (* A tactic that considers a given occurrence of [c] in [t] and *) (* abstract the minimal set of all the occurrences of [c] so that the *) (* abstraction [fun x -> t[x/c]] is well-typed *) (* *) (* Contributed by Chung-Kil Hur (Winter 2009) *) (**********************************************************************) let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Termops.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec = function | GVar (_,id) as x -> if id = tid then (decr occref; if !occref = 0 then x else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))) else x | c -> map_glob_constr_left_to_right substrec c in let t' = substrec t in if !occref > 0 then Termops.error_invalid_occurrence [occ] else t' let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec = function | GHole (_,Evd.QuestionMark(Evd.Define true)) -> decr occref; if !occref = 0 then tc else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))) | c -> map_glob_constr_left_to_right substrec c in substrec t open Tacmach let out_arg = function | ArgVar _ -> anomaly "Unevaluated or_var variable" | ArgArg x -> x let hResolve id c occ t gl = let sigma = project gl in let env = Termops.clear_named_body id (pf_env gl) in let env_ids = Termops.ids_of_context env in let env_names = Termops.names_of_rel_context env in let c_raw = Detyping.detype true env_ids env_names c in let t_raw = Detyping.detype true env_ids env_names t in let rec resolve_hole t_hole = try Pretyping.Default.understand sigma env t_hole with | Loc.Exc_located (loc,Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _)) -> resolve_hole (subst_hole_with_term (fst (unloc loc)) c_raw t_hole) in let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in let t_constr_type = Retyping.get_type_of env sigma t_constr in change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl let hResolve_auto id c t gl = let rec resolve_auto n = try hResolve id c n t gl with | UserError _ as e -> raise e | e when Errors.noncritical e -> resolve_auto (n+1) in resolve_auto 1 TACTIC EXTEND hresolve_core | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c (out_arg occ) t ] | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] END (** hget_evar *) open Evar_refiner open Sign let hget_evar n gl = let sigma = project gl in let evl = evar_list sigma (pf_concl gl) in if List.length evl < n then error "Not enough uninstantiated existential variables."; if n <= 0 then error "Incorrect existential variable index."; let ev = List.nth evl (n-1) in let ev_type = existential_type sigma ev in change_in_concl None (mkLetIn (Anonymous,mkEvar ev,ev_type,pf_concl gl)) gl TACTIC EXTEND hget_evar | [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ] END (**********************************************************************) (**********************************************************************) (* A tactic that reduces one match t with ... by doing destruct t. *) (* if t is not a variable, the tactic does *) (* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) (* preserved). *) (* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) (**********************************************************************) exception Found of tactic let rewrite_except h g = tclMAP (fun id -> if id = h then tclIDTAC else tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true true id (mkVar h) false)) (Tacmach.pf_ids_of_hyps g) g let refl_equal = let coq_base_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in function () -> (coq_base_constant "eq_refl") (* This is simply an implementation of the case_eq tactic. this code should be replaced by a call to the tactic but I don't know how to call it before it is defined. *) let mkCaseEq a : tactic = (fun g -> let type_of_a = Tacmach.pf_type_of g a in tclTHENLIST [Hiddentac.h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; (fun g2 -> change_in_concl None (Tacred.pattern_occs [((false,[1]), a)] (Tacmach.pf_env g2) Evd.empty (Tacmach.pf_concl g2)) g2); simplest_case a] g);; let case_eq_intros_rewrite x g = let n = nb_prod (Tacmach.pf_concl g) in Pp.msgnl (Printer.pr_lconstr x); tclTHENLIST [ mkCaseEq x; (fun g -> let n' = nb_prod (Tacmach.pf_concl g) in let h = fresh_id (Tacmach.pf_ids_of_hyps g) (id_of_string "heq") g in tclTHENLIST [ (tclDO (n'-n-1) intro); Tacmach.introduction h; rewrite_except h] g ) ] g let rec find_a_destructable_match t = match kind_of_term t with | Case (_,_,x,_) when closed0 x -> if isVar x then (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic(<:tactic>))) else let _ = Pp.msgnl (Printer.pr_lconstr x) in raise (Found (case_eq_intros_rewrite x)) | _ -> iter_constr find_a_destructable_match t let destauto t = try find_a_destructable_match t; error "No destructable match found" with Found tac -> tac let destauto_in id g = let ctype = Tacmach.pf_type_of g (mkVar id) in Pp.msgnl (Printer.pr_lconstr (mkVar id)); Pp.msgnl (Printer.pr_lconstr (ctype)); destauto ctype g TACTIC EXTEND destauto | [ "destauto" ] -> [ (fun g -> destauto (Tacmach.pf_concl g) g) ] | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] END (* ********************************************************************* *) TACTIC EXTEND constr_eq | [ "constr_eq" constr(x) constr(y) ] -> [ if eq_constr x y then tclIDTAC else tclFAIL 0 (str "Not equal") ] END TACTIC EXTEND is_evar | [ "is_evar" constr(x) ] -> [ match kind_of_term x with | Evar _ -> tclIDTAC | _ -> tclFAIL 0 (str "Not an evar") ] END let rec has_evar x = match kind_of_term x with | Evar _ -> true | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> false | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> has_evar t1 || has_evar t2 | LetIn (_, t1, t2, t3) -> has_evar t1 || has_evar t2 || has_evar t3 | App (t1, ts) -> has_evar t1 || has_evar_array ts | Case (_, t1, t2, ts) -> has_evar t1 || has_evar t2 || has_evar_array ts | Fix ((_, tr)) | CoFix ((_, tr)) -> has_evar_prec tr and has_evar_array x = array_exists has_evar x and has_evar_prec (_, ts1, ts2) = array_exists has_evar ts1 || array_exists has_evar ts2 TACTIC EXTEND has_evar | [ "has_evar" constr(x) ] -> [ if has_evar x then tclIDTAC else tclFAIL 0 (str "No evars") ] END TACTIC EXTEND is_hyp | [ "is_var" constr(x) ] -> [ match kind_of_term x with | Var _ -> tclIDTAC | _ -> tclFAIL 0 (str "Not a variable or hypothesis") ] END TACTIC EXTEND is_fix | [ "is_fix" constr(x) ] -> [ match kind_of_term x with | Fix _ -> Tacticals.tclIDTAC | _ -> Tacticals.tclFAIL 0 (Pp.str "not a fix definition") ] END;; (* Command to grab the evars left unresolved at the end of a proof. *) (* spiwack: I put it in extratactics because it is somewhat tied with the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars [ "Grab" "Existential" "Variables" ] -> [ let p = Proof_global.give_me_the_proof () in Proof.V82.grab_evars p; Flags.if_verbose (fun () -> Pp.msg (Printer.pr_open_subgoals ())) () ] END coq-8.4pl3/tactics/tacticals.ml0000640000175000017500000003713612255245502015561 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tclFAIL 0 (str "No applicable tactic") | [a] -> tac a (* so that returned failure is the one from last item *) | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl) (************************************************************************) (* Tacticals applying on hypotheses *) (************************************************************************) let nthDecl m gl = try List.nth (pf_hyps gl) (m-1) with Failure _ -> error "No such assumption." let nthHypId m gl = pi1 (nthDecl m gl) let nthHyp m gl = mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl let lastHypId gl = nthHypId 1 gl let lastHyp gl = nthHyp 1 gl let nLastDecls n gl = try list_firstn n (pf_hyps gl) with Failure _ -> error "Not enough hypotheses in the goal." let nLastHypsId n gl = List.map pi1 (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) let onNthDecl m tac gl = tac (nthDecl m gl) gl let onNthHypId m tac gl = tac (nthHypId m gl) gl let onNthHyp m tac gl = tac (nthHyp m gl) gl let onLastDecl = onNthDecl 1 let onLastHypId = onNthHypId 1 let onLastHyp = onNthHyp 1 let onHyps find tac gl = tac (find gl) gl let onNLastDecls n tac = onHyps (nLastDecls n) tac let onNLastHypsId n tac = onHyps (nLastHypsId n) tac let onNLastHyps n tac = onHyps (nLastHyps n) tac let afterHyp id gl = fst (list_split_when (fun (hyp,_,_) -> hyp = id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) (***************************************) (* The following functions introduce several tactic combinators and functions useful for working with clauses. A clause is either None or (Some id), where id is an identifier. This type is useful for defining tactics that may be used either to transform the conclusion (None) or to transform a hypothesis id (Some id). -- --Eduardo (8/8/97) *) (* A [simple_clause] is a set of hypotheses, possibly extended with the conclusion (conclusion is represented by None) *) type simple_clause = identifier option list (* An [clause] is the algebraic form of a [concrete_clause]; it may refer to all hypotheses independently of the effective contents of the current goal *) type clause = identifier gclause let allHypsAndConcl = { onhyps=None; concl_occs=all_occurrences_expr } let allHyps = { onhyps=None; concl_occs=no_occurrences_expr } let onConcl = { onhyps=Some[]; concl_occs=all_occurrences_expr } let onHyp id = { onhyps=Some[((all_occurrences_expr,id),InHyp)]; concl_occs=no_occurrences_expr } let simple_clause_of cl gls = let error_occurrences () = error "This tactic does not support occurrences selection" in let error_body_selection () = error "This tactic does not support body selection" in let hyps = match cl.onhyps with | None -> List.map Option.make (pf_ids_of_hyps gls) | Some l -> List.map (fun ((occs,id),w) -> if occs <> all_occurrences_expr then error_occurrences (); if w = InHypValueOnly then error_body_selection (); Some id) l in if cl.concl_occs = no_occurrences_expr then hyps else if cl.concl_occs <> all_occurrences_expr then error_occurrences () else None :: hyps let fullGoal gl = None :: List.map Option.make (pf_ids_of_hyps gl) let onAllHyps tac gl = tclMAP tac (pf_ids_of_hyps gl) gl let onAllHypsAndConcl tac gl = tclMAP tac (fullGoal gl) gl let tryAllHyps tac gl = tclFIRST_PROGRESS_ON tac (pf_ids_of_hyps gl) gl let tryAllHypsAndConcl tac gl = tclFIRST_PROGRESS_ON tac (fullGoal gl) gl let onClause tac cl gls = tclMAP tac (simple_clause_of cl gls) gls let onClauseLR tac cl gls = tclMAP tac (List.rev (simple_clause_of cl gls)) gls let ifOnHyp pred tac1 tac2 id gl = if pred (id,pf_get_hyp_typ gl id) then tac1 id gl else tac2 id gl (************************************************************************) (* An intermediate form of occurrence clause that select components *) (* of a definition, hypotheses and possibly the goal *) (* (used for reduction tactics) *) (************************************************************************) (* A [hyp_location] is an hypothesis together with a position, in body if any, in type or in both *) type hyp_location = identifier * hyp_location_flag (* A [goal_location] is either an hypothesis (together with a position, in body if any, in type or in both) or the goal *) type goal_location = hyp_location option (************************************************************************) (* An intermediate structure for dealing with occurrence clauses *) (************************************************************************) (* [clause_atom] refers either to an hypothesis location (i.e. an hypothesis with occurrences and a position, in body if any, in type or in both) or to some occurrences of the conclusion *) type clause_atom = | OnHyp of identifier * occurrences_expr * hyp_location_flag | OnConcl of occurrences_expr (* A [concrete_clause] is an effective collection of occurrences in the hypotheses and the conclusion *) type concrete_clause = clause_atom list let concrete_clause_of cl gls = let hyps = match cl.onhyps with | None -> let f id = OnHyp (id,all_occurrences_expr,InHyp) in List.map f (pf_ids_of_hyps gls) | Some l -> List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in if cl.concl_occs = no_occurrences_expr then hyps else OnConcl cl.concl_occs :: hyps (************************************************************************) (* Elimination Tacticals *) (************************************************************************) (* The following tacticals allow to apply a tactic to the branches generated by the application of an elimination tactic. Two auxiliary types --branch_args and branch_assumptions-- are used to keep track of some information about the ``branches'' of the elimination. *) type branch_args = { ity : inductive; (* the type we were eliminating on *) largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) pred : constr; (* the predicate we used *) nassums : int; (* the number of assumptions to be introduced *) branchsign : bool list; (* the signature of the branch. true=recursive argument, false=constant *) branchnames : intro_pattern_expr located list} type branch_assumptions = { ba : branch_args; (* the branch args *) assums : named_context} (* the list of assumptions introduced *) let fix_empty_or_and_pattern nv l = (* 1- The syntax does not distinguish between "[ ]" for one clause with no names and "[ ]" for no clause at all *) (* 2- More generally, we admit "[ ]" for any disjunctive pattern of arbitrary length *) if l = [[]] then list_make nv [] else l let check_or_and_pattern_size loc names n = if List.length names <> n then if n = 1 then user_err_loc (loc,"",str "Expects a conjunctive pattern.") else user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") let compute_induction_names n = function | None -> Array.make n [] | Some (loc,IntroOrAndPattern names) -> let names = fix_empty_or_and_pattern n names in check_or_and_pattern_size loc names n; Array.of_list names | Some (loc,_) -> user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.") let compute_construtor_signatures isrec (_,k as ity) = let rec analrec c recargs = match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> let b = match dest_recarg recarg with | Norec | Imbr _ -> false | Mrec (_,j) -> isrec & j=k in b :: (analrec c rest) | LetIn (_,_,_,c), rest -> false :: (analrec c rest) | _, [] -> [] | _ -> anomaly "compute_construtor_signatures" in let (mib,mip) = Global.lookup_inductive ity in let n = mib.mind_nparams in let lc = Array.map (fun c -> snd (decompose_prod_n_assum n c)) mip.mind_nf_lc in let lrecargs = dest_subterms mip.mind_recargs in array_map2 analrec lc lrecargs let elimination_sort_of_goal gl = pf_apply Retyping.get_sort_family_of gl (pf_concl gl) let elimination_sort_of_hyp id gl = pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) let elimination_sort_of_clause = function | None -> elimination_sort_of_goal | Some id -> elimination_sort_of_hyp id (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate (indbindings,elimbindings) ind indclause gl = let elim = mk_elim ind gl in (* applying elimination_scheme just a little modified *) let indclause' = clenv_match_args indbindings indclause in let elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in let indmv = match kind_of_term (last_arg elimclause.templval.Evd.rebus) with | Meta mv -> mv | _ -> anomaly "elimination" in let pmv = let p, _ = decompose_app elimclause.templtyp.Evd.rebus in match kind_of_term p with | Meta p -> p | _ -> let name_elim = match kind_of_term elim with | Const kn -> string_of_con kn | Var id -> string_of_id id | _ -> "\b" in error ("The elimination combinator " ^ name_elim ^ " is unknown.") in let elimclause' = clenv_fchain indmv elimclause indclause' in let elimclause' = clenv_match_args elimbindings elimclause' in let branchsigns = compute_construtor_signatures isrec ind in let brnames = compute_induction_names (Array.length branchsigns) allnames in let after_tac ce i gl = let (hd,largs) = decompose_app ce.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); nassums = List.fold_left (fun acc b -> if b then acc+2 else acc+1) 0 branchsigns.(i); branchnum = i+1; ity = ind; largs = List.map (clenv_nf_meta ce) largs; pred = clenv_nf_meta ce hd } in tac ba gl in let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in let elimclause' = match predicate with | None -> elimclause' | Some p -> clenv_unify ~flags:Unification.elim_flags Reduction.CONV (mkMeta pmv) p elimclause' in elim_res_pf_THEN_i elimclause' branchtacs gl (* computing the case/elim combinators *) let gl_make_elim ind gl = Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) let gl_make_case_dep ind gl = pf_apply Indrec.build_case_analysis_scheme gl ind true (elimination_sort_of_goal gl) let gl_make_case_nodep ind gl = pf_apply Indrec.build_case_analysis_scheme gl ind false (elimination_sort_of_goal gl) let elimination_then_using tac predicate bindings c gl = let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let indclause = mk_clenv_from gl (c,t) in general_elim_then_using gl_make_elim true None tac predicate bindings ind indclause gl let case_then_using = general_elim_then_using gl_make_case_dep false let case_nodep_then_using = general_elim_then_using gl_make_case_nodep false let elimination_then tac = elimination_then_using tac None let simple_elimination_then tac = elimination_then tac ([],[]) let make_elim_branch_assumptions ba gl = let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc = match lb,lc with | ([], _) -> { ba = ba; assums = assums} | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) -> makerec (recarg::indarg::assums, idrec::cargs, idrec::recargs, constargs, idind::indargs) tl idtl | ((false::tl), ((id,_,_ as constarg)::idtl)) -> makerec (constarg::assums, id::cargs, id::constargs, recargs, indargs) tl idtl | (_, _) -> anomaly "make_elim_branch_assumptions" in makerec ([],[],[],[],[]) ba.branchsign (try list_firstn ba.nassums (pf_hyps gl) with Failure _ -> anomaly "make_elim_branch_assumptions") let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl let make_case_branch_assumptions ba gl = let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 = match p_0,p_1 with | ([], _) -> { ba = ba; assums = assums} | ((true::tl), ((idrec,_,_ as recarg)::idtl)) -> makerec (recarg::assums, idrec::cargs, idrec::recargs, constargs) tl idtl | ((false::tl), ((id,_,_ as constarg)::idtl)) -> makerec (constarg::assums, id::cargs, recargs, id::constargs) tl idtl | (_, _) -> anomaly "make_case_branch_assumptions" in makerec ([],[],[],[]) ba.branchsign (try list_firstn ba.nassums (pf_hyps gl) with Failure _ -> anomaly "make_case_branch_assumptions") let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl coq-8.4pl3/tactics/inv.ml0000640000175000017500000004435312255245502014405 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mv::acc | _ -> fold_constr collrec acc c in collrec [] c let check_no_metas clenv ccl = if occur_meta ccl then let metas = List.filter (fun m -> not (Evd.meta_defined clenv.evd m)) (collect_meta_variables ccl) in let metas = List.map (Evd.meta_name clenv.evd) metas in errorlabstrm "inversion" (str ("Cannot find an instantiation for variable"^ (if List.length metas = 1 then " " else "s ")) ++ prlist_with_sep pr_comma pr_name metas (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *)) let var_occurs_in_pf gl id = let env = pf_env gl in occur_var env id (pf_concl gl) or List.exists (occur_var_in_decl env id) (pf_hyps gl) (* [make_inv_predicate (ity,args) C] is given the inductive type, its arguments, both the global parameters and its local arguments, and is expected to produce a predicate P such that if largs is the "local" part of the arguments, then (P largs) will be convertible with a conclusion of the form: a1=a1->a2=a2 ... -> C Algorithm: suppose length(largs)=n (1) Push the entire arity, [xbar:Abar], carrying along largs and the conclusion (2) Pair up each ai with its respective Rel version: a1==(Rel n), a2==(Rel n-1), etc. (3) For each pair, ai,Rel j, if the Ai is dependent - that is, the type of [Rel j] is an open term, then we construct the iterated tuple, [make_iterated_tuple] does it, and use that for our equation Otherwise, we just use ai=Rel j *) type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = (ai, (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))) let make_inv_predicate env sigma indf realargs id status concl = let nrealargs = List.length realargs in let (hyps,concl) = match status with | NoDep -> (* We push the arity and leave concl unchanged *) let hyps_arity,_ = get_arity env indf in (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env id concl) then errorlabstrm "make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have c also rewritten when the case * will be done *) let pred = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> let sort = get_sort_family_of env sigma concl in let p = make_arity env true indf (new_sort_in_family sort) in Unification.abstract_list_all env (Evd.create_evar_defs sigma) p concl (realargs@[mkVar id]) in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) in let nhyps = rel_context_length hyps in let env' = push_rel_context hyps env in let realargs' = List.map (lift nhyps) realargs in let pairs = list_map_i (compute_eqn env' sigma nhyps) 0 realargs' in (* Now the arity is pushed, and we need to construct the pairs * ai,mkRel(n-i+1) *) (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push (mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) let rec build_concl eqns n = function | [] -> (it_mkProd concl eqns,n) | (ai,(xi,ti))::restlist -> let (lhs,eqnty,rhs) = if closed0 ti then (xi,ti,ai) else make_iterated_tuple env' sigma ai (xi,ti) in let eq_term = Coqlib.build_coq_eq () in let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist in let (newconcl,neqns) = build_concl [] 0 pairs in let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) (predicate,neqns) (* The result of the elimination is a bunch of goals like: |- (cibar:Cibar)Equands->C where the cibar are either dependent or not. We are fed a signature, with "true" for every recursive argument, and false for every non-recursive one. So we need to do the sign_branch_len(sign) intros, thinning out all recursive assumptions. This leaves us with exactly length(sign) assumptions. We save their names, and then do introductions for all the equands (there are some number of them, which is the other argument of the tactic) This gives us the #neqns equations, whose names we get also, and the #length(sign) arguments. Suppose that #nodep of these arguments are non-dependent. Generalize and thin them. This gives us #dep = #length(sign)-#nodep arguments which are dependent. Now, we want to take each of the equations, and do all possible injections to get the left-hand-side to be a variable. At the same time, if we find a lhs/rhs pair which are different, we can discriminate them to prove false and finish the branch. Then, we thin away the equations, and do the introductions for the #nodep arguments which we generalized before. *) (* Called after the case-assumptions have been killed off, and all the intros have been done. Given that the clause in question is an equality (if it isn't we fail), we are responsible for projecting the equality, using Injection and Discriminate, and applying it to the concusion *) (* Computes the subset of hypothesis in the local context whose type depends on t (should be of the form (mkVar id)), then it generalizes them, applies tac to rewrite all occurrencies of t, and introduces generalized hypotheis. Precondition: t=(mkVar id) *) let rec dependent_hyps id idlist gl = let rec dep_rec =function | [] -> [] | (id1,_,_)::l -> (* Update the type of id1: it may have been subject to rewriting *) let d = pf_get_hyp gl id1 in if occur_var_in_decl (Global.env()) id d then d :: dep_rec l else dep_rec l in dep_rec idlist let split_dep_and_nodep hyps gl = List.fold_right (fun (id,_,_ as d) (l1,l2) -> if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) open Coqlib (* Computation of dids is late; must have been done in rewrite_equations*) (* Will keep generalizing and introducing back and forth... *) (* Moreover, others hyps depending of dids should have been *) (* generalized; in such a way that [dids] can endly be cleared *) (* Consider for instance this case extracted from Well_Ordering.v A : Set B : A ->Set a0 : A f : (B a0) ->WO y : WO H0 : (le_WO y (sup a0 f)) ============================ (Acc WO le_WO y) Inversion H0 gives A : Set B : A ->Set a0 : A f : (B a0) ->WO y : WO H0 : (le_WO y (sup a0 f)) a1 : A f0 : (B a1) ->WO v : (B a1) H1 : (f0 v)=y H3 : a1=a0 f1 : (B a0) ->WO v0 : (B a0) H4 : (existS A [a:A](B a) ->WO a0 f1)=(existS A [a:A](B a) ->WO a0 f) ============================ (Acc WO le_WO (f1 v0)) while, ideally, we would have expected A : Set B : A ->Set a0 : A f0 : (B a0)->WO v : (B a0) ============================ (Acc WO le_WO (f0 v)) obtained from destruction with equalities A : Set B : A ->Set a0 : A f : (B a0) ->WO y : WO H0 : (le_WO y (sup a0 f)) a1 : A f0 : (B a1)->WO v : (B a1) H1 : (f0 v)=y H2 : (sup a1 f0)=(sup a0 f) ============================ (Acc WO le_WO (f0 v)) by clearing initial hypothesis H0 and its dependency y, clearing H1 (in fact H1 can be avoided using the same trick as for newdestruct), decomposing H2 to get a1=a0 and (a1,f0)=(a0,f), replacing a1 by a0 everywhere and removing a1 and a1=a0 (in fact it would have been more regular to replace a0 by a1, avoiding f1 and v0 cannot replace f0 and v), finally removing H4 (here because f is not used, more generally after using eq_dep and replacing f by f0) [and finally rename a0, f0 into a,f]. Summary: nine useless hypotheses! Nota: with Inversion_clear, only four useless hypotheses *) let generalizeRewriteIntros tac depids id gls = let dids = dependent_hyps id depids gls in (tclTHENSEQ [bring_hyps dids; tac; (* may actually fail to replace if dependent in a previous eq *) intros_replacing (ids_of_named_context dids)]) gls let rec tclMAP_i n tacfun = function | [] -> tclDO n (tacfun None) | a::l -> if n=0 then error "Too many names." else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l) let remember_first_eq id x = if !x = no_move then x := MoveAfter id (* invariant: ProjectAndApply is responsible for erasing the clause which it is given as input It simplifies the clause (an equality) to use it as a rewrite rule and then erases the result of the simplification. *) (* invariant: ProjectAndApplyNoThining simplifies the clause (an equality) . If it can discriminate then the goal is proved, if not tries to use it as a rewrite rule. It erases the clause which is given as input *) let projectAndApply thin id eqname names depids gls = let subst_hyp l2r id = tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id))) (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in let substHypIfVariable tac id gls = let (t,t1,t2) = Hipattern.dest_nf_eq gls (pf_get_hyp_typ gls id) in match (kind_of_term t1, kind_of_term t2) with | Var id1, _ -> generalizeRewriteIntros (subst_hyp true id) depids id1 gls | _, Var id2 -> generalizeRewriteIntros (subst_hyp false id) depids id2 gls | _ -> tac id gls in let deq_trailer id neqns = tclTHENSEQ [(if names <> [] then clear [id] else tclIDTAC); (tclMAP_i neqns (fun idopt -> tclTRY (tclTHEN (intro_move idopt no_move) (* try again to substitute and if still not a variable after *) (* decomposition, arbitrarily try to rewrite RL !? *) (tclTRY (onLastHypId (substHypIfVariable (subst_hyp false)))))) names); (if names = [] then clear [id] else tclIDTAC)] in substHypIfVariable (* If no immediate variable in the equation, try to decompose it *) (* and apply a trailer which again try to substitute *) (fun id -> dEqThen false (deq_trailer id) (Some (ElimOnConstr (mkVar id,NoBindings)))) id gls (* Inversion qui n'introduit pas les hypotheses, afin de pouvoir les nommer soi-meme (proposition de Valerie). *) let rewrite_equations_gene othin neqns ba gl = let (depids,nodepids) = split_dep_and_nodep ba.assums gl in let rewrite_eqns = match othin with | Some thin -> onLastHypId (fun last -> tclTHENSEQ [tclDO neqns (tclTHEN intro (onLastHypId (fun id -> tclTRY (projectAndApply thin id (ref no_move) [] depids)))); onHyps (compose List.rev (afterHyp last)) bring_hyps; onHyps (afterHyp last) (compose clear ids_of_named_context)]) | None -> tclIDTAC in (tclTHENSEQ [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids); onHyps (compose List.rev (nLastDecls neqns)) bring_hyps; onHyps (nLastDecls neqns) (compose clear ids_of_named_context); rewrite_eqns; tclMAP (fun (id,_,_ as d) -> (tclORELSE (clear [id]) (tclTHEN (bring_hyps [d]) (clear [id])))) depids]) gl (* Introduction of the equations on arguments othin: discriminates Simple Inversion, Inversion and Inversion_clear None: the equations are introduced, but not rewritten Some thin: the equations are rewritten, and cleared if thin is true *) let rec get_names allow_conj (loc,pat) = match pat with | IntroWildcard -> error "Discarding pattern not allowed for inversion equations." | IntroAnonymous | IntroForthcoming _ -> error "Anonymous pattern not allowed for inversion equations." | IntroFresh _ -> error "Fresh pattern not allowed for inversion equations." | IntroRewrite _-> error "Rewriting pattern not allowed for inversion equations." | IntroOrAndPattern [l] -> if allow_conj then if l = [] then (None,[]) else let l = List.map (fun id -> Option.get (fst (get_names false id))) l in (Some (List.hd l), l) else error"Nested conjunctive patterns not allowed for inversion equations." | IntroOrAndPattern l -> error "Disjunctive patterns not allowed for inversion equations." | IntroIdentifier id -> (Some id,[id]) let extract_eqn_names = function | None -> None,[] | Some x -> x let rewrite_equations othin neqns names ba gl = let names = List.map (get_names true) names in let (depids,nodepids) = split_dep_and_nodep ba.assums gl in let rewrite_eqns = let first_eq = ref no_move in match othin with | Some thin -> tclTHENSEQ [onHyps (compose List.rev (nLastDecls neqns)) bring_hyps; onHyps (nLastDecls neqns) (compose clear ids_of_named_context); tclMAP_i neqns (fun o -> let idopt,names = extract_eqn_names o in (tclTHEN (intro_move idopt no_move) (onLastHypId (fun id -> tclTRY (projectAndApply thin id first_eq names depids))))) names; tclMAP (fun (id,_,_) gl -> intro_move None (if thin then no_move else !first_eq) gl) nodepids; tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids] | None -> tclIDTAC in (tclTHENSEQ [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids); rewrite_eqns]) gl let interp_inversion_kind = function | SimpleInversion -> None | FullInversion -> Some false | FullInversionClear -> Some true let rewrite_equations_tac (gene, othin) id neqns names ba = let othin = interp_inversion_kind othin in let tac = if gene then rewrite_equations_gene othin neqns ba else rewrite_equations othin neqns names ba in if othin = Some true (* if Inversion_clear, clear the hypothesis *) then tclTHEN tac (tclTRY (clear [id])) else tac let raw_inversion inv_kind id status names gl = let env = pf_env gl and sigma = project gl in let c = mkVar id in let (ind,t) = try pf_reduce_to_atomic_ind gl (pf_type_of gl c) with UserError _ -> errorlabstrm "raw_inversion" (str ("The type of "^(string_of_id id)^" is not inductive.")) in let indclause = mk_clenv_from gl (c,t) in let ccl = clenv_type indclause in check_no_metas indclause ccl; let IndType (indf,realargs) = find_rectype env sigma ccl in let (elim_predicate,neqns) = make_inv_predicate env sigma indf realargs id status (pf_concl gl) in let (cut_concl,case_tac) = if status <> NoDep & (dependent c (pf_concl gl)) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), case_then_using else Reduction.beta_appvect elim_predicate (Array.of_list realargs), case_nodep_then_using in (tclTHENS (assert_tac Anonymous cut_concl) [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ([],[]) ind indclause; onLastHypId (fun id -> (tclTHEN (apply_term (mkVar id) (list_tabulate (fun _ -> Evarutil.mk_new_meta()) neqns)) reflexivity))]) gl (* Error messages of the inversion tactics *) let wrap_inv_error id = function | Indrec.RecursionSchemeError (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> errorlabstrm "" (strbrk "Inversion would require case analysis on sort " ++ pr_sort k ++ strbrk " which is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str ".") | e -> raise e (* The most general inversion tactic *) let inversion inv_kind status names id gls = try (raw_inversion inv_kind id status names) gls with e when Errors.noncritical e -> wrap_inv_error id e (* Specializing it... *) let inv_gen gene thin status names = try_intros_until (inversion (gene,thin) status names) open Tacexpr let inv k = inv_gen false k NoDep let half_inv_tac id = inv SimpleInversion None (NamedHyp id) let inv_tac id = inv FullInversion None (NamedHyp id) let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) let dinv k c = inv_gen false k (Dep c) let half_dinv_tac id = dinv SimpleInversion None None (NamedHyp id) let dinv_tac id = dinv FullInversion None None (NamedHyp id) let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) (* InvIn will bring the specified clauses into the conclusion, and then * perform inversion on the named hypothesis. After, it will intro them * back to their places in the hyp-list. *) let invIn k names ids id gls = let hyps = List.map (pf_get_hyp gls) ids in let nb_prod_init = nb_prod (pf_concl gls) in let intros_replace_ids gls = let nb_of_new_hyp = nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init) in if nb_of_new_hyp < 1 then intros_replacing ids gls else tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls in try (tclTHENSEQ [bring_hyps hyps; inversion (false,k) NoDep names id; intros_replace_ids]) gls with e when Errors.noncritical e -> wrap_inv_error id e let invIn_gen k names idl = try_intros_until (invIn k names idl) let inv_clause k names = function | [] -> inv k names | idl -> invIn_gen k names idl coq-8.4pl3/tactics/btermdn.mli0000640000175000017500000000200012255245502015374 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* sig type t val create : unit -> t val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t val lookup : transparent_state option -> t -> constr -> (constr_pattern * Z.t) list val app : ((constr_pattern * Z.t) -> unit) -> t -> unit end val dnet_depth : int ref coq-8.4pl3/tactics/leminv.mli0000640000175000017500000000104412255245502015242 0ustar stephstephopen Util open Names open Term open Glob_term open Proof_type open Topconstr val lemInv_gen : quantified_hypothesis -> constr -> tactic val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic val lemInv_clause : quantified_hypothesis -> constr -> identifier list -> tactic val inversion_lemma_from_goal : int -> identifier -> identifier located -> sorts -> bool -> (identifier -> tactic) -> unit val add_inversion_lemma_exn : identifier -> constr_expr -> glob_sort -> bool -> (identifier -> tactic) -> unit coq-8.4pl3/tactics/hightactics.mllib0000640000175000017500000000011112255245502016552 0ustar stephstephRefine Extraargs Extratactics Eauto Class_tactics Rewrite Tauto Eqdecide coq-8.4pl3/tactics/rewrite.ml40000640000175000017500000023762212255245502015361 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = 2 -> let head = if isApp c then fst (destApp c) else c in if eq_constr (Lazy.force coq_eq) head then None else (try let params, args = array_chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in let _ = Typeclasses.resolve_one_typeclass env' evd inst in Some (it_mkProd_or_LetIn t rels) with e when Errors.noncritical e -> None) | _ -> None let _ = Equality.register_is_applied_rewrite_relation is_applied_rewrite_relation let split_head = function hd :: tl -> hd, tl | [] -> assert(false) let new_cstr_evar (goal,cstr) env t = let cstr', t = Evarutil.new_evar cstr env t in (goal, cstr'), t let new_goal_evar (goal,cstr) env t = let goal', t = Evarutil.new_evar goal env t in (goal', cstr), t let build_signature evars env m (cstrs : (types * types option) option list) (finalcstr : (types * types option) option) = let new_evar evars env t = new_cstr_evar evars env (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t in let mk_relty evars newenv ty obj = match obj with | None | Some (_, None) -> let relty = mk_relation ty in if closed0 ty then let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in new_evar evars env' relty else new_evar evars newenv relty | Some (x, Some rel) -> evars, rel in let rec aux env evars ty l = let t = Reductionops.whd_betadeltaiota env (fst evars) ty in match kind_of_term t, l with | Prod (na, ty, b), obj :: cstrs -> if noccurn 1 b (* non-dependent product *) then let ty = Reductionops.nf_betaiota (fst evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in let ty = Reductionops.nf_betaiota (fst evars) ty in let pred = mkLambda (na, ty, b) in let liftarg = mkLambda (na, ty, arg) in let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in if obj = None then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else error "build_signature: no constraint can apply on a dependent argument" | _, obj :: _ -> anomaly "build_signature: not enough products" | _, [] -> (match finalcstr with | None | Some (_, None) -> let t = Reductionops.nf_betaiota (fst evars) ty in let evars, rel = mk_relty evars env t None in evars, t, rel, [t, Some rel] | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) in aux env evars m cstrs let proper_proof env evars carrier relation x = let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |]) in new_cstr_evar evars env goal let extends_undefined evars evars' = let f ev evi found = found || not (Evd.mem evars ev) in fold_undefined f evars' false let find_class_proof proof_type proof_method env evars carrier relation = try let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in let evars', c = Typeclasses.resolve_one_typeclass env evars goal in if extends_undefined evars evars' then raise Not_found else mkApp (Lazy.force proof_method, [| carrier; relation; c |]) with e when Logic.catchable_exception e -> raise Not_found let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env let get_transitive_proof env = find_class_proof transitive_type transitive_proof env exception FoundInt of int let array_find (arr: 'a array) (pred: int -> 'a -> bool): int = try for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done; raise Not_found with FoundInt i -> i type hypinfo = { cl : clausenv; prf : constr; car : constr; rel : constr; l2r : bool; c1 : constr; c2 : constr; c : (Tacinterp.interp_sign * Genarg.glob_constr_and_expr with_bindings) option; abs : (constr * types) option; flags : Unification.unify_flags; } let goalevars evars = fst evars let cstrevars evars = snd evars let evd_convertible env evd x y = try ignore(Evarconv.the_conv_x env x y evd); true with e when Errors.noncritical e -> false let rec decompose_app_rel env evd t = match kind_of_term t with | App (f, args) -> if Array.length args > 1 then let fargs, args = array_chop (Array.length args - 2) args in mkApp (f, fargs), args else let (f', args) = decompose_app_rel env evd args.(0) in let ty = Typing.type_of env evd args.(0) in let f'' = mkLambda (Name (id_of_string "x"), ty, mkLambda (Name (id_of_string "y"), lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', args) | _ -> error "The term provided is not an applied relation." (* let nc, c', cl = push_rel_context_to_named_context env c in *) (* let env' = reset_with_named_context nc env in *) let decompose_applied_relation env sigma flags orig (c,l) left2right = let c' = c in let ctype = Typing.type_of env sigma c' in let find_rel ty = let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in let c1 = args.(0) and c2 = args.(1) in let ty1, ty2 = Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 in if not (evd_convertible env eqclause.evd ty1 ty2) then None else Some { cl=eqclause; prf=(Clenv.clenv_value eqclause); car=ty1; rel = equiv; l2r=left2right; c1=c1; c2=c2; c=orig; abs=None; flags = flags } in match find_rel ctype with | Some c -> c | None -> let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> c | None -> error "The term does not end with an applied homogeneous relation." open Tacinterp let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right = let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in decompose_applied_relation env sigma flags (Some (is, (c,l))) cbl left2right let rewrite_db = "rewrite" let conv_transparent_state = (Idpred.empty, Cpred.full) let _ = Auto.add_auto_init (fun () -> Auto.create_hint_db false rewrite_db conv_transparent_state true) let rewrite_transparent_state () = Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db) let rewrite_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = full_transparent_state; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; Unification.frozen_evars = ExistentialSet.empty; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = false; Unification.modulo_eta = true; Unification.allow_K_in_toplevel_higher_order_unification = true } let rewrite2_unif_flags = { Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = conv_transparent_state; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; Unification.frozen_evars = ExistentialSet.empty; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = true; Unification.modulo_eta = true; Unification.allow_K_in_toplevel_higher_order_unification = true } let general_rewrite_unif_flags () = let ts = rewrite_transparent_state () in { Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; Unification.modulo_delta_types = ts; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; Unification.frozen_evars = ExistentialSet.empty; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = true; Unification.modulo_eta = true; Unification.allow_K_in_toplevel_higher_order_unification = true } let convertible env evd x y = Reductionops.is_conv env evd x y let refresh_hypinfo env sigma hypinfo = if hypinfo.abs = None then let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in match c with | Some c -> (* Refresh the clausenv to not get the same meta twice in the goal. *) decompose_applied_relation_expr env sigma flags c l2r; | _ -> hypinfo else hypinfo let unify_eqn env sigma hypinfo t = if isEvar t then None else try let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in let left = if l2r then c1 else c2 in let env', prf, c1, c2, car, rel = match abs with | Some (absprf, absprfty) -> let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in env', prf, c1, c2, car, rel | None -> let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl in let env' = Clenvtac.clenv_pose_dependent_evars true env' in (* let env' = Clenv.clenv_pose_metas_as_evars env' (Evd.undefined_metas env'.evd) in *) let evd' = Typeclasses.resolve_typeclasses ~fail:true env'.env env'.evd in let env' = { env' with evd = evd' } in let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel and prf = nf (Clenv.clenv_value env') in let ty1 = Typing.type_of env'.env env'.evd c1 and ty2 = Typing.type_of env'.env env'.evd c2 in if convertible env env'.evd ty1 ty2 then ( if occur_meta_or_existential prf then hypinfo := refresh_hypinfo env env'.evd !hypinfo; env', prf, c1, c2, car, rel) else raise Reduction.NotConvertible in let res = if l2r then (prf, (car, rel, c1, c2)) else try (mkApp (get_symmetric_proof env env'.evd car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) with Not_found -> (prf, (car, inverse car rel, c2, c1)) in Some (env'.evd, res) with e when Class_tactics.catchable e -> None (* let unify_eqn env sigma hypinfo t = *) (* if isEvar t then None *) (* else try *) (* let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in *) (* let left = if l2r then c1 else c2 in *) (* let evd', prf, c1, c2, car, rel = *) (* match abs with *) (* | Some (absprf, absprfty) -> *) (* let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in *) (* env'.evd, prf, c1, c2, car, rel *) (* | None -> *) (* let cl' = Clenv.clenv_pose_metas_as_evars cl (Evd.undefined_metas cl.evd) in *) (* let sigma = cl'.evd in *) (* let c1 = Clenv.clenv_nf_meta cl' c1 *) (* and c2 = Clenv.clenv_nf_meta cl' c2 *) (* and prf = Clenv.clenv_nf_meta cl' prf *) (* and car = Clenv.clenv_nf_meta cl' car *) (* and rel = Clenv.clenv_nf_meta cl' rel *) (* in *) (* let sigma' = *) (* try Evarconv.the_conv_x ~ts:empty_transparent_state env t c1 sigma *) (* with Reduction.NotConvertible _ -> *) (* Evarconv.the_conv_x ~ts:conv_transparent_state env t c1 sigma *) (* in *) (* let sigma' = Evarconv.consider_remaining_unif_problems ~ts:conv_transparent_state env sigma' in *) (* let evd' = Typeclasses.resolve_typeclasses ~fail:true env sigma' in *) (* let nf c = Evarutil.nf_evar evd' c in *) (* let c1 = nf c1 and c2 = nf c2 *) (* and car = nf car and rel = nf rel *) (* and prf' = nf prf in *) (* if occur_meta_or_existential prf then *) (* hypinfo := refresh_hypinfo env evd' !hypinfo; *) (* evd', prf', c1, c2, car, rel *) (* in *) (* let res = *) (* if l2r then (prf, (car, rel, c1, c2)) *) (* else *) (* try (mkApp (get_symmetric_proof env Evd.empty car rel, *) (* [| c1 ; c2 ; prf |]), *) (* (car, rel, c2, c1)) *) (* with Not_found -> *) (* (prf, (car, inverse car rel, c2, c1)) *) (* in Some (evd', res) *) (* with Reduction.NotConvertible -> None *) (* | e when Class_tactics.catchable e -> None *) let unfold_impl t = match kind_of_term t with | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> mkProd (Anonymous, a, lift 1 b) | _ -> assert false let unfold_all t = match kind_of_term t with | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> (match kind_of_term b with | Lambda (n, ty, b) -> mkProd (n, ty, b) | _ -> assert false) | _ -> assert false let unfold_forall t = match kind_of_term t with | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> (match kind_of_term b with | Lambda (n, ty, b) -> mkProd (n, ty, b) | _ -> assert false) | _ -> assert false let arrow_morphism ta tb a b = let ap = is_Prop ta and bp = is_Prop tb in if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl else if ap then (* Domain in Prop, CoDomain in Type *) mkProd (Anonymous, a, b), (fun x -> x) else if bp then (* Dummy forall *) mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall else (* None in Prop, use arrow *) mkApp (Lazy.force arrow, [| a; b |]), unfold_impl let rec decomp_pointwise n c = if n = 0 then c else match kind_of_term c with | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> decomp_pointwise (pred n) relb | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) | _ -> raise (Invalid_argument "decomp_pointwise") let rec apply_pointwise rel = function | arg :: args -> (match kind_of_term rel with | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> apply_pointwise relb args | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args | _ -> raise (Invalid_argument "apply_pointwise")) | [] -> rel let pointwise_or_dep_relation n t car rel = if noccurn 1 car && noccurn 1 rel then mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) else mkApp (Lazy.force forall_relation, [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) let lift_cstr env sigma evars (args : constr list) c ty cstr = let start env car = match cstr with | None | Some (_, None) -> Evarutil.e_new_evar evars env (mk_relation car) | Some (ty, Some rel) -> rel in let rec aux env prod n = if n = 0 then start env prod else match kind_of_term (Reduction.whd_betadeltaiota env prod) with | Prod (na, ty, b) -> if noccurn 1 b then let b' = lift (-1) b in let rb = aux env b' (pred n) in mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]) else let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) in mkApp (Lazy.force forall_relation, [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]) | _ -> raise Not_found in let rec find env c ty = function | [] -> None | arg :: args -> try Some (aux env ty (succ (List.length args)), c, ty, arg :: args) with Not_found -> find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args in find env c ty args let unlift_cstr env sigma = function | None -> None | Some codom -> Some (decomp_pointwise 1 codom) type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } let default_flags = { under_lambdas = true; on_morphisms = true; } type evars = evar_map * evar_map (* goal evars, constraint evars *) type rewrite_proof = | RewPrf of constr * constr | RewCast of cast_kind let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None type rewrite_result_info = { rew_car : constr; rew_from : constr; rew_to : constr; rew_prf : rewrite_proof; rew_evars : evars; } type rewrite_result = rewrite_result_info option type strategy = Environ.env -> identifier list -> constr -> types -> constr option -> evars -> rewrite_result option let get_rew_rel r = match r.rew_prf with | RewPrf (rel, prf) -> rel | RewCast c -> mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |]) let get_rew_prf r = match r.rew_prf with | RewPrf (rel, prf) -> rel, prf | RewCast c -> let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]), c, mkApp (rel, [| r.rew_from; r.rew_to |])) let resolve_subrelation env avoid car rel prf rel' res = if eq_constr rel rel' then res else (* try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *) (* { res with rew_evars = evd' } *) (* with NotConvertible -> *) let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in let evars, subrel = new_cstr_evar res.rew_evars env app in let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in { res with rew_prf = RewPrf (rel', appsub); rew_evars = evars } let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = try (array_find args' (fun i b -> b <> None)) with Not_found -> raise (Invalid_argument "resolve_morphism") in let morphargs, morphobjs = array_chop first args in let morphargs', morphobjs' = array_chop first args' in let appm = mkApp(m, morphargs) in let appmtype = Typing.type_of env (goalevars evars) appm in let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') in (* Desired signature *) let evars, appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in let app = mkApp (Lazy.force proper_type, cl_args) in let env' = Environ.push_named (id_of_string "do_subrelation", Some (Lazy.force do_subrelation), Lazy.force apply_subrelation) env in let evars, morph = new_cstr_evar evars env' app in evars, morph, morph, sigargs, appm, morphobjs, morphobjs' in let projargs, subst, evars, respars, typeargs = array_fold_left2 (fun (acc, subst, evars, sigargs, typeargs') x y -> let (carrier, relation), sigargs = split_head sigargs in match relation with | Some relation -> let carrier = substl subst carrier and relation = substl subst relation in (match y with | None -> let evars, proof = proper_proof env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> if y <> None then error "Cannot rewrite the argument of a dependent function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' in let proof = applistc proj (List.rev projargs) in let newt = applistc m' (List.rev typeargs) in match respars with [ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt | _ -> assert(false) let apply_constraint env avoid car rel prf cstr res = match cstr with | None -> res | Some r -> resolve_subrelation env avoid car rel prf r res let eq_env x y = x == y let apply_rule hypinfo loccs : strategy = let (nowhere_except_in,occs) = loccs in let is_occ occ = if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in let occ = ref 0 in fun env avoid t ty cstr evars -> if not (eq_env !hypinfo.cl.env env) then hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo; let unif = unify_eqn env (goalevars evars) hypinfo t in if unif <> None then incr occ; match unif with | Some (evd', (prf, (car, rel, c1, c2))) when is_occ !occ -> begin if eq_constr t c2 then Some None else let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = evd', cstrevars evars } in Some (Some (apply_constraint env avoid car rel prf cstr res)) end | _ -> None let apply_lemma flags (evm,c) left2right loccs : strategy = fun env avoid t ty cstr evars -> let hypinfo = ref (decompose_applied_relation env (goalevars evars) flags None c left2right) in apply_rule hypinfo loccs env avoid t ty cstr evars let make_leibniz_proof c ty r = let prf = match r.rew_prf with | RewPrf (rel, prf) -> let rel = mkApp (Lazy.force coq_eq, [| ty |]) in let prf = mkApp (Lazy.force coq_f_equal, [| r.rew_car; ty; mkLambda (Anonymous, r.rew_car, c); r.rew_from; r.rew_to; prf |]) in RewPrf (rel, prf) | RewCast k -> r.rew_prf in { r with rew_car = ty; rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } open Elimschemes let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' let fold_match ?(force=false) env sigma c = let (ci, p, c, brs) = destCase c in let cty = Retyping.get_type_of env sigma c in let dep, pred, exists, sk = let env', ctx, body = let ctx, pred = decompose_lam_assum p in let env' = Environ.push_rel_context ctx env in env', ctx, pred in let sortp = Retyping.get_sort_family_of env' sigma body in let sortc = Retyping.get_sort_family_of env sigma cty in let dep = not (noccurn 1 body) in let pred = if dep then p else it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) in let sk = if sortp = InProp then if sortc = InProp then if dep then case_dep_scheme_kind_from_prop else case_scheme_kind_from_prop else ( if dep then case_dep_scheme_kind_from_type_in_prop else case_scheme_kind_from_type) else ((* sortc <> InProp by typing *) if dep then case_dep_scheme_kind_from_type else case_scheme_kind_from_type) in let exists = Ind_tables.check_scheme sk ci.ci_ind in if exists || force then dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind else raise Not_found in let app = let ind, args = Inductive.find_rectype env cty in let pars, args = list_chop ci.ci_npar args in let meths = List.map (fun br -> br) (Array.to_list brs) in applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) in sk, (if exists then env else reset_env env), app let unfold_match env sigma sk app = match kind_of_term app with | App (f', args) when f' = mkConst sk -> let v = Environ.constant_value (Global.env ()) sk in Reductionops.whd_beta sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false let coerce env avoid cstr res = let rel, prf = get_rew_prf res in apply_constraint env avoid res.rew_car rel prf cstr res let subterm all flags (s : strategy) : strategy = let rec aux env avoid t ty cstr evars = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> let rewrite_args success = let args', evars', progress = Array.fold_left (fun (acc, evars, progress) arg -> if progress <> None && not all then (None :: acc, evars, progress) else let res = s env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in match res with | Some None -> (None :: acc, evars, if progress = None then Some false else progress) | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true) | None -> (None :: acc, evars, progress)) ([], evars, success) args in match progress with | None -> None | Some false -> Some None | Some true -> let args' = Array.of_list (List.rev args') in if array_exists (function | None -> false | Some r -> not (is_rew_cast r.rew_prf)) args' then let evars', prf, car, rel, c1, c2 = resolve_morphism env avoid t m args args' cstr' evars' in let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = evars' } in Some (Some res) else let args' = array_map2 (fun aorig anew -> match anew with None -> aorig | Some r -> r.rew_to) args args' in let res = { rew_car = ty; rew_from = t; rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; rew_evars = evars' } in Some (Some res) in if flags.on_morphisms then let evarsref = ref (snd evars) in let mty = Typing.type_of env (goalevars evars) m in let cstr', m, mty, argsl, args = let argsl = Array.to_list args in match lift_cstr env (goalevars evars) evarsref argsl m mty None with | Some (cstr', m, mty, args) -> Some cstr', m, mty, args, Array.of_list args | None -> None, m, mty, argsl, args in let m' = s env avoid m mty cstr' (fst evars, !evarsref) in match m' with | None -> rewrite_args None (* Standard path, try rewrite on arguments *) | Some None -> rewrite_args (Some false) | Some (Some r) -> (* We rewrote the function and get a proof of pointwise rel for the arguments. We just apply it. *) let prf = match r.rew_prf with | RewPrf (rel, prf) -> RewPrf (apply_pointwise rel argsl, mkApp (prf, args)) | x -> x in let res = { rew_car = prod_appvect r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); rew_prf = prf; rew_evars = r.rew_evars } in match prf with | RewPrf (rel, prf) -> Some (Some (apply_constraint env avoid res.rew_car rel prf cstr res)) | _ -> Some (Some res) else rewrite_args None | Prod (n, x, b) when noccurn 1 b -> let b = subst1 mkProp b in let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in let mor, unfold = arrow_morphism tx tb x b in let res = aux env avoid mor ty cstr evars in (match res with | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) | _ -> res) (* if x' = None && flags.under_lambdas then *) (* let lam = mkLambda (n, x, b) in *) (* let lam', occ = aux env lam occ None in *) (* let res = *) (* match lam' with *) (* | None -> None *) (* | Some (prf, (car, rel, c1, c2)) -> *) (* Some (resolve_morphism env sigma t *) (* ~fnewt:unfold_all *) (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) (* cstr evars) *) (* in res, occ *) (* else *) | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in let app, unfold = if eq_constr ty mkProp then mkApp (Lazy.force coq_all, [| dom; lam |]), unfold_all else mkApp (Lazy.force coq_forall, [| dom; lam |]), unfold_forall in let res = aux env avoid app ty cstr evars in (match res with | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) | _ -> res) | Lambda (n, t, b) when flags.under_lambdas -> let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in let env' = Environ.push_rel (n', None, t) env in let b' = s env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in (match b' with | Some (Some r) -> let prf = match r.rew_prf with | RewPrf (rel, prf) -> let rel = pointwise_or_dep_relation n' t r.rew_car rel in let prf = mkLambda (n', t, prf) in RewPrf (rel, prf) | x -> x in Some (Some { r with rew_prf = prf; rew_car = mkProd (n, t, r.rew_car); rew_from = mkLambda(n, t, r.rew_from); rew_to = mkLambda (n, t, r.rew_to) }) | _ -> b') | Case (ci, p, c, brs) -> let cty = Typing.type_of env (goalevars evars) c in let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in let c' = s env avoid c cty cstr' evars in let res = match c' with | Some (Some r) -> let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in Some (Some (coerce env avoid cstr res)) | x -> if array_for_all ((=) 0) ci.ci_cstr_ndecls then let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in let found, brs' = Array.fold_left (fun (found, acc) br -> if found <> None then (found, fun x -> lift 1 br :: acc x) else match s env avoid br ty cstr evars with | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x) | _ -> (None, fun x -> lift 1 br :: acc x)) (None, fun x -> []) brs in match found with | Some r -> let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in Some (Some (make_leibniz_proof ctxc ty r)) | None -> x else match try Some (fold_match env (goalevars evars) t) with Not_found -> None with | None -> x | Some (cst, _, t') -> match aux env avoid t' ty cstr evars with | Some (Some prf) -> Some (Some { prf with rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to }) | x' -> x in (match res with | Some (Some r) -> let rel, prf = get_rew_prf r in Some (Some (apply_constraint env avoid r.rew_car rel prf cstr r)) | x -> x) | _ -> None in aux let all_subterms = subterm true default_flags let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) let transitivity env avoid (res : rewrite_result_info) (next : strategy) : rewrite_result option = match next env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars with | None -> None | Some None -> Some (Some res) | Some (Some res') -> match res.rew_prf with | RewCast c -> Some (Some { res' with rew_from = res.rew_from }) | RewPrf (rew_rel, rew_prf) -> match res'.rew_prf with | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to })) | RewPrf (res'_rel, res'_prf) -> let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in let evars, prf = new_cstr_evar res'.rew_evars env prfty in let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; rew_prf; res'_prf |]) in Some (Some { res' with rew_from = res.rew_from; rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }) (** Rewriting strategies. Inspired by ELAN's rewriting strategies: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 *) module Strategies = struct let fail : strategy = fun env avoid t ty cstr evars -> None let id : strategy = fun env avoid t ty cstr evars -> Some None let refl : strategy = fun env avoid t ty cstr evars -> let evars, rel = match cstr with | None -> new_cstr_evar evars env (mk_relation ty) | Some r -> evars, r in let evars, proof = let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in new_cstr_evar evars env mty in Some (Some { rew_car = ty; rew_from = t; rew_to = t; rew_prf = RewPrf (rel, proof); rew_evars = evars }) let progress (s : strategy) : strategy = fun env avoid t ty cstr evars -> match s env avoid t ty cstr evars with | None -> None | Some None -> None | r -> r let seq fst snd : strategy = fun env avoid t ty cstr evars -> match fst env avoid t ty cstr evars with | None -> None | Some None -> snd env avoid t ty cstr evars | Some (Some res) -> transitivity env avoid res snd let choice fst snd : strategy = fun env avoid t ty cstr evars -> match fst env avoid t ty cstr evars with | None -> snd env avoid t ty cstr evars | res -> res let try_ str : strategy = choice str id let fix (f : strategy -> strategy) : strategy = let rec aux env = f (fun env -> aux env) env in aux let any (s : strategy) : strategy = fix (fun any -> try_ (seq s any)) let repeat (s : strategy) : strategy = seq s (any s) let bu (s : strategy) : strategy = fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) let td (s : strategy) : strategy = fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) let innermost (s : strategy) : strategy = fix (fun ins -> choice (one_subterm ins) s) let outermost (s : strategy) : strategy = fix (fun out -> choice s (one_subterm out)) let lemmas flags cs : strategy = List.fold_left (fun tac (l,l2r) -> choice tac (apply_lemma flags l l2r (false,[]))) fail cs let inj_open c = (Evd.empty,c) let old_hints (db : string) : strategy = let rules = Autorewrite.find_rewrites db in lemmas rewrite_unif_flags (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules) let hints (db : string) : strategy = fun env avoid t ty cstr evars -> let rules = Autorewrite.find_matches db t in let lemma hint = (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r) in let lems = List.map lemma rules in lemmas rewrite_unif_flags lems env avoid t ty cstr evars let reduce (r : Redexpr.red_expr) : strategy = let rfn, ckind = Redexpr.reduction_of_red_expr r in fun env avoid t ty cstr evars -> let t' = rfn env (goalevars evars) t in if eq_constr t' t then Some None else Some (Some { rew_car = ty; rew_from = t; rew_to = t'; rew_prf = RewCast ckind; rew_evars = evars }) let fold c : strategy = fun env avoid t ty cstr evars -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in let unfolded = try Tacred.try_red_product env sigma c with e when Errors.noncritical e -> error "fold: the term is not unfoldable !" in try let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in let c' = Evarutil.nf_evar sigma c in Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; rew_evars = sigma, cstrevars evars }) with e when Errors.noncritical e -> None let fold_glob c : strategy = fun env avoid t ty cstr evars -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.Default.understand_tcc (goalevars evars) env c in let unfolded = try Tacred.try_red_product env sigma c with e when Errors.noncritical e -> error "fold: the term is not unfoldable !" in try let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in let c' = Evarutil.nf_evar sigma c in Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; rew_evars = sigma, cstrevars evars }) with e when Errors.noncritical e -> None end (** The strategy for a single rewrite, dealing with occurences. *) let rewrite_strat flags occs hyp = let app = apply_rule hyp occs in let rec aux () = Strategies.choice app (subterm true flags (fun env -> aux () env)) in aux () let get_hypinfo_ids {c = opt} = match opt with | None -> [] | Some (is, gc) -> List.map fst is.lfun @ is.avoid_ids let rewrite_with flags c left2right loccs : strategy = fun env avoid t ty cstr evars -> let gevars = goalevars evars in let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in let avoid = get_hypinfo_ids !hypinfo @ avoid in rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars) let apply_strategy (s : strategy) env avoid concl cstr evars = let res = s env avoid concl (Typing.type_of env (goalevars evars) concl) (Option.map snd cstr) evars in match res with | None -> None | Some None -> Some None | Some (Some res) -> Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to)) let merge_evars (goal,cstr) = Evd.merge goal cstr let solve_constraints env evars = Typeclasses.resolve_typeclasses env ~split:false ~fail:true (merge_evars evars) let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) let map_rewprf f = function | RewPrf (rel, prf) -> RewPrf (f rel, f prf) | RewCast c -> RewCast c type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = let cstr = let sort = mkProp in let impl = Lazy.force impl in match is_hyp with | None -> (sort, inverse sort impl) | Some _ -> (sort, impl) in let evars = (sigma, Evd.empty) in let eq = apply_strategy strat env avoid concl (Some cstr) evars in match eq with | Some (Some (p, evars, car, oldt, newt)) -> let evars' = solve_constraints env evars in let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in let newt = Evarutil.nf_evar evars' newt in let abs = Option.map (fun (x, y) -> Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in let evars = (* Keep only original evars (potentially instantiated) and goal evars, the rest has been defined and substituted already. *) (* let cstrs = cstrevars evars in *) (* cstrs is small *) let gevars = goalevars evars in Evd.fold (fun ev evi acc -> if Evd.mem gevars ev then Evd.add acc ev evi else acc) evars' Evd.empty (* Evd.fold (fun ev evi acc -> Evd.remove acc ev) cstrs evars' *) in let res = match is_hyp with | Some id -> (match p with | RewPrf (rel, p) -> let term = match abs with | None -> p | Some (t, ty) -> mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in Some (evars, Some (mkApp (term, [| mkVar id |])), newt) | RewCast c -> Some (evars, None, newt)) | None -> (match p with | RewPrf (rel, p) -> (match abs with | None -> Some (evars, Some p, newt) | Some (t, ty) -> let proof = mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in Some (evars, Some proof, newt)) | RewCast c -> Some (evars, None, newt)) in Some res | Some None -> Some None | None -> None let rewrite_refine (evd,c) = Tacmach.refine c let cl_rewrite_clause_tac ?abs strat meta clause gl = let evartac evd = Refiner.tclEVARS evd in let treat res = match res with | None -> tclFAIL 0 (str "Nothing to rewrite") | Some None -> tclFAIL 0 (str"No progress made") | Some (Some (undef, p, newt)) -> let tac = match clause, p with | Some id, Some p -> cut_replacing id newt (Tacmach.refine p) | Some id, None -> change_in_hyp None newt (id, InHypTypeOnly) | None, Some p -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST (Tacmach.internal_cut_no_check false name newt) (tclTHEN (Tactics.revert [name]) (Tacmach.refine p)) | None, None -> change_in_concl None newt in tclTHEN (evartac undef) tac in let tac = try let concl, is_hyp = match clause with | Some id -> pf_get_hyp_typ gl id, Some id | None -> pf_concl gl, None in let sigma = project gl in let concl = Evarutil.nf_evar sigma concl in let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in treat res with | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> Refiner.tclFAIL_lazy 0 (lazy (str"Unable to satisfy the rewriting constraints." ++ fnl () ++ Himsg.explain_typeclass_error env e)) in tac gl open Goal open Environ let bind_gl_info f = bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) let fail l s = raise (Refiner.FailError (l, lazy s)) let new_refine c : Goal.subgoals Goal.sensitive = let refable = Goal.Refinable.make (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) in Goal.bind refable Goal.refine let assert_replacing id newt tac = let sens = bind_gl_info (fun concl env sigma -> let nc' = Environ.fold_named_context (fun _ (n, b, t as decl) nc' -> if n = id then (n, b, newt) :: nc' else decl :: nc') env ~init:[] in let reft = Refinable.make (fun h -> Goal.bind (Refinable.mkEvar h (Environ.reset_with_named_context (val_of_named_context nc') env) concl) (fun ev -> Goal.bind (Refinable.mkEvar h env newt) (fun ev' -> let inst = fold_named_context (fun _ (n, b, t) inst -> if n = id then ev' :: inst else if b = None then mkVar n :: inst else inst) env ~init:[] in let (e, args) = destEvar ev in Goal.return (mkEvar (e, Array.of_list inst))))) in Goal.bind reft Goal.refine) in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) (Proofview.tclFOCUS 2 2 tac) let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) let cl_rewrite_clause_newtac ?abs strat clause = let treat (res, is_hyp) = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> newfail 0 (str"No progress made") | Some (Some res) -> match is_hyp, res with | Some id, (undef, Some p, newt) -> assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p))) | Some id, (undef, None, newt) -> Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt)) | None, (undef, Some p, newt) -> let refable = Goal.Refinable.make (fun handle -> Goal.bind env (fun env -> Goal.bind (Refinable.mkEvar handle env newt) (fun ev -> Goal.Refinable.constr_of_open_constr handle true (undef, mkApp (p, [| ev |]))))) in Proofview.tclSENSITIVE (Goal.bind refable Goal.refine) | None, (undef, None, newt) -> Proofview.tclSENSITIVE (Goal.convert_concl false newt) in let info = bind_gl_info (fun concl env sigma -> let ty, is_hyp = match clause with | Some id -> Environ.named_type id env, Some id | None -> concl, None in let res = try cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp with | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> fail 0 (str"setoid rewrite failed: unable to satisfy the rewriting constraints." ++ fnl () ++ Himsg.explain_typeclass_error env e) in return (res, is_hyp)) in Proofview.tclGOALBINDU info (fun i -> treat i) let cl_rewrite_clause_new_strat ?abs strat clause = init_setoid (); cl_rewrite_clause_newtac ?abs strat clause let cl_rewrite_clause_newtac' l left2right occs clause = Proof_global.run_tactic (Proofview.tclFOCUS 1 1 (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause)) let tactic_init_setoid () = init_setoid (); tclIDTAC let cl_rewrite_clause_strat strat clause = tclTHEN (tactic_init_setoid ()) (fun gl -> let meta = Evarutil.new_meta() in try cl_rewrite_clause_tac strat (mkMeta meta) clause gl with | Refiner.FailError (n, pp) -> tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl) let cl_rewrite_clause l left2right occs clause gl = cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl open Pp open Pcoq open Names open Tacexpr open Tacinterp open Termops open Genarg open Extraargs let occurrences_of = function | n::_ as nl when n < 0 -> (false,List.map abs nl) | nl -> if List.exists (fun n -> n < 0) nl then error "Illegal negative occurrence number."; (true,nl) let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars -> let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) l2r occs env avoid t ty cstr (evd, cstrevars evars) let apply_glob_constr c l2r occs = fun env avoid t ty cstr evars -> let evd, c = (Pretyping.Default.understand_tcc (goalevars evars) env c) in apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) l2r occs env avoid t ty cstr (evd, cstrevars evars) let interp_constr_list env sigma = List.map (fun c -> let evd, c = Constrintern.interp_open_constr sigma env c in (evd, (c, NoBindings)), true) let interp_glob_constr_list env sigma = List.map (fun c -> let evd, c = Pretyping.Default.understand_tcc sigma env c in (evd, (c, NoBindings)), true) open Pcoq (* Syntax for rewriting with strategies *) type constr_expr_with_bindings = constr_expr with_bindings type glob_constr_with_bindings = glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge))) let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge)) let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c ARGUMENT EXTEND glob_constr_with_bindings PRINTED BY pr_glob_constr_with_bindings_sign INTERPRETED BY interp_glob_constr_with_bindings GLOBALIZED BY glob_glob_constr_with_bindings SUBSTITUTED BY subst_glob_constr_with_bindings RAW_TYPED AS constr_expr_with_bindings RAW_PRINTED BY pr_constr_expr_with_bindings GLOB_TYPED AS glob_constr_with_bindings GLOB_PRINTED BY pr_glob_constr_with_bindings [ constr_with_bindings(bl) ] -> [ bl ] END type ('constr,'redexpr) strategy_ast = | StratId | StratFail | StratRefl | StratUnary of string * ('constr,'redexpr) strategy_ast | StratBinary of string * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast | StratConstr of 'constr * bool | StratTerms of 'constr list | StratHints of bool * string | StratEval of 'redexpr | StratFold of 'constr let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function | StratId | StratFail | StratRefl as s -> s | StratUnary (s, str) -> StratUnary (s, map_strategy f g str) | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str') | StratConstr (c, b) -> StratConstr (f c, b) | StratTerms l -> StratTerms (List.map f l) | StratHints (b, id) -> StratHints (b, id) | StratEval r -> StratEval (g r) | StratFold c -> StratFold (f c) let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl | StratUnary (f, s) -> let s' = strategy_of_ast s in let f' = match f with | "subterms" -> all_subterms | "subterm" -> one_subterm | "innermost" -> Strategies.innermost | "outermost" -> Strategies.outermost | "bottomup" -> Strategies.bu | "topdown" -> Strategies.td | "progress" -> Strategies.progress | "try" -> Strategies.try_ | "any" -> Strategies.any | "repeat" -> Strategies.repeat | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f) in f' s' | StratBinary (f, s, t) -> let s' = strategy_of_ast s in let t' = strategy_of_ast t in let f' = match f with | "compose" -> Strategies.seq | "choice" -> Strategies.choice | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f) in f' s' t' | StratConstr (c, b) -> apply_glob_constr (fst c) b all_occurrences | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id | StratTerms l -> (fun env avoid t ty cstr evars -> let l' = interp_glob_constr_list env (goalevars evars) (List.map fst l) in Strategies.lemmas rewrite_unif_flags l' env avoid t ty cstr evars) | StratEval r -> (fun env avoid t ty cstr evars -> let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars)) | StratFold c -> Strategies.fold_glob (fst c) type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast let interp_strategy ist gl s = let sigma = project gl in sigma, strategy_of_ast s let glob_strategy ist s = map_strategy (Tacinterp.intern_constr ist) (fun c -> c) s let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "" let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "" let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "" ARGUMENT EXTEND rewstrategy PRINTED BY pr_strategy INTERPRETED BY interp_strategy GLOBALIZED BY glob_strategy SUBSTITUTED BY subst_strategy RAW_TYPED AS raw_strategy RAW_PRINTED BY pr_raw_strategy GLOB_TYPED AS glob_strategy GLOB_PRINTED BY pr_glob_strategy [ glob(c) ] -> [ StratConstr (c, true) ] | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] | [ "subterms" rewstrategy(h) ] -> [ StratUnary ("all_subterms", h) ] | [ "subterm" rewstrategy(h) ] -> [ StratUnary ("one_subterm", h) ] | [ "innermost" rewstrategy(h) ] -> [ StratUnary("innermost", h) ] | [ "outermost" rewstrategy(h) ] -> [ StratUnary("outermost", h) ] | [ "bottomup" rewstrategy(h) ] -> [ StratUnary("bottomup", h) ] | [ "topdown" rewstrategy(h) ] -> [ StratUnary("topdown", h) ] | [ "id" ] -> [ StratId ] | [ "fail" ] -> [ StratFail ] | [ "refl" ] -> [ StratRefl ] | [ "progress" rewstrategy(h) ] -> [ StratUnary ("progress", h) ] | [ "try" rewstrategy(h) ] -> [ StratUnary ("try", h) ] | [ "any" rewstrategy(h) ] -> [ StratUnary ("any", h) ] | [ "repeat" rewstrategy(h) ] -> [ StratUnary ("repeat", h) ] | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary ("compose", h, h') ] | [ "(" rewstrategy(h) ")" ] -> [ h ] | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary ("choice", h, h') ] | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] | [ "hints" preident(h) ] -> [ StratHints (false, h) ] | [ "terms" constr_list(h) ] -> [ StratTerms h ] | [ "eval" red_expr(r) ] -> [ StratEval r ] | [ "fold" constr(c) ] -> [ StratFold c ] END (* By default the strategy for "rewrite_db" is top-down *) let db_strat db = Strategies.td (Strategies.hints db) let cl_rewrite_clause_db db cl = cl_rewrite_clause_strat (db_strat db) cl TACTIC EXTEND rewrite_strat | [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] | [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] | [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] | [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] END let clsubstitute o c = let is_tac id = match fst (fst (snd c)) with GVar (_, id') when id' = id -> true | _ -> false in Tacticals.onAllHypsAndConcl (fun cl -> match cl with | Some id when is_tac id -> tclIDTAC | _ -> cl_rewrite_clause c o all_occurrences cl) open Extraargs TACTIC EXTEND substitute | [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] END (* Compatibility with old Setoids *) TACTIC EXTEND setoid_rewrite [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id)] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] END let cl_rewrite_clause_newtac_tac c o occ cl gl = cl_rewrite_clause_newtac' c o occ cl; tclIDTAC gl TACTIC EXTEND GenRew | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause_newtac_tac c o all_occurrences (Some id) ] | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ] | [ "rew" orient(o) glob_constr_with_bindings(c) ] -> [ cl_rewrite_clause_newtac_tac c o all_occurrences None ] END let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l) let declare_an_instance n s args = ((dummy_loc,Name n), Explicit, CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = new_instance binders instance (Some (CRecord (dummy_loc,None,fields))) ~global:(not (Vernacexpr.use_section_locality ())) ~generalize:false None let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" in anew_instance global binders instance [(Ident (dummy_loc,id_of_string "reflexivity"),lemma)] let declare_instance_sym global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" in anew_instance global binders instance [(Ident (dummy_loc,id_of_string "symmetry"),lemma)] let declare_instance_trans global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" in anew_instance global binders instance [(Ident (dummy_loc,id_of_string "transitivity"),lemma)] let declare_relation ?(binders=[]) a aeq n refl symm trans = init_setoid (); let global = not (Vernacexpr.use_section_locality ()) in let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in ignore(anew_instance global binders instance []); match (refl,symm,trans) with (None, None, None) -> () | (Some lemma1, None, None) -> ignore (declare_instance_refl global binders a aeq n lemma1) | (None, Some lemma2, None) -> ignore (declare_instance_sym global binders a aeq n lemma2) | (None, None, Some lemma3) -> ignore (declare_instance_trans global binders a aeq n lemma3) | (Some lemma1, Some lemma2, None) -> ignore (declare_instance_refl global binders a aeq n lemma1); ignore (declare_instance_sym global binders a aeq n lemma2) | (Some lemma1, None, Some lemma3) -> let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance global binders instance [(Ident (dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1); (Ident (dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( anew_instance global binders instance [(Ident (dummy_loc,id_of_string "PER_Symmetric"), lemma2); (Ident (dummy_loc,id_of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1); (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type let _, _, rawwit_binders = (Genarg.create_arg None "binders" : Genarg.tlevel binders_argtype * Genarg.glevel binders_argtype * Genarg.rlevel binders_argtype) open Pcoq.Constr VERNAC COMMAND EXTEND AddRelation | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) None None ] | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> [ declare_relation a aeq n None None None ] END VERNAC COMMAND EXTEND AddRelation2 [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation a aeq n None (Some lemma2) None ] | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] END VERNAC COMMAND EXTEND AddRelation3 [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n None None (Some lemma3) ] END VERNAC COMMAND EXTEND AddParametricRelation | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None None None ] END VERNAC COMMAND EXTEND AddParametricRelation2 [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] END VERNAC COMMAND EXTEND AddParametricRelation3 [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] END let cHole = CHole (dummy_loc, None) open Entries open Libnames let proper_projection r ty = let ctx, inst = decompose_prod_assum ty in let mor, args = destApp inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in let app = mkApp (Lazy.force proper_proj, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = let ty = Global.type_of_global r in let c = constr_of_global r in let term = proper_projection c ty in let typ = Typing.type_of (Global.env ()) Evd.empty term in let ctx, typ = decompose_prod_assum typ in let typ = let n = let rec aux t = match kind_of_term t with App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> succ (aux rel') | _ -> 0 in let init = match kind_of_term typ with App (f, args) when eq_constr f (Lazy.force respectful) -> mkApp (f, fst (array_chop (Array.length args - 2) args)) | _ -> typ in aux init in let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in let cst = { const_entry_body = term; const_entry_secctx = None; const_entry_type = Some typ; const_entry_opaque = false } in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) let build_morphism_signature m = let env = Global.env () in let m = Constrintern.interp_constr Evd.empty env m in let t = Typing.type_of env Evd.empty m in let isevars = ref (Evd.empty, Evd.empty) in let cstrs = let rec aux t = match kind_of_term t with | Prod (na, a, b) -> None :: aux b | _ -> [] in aux t in let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None in let _ = isevars := evars in let _ = List.iter (fun (ty, rel) -> Option.iter (fun rel -> let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in let evars,c = new_cstr_evar !isevars env default in isevars := evars) rel) cstrs in let morph = mkApp (Lazy.force proper_type, [| t; sig_; m |]) in let evd = solve_constraints env !isevars in let m = Evarutil.nf_evar evd morph in Evarutil.check_evars env Evd.empty evd m; m let default_morphism sign m = let env = Global.env () in let t = Typing.type_of env Evd.empty m in let evars, _, sign, cstrs = build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign) in let morph = mkApp (Lazy.force proper_type, [| t; sign; m |]) in let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in mor, proper_projection mor morph let add_setoid global binders a aeq t n = init_setoid (); let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let add_morphism_infer glob m n = init_setoid (); let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in if Lib.is_modtype () then let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id (Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in Flags.silently (fun () -> Lemmas.start_proof instance_id kind instance (fun _ -> function Libnames.ConstRef cst -> add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false); Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) (); Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) () let add_morphism glob binders m s n = init_setoid (); let instance_id = add_suffix n "_Proper" in let instance = ((dummy_loc,Name instance_id), Explicit, CAppExpl (dummy_loc, (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")), [cHole; s; m])) in let tac = Tacinterp.interp <:tactic> in ignore(new_instance ~global:glob binders instance (Some (CRecord (dummy_loc,None,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) VERNAC COMMAND EXTEND AddSetoid1 [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> [ add_setoid (not (Vernacexpr.use_section_locality ())) [] a aeq t n ] | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> [ add_setoid (not (Vernacexpr.use_section_locality ())) binders a aeq t n ] | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ] | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> [ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ] | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> [ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ] END (** Bind to "rewrite" too *) (** Taken from original setoid_replace, to emulate the old rewrite semantics where lemmas are first instantiated and then rewrite proceeds. *) let check_evar_map_of_evars_defs evd = let metas = Evd.meta_list evd in let check_freemetas_is_empty rebus = Evd.Metaset.iter (fun m -> if Evd.meta_defined evd m then () else raise (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) in List.iter (fun (_,binding) -> match binding with Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> check_freemetas_is_empty rebus freemetas | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> check_freemetas_is_empty rebus1 freemetas1 ; check_freemetas_is_empty rebus2 freemetas2 ) metas let unification_rewrite flags l2r c1 c2 cl car rel but gl = let env = pf_env gl in let (evd',c') = try (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env cl.evd ((if l2r then c1 else c2),but) with Pretype_errors.PretypeError _ -> (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) Unification.w_unify_to_subterm ~flags:flags env cl.evd ((if l2r then c1 else c2),but) in let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in let cl' = {cl with evd = evd'} in let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in let nf c = Evarutil.nf_evar cl'.evd (Clenv.clenv_nf_meta cl' c) in let c1 = if l2r then nf c' else nf c1 and c2 = if l2r then nf c2 else nf c' and car = nf car and rel = nf rel in check_evar_map_of_evars_defs cl'.evd; let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty); flags = flags} let get_hyp gl evars (c,l) clause l2r = let flags = rewrite2_unif_flags in let hi = decompose_applied_relation (pf_env gl) evars flags None (c,l) l2r in let but = match clause with | Some id -> pf_get_hyp_typ gl id | None -> Evarutil.nf_evar evars (pf_concl gl) in { unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl with flags = rewrite_unif_flags } let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } let apply_lemma gl (c,l) cl l2r occs = let sigma = project gl in let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in let app = apply_rule hypinfo occs in let rec aux () = Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env)) in !hypinfo, aux () let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = let meta = Evarutil.new_meta() in let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in tclWEAK_PROGRESS (tclTHEN (Refiner.tclEVARS hypinfo.cl.evd) (cl_rewrite_clause_tac ~abs:hypinfo.abs strat (mkMeta meta) cl)) gl let general_s_rewrite_clause x = init_setoid (); match x with | None -> general_s_rewrite None | Some id -> general_s_rewrite (Some id) let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause (** [setoid_]{reflexivity,symmetry,transitivity} tactics *) let not_declared env ty rel = tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ str ty ++ str" relation. Maybe you need to require the Setoid library") let setoid_proof gl ty fn fallback = let env = pf_env gl in try let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in let evm = project gl in let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in fn env evm car rel gl with e when Errors.noncritical e -> try fallback gl with Hipattern.NoEquationFound -> match e with | Not_found -> let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in not_declared env ty rel gl | _ -> raise e let setoid_reflexivity gl = setoid_proof gl "reflexive" (fun env evm car rel -> apply (get_reflexive_proof env evm car rel)) (reflexivity_red true) let setoid_symmetry gl = setoid_proof gl "symmetric" (fun env evm car rel -> apply (get_symmetric_proof env evm car rel)) (symmetry_red true) let setoid_transitivity c gl = setoid_proof gl "transitive" (fun env evm car rel -> let proof = get_transitive_proof env evm car rel in match c with | None -> eapply proof | Some c -> apply_with_bindings (proof,Glob_term.ImplicitBindings [ c ])) (transitivity_red true c) let setoid_symmetry_in id gl = let ctype = pf_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum ctype in let (equiv, args) = decompose_app concl in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> let l,res = split_last_two (y::z) in x::l, res | _ -> error "The term provided is not an equivalence." in let others,(c1,c2) = split_last_two args in let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in let new_hyp' = mkApp (he, [| c2 ; c1 |]) in let new_hyp = it_mkProd_or_LetIn new_hyp' binders in tclTHENS (Tactics.cut new_hyp) [ intro_replacing id; tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ] ] gl let _ = Tactics.register_setoid_reflexivity setoid_reflexivity let _ = Tactics.register_setoid_symmetry setoid_symmetry let _ = Tactics.register_setoid_symmetry_in setoid_symmetry_in let _ = Tactics.register_setoid_transitivity setoid_transitivity TACTIC EXTEND setoid_symmetry [ "setoid_symmetry" ] -> [ setoid_symmetry ] | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] END TACTIC EXTEND setoid_reflexivity [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] END TACTIC EXTEND setoid_transitivity [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] | [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] END let implify id gl = let (_, b, ctype) = pf_get_hyp gl id in let binders,concl = decompose_prod_assum ctype in let ctype' = match binders with | (_, None, ty as hd) :: tl when noccurn 1 concl -> let env = Environ.push_rel_context tl (pf_env gl) in let sigma = project gl in let tyhd = Typing.type_of env sigma ty and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in let app, unfold = arrow_morphism tyhd (subst1 mkProp tyconcl) ty (subst1 mkProp concl) in it_mkProd_or_LetIn app tl | _ -> ctype in convert_hyp_no_check (id, b, ctype') gl TACTIC EXTEND implify [ "implify" hyp(n) ] -> [ implify n ] END let rec fold_matches env sigma c = map_constr_with_full_binders Environ.push_rel (fun env c -> match kind_of_term c with | Case _ -> let cst, env, c' = fold_match ~force:true env sigma c in fold_matches env sigma c' | _ -> fold_matches env sigma c) env c TACTIC EXTEND fold_match [ "fold_match" constr(c) ] -> [ fun gl -> let _, _, c' = fold_match ~force:true (pf_env gl) (project gl) c in change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ] END TACTIC EXTEND fold_matches | [ "fold_matches" constr(c) ] -> [ fun gl -> let c' = fold_matches (pf_env gl) (project gl) c in change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ] END TACTIC EXTEND myapply | [ "myapply" global(id) constr_list(l) ] -> [ fun gl -> let gr = id in let _, impls = List.hd (Impargs.implicits_of_global gr) in let ty = Global.type_of_global gr in let env = pf_env gl in let evars = ref (project gl) in let app = let rec aux ty impls args args' = match impls, kind_of_term ty with | Some (_, _, (_, _)) :: impls, Prod (n, t, t') -> let arg = Evarutil.e_new_evar evars env t in aux (subst1 arg t') impls args (arg :: args') | None :: impls, Prod (n, t, t') -> (match args with | [] -> if dependent (mkRel 1) t' then let arg = Evarutil.e_new_evar evars env t in aux (subst1 arg t') impls args (arg :: args') else let arg = Evarutil.mk_new_meta () in evars := meta_declare (destMeta arg) t !evars; aux (subst1 arg t') impls args (arg :: args') | arg :: args -> aux (subst1 arg t') impls args (arg :: args')) | _, _ -> mkApp (constr_of_global gr, Array.of_list (List.rev args')) in aux ty impls l [] in tclTHEN (Refiner.tclEVARS !evars) (apply app) gl ] END coq-8.4pl3/tactics/dn.mli0000640000175000017500000000245212255245502014355 0ustar stephsteph module Make : functor (X : Set.OrderedType) -> functor (Y : Map.OrderedType) -> functor (Z : Map.OrderedType) -> sig type decompose_fun = X.t -> (Y.t * X.t list) option type t val create : unit -> t (** [add t f (tree,inf)] adds a structured object [tree] together with the associated information [inf] to the table [t]; the function [f] is used to translated [tree] into its prefix decomposition: [f] must decompose any tree into a label characterizing its root node and the list of its subtree *) val add : t -> decompose_fun -> X.t * Z.t -> t val rmv : t -> decompose_fun -> X.t * Z.t -> t type 'res lookup_res = Label of 'res | Nothing | Everything type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res (** [lookup t f tree] looks for trees (and their associated information) in table [t] such that the structured object [tree] matches against them; [f] is used to translated [tree] into its prefix decomposition: [f] must decompose any tree into a label characterizing its root node and the list of its subtree *) val lookup : t -> 'term lookup_fun -> 'term -> (X.t * Z.t) list val app : ((X.t * Z.t) -> unit) -> t -> unit val skip_arg : int -> t -> (t * bool) list end coq-8.4pl3/tactics/tactic_option.mli0000640000175000017500000000142712255245502016614 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> (* put *) (locality_flag -> glob_tactic_expr -> unit) * (* get *) (unit -> locality_flag * tactic) * (* print *) (unit -> Pp.std_ppcmds) coq-8.4pl3/tactics/hipattern.mli0000640000175000017500000001454212255245502015755 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a option type testing_function = constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function (** Non recursive type with no indices and exactly one argument for each constructor; canonical definition of n-ary disjunction if strict *) val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function val is_disjunction : ?strict:bool -> testing_function (** Non recursive tuple (one constructor and no indices) with no inner dependencies; canonical definition of n-ary conjunction if strict *) val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function val is_conjunction : ?strict:bool -> testing_function (** Non recursive tuple, possibly with inner dependencies *) val match_with_record : (constr * constr list) matching_function val is_record : testing_function (** Like record but supports and tells if recursive (e.g. Acc) *) val match_with_tuple : (constr * constr list * bool) matching_function val is_tuple : testing_function (** No constructor, possibly with indices *) val match_with_empty_type : constr matching_function val is_empty_type : testing_function (** type with only one constructor and no arguments, possibly with indices *) val match_with_unit_or_eq_type : constr matching_function val is_unit_or_eq_type : testing_function (** type with only one constructor and no arguments, no indices *) val is_unit_type : testing_function (** type with only one constructor, no arguments and at least one dependency *) val is_inductive_equality : inductive -> bool val match_with_equality_type : (constr * constr list) matching_function val is_equality_type : testing_function val match_with_nottype : (constr * constr) matching_function val is_nottype : testing_function val match_with_forall_term : (name * constr * constr) matching_function val is_forall_term : testing_function val match_with_imp_term : (constr * constr) matching_function val is_imp_term : testing_function (** I added these functions to test whether a type contains dependent products or not, and if an inductive has constructors with dependent types (excluding parameters). this is useful to check whether a conjunction is a real conjunction and not a dependent tuple. (Pierre Corbineau, 13/5/2002) *) val has_nodep_prod_after : int -> testing_function val has_nodep_prod : testing_function val match_with_nodep_ind : (constr * constr list * int) matching_function val is_nodep_ind : testing_function val match_with_sigma_type : (constr * constr list) matching_function val is_sigma_type : testing_function (** Recongnize inductive relation defined by reflexivity *) type equation_kind = | MonomorphicLeibnizEq of constr * constr | PolymorphicLeibnizEq of constr * constr * constr | HeterogenousEq of constr * constr * constr * constr exception NoEquationFound val match_with_equation: constr -> coq_eq_data option * constr * equation_kind (***** Destructing patterns bound to some theory *) (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) val find_eq_data_decompose : Proof_type.goal sigma -> constr -> coq_eq_data * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) val find_this_eq_data_decompose : Proof_type.goal sigma -> constr -> coq_eq_data * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) val find_eq_data : constr -> coq_eq_data * equation_kind (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) val find_sigma_data_decompose : constr -> coq_sigma_data * (constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) val match_sigma : constr -> constr * constr val is_matching_sigma : constr -> bool (** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns [t,u,T] and a boolean telling if equality is on the left side *) val match_eqdec : constr -> bool * constr * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) open Proof_type open Tacmach val dest_nf_eq : goal sigma -> constr -> (constr * constr * constr) (** Match a negation *) val is_matching_not : constr -> bool val is_matching_imp_False : constr -> bool coq-8.4pl3/tactics/tauto.ml40000640000175000017500000002242512255245502015025 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* c | _ -> failwith "tauto: anomaly" (** Parametrization of tauto *) (* Whether conjunction and disjunction are restricted to binary connectives *) (* (this is the compatibility mode) *) let binary_mode = true (* Whether conjunction and disjunction are restricted to the connectives *) (* having the structure of "and" and "or" (up to the choice of sorts) in *) (* contravariant position in an hypothesis (this is the compatibility mode) *) let strict_in_contravariant_hyp = true (* Whether conjunction and disjunction are restricted to the connectives *) (* having the structure of "and" and "or" (up to the choice of sorts) in *) (* an hypothesis and in the conclusion *) let strict_in_hyp_and_ccl = false (* Whether unit type includes equality types *) let strict_unit = false (* Whether inner iff are unfolded *) let iff_unfolding = ref false let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 open Goptions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "unfolding of iff and not in intuition"; optkey = ["Intuition";"Iff";"Unfolding"]; optread = (fun () -> !iff_unfolding); optwrite = (:=) iff_unfolding } (** Test *) let is_empty ist = if is_empty_type (assoc_var "X1" ist) then <:tactic> else <:tactic> (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) let is_unit_or_eq ist = let test = if strict_unit then is_unit_type else is_unit_or_eq_type in if test (assoc_var "X1" ist) then <:tactic> else <:tactic> let is_record t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_record | _ -> false let is_binary t = isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_nparams = 2 | _ -> false let iter_tac tacl = List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl (** Dealing with conjunction *) let is_conj ist = let ind = assoc_var "X1" ist in if (not binary_mode || is_binary ind) (* && not (is_record ind) *) && is_conjunction ~strict:strict_in_hyp_and_ccl ind then <:tactic> else <:tactic> let flatten_contravariant_conj ist = let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with | Some (_,args) -> let i = List.length args in if not binary_mode || i = 2 then let newtyp = valueIn (VConstr ([],List.fold_right mkArrow args c)) in let hyp = valueIn (VConstr ([],hyp)) in let intros = iter_tac (List.map (fun _ -> <:tactic< intro >>) args) <:tactic< idtac >> in <:tactic< let newtyp := $newtyp in let hyp := $hyp in assert newtyp by ($intros; apply hyp; split; assumption); clear hyp >> else <:tactic> | _ -> <:tactic> (** Dealing with disjunction *) let is_disj ist = let t = assoc_var "X1" ist in if (not binary_mode || is_binary t) && is_disjunction ~strict:strict_in_hyp_and_ccl t then <:tactic> else <:tactic> let flatten_contravariant_disj ist = let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with | Some (_,args) -> let i = List.length args in if not binary_mode || i = 2 then let hyp = valueIn (VConstr ([],hyp)) in iter_tac (list_map_i (fun i arg -> let typ = valueIn (VConstr ([],mkArrow arg c)) in let i = Tacexpr.Integer i in <:tactic< let typ := $typ in let hyp := $hyp in let i := $i in assert typ by (intro; apply hyp; constructor i; assumption) >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >> else <:tactic> | _ -> <:tactic> (** Main tactic *) let not_dep_intros ist = <:tactic< repeat match goal with | |- (?X1 -> ?X2) => intro | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1 | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not at 1 in H | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not at 1 in H end >> let axioms ist = let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_empty = tacticIn is_empty in <:tactic< match reverse goal with | |- ?X1 => $t_is_unit_or_eq; constructor 1 | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption | _:?X1 |- ?X1 => assumption end >> let simplif ist = let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_conj = tacticIn is_conj and t_flatten_contravariant_conj = tacticIn flatten_contravariant_conj and t_flatten_contravariant_disj = tacticIn flatten_contravariant_disj and t_is_disj = tacticIn is_disj and t_not_dep_intros = tacticIn not_dep_intros in <:tactic< $t_not_dep_intros; repeat (match reverse goal with | id: ?X1 |- _ => $t_is_conj; elim id; do 2 intro; clear id | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id | id: (Coq.Init.Logic.not _) |- _ => red in id | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id | id0: ?X1 -> ?X2, id1: ?X1|- _ => (* generalize (id0 id1); intro; clear id0 does not work (see Marco Maggiesi's bug PR#301) so we instead use Assert and exact. *) assert X2; [exact (id0 id1) | clear id0] | id: ?X1 -> ?X2|- _ => $t_is_unit_or_eq; cut X2; [ intro; clear id | (* id : ?X1 -> ?X2 |- ?X2 *) cut X1; [exact id| constructor 1; fail] ] | id: ?X1 -> ?X2|- _ => $t_flatten_contravariant_conj (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *) | id: (Coq.Init.Logic.iff ?X1 ?X2) -> ?X3|- _ => assert ((X1 -> X2) -> (X2 -> X1) -> X3) by (do 2 intro; apply id; split; assumption); clear id | id: ?X1 -> ?X2|- _ => $t_flatten_contravariant_disj (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *) | |- ?X1 => $t_is_conj; split | |- (Coq.Init.Logic.iff _ _) => split | |- (Coq.Init.Logic.not _) => red end; $t_not_dep_intros) >> let rec tauto_intuit t_reduce solver ist = let t_axioms = tacticIn axioms and t_simplif = tacticIn simplif and t_is_disj = tacticIn is_disj and t_tauto_intuit = tacticIn (tauto_intuit t_reduce solver) in let t_solver = globTacticIn (fun _ist -> solver) in <:tactic< ($t_simplif;$t_axioms || match reverse goal with | id:(?X1 -> ?X2)-> ?X3|- _ => cut X3; [ intro; clear id; $t_tauto_intuit | cut (X1 -> X2); [ exact id | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; solve [ $t_tauto_intuit ]]] | |- ?X1 => $t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit] end || (* NB: [|- _ -> _] matches any product *) match goal with | |- _ -> _ => intro; $t_tauto_intuit | |- _ => $t_reduce;$t_solver end || $t_solver ) >> let reduction_not _ist = if unfold_iff () then <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> else <:tactic< unfold Coq.Init.Logic.not in * >> let t_reduction_not = tacticIn reduction_not let intuition_gen tac = interp (tacticIn (tauto_intuit t_reduction_not tac)) let tauto_intuitionistic g = try intuition_gen <:tactic> g with Refiner.FailError _ | UserError _ -> errorlabstrm "tauto" (str "tauto failed.") let coq_nnpp_path = let dir = List.map id_of_string ["Classical_Prop";"Logic";"Coq"] in Libnames.make_path (make_dirpath dir) (id_of_string "NNPP") let tauto_classical nnpp g = try tclTHEN (apply nnpp) tauto_intuitionistic g with UserError _ -> errorlabstrm "tauto" (str "Classical tauto failed.") let tauto g = try let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in (* try intuitionistic version first to avoid an axiom if possible *) tclORELSE tauto_intuitionistic (tauto_classical nnpp) g with Not_found -> tauto_intuitionistic g let default_intuition_tac = <:tactic< auto with * >> TACTIC EXTEND tauto | [ "tauto" ] -> [ tauto ] END TACTIC EXTEND intuition | [ "intuition" ] -> [ intuition_gen default_intuition_tac ] | [ "intuition" tactic(t) ] -> [ intuition_gen t ] END coq-8.4pl3/tactics/refine.ml0000640000175000017500000003134712255245502015060 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* exist nat [y:nat]((minus y x)=x) (plus x x) ? * ce qui engendre le but * (minus (plus x x) x) = x *) (* Pour cela, on procde de la manire suivante : * * 1. Un terme de preuve incomplet est un terme contenant des variables * existentielles Evar i.e. "_" en syntaxe concrte. * La rsolution de ces variables n'est plus ncessairement totale * (ise_resolve called with fail_evar=false) et les variables * existentielles restantes sont remplaces par des mta-variables * castes par leur types (celui est connu : soit donn, soit trouv * pendant la phase de rsolution). * * 2. On met ensuite le terme " plat" i.e. on n'autorise des MV qu'au * permier niveau et pour chacune d'elles, si ncessaire, on donne * son tour un terme de preuve incomplet pour la rsoudre. * Exemple: le terme (f a _ (fun (x:nat) => e _)) donne * (f a ?1 ?2) avec: * - ?2 := fun (x:nat) => ?3 * - ?3 := e ?4 * ?1 et ?4 donneront des buts * * 3. On crit ensuite une tactique tcc qui engendre les sous-buts * partir d'une preuve incomplte. *) open Pp open Util open Names open Term open Termops open Namegen open Tacmach open Sign open Environ open Reduction open Typing open Tactics open Tacticals open Printer type term_with_holes = TH of constr * meta_type_map * sg_proofs and sg_proofs = (term_with_holes option) list (* pour debugger *) let rec pp_th (TH(c,mm,sg)) = (str"TH=[ " ++ hov 0 (pr_lconstr c ++ fnl () ++ (* pp_mm mm ++ fnl () ++ *) pp_sg sg) ++ str "]") and pp_mm l = hov 0 (prlist_with_sep (fun _ -> (fnl ())) (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l) and pp_sg sg = hov 0 (prlist_with_sep (fun _ -> (fnl ())) (function None -> (str"None") | Some th -> (pp_th th)) sg) (* compute_metamap : constr -> 'a evar_map -> term_with_holes * ralise le 2. ci-dessus * * Pour cela, on renvoie une meta_map qui indique pour chaque meta-variable * si elle correspond un but (None) ou si elle rduite son tour * par un terme de preuve incomplet (Some c). * * On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1" * -- i.e. plat -- et la meta_map contient autant d'lments qu'il y * a de meta-variables dans c. On suppose de plus que l'ordre dans la * meta_map correspond celui des buts qui seront engendrs par le refine. *) let replace_by_meta env sigma = function | TH (m, mm, sgp) when isMeta (strip_outer_cast m) -> m,mm,sgp | (TH (c,mm,_)) as th -> let n = Evarutil.new_meta() in let m = mkMeta n in (* quand on introduit une mv on calcule son type *) let ty = match kind_of_term c with | Lambda (Name id,c1,c2) when isCast c2 -> let _,_,t = destCast c2 in mkNamedProd id c1 t | Lambda (Anonymous,c1,c2) when isCast c2 -> let _,_,t = destCast c2 in mkArrow c1 t | _ -> (* (App _ | Case _) -> *) let sigma' = List.fold_right (fun (m,t) sigma -> Evd.meta_declare m t sigma) mm sigma in Retyping.get_type_of env sigma' c (* | Fix ((_,j),(v,_,_)) -> v.(j) (* en pleine confiance ! *) | _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" *) in mkCast (m,DEFAULTcast, ty),[n,ty],[Some th] exception NoMeta let replace_in_array keep_length env sigma a = if array_for_all (function (TH (_,_,[])) -> true | _ -> false) a then raise NoMeta; let a' = Array.map (function | (TH (c,mm,[])) when not keep_length -> c,mm,[] | th -> replace_by_meta env sigma th) a in let v' = Array.map pi1 a' in let mm = Array.fold_left (@) [] (Array.map pi2 a') in let sgp = Array.fold_left (@) [] (Array.map pi3 a') in v',mm,sgp let fresh env n = let id = match n with Name x -> x | _ -> id_of_string "_H" in next_ident_away_in_goal id (ids_of_named_context (named_context env)) let rec compute_metamap env sigma c = match kind_of_term c with (* le terme est directement une preuve *) | (Const _ | Evar _ | Ind _ | Construct _ | Sort _ | Var _ | Rel _) -> TH (c,[],[]) (* le terme est une mv => un but *) | Meta n -> TH (c,[],[None]) | Cast (m,_, ty) when isMeta m -> TH (c,[destMeta m,ty],[None]) (* abstraction => il faut dcomposer si le terme dessous n'est pas pur * attention : dans ce cas il faut remplacer (Rel 1) par (Var x) * o x est une variable FRAICHE *) | Lambda (name,c1,c2) -> let v = fresh env name in let env' = push_named (v,None,c1) env in begin match compute_metamap env' sigma (subst1 (mkVar v) c2) with (* terme de preuve complet *) | TH (_,_,[]) -> TH (c,[],[]) (* terme de preuve incomplet *) | th -> let m,mm,sgp = replace_by_meta env' sigma th in TH (mkLambda (Name v,c1,m), mm, sgp) end | LetIn (name, c1, t1, c2) -> let v = fresh env name in let th1 = compute_metamap env sigma c1 in let env' = push_named (v,Some c1,t1) env in let th2 = compute_metamap env' sigma (subst1 (mkVar v) c2) in begin match th1,th2 with (* terme de preuve complet *) | TH (_,_,[]), TH (_,_,[]) -> TH (c,[],[]) (* terme de preuve incomplet *) | TH (c1,mm1,sgp1), TH (c2,mm2,sgp2) -> let m1,mm1,sgp1 = if sgp1=[] then (c1,mm1,[]) else replace_by_meta env sigma th1 in let m2,mm2,sgp2 = if sgp2=[] then (c2,mm2,[]) else replace_by_meta env' sigma th2 in TH (mkNamedLetIn v m1 t1 m2, mm1@mm2, sgp1@sgp2) end (* 4. Application *) | App (f,v) -> let a = Array.map (compute_metamap env sigma) (Array.append [|f|] v) in begin try let v',mm,sgp = replace_in_array false env sigma a in let v'' = Array.sub v' 1 (Array.length v) in TH (mkApp(v'.(0), v''),mm,sgp) with NoMeta -> TH (c,[],[]) end | Case (ci,p,cc,v) -> (* bof... *) let nbr = Array.length v in let v = Array.append [|p;cc|] v in let a = Array.map (compute_metamap env sigma) v in begin try let v',mm,sgp = replace_in_array false env sigma a in let v'' = Array.sub v' 2 nbr in TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp) with NoMeta -> TH (c,[],[]) end (* 5. Fix. *) | Fix ((ni,i),(fi,ai,v)) -> (* TODO: use a fold *) let vi = Array.map (fresh env) fi in let fi' = Array.map (fun id -> Name id) vi in let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map (compute_metamap env' sigma) (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try let v',mm,sgp = replace_in_array true env' sigma a in let fix = mkFix ((ni,i),(fi',ai,v')) in TH (fix,mm,sgp) with NoMeta -> TH (c,[],[]) end (* Cast. Est-ce bien exact ? *) | Cast (c,_,t) -> compute_metamap env sigma c (*let TH (c',mm,sgp) = compute_metamap sign c in TH (mkCast (c',t),mm,sgp) *) (* Produit. Est-ce bien exact ? *) | Prod (_,_,_) -> if occur_meta c then error "refine: proof term contains metas in a product." else TH (c,[],[]) (* Cofix. *) | CoFix (i,(fi,ai,v)) -> let vi = Array.map (fresh env) fi in let fi' = Array.map (fun id -> Name id) vi in let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map (compute_metamap env' sigma) (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try let v',mm,sgp = replace_in_array true env' sigma a in let cofix = mkCoFix (i,(fi',ai,v')) in TH (cofix,mm,sgp) with NoMeta -> TH (c,[],[]) end (* tcc_aux : term_with_holes -> tactic * * Ralise le 3. ci-dessus *) let ensure_products n = let p = ref 0 in let rec aux n gl = if n = 0 then tclFAIL 0 (mt()) gl else tclTHEN (tclORELSE intro (fun gl -> incr p; introf gl)) (aux (n-1)) gl in tclORELSE (aux n) (* Now we know how many red are needed *) (fun gl -> tclDO !p red_in_concl gl) let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = let c = substl subst c in match (kind_of_term c,sgp) with (* mv => sous-but : on ne fait rien *) | Meta _ , _ -> tclIDTAC gl | Cast (c,_,_), _ when isMeta c -> tclIDTAC gl (* terme pur => refine *) | _,[] -> refine c gl (* abstraction => intro *) | Lambda (Name id,_,m), _ -> assert (isMeta (strip_outer_cast m)); begin match sgp with | [None] -> intro_mustbe_force id gl | [Some th] -> tclTHEN (introduction id) (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) gl | _ -> assert false end | Lambda (Anonymous,_,m), _ -> (* if anon vars are allowed in evars *) assert (isMeta (strip_outer_cast m)); begin match sgp with | [None] -> tclTHEN intro (onLastHypId (fun id -> clear [id])) gl | [Some th] -> tclTHEN intro (onLastHypId (fun id -> tclTHEN (clear [id]) (tcc_aux (mkVar (*dummy*) id::subst) th))) gl | _ -> assert false end (* let in without holes in the body => possibly dependent intro *) | LetIn (Name id,c1,t1,c2), _ when not (isMeta (strip_outer_cast c1)) -> let c = pf_concl gl in let newc = mkNamedLetIn id c1 t1 c in tclTHEN (change_in_concl None newc) (match sgp with | [None] -> introduction id | [Some th] -> tclTHEN (introduction id) (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) | _ -> assert false) gl (* let in with holes in the body => unable to handle dependency because of evars limitation, use non dependent assert instead *) | LetIn (Name id,c1,t1,c2), _ -> tclTHENS (assert_tac (Name id) t1) [(match List.hd sgp with | None -> tclIDTAC | Some th -> onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)); (match List.tl sgp with | [] -> refine (subst1 (mkVar id) c2) (* a complete proof *) | [None] -> tclIDTAC (* a meta *) | [Some th] -> (* a partial proof *) onLastHypId (fun id -> tcc_aux (mkVar id::subst) th) | _ -> assert false)] gl (* fix => tactique Fix *) | Fix ((ni,j),(fi,ai,_)) , _ -> let out_name = function | Name id -> id | _ -> error "Recursive functions must have names." in let fixes = array_map3 (fun f n c -> (out_name f,succ n,c)) fi ni ai in let firsts,lasts = list_chop j (Array.to_list fixes) in tclTHENS (tclTHEN (ensure_products (succ ni.(j))) (mutual_fix (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j)) (List.map (function | None -> tclIDTAC | Some th -> tcc_aux subst th) sgp) gl (* cofix => tactique CoFix *) | CoFix (j,(fi,ai,_)) , _ -> let out_name = function | Name id -> id | _ -> error "Recursive functions must have names." in let cofixes = array_map2 (fun f c -> (out_name f,c)) fi ai in let firsts,lasts = list_chop j (Array.to_list cofixes) in tclTHENS (mutual_cofix (out_name fi.(j)) (firsts@List.tl lasts) j) (List.map (function | None -> tclIDTAC | Some th -> tcc_aux subst th) sgp) gl (* sinon on fait refine du terme puis appels rec. sur les sous-buts. * c'est le cas pour App et MutCase. *) | _ -> tclTHENS (refine c) (List.map (function None -> tclIDTAC | Some th -> tcc_aux subst th) sgp) gl (* Et finalement la tactique refine elle-mme : *) let refine (evd,c) gl = let sigma = project gl in let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals (pf_env gl) evd in let c = Evarutil.nf_evar evd c in let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise complicated to update meta types when passing through a binder *) let th = compute_metamap (pf_env gl) evd c in tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl coq-8.4pl3/tactics/tactics.ml0000640000175000017500000040662112255245502015243 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* count (n+1) t | LetIn(_,a,_,t) -> count n (subst1 a t) | Cast(c,_,_) -> count n c | _ -> n in count 0 x let inj_with_occurrences e = (all_occurrences_expr,e) let dloc = dummy_loc let typ_of = Retyping.get_type_of (* Option for 8.2 compatibility *) open Goptions let dependent_propositions_elimination = ref true let use_dependent_propositions_elimination () = !dependent_propositions_elimination && Flags.version_strictly_greater Flags.V8_2 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "dependent-propositions-elimination tactic"; optkey = ["Dependent";"Propositions";"Elimination"]; optread = (fun () -> !dependent_propositions_elimination) ; optwrite = (fun b -> dependent_propositions_elimination := b) } let finish_evar_resolution env initial_sigma c = snd (Pretyping.solve_remaining_evars true true solve_by_implicit_tactic env initial_sigma c) (*********************************************) (* Tactics *) (*********************************************) (****************************************) (* General functions *) (****************************************) let string_of_inductive c = try match kind_of_term c with | Ind ind_sp -> let (mib,mip) = Global.lookup_inductive ind_sp in string_of_id mip.mind_typename | _ -> raise Bound with Bound -> error "Bound head variable." let rec head_constr_bound t = let t = strip_outer_cast t in let _,ccl = decompose_prod_assum t in let hd,args = decompose_app ccl in match kind_of_term hd with | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) | _ -> raise Bound let head_constr c = try head_constr_bound c with Bound -> error "Bound head variable." (******************************************) (* Primitive tactics *) (******************************************) let introduction = Tacmach.introduction let refine = Tacmach.refine let convert_concl = Tacmach.convert_concl let convert_hyp = Tacmach.convert_hyp let thin_body = Tacmach.thin_body let error_clear_dependency env id = function | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (pr_id id ++ str " is used in conclusion.") | Evarutil.OccurHypInSimpleClause (Some id') -> errorlabstrm "" (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".") | Evarutil.EvarTypingBreak ev -> errorlabstrm "" (str "Cannot remove " ++ pr_id id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env ev ++ str".") let thin l gl = try thin l gl with Evarutil.ClearDependencyError (id,err) -> error_clear_dependency (pf_env gl) id err let internal_cut_gen b d t gl = try internal_cut b d t gl with Evarutil.ClearDependencyError (id,err) -> error_clear_dependency (pf_env gl) id err let internal_cut = internal_cut_gen false let internal_cut_replace = internal_cut_gen true let internal_cut_rev_gen b d t gl = try internal_cut_rev b d t gl with Evarutil.ClearDependencyError (id,err) -> error_clear_dependency (pf_env gl) id err let internal_cut_rev = internal_cut_rev_gen false let internal_cut_rev_replace = internal_cut_rev_gen true (* Moving hypotheses *) let move_hyp = Tacmach.move_hyp (* Renaming hypotheses *) let rename_hyp = Tacmach.rename_hyp (**************************************************************) (* Fresh names *) (**************************************************************) let fresh_id_in_env avoid id env = next_ident_away_in_goal id (avoid@ids_of_named_context (named_context env)) let fresh_id avoid id gl = fresh_id_in_env avoid id (pf_env gl) (**************************************************************) (* Fixpoints and CoFixpoints *) (**************************************************************) (* Refine as a fixpoint *) let mutual_fix = Tacmach.mutual_fix let fix ido n gl = match ido with | None -> mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] 0 gl | Some id -> mutual_fix id n [] 0 gl (* Refine as a cofixpoint *) let mutual_cofix = Tacmach.mutual_cofix let cofix ido gl = match ido with | None -> mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] 0 gl | Some id -> mutual_cofix id [] 0 gl (**************************************************************) (* Reduction and conversion tactics *) (**************************************************************) type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where (id,c,ty) gl = let redfun' = pf_reduce redfun gl in match c with | None -> if where = InHypValueOnly then errorlabstrm "" (pr_id id ++ str "has no value."); (id,None,redfun' ty) | Some b -> let b' = if where <> InHypTypeOnly then redfun' b else b in let ty' = if where <> InHypValueOnly then redfun' ty else ty in (id,Some b',ty') (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) let error_illegal_clause () = error "\"at\" clause not supported in presence of an occurrence clause." let error_illegal_non_atomic_clause () = error "\"at\" clause not supported in presence of a non atomic \"in\" clause." let error_occurrences_not_unsupported () = error "Occurrences not supported for this reduction tactic." let bind_change_occurrences occs = function | None -> None | Some c -> Some (Redexpr.out_with_occurrences (occs,c)) let bind_red_expr_occurrences occs nbcl redexp = let has_at_clause = function | Unfold l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l | Pattern l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l | Simpl (Some (occl,_)) -> occl <> all_occurrences_expr | _ -> false in if occs = all_occurrences_expr then if nbcl > 1 && has_at_clause redexp then error_illegal_non_atomic_clause () else redexp else match redexp with | Unfold (_::_::_) -> error_illegal_clause () | Unfold [(occl,c)] -> if occl <> all_occurrences_expr then error_illegal_clause () else Unfold [(occs,c)] | Pattern (_::_::_) -> error_illegal_clause () | Pattern [(occl,c)] -> if occl <> all_occurrences_expr then error_illegal_clause () else Pattern [(occs,c)] | Simpl (Some (occl,c)) -> if occl <> all_occurrences_expr then error_illegal_clause () else Simpl (Some (occs,c)) | Red _ | Hnf | Cbv _ | Lazy _ | ExtraRedExpr _ | CbvVm | Fold _ | Simpl None -> error_occurrences_not_unsupported () | Unfold [] | Pattern [] -> assert false (* The following two tactics apply an arbitrary reduction function either to the conclusion or to a certain hypothesis *) let reduct_in_concl (redfun,sty) gl = convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl let reduct_in_hyp redfun (id,where) gl = convert_hyp_no_check (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl let revert_cast (redfun,kind as r) = if kind = DEFAULTcast then (redfun,REVERTcast) else r let reduct_option redfun = function | Some id -> reduct_in_hyp (fst redfun) id | None -> reduct_in_concl (revert_cast redfun) (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb t env sigma c = if is_fconv cv_pb env sigma t c then t else errorlabstrm "convert-check-hyp" (str "Not convertible.") (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t | Some occl -> contextually false occl (fun subst -> change_and_check Reduction.CONV (replace_vars subst t)) let change_in_concl occl t = reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) let change_in_hyp occl t id = with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) let change_option occl t = function | Some id -> change_in_hyp occl t id | None -> change_in_concl occl t let change chg c cls gl = let cls = concrete_clause_of cls gl in tclMAP (function | OnHyp (id,occs,where) -> change_option (bind_change_occurrences occs chg) c (Some (id,where)) | OnConcl occs -> change_option (bind_change_occurrences occs chg) c None) cls gl (* Pour usage interne (le niveau User est pris en compte par reduce) *) let try_red_in_concl = reduct_in_concl (try_red_product,REVERTcast) let red_in_concl = reduct_in_concl (red_product,REVERTcast) let red_in_hyp = reduct_in_hyp red_product let red_option = reduct_option (red_product,REVERTcast) let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) let hnf_in_hyp = reduct_in_hyp hnf_constr let hnf_option = reduct_option (hnf_constr,REVERTcast) let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) let simpl_in_hyp = reduct_in_hyp simpl let simpl_option = reduct_option (simpl,REVERTcast) let normalise_in_concl = reduct_in_concl (compute,REVERTcast) let normalise_in_hyp = reduct_in_hyp compute let normalise_option = reduct_option (compute,REVERTcast) let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast) (* The main reduction function *) let reduction_clause redexp cl = let nbcl = List.length cl in List.map (function | OnHyp (id,occs,where) -> (Some (id,where), bind_red_expr_occurrences occs nbcl redexp) | OnConcl occs -> (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl goal = let cl = concrete_clause_of cl goal in let redexps = reduction_clause redexp cl in let tac = tclMAP (fun (where,redexp) -> reduct_option (Redexpr.reduction_of_red_expr redexp) where) redexps in match redexp with | Fold _ | Pattern _ -> with_check tac goal | _ -> tac goal (* Unfolding occurrences of a constant *) let unfold_constr = function | ConstRef sp -> unfold_in_concl [all_occurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [all_occurrences,EvalVarRef id] | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) (*******************************************) let id_of_name_with_default id = function | Anonymous -> id | Name id -> id let hid = id_of_string "H" let xid = id_of_string "X" let default_id_of_sort = function Prop _ -> hid | Type _ -> xid let default_id env sigma = function | (name,None,t) -> let dft = default_id_of_sort (Typing.sort_of env sigma t) in id_of_name_with_default dft name | (name,Some b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by central_intro There is possibly renaming, with possibly names to avoid and possibly a move to do after the introduction *) type intro_name_flag = | IntroAvoid of identifier list | IntroBasedOn of identifier * identifier list | IntroMustBe of identifier let find_name loc decl gl = function | IntroAvoid idl -> (* this case must be compatible with [find_intro_names] below. *) let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id | IntroBasedOn (id,idl) -> fresh_id idl id gl | IntroMustBe id -> (* When name is given, we allow to hide a global name *) let id' = next_ident_away id (pf_ids_of_hyps gl) in if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used."); id' (* Returns the names that would be created by intros, without doing intros. This function is supposed to be compatible with an iteration of [find_name] above. As [default_id] checks the sort of the type to build hyp names, we maintain an environment to be able to type dependent hyps. *) let find_intro_names ctxt gl = let _, res = List.fold_right (fun decl acc -> let wantedname,x,typdecl = decl in let env,idl = acc in let name = fresh_id idl (default_id env gl.sigma decl) gl in let newenv = push_rel (wantedname,x,typdecl) env in (newenv,(name::idl))) ctxt (pf_env gl , []) in List.rev res let build_intro_tac id dest tac = match dest with | MoveToEnd true -> tclTHEN (introduction id) (tac id) | dest -> tclTHENLIST [introduction id; move_hyp true id dest; tac id] let rec intro_then_gen loc name_flag move_flag force_flag dep_flag tac gl = match kind_of_term (pf_concl gl) with | Prod (name,t,u) when not dep_flag or (dependent (mkRel 1) u) -> build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag tac gl | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) -> build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag tac gl | _ -> if not force_flag then raise (RefinerError IntroNeedsProduct); try tclTHEN try_red_in_concl (intro_then_gen loc name_flag move_flag force_flag dep_flag tac) gl with Redelimination -> user_err_loc(loc,"Intro",str "No product even after head-reduction.") let intro_gen loc n m f d = intro_then_gen loc n m f d (fun _ -> tclIDTAC) let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true false let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false false let intro_then = intro_then_gen dloc (IntroAvoid []) no_move false false let intro = intro_gen dloc (IntroAvoid []) no_move false false let introf = intro_gen dloc (IntroAvoid []) no_move true false let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false false let intro_then_force = intro_then_gen dloc (IntroAvoid []) no_move true false (**** Multiple introduction tactics ****) let rec intros_using = function | [] -> tclIDTAC | str::l -> tclTHEN (intro_using str) (intros_using l) let intros = tclREPEAT intro let intro_erasing id = tclTHEN (thin [id]) (introduction id) let intro_forthcoming_then_gen loc name_flag move_flag dep_flag tac = let rec aux ids = tclORELSE0 (intro_then_gen loc name_flag move_flag false dep_flag (fun id -> aux (id::ids))) (tac ids) in aux [] let rec get_next_hyp_position id = function | [] -> error ("No such hypothesis: " ^ string_of_id id) | (hyp,_,_) :: right -> if hyp = id then match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd true else get_next_hyp_position id right let thin_for_replacing l gl = try Tacmach.thin l gl with Evarutil.ClearDependencyError (id,err) -> match err with | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.") | Evarutil.OccurHypInSimpleClause (Some id') -> errorlabstrm "" (str "Cannot change " ++ pr_id id ++ strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".") | Evarutil.EvarTypingBreak ev -> errorlabstrm "" (str "Cannot change " ++ pr_id id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential (pf_env gl) ev ++ str".") let intro_replacing id gl = let next_hyp = get_next_hyp_position id (pf_hyps gl) in tclTHENLIST [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl let intros_replacing ids gl = let rec introrec = function | [] -> tclIDTAC | id::tl -> tclTHEN (tclORELSE (intro_replacing id) (intro_using id)) (introrec tl) in introrec ids gl (* User-level introduction tactics *) let intro_move idopt hto = match idopt with | None -> intro_gen dloc (IntroAvoid []) hto true false | Some id -> intro_gen dloc (IntroMustBe id) hto true false let pf_lookup_hypothesis_as_renamed env ccl = function | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id let pf_lookup_hypothesis_as_renamed_gen red h gl = let env = pf_env gl in let rec aux ccl = match pf_lookup_hypothesis_as_renamed env ccl h with | None when red -> aux ((fst (Redexpr.reduction_of_red_expr (Red true))) env (project gl) ccl) | x -> x in try aux (pf_concl gl) with Redelimination -> None let is_quantified_hypothesis id g = match pf_lookup_hypothesis_as_renamed_gen true (NamedHyp id) g with | Some _ -> true | None -> false let msg_quantified_hypothesis = function | NamedHyp id -> str "quantified hypothesis named " ++ pr_id id | AnonHyp n -> int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++ str " non dependent hypothesis" let depth_of_quantified_hypothesis red h gl = match pf_lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> errorlabstrm "lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ str".") let intros_until_gen red h g = tclDO (depth_of_quantified_hypothesis red h g) (if red then introf else intro) g let intros_until_id id = intros_until_gen true (NamedHyp id) let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true let intros_until_n_wored = intros_until_n_gen false let tclCHECKVAR id gl = ignore (pf_get_hyp gl id); tclIDTAC gl let try_intros_until_id_check id = tclORELSE (intros_until_id id) (tclCHECKVAR id) let try_intros_until tac = function | NamedHyp id -> tclTHEN (try_intros_until_id_check id) (tac id) | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac) let rec intros_move = function | [] -> tclIDTAC | (hyp,destopt) :: rest -> tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false false) (intros_move rest) let dependent_in_decl a (_,c,t) = match c with | None -> dependent a t | Some body -> dependent a body || dependent a t (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) let onOpenInductionArg tac = function | ElimOnConstr cbl -> tac cbl | ElimOnAnonHyp n -> tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (Evd.empty,(c,NoBindings)))) | ElimOnIdent (_,id) -> (* A quantified hypothesis *) tclTHEN (try_intros_until_id_check id) (tac (Evd.empty,(mkVar id,NoBindings))) let onInductionArg tac = function | ElimOnConstr cbl -> tac cbl | ElimOnAnonHyp n -> tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (c,NoBindings))) | ElimOnIdent (_,id) -> (* A quantified hypothesis *) tclTHEN (try_intros_until_id_check id) (tac (mkVar id,NoBindings)) let map_induction_arg f = function | ElimOnConstr (sigma,(c,bl)) -> ElimOnConstr (f (sigma,c),bl) | ElimOnAnonHyp n -> ElimOnAnonHyp n | ElimOnIdent id -> ElimOnIdent id (**************************) (* Refinement tactics *) (**************************) let apply_type hdcty argl gl = refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl let apply_term hdc argl gl = refine (applist (hdc,argl)) gl let bring_hyps hyps = if hyps = [] then Refiner.tclIDTAC else (fun gl -> let newcl = List.fold_right mkNamedProd_or_LetIn hyps (pf_concl gl) in let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in refine_no_check (mkApp (f, instance_from_named_context hyps)) gl) let resolve_classes gl = let env = pf_env gl and evd = project gl in if Evd.is_empty evd then tclIDTAC gl else let evd' = Typeclasses.resolve_typeclasses env evd in (tclTHEN (tclEVARS evd') tclNORMEVAR) gl (**************************) (* Cut tactics *) (**************************) let cut c gl = match kind_of_term (pf_hnf_type_of gl c) with | Sort _ -> let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in let t = mkProd (Anonymous, c, pf_concl gl) in tclTHENFIRST (internal_cut_rev id c) (tclTHEN (apply_type t [mkVar id]) (thin [id])) gl | _ -> error "Not a proposition or a type." let cut_intro t = tclTHENFIRST (cut t) intro (* [assert_replacing id T tac] adds the subgoals of the proof of [T] before the current goal id:T0 id:T0 id:T ===== ------> tac(=====) + ==== G T G It fails if the hypothesis to replace appears in the goal or in another hypothesis. *) let assert_replacing id t tac = tclTHENFIRST (internal_cut_replace id t) tac (* [cut_replacing id T tac] adds the subgoals of the proof of [T] after the current goal id:T0 id:T id:T0 ===== ------> ==== + tac(=====) G G T It fails if the hypothesis to replace appears in the goal or in another hypothesis. *) let cut_replacing id t tac = tclTHENLAST (internal_cut_rev_replace id t) tac let cut_in_parallel l = let rec prec = function | [] -> tclIDTAC | h::t -> tclTHENFIRST (cut h) (prec t) in prec (List.rev l) let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly "unnamed dependent meta" in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") (* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last ones (resp [n] first ones if [sidecond_first] is [true]) being the [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) id clenv gl = let clenv = clenv_pose_dependent_evars with_evars clenv in let clenv = if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } else clenv in let new_hyp_typ = clenv_type clenv in if not with_evars & occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in tclTHEN (tclEVARS clenv.evd) ((if sidecond_first then assert_replacing else cut_replacing) id new_hyp_typ (refine_no_check new_hyp_prf)) gl (********************************************) (* Elimination tactics *) (********************************************) let last_arg c = match kind_of_term c with | App (f,cl) -> array_last cl | _ -> anomaly "last_arg" let nth_arg i c = if i = -1 then last_arg c else match kind_of_term c with | App (f,cl) -> cl.(i) | _ -> anomaly "nth_arg" let index_of_ind_arg t = let rec aux i j t = match kind_of_term t with | Prod (_,t,u) -> (* heuristic *) if isInd (fst (decompose_app t)) then aux (Some j) (j+1) u else aux i (j+1) u | _ -> match i with | Some i -> i | None -> error "Could not find inductive argument of elimination scheme." in aux None 0 t let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl = let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.")) in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in res_pf elimclause' ~with_evars:with_evars ~flags gl (* * Elimination tactic with bindings and using an arbitrary * elimination constant called elimc. This constant should end * with a clause (x:I)(P .. ), where P is a bound variable. * The term c is of type t, which is a product ending with a type * matching I, lbindc are the expected terms for c arguments *) type eliminator = { elimindex : int option; (* None = find it automatically *) elimbody : constr with_bindings } let general_elim_clause_gen elimtac indclause elim gl = let (elimc,lbindelimc) = elim.elimbody in let elimt = pf_type_of gl elimc in let i = match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in elimtac i elimclause indclause gl let general_elim_clause elimtac (c,lbindc) elim gl = let ct = pf_type_of gl c in let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in let indclause = make_clenv_binding gl (c,t) lbindc in general_elim_clause_gen elimtac indclause elim gl let general_elim with_evars c e = general_elim_clause (elimination_clause_scheme with_evars) c e (* Elimination tactic with bindings but using the default elimination * constant associated with the type. *) let find_eliminator c gl = let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let c = lookup_eliminator ind (elimination_sort_of_goal gl) in {elimindex = None; elimbody = (c,NoBindings)} let default_elim with_evars (c,_ as cx) gl = general_elim with_evars cx (find_eliminator c gl) gl let elim_in_context with_evars c = function | Some elim -> general_elim with_evars c {elimindex = Some (-1); elimbody = elim} | None -> default_elim with_evars c let elim with_evars (c,lbindc as cx) elim = match kind_of_term c with | Var id when lbindc = NoBindings -> tclTHEN (try_intros_until_id_check id) (elim_in_context with_evars cx elim) | _ -> elim_in_context with_evars cx elim (* The simplest elimination tactic, with no substitutions at all. *) let simplest_elim c = default_elim false (c,NoBindings) (* Elimination in hypothesis *) (* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y) indclause : forall ..., hyps -> a=b (to take place of ?Heq) id : phi(a) (to take place of ?H) and the result is to overwrite id with the proof of phi(b) but this generalizes to any elimination scheme with one constructor (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause = try clenv_fchain ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl = let indmv = destMeta (nth_arg i elimclause.templval.rebus) in let hypmv = try match list_remove indmv (clenv_independent elimclause) with | [a] -> a | _ -> failwith "" with Failure _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = pf_type_of gl hyp in let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if eq_constr hyp_typ new_hyp_typ then errorlabstrm "general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id elimclause'' gl let general_elim_in with_evars id = general_elim_clause (elimination_in_clause_scheme with_evars id) (* Case analysis tactics *) let general_case_analysis_in_context with_evars (c,lbindc) gl = let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sort = elimination_sort_of_goal gl in let elim = if occur_term c (pf_concl gl) then pf_apply build_case_analysis_scheme gl mind true sort else pf_apply build_case_analysis_scheme_default gl mind sort in general_elim with_evars (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings)} gl let general_case_analysis with_evars (c,lbindc as cx) = match kind_of_term c with | Var id when lbindc = NoBindings -> tclTHEN (try_intros_until_id_check id) (general_case_analysis_in_context with_evars cx) | _ -> general_case_analysis_in_context with_evars cx let simplest_case c = general_case_analysis false (c,NoBindings) (* Apply a tactic below the products of the conclusion of a lemma *) type conjunction_status = | DefinedRecord of constant option list | NotADefinedRecordUseScheme of constr let make_projection sigma params cstr sign elim i n c = let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) let (na,b,t) = List.nth cstr.cs_args i in let b = match b with None -> mkRel (i+1) | Some b -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if (* excludes dependent projection types *) noccur_between 1 (n-i-1) t (* excludes flexible projection types *) && not (isEvar (fst (whd_betaiota_stack sigma t))) then let t = lift (i+1-n) t in Some (beta_applist (elim,params@[t;branch]),t) else None | DefinedRecord l -> (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> let t = Typeops.type_of_constant (Global.env()) proj in let args = extended_rel_vect 0 sign in Some (beta_applist (mkConst proj,params),prod_applist t (params@[mkApp (c,args)])) | None -> None in Option.map (fun (abselim,elimt) -> let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim let descend_in_conjunctions tac exit c gl = try let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sign,ccl = decompose_prod_assum t in match match_with_tuple ccl with | Some (_,_,isrec) -> let n = (mis_constr_nargs ind).(0) in let sort = elimination_sort_of_goal gl in let id = fresh_id [] (id_of_string "H") gl in let IndType (indf,_) = pf_apply find_rectype gl ccl in let params = snd (dest_ind_family indf) in let cstr = (get_constructors (pf_env gl) indf).(0) in let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> let elim = pf_apply build_case_analysis_scheme gl ind false sort in NotADefinedRecordUseScheme elim in tclFIRST (list_tabulate (fun i gl -> match make_projection (project gl) params cstr sign elim i n c with | None -> tclFAIL 0 (mt()) gl | Some (p,pt) -> tclTHENS (internal_cut id pt) [refine p; (* Might be ill-typed due to forbidden elimination. *) tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n) gl | None -> raise Exit with RefinerError _|UserError _|Exit -> exit () (****************************************************) (* Resolution tactics *) (****************************************************) let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = let flags = if with_delta then default_unify_flags else default_no_delta_unify_flags in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) let concl_nprod = nb_prod (pf_concl gl0) in let rec try_main_apply with_destruct c gl = let thm_ty0 = nf_betaiota (project gl) (pf_type_of gl c) in let try_apply thm_ty nprod = let n = nb_prod thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in try try_apply thm_ty0 concl_nprod with PretypeError _|RefinerError _|UserError _|Failure _ as exn -> let rec try_red_apply thm_ty = try (* Try to head-reduce the conclusion of the theorem *) let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in try try_apply red_thm concl_nprod with PretypeError _|RefinerError _|UserError _|Failure _ -> try_red_apply red_thm with Redelimination -> (* Last chance: if the head is a variable, apply may try second order unification *) try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit with PretypeError _|RefinerError _|UserError _|Failure _|Exit -> if with_destruct then descend_in_conjunctions try_main_apply (fun _ -> Loc.raise loc exn) c gl else Loc.raise loc exn in try_red_apply thm_ty0 in try_main_apply with_destruct c gl0 let rec apply_with_bindings_gen b e = function | [] -> tclIDTAC | [cb] -> general_apply b b e cb | cb::cbl -> tclTHENLAST (general_apply b b e cb) (apply_with_bindings_gen b e cbl) let apply_with_bindings cb = apply_with_bindings_gen false false [dloc,cb] let eapply_with_bindings cb = apply_with_bindings_gen false true [dloc,cb] let apply c = apply_with_bindings_gen false false [dloc,(c,NoBindings)] let eapply c = apply_with_bindings_gen false true [dloc,(c,NoBindings)] let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) | _ -> assert false (* [apply_in hyp c] replaces hyp : forall y1, ti -> t hyp : rho(u) ======================== with ============ and the ======= goal goal rho(ti) assuming that [c] has type [forall x1..xn -> t' -> u] for some [t] unifiable with [t'] with unifier [rho] *) let find_matching_clause unifier clause = let rec find clause = try unifier clause with exn when catchable_exception exn -> try find (clenv_push_prod clause) with NotExtensibleClause -> failwith "Cannot apply" in find clause let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in if ordered_metas = [] then error "Statement without assumptions."; let f mv = find_matching_clause (clenv_fchain mv ~flags clause) innerclause in try list_try_find f ordered_metas with Failure _ -> error "Unable to unify." let apply_in_once_main flags innerclause (d,lbind) gl = let thm = nf_betaiota gl.sigma (pf_type_of gl d) in let rec aux clause = try progress_with_clause flags innerclause clause with err when Errors.noncritical err -> try aux (clenv_push_prod clause) with NotExtensibleClause -> raise err in aux (make_clenv_binding gl (d,thm) lbind) let apply_in_once sidecond_first with_delta with_destruct with_evars id (loc,(d,lbind)) gl0 = let flags = if with_delta then elim_flags else elim_no_delta_flags in let t' = pf_get_hyp_typ gl0 id in let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in let rec aux with_destruct c gl = try let clause = apply_in_once_main flags innerclause (c,lbind) gl in clenv_refine_in ~sidecond_first with_evars id clause gl with exn when with_destruct -> descend_in_conjunctions aux (fun _ -> raise exn) c gl in aux with_destruct d gl0 (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A ------------------- Gamma |- c : A -> B Gamma |- ?2 : A ---------------------------------------- Gamma |- B Gamma |- ?1 : B -> C ----------------------------------------------------- Gamma |- ? : C Ltac lapply c := let ty := check c in match eval hnf in ty with ?A -> ?B => cut B; [ idtac | apply c ] end. *) let cut_and_apply c gl = let goal_constr = pf_concl gl in match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> tclTHENLAST (apply_type (mkProd (Anonymous,c2,goal_constr)) [mkMeta(new_meta())]) (apply_term c [mkMeta (new_meta())]) gl | _ -> error "lapply needs a non-dependent product." (********************************************************************) (* Exact tactics *) (********************************************************************) let exact_check c gl = let concl = (pf_concl gl) in let ct = pf_type_of gl c in if pf_conv_x_leq gl ct concl then refine_no_check c gl else error "Not an exact proof." let exact_no_check = refine_no_check let vm_cast_no_check c gl = let concl = pf_concl gl in refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl let exact_proof c gl = (* on experimente la synthese d'ise dans exact *) let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) in refine_no_check c gl let (assumption : tactic) = fun gl -> let concl = pf_concl gl in let hyps = pf_hyps gl in let rec arec only_eq = function | [] -> if only_eq then arec false hyps else error "No such assumption." | (id,c,t)::rest -> if (only_eq & eq_constr t concl) or (not only_eq & pf_conv_x_leq gl t concl) then refine_no_check (mkVar id) gl else arec only_eq rest in arec true hyps (*****************************************************************) (* Modification of a local context *) (*****************************************************************) (* This tactic enables the user to remove hypotheses from the signature. * Some care is taken to prevent him from removing variables that are * subsequently used in other hypotheses or in the conclusion of the * goal. *) let clear ids = (* avant seul dyn_clear n'echouait pas en [] *) if ids=[] then tclIDTAC else thin ids let clear_body = thin_body let clear_wildcards ids = tclMAP (fun (loc,id) gl -> try with_check (Tacmach.thin_no_check [id]) gl with ClearDependencyError (id,err) -> (* Intercept standard [thin] error message *) Loc.raise loc (error_clear_dependency (pf_env gl) (id_of_string "_") err)) ids (* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value * true in the boolean list. *) let rec intros_clearing = function | [] -> tclIDTAC | (false::tl) -> tclTHEN intro (intros_clearing tl) | (true::tl) -> tclTHENLIST [ intro; onLastHypId (fun id -> clear [id]); intros_clearing tl] (* Modifying/Adding an hypothesis *) let specialize mopt (c,lbind) g = let tac, term = if lbind = NoBindings then let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in tclEVARS evd, nf_evar evd c else let clause = make_clenv_binding g (c,pf_type_of g c) lbind in let flags = { default_unify_flags with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in let nargs = List.length tstack in let tstack = match mopt with | Some m -> if m < nargs then list_firstn m tstack else tstack | None -> let rec chk = function | [] -> [] | t::l -> if occur_meta t then [] else t :: chk l in chk tstack in let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then errorlabstrm "" (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); tclEVARS clause.evd, term in match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with | Var id when List.mem id (pf_ids_of_hyps g) -> tclTHEN tac (tclTHENFIRST (fun g -> internal_cut_replace id (pf_type_of g term) g) (exact_no_check term)) g | _ -> tclTHEN tac (tclTHENLAST (fun g -> cut (pf_type_of g term) g) (exact_no_check term)) g (* Keeping only a few hypotheses *) let keep hyps gl = let env = Global.env() in let ccl = pf_concl gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> if List.mem hyp hyps or List.exists (occur_var_in_decl env hyp) keep or occur_var env hyp ccl then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (pf_env gl) in thin cl gl (************************) (* Introduction tactics *) (************************) let check_number_of_constructors expctdnumopt i nconstr = if i=0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when n <> nconstr -> error ("Not an inductive goal with "^ string_of_int n^plural n " constructor"^".") | _ -> () end; if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind gl = let cl = pf_concl gl in let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in let nconstr = Array.length (snd (Global.lookup_inductive mind)).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; let cons = mkConstruct (ith_constructor_of_inductive mind i) in let apply_tac = general_apply true false with_evars (dloc,(cons,lbind)) in (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl let one_constructor i lbind = constructor_tac false None i lbind (* Try to apply the constructor of the inductive definition followed by a tactic t given as an argument. Should be generalize in Constructor (Fun c : I -> tactic) *) let any_constructor with_evars tacopt gl = let t = match tacopt with None -> tclIDTAC | Some t -> t in let mind = fst (pf_reduce_to_quantified_ind gl (pf_concl gl)) in let nconstr = Array.length (snd (Global.lookup_inductive mind)).mind_consnames in if nconstr = 0 then error "The type has no constructors."; tclFIRST (List.map (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t) (interval 1 nconstr)) gl let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 let split_with_bindings with_evars l = tclMAP (constructor_tac with_evars (Some 1) 1) l let left = left_with_bindings false let simplest_left = left NoBindings let right = right_with_bindings false let simplest_right = right NoBindings let split = constructor_tac false (Some 1) 1 let simplest_split = split NoBindings (*****************************) (* Decomposing introductions *) (*****************************) (* Rewriting function for rewriting one hypothesis at the time *) let forward_general_multi_rewrite = ref (fun _ -> failwith "general_multi_rewrite undefined") (* Rewriting function for substitution (x=t) everywhere at the same time *) let forward_subst_one = ref (fun _ -> failwith "subst_one undefined") let register_general_multi_rewrite f = forward_general_multi_rewrite := f let register_subst_one f = forward_subst_one := f let error_unexpected_extra_pattern loc nb pat = let s1,s2,s3 = match pat with | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ (if nb = 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if nb = 1 then "was" else "were") ++ strbrk " expected in the branch).") let intro_or_and_pattern loc b ll l' tac id gl = let c = mkVar id in let ind,_ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let nv = mis_constr_nargs ind in let bracketed = b or not (l'=[]) in let rec adjust_names_length nb n = function | [] when n = 0 or not bracketed -> [] | [] -> (dloc,IntroAnonymous) :: adjust_names_length nb (n-1) [] | (loc',pat) :: _ as l when n = 0 -> if bracketed then error_unexpected_extra_pattern loc' nb pat; l | ip :: l -> ip :: adjust_names_length nb (n-1) l in let ll = fix_empty_or_and_pattern (Array.length nv) ll in check_or_and_pattern_size loc ll (Array.length nv); tclTHENLASTn (tclTHEN (simplest_case c) (clear [id])) (array_map2 (fun n l -> tac ((adjust_names_length n n l)@l')) nv (Array.of_list ll)) gl let rewrite_hyp l2r id gl = let rew_on l2r = !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) in let subst_on l2r x rhs = !forward_subst_one true x (id,rhs,l2r) in let clear_var_and_eq c = tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in (* TODO: detect setoid equality? better detect the different equalities *) match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then subst_on l2r (destVar lhs) rhs gl else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then subst_on l2r (destVar rhs) lhs gl else tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl | Some (hdcncl,[c]) -> let l2r = not l2r in (* equality of the form eq_true *) if isVar c then tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq c) gl else tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl | _ -> error "Cannot find a known equation." let rec explicit_intro_names = function | (_, IntroIdentifier id) :: l -> id :: explicit_intro_names l | (_, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ | IntroForthcoming _)) :: l -> explicit_intro_names l | (_, IntroOrAndPattern ll) :: l' -> List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | [] -> [] let wild_id = id_of_string "_tmp" let rec list_mem_assoc_right id = function | [] -> false | (x,id')::l -> id = id' || list_mem_assoc_right id l let check_thin_clash_then id thin avoid tac = if list_mem_assoc_right id thin then let newid = next_ident_away (add_suffix id "'") avoid in let thin = List.map (on_snd (fun id' -> if id = id' then newid else id')) thin in tclTHEN (rename_hyp [id,newid]) (tac thin) else tac thin (* We delay thinning until the completion of the whole intros tactic to ensure that dependent hypotheses are cleared in the right dependency order (see bug #1000); we use fresh names, not used in the tactic, for the hyps to clear *) let rec intros_patterns b avoid ids thin destopt tac = function | (loc, IntroWildcard) :: l -> intro_then_gen loc (IntroBasedOn(wild_id,avoid@explicit_intro_names l)) no_move true false (fun id -> intros_patterns b avoid ids ((loc,id)::thin) destopt tac l) | (loc, IntroIdentifier id) :: l -> check_thin_clash_then id thin avoid (fun thin -> intro_then_gen loc (IntroMustBe id) destopt true false (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)) | (loc, IntroAnonymous) :: l -> intro_then_gen loc (IntroAvoid (avoid@explicit_intro_names l)) destopt true false (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l) | (loc, IntroFresh id) :: l -> (* todo: avoid thinned names to interfere with generation of fresh name *) intro_then_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l)) destopt true false (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l) | (loc, IntroForthcoming onlydeps) :: l -> intro_forthcoming_then_gen loc (IntroAvoid (avoid@explicit_intro_names l)) destopt onlydeps (fun ids -> intros_patterns b avoid ids thin destopt tac l) | (loc, IntroOrAndPattern ll) :: l' -> intro_then_force (intro_or_and_pattern loc b ll l' (intros_patterns b avoid ids thin destopt tac)) | (loc, IntroRewrite l2r) :: l -> intro_then_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true false (fun id -> tclTHENLAST (* Skip the side conditions of the rewriting step *) (rewrite_hyp l2r id) (intros_patterns b avoid ids thin destopt tac l)) | [] -> tac ids thin let intros_pattern destopt = intros_patterns false [] [] [] destopt (fun _ -> clear_wildcards) let intro_pattern destopt pat = intros_pattern destopt [dloc,pat] let intro_patterns = function | [] -> tclREPEAT intro | l -> intros_pattern no_move l (**************************) (* Other cut tactics *) (**************************) let make_id s = fresh_id [] (default_id_of_sort s) let prepare_intros s ipat gl = match ipat with | None -> make_id s gl, tclIDTAC | Some (loc,ipat) -> match ipat with | IntroIdentifier id -> id, tclIDTAC | IntroAnonymous -> make_id s gl, tclIDTAC | IntroFresh id -> fresh_id [] id gl, tclIDTAC | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id] | IntroRewrite l2r -> let id = make_id s gl in id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl | IntroOrAndPattern ll -> make_id s gl, onLastHypId (intro_or_and_pattern loc true ll [] (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards))) | IntroForthcoming _ -> user_err_loc (loc,"",str "Introduction pattern for one hypothesis expected") let ipat_of_name = function | Anonymous -> None | Name id -> Some (dloc, IntroIdentifier id) let allow_replace c gl = function (* A rather arbitrary condition... *) | Some (_, IntroIdentifier id) -> let c = fst (decompose_app ((strip_lam_assum c))) in isVar c && destVar c = id | _ -> false let assert_as first ipat c gl = match kind_of_term (pf_hnf_type_of gl c) with | Sort s -> let id,tac = prepare_intros s ipat gl in let repl = allow_replace c gl ipat in tclTHENS ((if first then internal_cut_gen else internal_cut_rev_gen) repl id c) (if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl | _ -> error "Not a proposition or a type." let assert_tac na = assert_as true (ipat_of_name na) (* apply in as *) let as_tac id ipat = match ipat with | Some (loc,IntroRewrite l2r) -> !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl | Some (loc,IntroOrAndPattern ll) -> intro_or_and_pattern loc true ll [] (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards)) id | Some (loc, (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | IntroWildcard | IntroForthcoming _)) -> user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected") | None -> tclIDTAC let tclMAPLAST tacfun l = List.fold_right (fun x -> tclTHENLAST (tacfun x)) l tclIDTAC let tclMAPFIRST tacfun l = List.fold_right (fun x -> tclTHENFIRST (tacfun x)) l tclIDTAC let general_apply_in sidecond_first with_delta with_destruct with_evars id lemmas ipat = if sidecond_first then (* Skip the side conditions of the applied lemma *) tclTHENLAST (tclMAPLAST (apply_in_once sidecond_first with_delta with_destruct with_evars id) lemmas) (as_tac id ipat) else tclTHENFIRST (tclMAPFIRST (apply_in_once sidecond_first with_delta with_destruct with_evars id) lemmas) (as_tac id ipat) let apply_in simple with_evars id lemmas ipat = general_apply_in false simple simple with_evars id lemmas ipat let simple_apply_in id c = general_apply_in false false false false id [dloc,(c,NoBindings)] None (**************************) (* Generalize tactics *) (**************************) let generalized_name c t ids cl = function | Name id as na -> if List.mem id ids then errorlabstrm "" (pr_id id ++ str " is already used"); na | Anonymous -> match kind_of_term c with | Var id -> (* Keep the name even if not occurring: may be used by intros later *) Name id | _ -> if noccurn 1 cl then Anonymous else (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous let generalize_goal gl i ((occs,c,b),na) cl = let t = pf_type_of gl c in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in mkProd_or_LetIn (na,b,t) cl' let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in let rec seek d toquant = if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant or dependent_in_decl c d then d::toquant else toquant in let to_quantify = Sign.fold_named_context seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with | Var id when mem_named_context id sign & not (List.mem id init_ids) -> id::tothin | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in let body = if with_let then match kind_of_term c with | Var id -> pi2 (pf_get_hyp gl id) | _ -> None else None in let cl'' = generalize_goal gl 0 ((all_occurrences,c,body),Anonymous) cl' in let args = Array.to_list (instance_from_named_context to_quantify_rev) in tclTHEN (apply_type cl'' (if body = None then c::args else args)) (thin (List.rev tothin')) gl let generalize_gen_let lconstr gl = let newcl = list_fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in apply_type newcl (list_map_filter (fun ((_,c,b),_) -> if b = None then Some c else None) lconstr) gl let generalize_gen lconstr = generalize_gen_let (List.map (fun ((occs,c),na) -> (occs,c,None),na) lconstr) let generalize l = generalize_gen_let (List.map (fun c -> ((all_occurrences,c,None),Anonymous)) l) let pf_get_hyp_val gl id = let (_, b, _) = pf_get_hyp gl id in b let revert hyps gl = let lconstr = List.map (fun id -> ((all_occurrences, mkVar id, pf_get_hyp_val gl id), Anonymous)) hyps in tclTHEN (generalize_gen_let lconstr) (clear hyps) gl (* Faudra-t-il une version avec plusieurs args de generalize_dep ? Cela peut-être troublant de faire "Generalize Dependent H n" dans "n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la généralisation dépendante par n. let quantify lconstr = List.fold_right (fun com tac -> tclTHEN tac (tactic_com generalize_dep c)) lconstr tclIDTAC *) (* A dependent cut rule à la sequent calculus ------------------------------------------ Sera simplifiable le jour où il y aura un let in primitif dans constr [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms [...x1:T1(c),...,x2:T2(c),... |- G(c)] into [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true [occ_hyp,occ_ccl] tells which occurrences of [c] have to be substituted; if [occ_hyp = []] and [occ_ccl = None] then [c] is substituted wherever it occurs, otherwise [c] is substituted only in hyps present in [occ_hyps] at the specified occurrences (everywhere if the list of occurrences is empty), and in the goal at the specified occurrences if [occ_goal] is not [None]; if name = Anonymous, the name is build from the first letter of the type; The tactic first quantify the goal over x1, x2,... then substitute then re-intro x1, x2,... at their initial place ([marks] is internally used to remember the place of x1, x2, ...: it is the list of hypotheses on the left of each x1, ...). *) let out_arg = function | ArgVar _ -> anomaly "Unevaluated or_var variable" | ArgArg x -> x let occurrences_of_hyp id cls = let rec hyp_occ = function [] -> None | (((b,occs),id'),hl)::_ when id=id' -> Some ((b,List.map out_arg occs),hl) | _::l -> hyp_occ l in match cls.onhyps with None -> Some (all_occurrences,InHyp) | Some l -> hyp_occ l let occurrences_of_goal cls = if cls.concl_occs = no_occurrences_expr then None else Some (on_snd (List.map out_arg) cls.concl_occs) let in_every_hyp cls = (cls.onhyps=None) (* (* Implementation with generalisation then re-intro: introduces noise *) (* in proofs *) let letin_abstract id c occs gl = let env = pf_env gl in let compute_dependency _ (hyp,_,_ as d) ctxt = let d' = try match occurrences_of_hyp hyp occs with | None -> raise Not_found | Some occ -> let newdecl = subst_term_occ_decl occ c d in if occ = [] & d = newdecl then if not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else raise Not_found else (subst1_named_decl (mkVar id) newdecl, true) with Not_found -> (d,List.exists (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt) in d'::ctxt in let ctxt' = fold_named_context compute_dependency env ~init:[] in let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) = if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp) else (accu, Some hyp) in let (depdecls,marks),_ = List.fold_left compute_marks (([],[]),None) ctxt' in let ccl = match occurrences_of_goal occs with | None -> pf_concl gl | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in (depdecls,marks,ccl) let letin_tac with_eq name c occs gl = let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in let id = if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared") in let (depdecls,marks,ccl)= letin_abstract id c occs gl in let t = pf_type_of gl c in let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in let args = Array.to_list (instance_from_named_context depdecls) in let newcl = mkNamedLetIn id c t tmpcl in let lastlhyp = if marks=[] then None else snd (List.hd marks) in tclTHENLIST [ apply_type newcl args; thin (List.map (fun (id,_,_) -> id) depdecls); intro_gen (IntroMustBe id) lastlhyp false; if with_eq then tclIDTAC else thin_body [id]; intros_move marks ] gl *) (* Implementation without generalisation: abbrev will be lost in hyps in *) (* in the extracted proof *) let default_matching_flags sigma = { modulo_conv_on_closed_terms = Some empty_transparent_state; use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; modulo_delta_in_merge = Some full_transparent_state; check_applied_meta_types = true; resolve_evars = false; use_pattern_unification = false; use_meta_bound_pattern_unification = false; frozen_evars = fold_undefined (fun evk _ evars -> ExistentialSet.add evk evars) sigma ExistentialSet.empty; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = false; allow_K_in_toplevel_higher_order_unification = false } let make_pattern_test env sigma0 (sigma,c) = let flags = default_matching_flags sigma0 in let matching_fun t = try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t) with e when Errors.noncritical e -> raise NotUnifiable in let merge_fun c1 c2 = match c1, c2 with | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) -> raise NotUnifiable | _ -> c1 in { match_fun = matching_fun; merge_fun = merge_fun; testing_state = None; last_found = None }, (fun test -> match test.testing_state with | None -> finish_evar_resolution env sigma0 (sigma,c) | Some (sigma,_) -> nf_evar sigma c) let letin_abstract id c (test,out) (occs,check_occs) gl = let env = pf_env gl in let compute_dependency _ (hyp,_,_ as d) depdecls = match occurrences_of_hyp hyp occs with | None -> depdecls | Some occ -> let newdecl = subst_closed_term_occ_decl_modulo occ test d in if occ = (all_occurrences,InHyp) & eq_named_declaration d newdecl then if check_occs & not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else depdecls else (subst1_named_decl (mkVar id) newdecl)::depdecls in let depdecls = fold_named_context compute_dependency env ~init:[] in let ccl = match occurrences_of_goal occs with | None -> pf_concl gl | Some occ -> subst1 (mkVar id) (subst_closed_term_occ_modulo occ test None (pf_concl gl)) in let lastlhyp = if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in (depdecls,lastlhyp,ccl,out test) let letin_tac_gen with_eq name (sigmac,c) test ty occs gl = let id = let t = match ty with Some t -> t | None -> typ_of (pf_env gl) sigmac c in let x = id_of_name_using_hdchar (Global.env()) t name in if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared.") in let (depdecls,lastlhyp,ccl,c) = letin_abstract id c test occs gl in let t = match ty with Some t -> t | None -> pf_apply typ_of gl c in let newcl,eq_tac = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> fresh_id [id] (add_prefix "Heq" id) gl | IntroFresh heq_base -> fresh_id [id] heq_base gl | IntroIdentifier id -> id | _ -> error"Expect an introduction pattern naming one hypothesis." in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let eq = applist (eqdata.eq,args) in let refl = applist (eqdata.refl, [t;mkVar id]) in mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)), tclTHEN (intro_gen loc (IntroMustBe heq) lastlhyp true false) (thin_body [heq;id]) | None -> mkNamedLetIn id c t ccl, tclIDTAC in tclTHENLIST [ convert_concl_no_check newcl DEFAULTcast; intro_gen dloc (IntroMustBe id) lastlhyp true false; tclMAP convert_hyp_no_check depdecls; eq_tac ] gl let make_eq_test c = (make_eq_test c,fun _ -> c) let letin_tac with_eq name c ty occs gl = letin_tac_gen with_eq name (project gl,c) (make_eq_test c) ty (occs,true) gl let letin_pat_tac with_eq name c ty occs gl = letin_tac_gen with_eq name c (make_pattern_test (pf_env gl) (project gl) c) ty (occs,true) gl (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *) let forward usetac ipat c gl = match usetac with | None -> let t = pf_type_of gl c in tclTHENFIRST (assert_as true ipat t) (exact_no_check c) gl | Some tac -> tclTHENFIRST (assert_as true ipat c) tac gl let pose_proof na c = forward None (ipat_of_name na) c let assert_by na t tac = forward (Some tac) (ipat_of_name na) t (*****************************) (* Ad hoc unfold *) (*****************************) (* The two following functions should already exist, but found nowhere *) (* Unfolds x by its definition everywhere *) let unfold_body x gl = let hyps = pf_hyps gl in let xval = match Sign.lookup_named x hyps with (_,Some xval,_) -> xval | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") in let aft = afterHyp x gl in let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in tclTHENLIST [tclMAP (fun h -> reduct_in_hyp rfun h) hl; reduct_in_concl (rfun,DEFAULTcast)] gl (* Unfolds x by its definition everywhere and clear x. This may raise an error if x is not defined. *) let unfold_all x gl = let (_,xval,_) = pf_get_hyp gl x in (* If x has a body, simply replace x with body and clear x *) if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else tclIDTAC gl (* Either unfold and clear if defined or simply clear if not a definition *) let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id]) (*****************************) (* High-level induction *) (*****************************) (* * A "natural" induction tactic * - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal - [hyp0] is the induction hypothesis - we extract from [args] the variables which are not rigid parameters of the inductive type, this is [indvars] (other terms are forgotten); [indhyps] are the ones which actually are declared in context (done in [find_atomic_param_of_ind]) - we look for all hyps depending of [hyp0] or one of [indvars]: this is [dephyps] of types [deptyps] respectively - [statuslist] tells for each hyps in [dephyps] after which other hyp fixed in the context they must be moved (when induction is done) - [hyp0succ] is the name of the hyp fixed in the context after which to move the subterms of [hyp0succ] in the i-th branch where it is supposed to be the i-th constructor of the inductive type. Strategy: (cf in [induction_from_context]) - requantify and clear all [dephyps] - apply induction on [hyp0] - clear [indhyps] and [hyp0] - in the i-th subgoal, intro the arguments of the i-th constructor of the inductive type after [hyp0succ] (done in [induct_discharge]) let the induction hypotheses on top of the hyps because they may depend on variables between [hyp0] and the top. A counterpart is that the dep hyps programmed to be intro-ed on top must now be intro-ed after the induction hypotheses - move each of [dephyps] at the right place following the [statuslist] *) let check_unused_names names = if names <> [] & Flags.is_verbose () then msg_warning (str"Unused introduction " ++ str (plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc pr_intro_pattern names) let rec consume_pattern avoid id isdep gl = function | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), []) | (loc,IntroAnonymous)::names -> let avoid = avoid@explicit_intro_names names in ((loc,IntroIdentifier (fresh_id avoid id gl)), names) | (loc,IntroForthcoming true)::names when not isdep -> consume_pattern avoid id isdep gl names | (loc,IntroForthcoming _)::names as fullpat -> let avoid = avoid@explicit_intro_names names in ((loc,IntroIdentifier (fresh_id avoid id gl)), fullpat) | (loc,IntroFresh id')::names -> let avoid = avoid@explicit_intro_names names in ((loc,IntroIdentifier (fresh_id avoid id' gl)), names) | pat::names -> (pat,names) let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = let tophyp = match tophyp with None -> MoveToEnd true | Some hyp -> MoveAfter hyp in let newlstatus = (* if some IH has taken place at the top of hyps *) List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus in tclTHEN (intros_move rstatus) (intros_move newlstatus) let update destopt tophyp = if destopt = no_move then tophyp else destopt let safe_dest_intros_patterns avoid thin dest pat tac gl = try intros_patterns true avoid [] thin dest tac pat gl with UserError ("move_hyp",_) -> (* May happen if the lemma has dependent arguments that are resolved only after cook_sign is called, e.g. as in "destruct dec" in context "dec:forall x, {x=0}+{x<>0}; a:A |- if dec a then True else False" where argument a of dec will be found only lately *) intros_patterns true avoid [] [] no_move tac pat gl type elim_arg_kind = RecArg | IndArg | OtherArg type recarg_position = | AfterFixedPosition of identifier option (* None = top of context *) let update_dest (recargdests,tophyp as dests) = function | [] -> dests | hyp::_ -> (match recargdests with | AfterFixedPosition None -> AfterFixedPosition (Some hyp) | x -> x), (match tophyp with None -> Some hyp | x -> x) let get_recarg_dest (recargdests,tophyp) = match recargdests with | AfterFixedPosition None -> MoveToEnd true | AfterFixedPosition (Some id) -> MoveAfter id (* Current policy re-introduces recursive arguments of destructed variable at the place of the original variable while induction hypothesese are introduced at the top of the context. Since in the general case of an inductive scheme, the induction hypotheses can arrive just after the recursive arguments (e.g. as in "forall t1:tree, P t1 -> forall t2:tree, P t2 -> P (node t1 t2)", we need to update the position for t2 after "P t1" is introduced if ever t2 had to be introduced at the top of the context). *) let induct_discharge dests avoid' tac (avoid,ra) names gl = let avoid = avoid @ avoid' in let rec peel_tac ra dests names thin gl = match ra with | (RecArg,deprec,recvarname) :: (IndArg,depind,hyprecname) :: ra' -> let recpat,names = match names with | [loc,IntroIdentifier id as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in (pat, [dloc, IntroIdentifier id']) | _ -> consume_pattern avoid recvarname deprec gl names in let hyprec,names = consume_pattern avoid hyprecname depind gl names in let dest = get_recarg_dest dests in safe_dest_intros_patterns avoid thin dest [recpat] (fun ids thin -> safe_dest_intros_patterns avoid thin no_move [hyprec] (fun ids' thin -> peel_tac ra' (update_dest dests ids') names thin)) gl | (IndArg,dep,hyprecname) :: ra' -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid hyprecname dep gl names in safe_dest_intros_patterns avoid thin no_move [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) gl | (RecArg,dep,recvarname) :: ra' -> let pat,names = consume_pattern avoid recvarname dep gl names in let dest = get_recarg_dest dests in safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) gl | (OtherArg,_,_) :: ra' -> let pat,names = match names with | [] -> (dloc, IntroAnonymous), [] | pat::names -> pat,names in let dest = get_recarg_dest dests in safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) gl | [] -> check_unused_names names; tclTHEN (clear_wildcards thin) (tac dests) gl in peel_tac ra dests names [] gl (* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas s'embêter à regarder si un letin_tac ne fait pas des substitutions aussi sur l'argument voisin *) (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind (indref,nparams,_) hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in let prods, indtyp = decompose_prod typ0 in let argl = snd (decompose_app indtyp) in let params = list_firstn nparams argl in (* le gl est important pour ne pas préévaluer *) let rec atomize_one i avoid gl = if i<>nparams then let tmptyp0 = pf_get_hyp_typ gl hyp0 in (* If argl <> [], we expect typ0 not to be quantified, in order to avoid bound parameters... then we call pf_reduce_to_atomic_ind *) let indtyp = pf_apply reduce_to_atomic_ref gl indref tmptyp0 in let argl = snd (decompose_app indtyp) in let c = List.nth argl (i-1) in match kind_of_term c with | Var id when not (List.exists (occur_var (pf_env gl) id) avoid) -> atomize_one (i-1) ((mkVar id)::avoid) gl | Var id -> let x = fresh_id [] id gl in tclTHEN (letin_tac None (Name x) (mkVar id) None allHypsAndConcl) (atomize_one (i-1) ((mkVar x)::avoid)) gl | _ -> let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let x = fresh_id [] id gl in tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) (atomize_one (i-1) ((mkVar x)::avoid)) gl else tclIDTAC gl in atomize_one (List.length argl) params gl let find_atomic_param_of_ind nparams indtyp = let argl = snd (decompose_app indtyp) in let argv = Array.of_list argl in let params = list_firstn nparams argl in let indvars = ref Idset.empty in for i = nparams to (Array.length argv)-1 do match kind_of_term argv.(i) with | Var id when not (List.exists (occur_var (Global.env()) id) params) -> indvars := Idset.add id !indvars | _ -> () done; Idset.elements !indvars; (* [cook_sign] builds the lists [indhyps] of hyps that must be erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the goal together with the places [(lstatus,rstatus)] where to re-intro them after induction. To know where to re-intro the dep hyp, we remember the name of the hypothesis [lhyp] after which (if the dep hyp is more recent than [hyp0]) or [rhyp] before which (if older than [hyp0]) its equivalent must be moved when the induction has been applied. Since computation of dependencies and [rhyp] is from more ancient (on the right) to more recent hyp (on the left) but the computation of [lhyp] progresses from the other way, [cook_hyp] is in two passes (an alternative would have been to write an higher-order algorithm). We use references to reduce the accumulation of arguments. To summarize, the situation looks like this Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat Left Right Induction hypothesis is H4 ([hyp0]) Variable parameters of (le O n) is the singleton list with "n" ([indvars]) Part of [indvars] really in context is the same ([indhyps]) The dependent hyps are H3 and H6 ([dephyps]) For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp]) because these names are among the hyp which are fixed through the induction For H6 the neighbours are None ([lhyp]) and H5 ([rhyp]) For H3, because on the right of H4, we remember rhyp (here H2) For H6, because on the left of H4, we remember lhyp (here None) For H4, we remember lhyp (here H5) The right neighbour is then translated into the left neighbour because move_hyp tactic needs the name of the hyp _after_ which we move the hyp to move. But, say in the 2nd subgoal of the hypotheses, the goal will be (m:nat)((P m)->(Q m)->(Goal m)) -> (P Sm)-> (Q Sm)-> (Goal Sm) ^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^ both go where H4 was goes where goes where H3 was H6 was We have to intro and move m and the recursive hyp first, but then where to move H3 ??? Only the hyp on its right is relevant, but we have to translate it into the name of the hyp on the left Note: this case where some hyp(s) in [dephyps] has(have) the same left neighbour as [hyp0] is the only problematic case with right neighbours. For the other cases (e.g. an hyp H1:(R n) between n and H2 would have posed no problem. But for uniformity, we decided to use the right hyp for all hyps on the right of H4. Others solutions are welcome PC 9 fev 06: Adapted to accept multi argument principle with no main arg hyp. hyp0 is now optional, meaning that it is possible that there is no main induction hypotheses. In this case, we consider the last "parameter" (in [indvars]) as the limit between "left" and "right", BUT it must be included in indhyps. Other solutions are still welcome *) exception Shunt of identifier move_location let cook_sign hyp0_opt indvars env = let hyp0,inhyps = match hyp0_opt with | None -> List.hd (List.rev indvars), [] | Some (hyp0,at_least_in_hyps) -> hyp0, at_least_in_hyps in (* First phase from L to R: get [indhyps], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) let allindhyps = hyp0::indvars in let indhyps = ref [] in let decldeps = ref [] in let ldeps = ref [] in let rstatus = ref [] in let lstatus = ref [] in let before = ref true in let seek_deps env (hyp,_,_ as decl) rhyp = if hyp = hyp0 then begin before:=false; (* If there was no main induction hypotheses, then hyp is one of indvars too, so add it to indhyps. *) (if hyp0_opt=None then indhyps := hyp::!indhyps); MoveToEnd false (* fake value *) end else if List.mem hyp indvars then begin (* warning: hyp can still occur after induction *) (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *) indhyps := hyp::!indhyps; rhyp end else if inhyps <> [] && List.mem hyp inhyps || inhyps = [] && (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps || List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps) then begin decldeps := decl::!decldeps; if !before then rstatus := (hyp,rhyp)::!rstatus else ldeps := hyp::!ldeps; (* status computed in 2nd phase *) MoveBefore hyp end else MoveBefore hyp in let _ = fold_named_context seek_deps env ~init:(MoveToEnd false) in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp (hyp,_,_) = if hyp = hyp0 then raise (Shunt lhyp); if List.mem hyp !ldeps then begin lstatus := (hyp,lhyp)::!lstatus; lhyp end else if List.mem hyp !indhyps then lhyp else MoveAfter hyp in try let _ = fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in raise (Shunt (MoveToEnd true)) (* ?? FIXME *) with Shunt lhyp0 -> let lhyp0 = match lhyp0 with | MoveToEnd true -> None | MoveAfter hyp -> Some hyp | _ -> assert false in let statuslists = (!lstatus,List.rev !rstatus) in let recargdests = AfterFixedPosition (if hyp0_opt=None then None else lhyp0) in (statuslists, (recargdests,None), !indhyps, !decldeps) (* The general form of an induction principle is the following: forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni), (induction arguments) (HI: I prm1..prmp x1...xni) (optional main induction arg) -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ optional optional argument added if even if HI principle generated by functional present above induction, only if HI does not exist [indarg] [farg] HI is not present when the induction principle does not come directly from an inductive type (like when it is generated by functional induction for example). HI is present otherwise BUT may not appear in the conclusion (dependent principle). HI and (f...) cannot be both present. Principles taken from functional induction have the final (f...).*) (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; index: int; (* index of the elimination type in the scheme *) params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) branches: rel_context; (* branchr,...,branch1 *) nbranches: int; (* Number of branches *) args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } let empty_scheme = { elimc = None; elimt = mkProp; indref = None; index = -1; params = []; nparams = 0; predicates = []; npredicates = 0; branches = []; nbranches = 0; args = []; nargs = 0; indarg = None; concl = mkProp; indarg_in_concl = false; farg_in_concl = false; } let make_base n id = if n=0 or n=1 then id else (* This extends the name to accept new digits if it already ends with *) (* digits *) id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0))) (* Builds two different names from an optional inductive type and a number, also deals with a list of names to avoid. If the inductive type is None, then hyprecname is IHi where i is a number. *) let make_up_names n ind_opt cname = let is_hyp = atompart_of_id cname = "H" in let base = string_of_id (make_base n cname) in let ind_prefix = "IH" in let base_ind = if is_hyp then match ind_opt with | None -> id_of_string ind_prefix | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) else add_prefix ind_prefix cname in let hyprecname = make_base n base_ind in let avoid = if n=1 (* Only one recursive argument *) or n=0 then [] else (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) (* in order to get names such as f1, f2, ... *) let avoid = (make_ident (string_of_id hyprecname) None) :: (make_ident (string_of_id hyprecname) (Some 0)) :: [] in if atompart_of_id cname <> "H" then (make_ident base (Some 0)) :: (make_ident base None) :: avoid else avoid in id_of_string base, hyprecname, avoid let error_ind_scheme s = let s = if s <> "" then s^" " else s in error ("Cannot recognize "^s^"an induction scheme.") let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") let mkEq t x y = mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |]) let mkRefl t x = mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |]) let mkHEq t x u y = mkApp (Lazy.force coq_heq, [| refresh_universes_strict t; x; refresh_universes_strict u; y |]) let mkHRefl t x = mkApp (Lazy.force coq_heq_refl, [| refresh_universes_strict t; x |]) let lift_togethern n l = let l', _ = List.fold_right (fun x (acc, n) -> (lift n x :: acc, succ n)) l ([], n) in l' let lift_list l = List.map (lift 1) l let ids_of_constr ?(all=false) vars c = let rec aux vars c = match kind_of_term c with | Var id -> Idset.add id vars | App (f, args) -> (match kind_of_term f with | Construct (ind,_) | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in array_fold_left_from (if all then 0 else mib.Declarations.mind_nparams) aux vars args | _ -> fold_constr aux vars c) | _ -> fold_constr aux vars c in aux vars c let decompose_indapp f args = match kind_of_term f with | Construct (ind,_) | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams_rec in let pars, args = array_chop first args in mkApp (f, pars), args | _ -> f, args let mk_term_eq env sigma ty t ty' t' = if Reductionops.is_conv env sigma ty ty' then mkEq ty t t', mkRefl ty' t' else mkHEq ty t ty' t', mkHRefl ty' t' let make_abstract_generalize gl id concl dep ctx body c eqs args refls = let meta = Evarutil.new_meta() in let eqslen = List.length eqs in let term, typ = mkVar id, pf_get_hyp_typ gl id in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let abshypeq, abshypt = if dep then let eq, refl = mk_term_eq (push_rel_context ctx (pf_env gl)) (project gl) (lift 1 c) (mkRel 1) typ term in mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in (* Abstract by equalitites *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instanciated hyp. *) let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body in (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) mkApp (appeqs, abshypt) let hyps_of_vars env sign nogen hyps = if Idset.is_empty hyps then [] else let (_,lh) = Sign.fold_named_context_reverse (fun (hs,hl) (x,_,_ as d) -> if Idset.mem x nogen then (hs,hl) else if Idset.mem x hs then (hs,x::hl) else let xvars = global_vars_set_of_decl env d in if not (Idset.equal (Idset.diff xvars hs) Idset.empty) then (Idset.add x hs, x :: hl) else (hs, hl)) ~init:(hyps,[]) sign in lh exception Seen let linear vars args = let seen = ref vars in try Array.iter (fun i -> let rels = ids_of_constr ~all:true Idset.empty i in let seen' = Idset.fold (fun id acc -> if Idset.mem id acc then raise Seen else Idset.add id acc) rels !seen in seen := seen') args; true with Seen -> false let is_defined_variable env id = pi2 (lookup_named id env) <> None let abstract_args gl generalize_vars dep id defined f args = let sigma = project gl in let env = pf_env gl in let concl = pf_concl gl in let dep = dep || dependent (mkVar id) concl in let avoid = ref [] in let get_id name = let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in avoid := id :: !avoid; id in (* Build application generalized w.r.t. the argument plus the necessary eqs. From env |- c : forall G, T and args : G we build (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize) eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let (name, _, ty), arity = let rel, c = Reductionops.splay_prod_n env sigma 1 prod in List.hd rel, c in let argty = pf_type_of gl arg in let argty = refresh_universes_strict argty in let ty = refresh_universes_strict ty in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in match kind_of_term arg with | Var id when not (is_defined_variable env id) && leq && not (Idset.mem id nongenvars) -> (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, Idset.add id nongenvars, Idset.remove id vars, env) | _ -> let name = get_id name in let decl = (Name name, None, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in let liftarg = lift (List.length ctx) arg in let eq, refl = if leq then mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg else mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg in let eqs = eq :: lift_list eqs in let refls = refl :: refls in let argvars = ids_of_constr vars arg in (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, nongenvars, Idset.union argvars vars, env) in let f', args' = decompose_indapp f args in let dogen, f', args' = let parvars = ids_of_constr ~all:true Idset.empty f' in if not (linear parvars args') then true, f, args else match array_find_i (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with | None -> false, f', args' | Some nonvar -> let before, after = array_chop nonvar args' in true, mkApp (f', before), after in if dogen then let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = if generalize_vars then let nogen = Idset.add id nogen in hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in let body, c' = if defined then Some c', typ_of ctxenv Evd.empty c' else None, c' in Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl = Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; let f, args, def, id, oldid = let oldid = pf_get_new_id id gl in let (_, b, t) = pf_get_hyp gl id in match b with | None -> let f, args = decompose_app t in f, args, false, id, oldid | Some t -> let f, args = decompose_app t in f, args, true, id, oldid in if args = [] then tclIDTAC gl else let args = Array.of_list args in let newc = abstract_args gl generalize_vars force_dep id def f args in match newc with | None -> tclIDTAC gl | Some (newc, dep, n, vars) -> let tac = if dep then tclTHENLIST [refine newc; rename_hyp [(id, oldid)]; tclDO n intro; generalize_dep ~with_let:true (mkVar oldid)] else tclTHENLIST [refine newc; clear [id]; tclDO n intro] in if vars = [] then tac gl else tclTHEN tac (fun gl -> tclFIRST [revert vars ; tclMAP (fun id -> tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl let rec compare_upto_variables x y = if (isVar x || isRel x) && (isVar y || isRel y) then true else compare_constr compare_upto_variables x y let specialize_eqs id gl = let env = pf_env gl in let ty = pf_get_hyp_typ gl id in let evars = ref (project gl) in let unif env evars c1 c2 = compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 in let rec aux in_eqs ctx acc ty = match kind_of_term ty with | Prod (na, t, b) -> (match kind_of_term t with | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> let c = if noccur_between 1 (List.length ctx) x then y else x in let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty | App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) -> let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty | _ -> if in_eqs then acc, in_eqs, ctx, ty else let e = e_new_evar evars (push_rel_context ctx env) t in aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in let ctx'' = List.map (fun (n,b,t as decl) -> match b with | Some k when isEvar k -> (n,None,t) | b -> decl) ctx' in let ty' = it_mkProd_or_LetIn ty ctx'' in let acc' = it_mkLambda_or_LetIn acc ctx'' in let ty' = Tacred.whd_simpl env !evars ty' and acc' = Tacred.whd_simpl env !evars acc' in let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') (exact_no_check (refresh_universes_strict acc')) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl let specialize_eqs id gl = if (try ignore(clear [id] gl); false with e when Errors.noncritical e -> true) then tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl else specialize_eqs id gl let occur_rel n c = let res = not (noccurn n c) in res (* cuts a list in two parts, first of size n. Size must be greater than n *) let cut_list n l = let rec cut_list_aux acc n l = if n<=0 then acc,l else match l with | [] -> assert false | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in let res = cut_list_aux [] n l in res (* This function splits the products of the induction scheme [elimt] into four parts: - branches, easily detectable (they are not referred by rels in the subterm) - what was found before branches (acc1) that is: parameters and predicates - what was found after branches (acc3) that is: args and indarg if any if there is no branch, we try to fill in acc3 with args/indargs. We also return the conclusion. *) let decompose_paramspred_branch_args elimt = let rec cut_noccur elimt acc2 : rel_context * rel_context * types = match kind_of_term elimt with | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in if not (occur_rel 1 elimt') && isRel hd_tpe then cut_noccur elimt' ((nme,None,tpe)::acc2) else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in let rec cut_occur elimt acc1 : rel_context * rel_context * rel_context * types = match kind_of_term elimt with | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c ((nme,None,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl | App(_, _) | Rel _ -> acc1,[],[],elimt | _ -> error_ind_scheme "" in let acc1, acc2 , acc3, ccl = cut_occur elimt [] in (* Particular treatment when dealing with a dependent empty type elim scheme: if there is no branch, then acc1 contains all hyps which is wrong (acc1 should contain parameters and predicate only). This happens for an empty type (See for example Empty_set_ind, as False would actually be ok). Then we must find the predicate of the conclusion to separate params_pred from args. We suppose there is only one predicate here. *) if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl else let hyps,ccl = decompose_prod_assum elimt in let hd_ccl_pred,_ = decompose_app ccl in match kind_of_term hd_ccl_pred with | Rel i -> let acc3,acc1 = cut_list (i-1) hyps in acc1 , [] , acc3 , ccl | _ -> error_ind_scheme "" let exchange_hd_app subst_hd t = let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) (* [rebuild_elimtype_from_scheme scheme] rebuilds the type of an eliminator from its [scheme_info]. The idea is to build variants of eliminator by modifying their scheme_info, then rebuild the eliminator type, then prove it (with tactics). *) let rebuild_elimtype_from_scheme (scheme:elim_scheme): types = let hiconcl = match scheme.indarg with | None -> scheme.concl | Some x -> mkProd_or_LetIn x scheme.concl in let xihiconcl = it_mkProd_or_LetIn hiconcl scheme.args in let brconcl = it_mkProd_or_LetIn xihiconcl scheme.branches in let predconcl = it_mkProd_or_LetIn brconcl scheme.predicates in let paramconcl = it_mkProd_or_LetIn predconcl scheme.params in paramconcl exception NoLastArg exception NoLastArgCcl (* Builds an elim_scheme from its type and calling form (const+binding). We first separate branches. We obtain branches, hyps before (params + preds), hyps after (args <+ indarg if present>) and conclusion. Then we proceed as follows: - separate parameters and predicates in params_preds. For that we build: forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^ optional opt Free rels appearing in this term are parameters (branches should not appear, and the only predicate would have been Qi but we replaced it by DUMMY). We guess this heuristic catches all params. TODO: generalize to the case where args are merged with branches (?) and/or where several predicates are cited in the conclusion. - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) let compute_elim_sig ?elimc elimt = let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in let nparams = Intset.cardinal (free_rels concl_with_args) in let preds,params = cut_list (List.length params_preds - nparams) params_preds in (* A first approximation, further analysis will tweak it *) let res = ref { empty_scheme with (* This fields are ok: *) elimc = elimc; elimt = elimt; concl = conclusion; predicates = preds; npredicates = List.length preds; branches = branches; nbranches = List.length branches; farg_in_concl = isApp ccl && isApp (last_arg ccl); params = params; nparams = nparams; (* all other fields are unsure at this point. Including these:*) args = args_indargs; nargs = List.length args_indargs; } in try (* Order of tests below is important. Each of them exits if successful. *) (* 1- First see if (f x...) is in the conclusion. *) if !res.farg_in_concl then begin res := { !res with indarg = None; indarg_in_concl = false; farg_in_concl = true }; raise Exit end; (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *) if !res.nargs=0 then raise Exit; (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with | hiname,Some _,hi -> error_ind_scheme "" | hiname,None,hi -> let hi_ind, hi_args = decompose_app hi in let hi_is_ind = (* hi est d'un type globalisable *) match kind_of_term hi_ind with | Ind (mind,_) -> true | Var _ -> true | Const _ -> true | Construct _ -> true | _ -> false in let hi_args_enough = (* hi a le bon nbre d'arguments *) List.length hi_args = List.length params + !res.nargs -1 in (* FIXME: Ces deux tests ne sont pas suffisants. *) if not (hi_is_ind & hi_args_enough) then raise Exit (* No indarg *) else (* Last arg is the indarg *) res := {!res with indarg = Some (List.hd !res.args); indarg_in_concl = occur_rel 1 ccl; args = List.tl !res.args; nargs = !res.nargs - 1; }; raise Exit); raise Exit(* exit anyway *) with Exit -> (* Ending by computing indrev: *) match !res.indarg with | None -> !res (* No indref *) | Some ( _,Some _,_) -> error_ind_scheme "" | Some ( _,None,ind) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } with e when Errors.noncritical e -> error "Cannot find the inductive type of the inductive scheme.";; let compute_scheme_signature scheme names_info ind_type_guess = let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) let cond, check_concl = match scheme.indarg with | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) let cond hd = eq_constr hd ind_type_guess && not scheme.farg_in_concl in (cond, fun _ _ -> ()) | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in let cond hd = eq_constr hd indhd in let check_concl is_pred p = (* Check again conclusion *) let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in let ind_is_ok = list_equal eq_constr (list_lastn scheme.nargs indargs) (extended_rel_list 0 scheme.args) in if not (ccl_arg_ok & ind_is_ok) then error_ind_scheme "the conclusion of" in (cond, check_concl) in let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with | Rel q when n < q & q <= n+scheme.npredicates -> IndArg | _ when cond hd -> RecArg | _ -> OtherArg in let rec check_branch p c = match kind_of_term c with | Prod (_,t,c) -> (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c | LetIn (_,_,_,c) -> (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c = IndArg -> [] | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with | (_,None,t)::brs -> (try let lchck_brch = check_branch p t in let n = List.fold_left (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in let namesign = List.map (fun (b,dep) -> (b,dep,if b=IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit-> error_ind_scheme "the branches of") | (_,Some _,_)::_ -> error_ind_scheme "the branches of" | [] -> check_concl is_pred p; [] in Array.of_list (find_branches 0 (List.rev scheme.branches)) (* Check that the elimination scheme has a form similar to the elimination schemes built by Coq. Schemes may have the standard form computed from an inductive type OR (feb. 2006) a non standard form. That is: with no main induction argument and with an optional extra final argument of the form (f x y ...) in the conclusion. In the non standard case, naming of generated hypos is slightly different. *) let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info = let scheme = compute_elim_sig ~elimc:elimc elimt in compute_scheme_signature scheme names_info ind_type_guess, scheme let guess_elim isrec hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in let s = elimination_sort_of_goal gl in let elimc = if isrec then lookup_eliminator mind s else if use_dependent_propositions_elimination () && dependent_no_evar (mkVar hyp0) (pf_concl gl) then pf_apply build_case_analysis_scheme gl mind true s else pf_apply build_case_analysis_scheme_default gl mind s in let elimt = pf_type_of gl elimc in ((elimc, NoBindings), elimt), mkInd mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in (e, pf_type_of gl elimc), ind_type_guess let find_elim isrec elim hyp0 gl = match elim with | None -> guess_elim isrec hyp0 gl | Some e -> given_elim hyp0 e gl type scheme_signature = (identifier list * (elim_arg_kind * bool * identifier) list) array type eliminator_source = | ElimUsing of (eliminator * types) * scheme_signature | ElimOver of bool * identifier let find_induction_type isrec elim hyp0 gl = let scheme,elim = match elim with | None -> let (elimc,elimt),_ = guess_elim isrec hyp0 gl in let scheme = compute_elim_sig ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) scheme, ElimOver (isrec,hyp0) | Some e -> let (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig ~elimc elimt in if scheme.indarg = None then error "Cannot find induction type"; let indsign = compute_scheme_signature scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in scheme, ElimUsing (elim,indsign) in Option.get scheme.indref,scheme.nparams, elim let find_elim_signature isrec elim hyp0 gl = compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0 let is_functional_induction elim gl = match elim with | Some elimc -> let scheme = compute_elim_sig ~elimc (pf_type_of gl (fst elimc)) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) scheme.indarg = None | None -> false (* Wait the last moment to guess the eliminator so as to know if we need a dependent one or not *) let get_eliminator elim gl = match elim with | ElimUsing (elim,indsign) -> (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let (elimc,elimt),_ as elims = guess_elim isrec id gl in isrec, ({elimindex = None; elimbody = elimc}, elimt), fst (compute_elim_signature elims id) (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) let recolle_clenv nparams lid elimclause gl = let _,arr = destApp elimclause.templval.rebus in let lindmv = Array.map (fun x -> match kind_of_term x with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let nmv = Array.length lindmv in let lidparams,lidargs = cut_list nparams lid in let nidargs = List.length lidargs in (* parameters correspond to first elts of lid. *) let clauses_params = list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) 0 lidparams in (* arguments correspond to last elts of lid. *) let clauses_args = list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i)) 0 lidargs in let clauses = clauses_params@clauses_args in (* iteration of clenv_fchain with all infos we have. *) List.fold_right (fun e acc -> let x,y,i = e in (* from_n (Some 0) means that x should be taken "as is" without trying to unify (which would lead to trying to apply it to evars if y is a product). *) let indclause = mk_clenv_from_n gl (Some 0) (x,y) in let elimclause' = clenv_fchain i acc indclause in elimclause') (List.rev clauses) elimclause (* Unification of the goal and the principle applied to meta variables: (elimc ?i ?j ?k...?l). This solves partly meta variables (and may produce new ones). Then refine with the resulting term with holes. *) let induction_tac_felim with_evars indvars nparams elim gl = let {elimbody=(elimc,lbindelimc)},elimt = elim in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimclause = make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv nparams indvars elimclause gl in (* one last resolution (useless?) *) let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in clenv_refine with_evars resolved gl (* Apply induction "in place" replacing the hypothesis on which induction applies with the induction hypotheses *) let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac gl = let isrec, elim, indsign = get_eliminator elim gl in let names = compute_induction_names (Array.length indsign) names in (if isrec then tclTHENFIRSTn else tclTHENLASTn) (tclTHEN (induct_tac elim) (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps))) (array_map2 (induct_discharge destopt avoid tac) indsign names) gl (* Apply induction "in place" taking into account dependent hypotheses from the context *) let apply_induction_in_context hyp0 elim indvars names induct_tac gl = let env = pf_env gl in let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in let deps = List.map (on_pi3 refresh_universes_strict) deps in let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in let dephyps = List.map (fun (id,_,_) -> id) deps in let deps_cstr = List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in tclTHENLIST [ (* Generalize dependent hyps (but not args) *) if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; (* clear dependent hyps *) thin dephyps; (* side-conditions in elim (resp case) schemes come last (resp first) *) apply_induction_with_discharge induct_tac elim (List.rev indhyps) lhyp0 (List.rev dephyps) names (re_intro_dependent_hypotheses statuslists) ] gl (* Induction with several induction arguments, main differences with induction_from_context is that there is no main induction argument, so we choose one to be the positioning reference. On the other hand, all args and params must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac_felim FIXME: REUNIF AVEC induction_tac_felim? *) let induction_from_context_l with_evars elim_info lid names gl = let indsign,scheme = elim_info in (* number of all args, counting farg and indarg if present. *) let nargs_indarg_farg = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) + (if scheme.indarg <> None then 1 else 0) in (* Number of given induction args must be exact. *) if List.length lid <> nargs_indarg_farg + scheme.nparams then error "Not the right number of arguments given to induction scheme."; (* hyp0 is used for re-introducing hyps at the right place afterward. We chose the first element of the list of variables on which to induct. It is probably the first of them appearing in the context. *) let hyp0,indvars,lid_params = match lid with | [] -> anomaly "induction_from_context_l" | e::l -> let nargs_without_first = nargs_indarg_farg - 1 in let ivs,lp = cut_list nargs_without_first l in e, ivs, lp in (* terms to patternify we must patternify indarg or farg if present in concl *) let lid_in_pattern = if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars else List.rev (hyp0::indvars) in let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in let realindvars = (* hyp0 is a real induction arg if it is not the farg in the conclusion of the induction scheme *) List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in let induct_tac elim = tclTHENLIST [ (* pattern to make the predicate appear. *) reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all possible holes using arguments given by the user (but the functional one). *) (* FIXME: Tester ca avec un principe dependant et non-dependant *) induction_tac_felim with_evars realindvars scheme.nparams elim ] in let elim = ElimUsing (({elimindex = Some scheme.index; elimbody = Option.get scheme.elimc}, scheme.elimt), indsign) in apply_induction_in_context None elim (hyp0::indvars) names induct_tac gl (* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the hypothesis on which the induction is made *) let induction_tac with_evars elim (varname,lbind) typ gl = let ({elimindex=i;elimbody=(elimc,lbindelimc)},elimt) = elim in let indclause = make_clenv_binding gl (mkVar varname,typ) lbind in let i = match i with None -> index_of_ind_arg elimt | Some i -> i in let elimclause = make_clenv_binding gl (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in elimination_clause_scheme with_evars i elimclause indclause gl let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names inhyps gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in let indvars = find_atomic_param_of_ind nparams ((strip_prod typ0)) in let induct_tac elim = tclTHENLIST [ induction_tac with_evars elim (hyp0,lbind) typ0; tclTRY (unfold_body hyp0); thin [hyp0] ] in apply_induction_in_context (Some (hyp0,inhyps)) elim indvars names induct_tac gl let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps gl = let elim_info = find_induction_type isrec elim hyp0 gl in tclTHEN (atomize_param_of_ind elim_info hyp0) (induction_from_context isrec with_evars elim_info (hyp0,lbind) names inhyps) gl (* Induction on a list of induction arguments. Analyse the elim scheme (which is mandatory for multiple ind args), check that all parameters and arguments are given (mandatory too). *) let induction_without_atomization isrec with_evars elim names lid gl = let (indsign,scheme as elim_info) = find_elim_signature isrec elim (List.hd lid) gl in let awaited_nargs = scheme.nparams + scheme.nargs + (if scheme.farg_in_concl then 1 else 0) + (if scheme.indarg <> None then 1 else 0) in let nlid = List.length lid in if nlid <> awaited_nargs then error "Not the right number of induction arguments." else induction_from_context_l with_evars elim_info lid names gl let has_selected_occurrences = function | None -> false | Some cls -> cls.concl_occs <> all_occurrences_expr || cls.onhyps <> None && List.exists (fun ((occs,_),hl) -> occs <> all_occurrences_expr || hl <> InHyp) (Option.get cls.onhyps) (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls gl = match cls with | None -> tclIDTAC gl | Some cls -> if occur_var (pf_env gl) id (pf_concl gl) && cls.concl_occs = no_occurrences_expr then errorlabstrm "" (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); match cls.onhyps with | Some hyps -> let to_erase (id',_,_ as d) = if List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) let test id = occur_var_in_decl (pf_env gl) id d in if List.exists test (id::inhyps) then Some id' else None in let ids = list_map_filter to_erase (pf_hyps gl) in thin ids gl | None -> tclIDTAC gl let new_induct_gen isrec with_evars elim (eqname,names) (sigma,(c,lbind)) cls gl = let inhyps = match cls with | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps | _ -> [] in match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) & lbind = NoBindings & not with_evars & eqname = None & not (has_selected_occurrences cls) -> tclTHEN (clear_unselected_context id inhyps cls) (induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) inhyps) gl | _ -> let x = id_of_name_using_hdchar (Global.env()) (typ_of (pf_env gl) sigma c) Anonymous in let id = fresh_id [] x gl in (* We need the equality name now *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) tclTHEN (* Warning: letin is buggy when c is not of inductive type *) (letin_tac_gen with_eq (Name id) (sigma,c) (make_pattern_test (pf_env gl) (project gl) (sigma,c)) None (Option.default allHypsAndConcl cls,false)) (induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) inhyps) gl (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is that all arguments and parameters of the scheme are given (mandatory for the moment), so we don't need to deal with parameters of the inductive type as in new_induct_gen. *) let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = if eqname <> None then errorlabstrm "" (str "Do not know what to do with " ++ pr_intro_pattern (Option.get eqname)); let newlc = ref [] in let letids = ref [] in let rec atomize_list l gl = match l with | [] -> tclIDTAC gl | c::l' -> match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) & not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' gl | _ -> let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let id = fresh_id [] x gl in let newl' = List.map (replace_term c (mkVar id)) l' in let _ = newlc:=id::!newlc in let _ = letids:=id::!letids in tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') gl in tclTHENLIST [ (atomize_list lc); (fun gl' -> (* recompute each time to have the new value of newlc *) induction_without_atomization isrec with_evars elim names !newlc gl') ; (* after induction, try to unfold all letins created by atomize_list FIXME: unfold_all does not exist anywhere else? *) (fun gl' -> (* recompute each time to have the new value of letids *) tclMAP (fun x -> tclTRY (unfold_all x)) !letids gl') ] gl (* Induction either over a term, over a quantified premisse, or over several quantified premisses (like with functional induction principles). TODO: really unify induction with one and induction with several args *) let induct_destruct isrec with_evars (lc,elim,names,cls) gl = assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *) if List.length lc = 1 && not (is_functional_induction elim gl) then (* standard induction *) onOpenInductionArg (fun c -> new_induct_gen isrec with_evars elim names c cls) (List.hd lc) gl else begin (* functional induction *) (* Several induction hyps: induction scheme is mandatory *) if elim = None then errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypotheses are given.\n" ++ str "Example: induction x1 x2 x3 using my_scheme."); if cls <> None then error "'in' clause not supported here."; let lc = List.map (map_induction_arg (pf_apply finish_evar_resolution gl)) lc in if List.length lc = 1 then (* Hook to recover standard induction on non-standard induction schemes *) (* will be removable when is_functional_induction will be more clever *) onInductionArg (fun (c,lbind) -> if lbind <> NoBindings then error "'with' clause not supported here."; new_induct_gen_l isrec with_evars elim names [c]) (List.hd lc) gl else let newlc = List.map (fun x -> match x with (* FIXME: should we deal with ElimOnIdent? *) | ElimOnConstr (x,NoBindings) -> x | _ -> error "Don't know where to find some argument.") lc in new_induct_gen_l isrec with_evars elim names newlc gl end let induction_destruct isrec with_evars = function | [],_,_ -> tclIDTAC | [a,b],el,cl -> induct_destruct isrec with_evars ([a],el,b,cl) | (a,b)::l,None,cl -> tclTHEN (induct_destruct isrec with_evars ([a],None,b,cl)) (tclMAP (fun (a,b) -> induct_destruct false with_evars ([a],None,b,cl)) l) | l,Some el,cl -> let check_basic_using = function | a,(None,None) -> a | _ -> error "Unsupported syntax for \"using\"." in let l' = List.map check_basic_using l in induct_destruct isrec with_evars (l', Some el, (None,None), cl) let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls) let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls) (* The registered tactic, which calls the default elimination * if no elimination constant is provided. *) (* Induction tactics *) (* This was Induction before 6.3 (induction only in quantified premisses) *) let simple_induct_id s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim) let simple_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim) let simple_induct = function | NamedHyp id -> simple_induct_id id | AnonHyp n -> simple_induct_nodep n (* Destruction tactics *) let simple_destruct_id s = (tclTHEN (intros_until_id s) (onLastHyp simplest_case)) let simple_destruct_nodep n = (tclTHEN (intros_until_n n) (onLastHyp simplest_case)) let simple_destruct = function | NamedHyp id -> simple_destruct_id id | AnonHyp n -> simple_destruct_nodep n (* * Eliminations giving the type instead of the proof. * These tactics use the default elimination constant and * no substitutions at all. * May be they should be integrated into Elim ... *) let elim_scheme_type elim t gl = let clause = mk_clenv_type_of gl elim in match kind_of_term (last_arg clause.templval.rebus) with | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) clenv_unify ~flags:elim_flags Reduction.CUMUL t (clenv_meta_type clause mv) clause in res_pf clause' ~flags:elim_flags gl | _ -> anomaly "elim_scheme_type" let elim_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in elim_scheme_type elimc t gl let case_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in elim_scheme_type elimc t gl (* Some eliminations frequently used *) (* These elimination tactics are particularly adapted for sequent calculus. They take a clause as argument, and yield the elimination rule if the clause is of the form (Some id) and a suitable introduction rule otherwise. They do not depend on the name of the eliminated constant, so they can be also used on ad-hoc disjunctions and conjunctions introduced by the user. -- Eduardo Gimenez (11/8/97) HH (29/5/99) replaces failures by specific error messages *) let andE id gl = let t = pf_get_hyp_typ gl id in if is_conjunction (pf_hnf_constr gl t) then (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl else errorlabstrm "andE" (str("Tactic andE expects "^(string_of_id id)^" is a conjunction.")) let dAnd cls = onClause (function | None -> simplest_split | Some id -> andE id) cls let orE id gl = let t = pf_get_hyp_typ gl id in if is_disjunction (pf_hnf_constr gl t) then (tclTHEN (simplest_elim (mkVar id)) intro) gl else errorlabstrm "orE" (str("Tactic orE expects "^(string_of_id id)^" is a disjunction.")) let dorE b cls = onClause (function | Some id -> orE id | None -> (if b then right else left) NoBindings) cls let impE id gl = let t = pf_get_hyp_typ gl id in if is_imp_term (pf_hnf_constr gl t) then let (dom, _, rng) = destProd (pf_hnf_constr gl t) in tclTHENLAST (cut_intro rng) (apply_term (mkVar id) [mkMeta (new_meta())]) gl else errorlabstrm "impE" (str("Tactic impE expects "^(string_of_id id)^ " is a an implication.")) let dImp cls = onClause (function | None -> intro | Some id -> impE id) cls (************************************************) (* Tactics related with logic connectives *) (************************************************) (* Reflexivity tactics *) let setoid_reflexivity = ref (fun _ -> assert false) let register_setoid_reflexivity f = setoid_reflexivity := f let reflexivity_red allowred gl = (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = if not allowred then pf_concl gl else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) in match match_with_equality_type concl with | None -> raise NoEquationFound | Some _ -> one_constructor 1 NoBindings gl let reflexivity gl = try reflexivity_red false gl with NoEquationFound -> !setoid_reflexivity gl let intros_reflexivity = (tclTHEN intros reflexivity) (* Symmetry tactics *) (* This tactic first tries to apply a constant named sym_eq, where eq is the name of the equality predicate. If this constant is not defined and the conclusion is a=b, it solves the goal doing (Cut b=a;Intro H;Case H;Constructor 1) *) let setoid_symmetry = ref (fun _ -> assert false) let register_setoid_symmetry f = setoid_symmetry := f (* This is probably not very useful any longer *) let prove_symmetry hdcncl eq_kind = let symc = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in tclTHENFIRST (cut symc) (tclTHENLIST [ intro; onLastHyp simplest_case; one_constructor 1 NoBindings ]) let symmetry_red allowred gl = (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl) in match match_with_equation concl with | Some eq_data,_,_ -> tclTHEN (convert_concl_no_check concl DEFAULTcast) (apply eq_data.sym) gl | None,eq,eq_kind -> prove_symmetry eq eq_kind gl let symmetry gl = try symmetry_red false gl with NoEquationFound -> !setoid_symmetry gl let setoid_symmetry_in = ref (fun _ _ -> assert false) let register_setoid_symmetry_in f = setoid_symmetry_in := f let symmetry_in id gl = let ctype = pf_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in try let _,hdcncl,eq = match_with_equation t in let symccl = match eq with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in tclTHENS (cut (it_mkProd_or_LetIn symccl sign)) [ intro_replacing id; tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] gl with NoEquationFound -> !setoid_symmetry_in id gl let intros_symmetry = onClause (function | None -> tclTHEN intros symmetry | Some id -> symmetry_in id) (* Transitivity tactics *) (* This tactic first tries to apply a constant named eq_trans, where eq is the name of the equality predicate. If this constant is not defined and the conclusion is a=b, it solves the goal doing Cut x1=x2; [Cut x2=x3; [Intros e1 e2; Case e2;Assumption | Idtac] | Idtac] --Eduardo (19/8/97) *) let setoid_transitivity = ref (fun _ _ -> assert false) let register_setoid_transitivity f = setoid_transitivity := f (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t gl = let eq1,eq2 = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> (mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |])) | PolymorphicLeibnizEq (typ,c1,c2) -> (mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |])) | HeterogenousEq (typ1,c1,typ2,c2) -> let typt = pf_type_of gl t in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) in tclTHENFIRST (cut eq2) (tclTHENFIRST (cut eq1) (tclTHENLIST [ tclDO 2 intro; onLastHyp simplest_case; assumption ])) gl let transitivity_red allowred t gl = (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl) in match match_with_equation concl with | Some eq_data,_,_ -> tclTHEN (convert_concl_no_check concl DEFAULTcast) (match t with | None -> eapply eq_data.trans | Some t -> apply_list [eq_data.trans;t]) gl | None,eq,eq_kind -> match t with | None -> error "etransitivity not supported for this relation." | Some t -> prove_transitivity eq eq_kind t gl let transitivity_gen t gl = try transitivity_red false t gl with NoEquationFound -> !setoid_transitivity t gl let etransitivity = transitivity_gen None let transitivity t = transitivity_gen (Some t) let intros_transitivity n = tclTHEN intros (transitivity_gen n) (* tactical to save as name a subproof such that the generalisation of the current goal, abstracted with respect to the local signature, is solved by tac *) let interpretable_as_section_decl d1 d2 = match d1,d2 with | (_,Some _,_), (_,None,_) -> false | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2 | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 let abstract_subproof id tac gl = let current_sign = Global.named_context() and global_sign = pf_hyps gl in let sign,secsign = List.fold_right (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign & interpretable_as_section_decl (Sign.lookup_named id current_sign) d then (s1,push_named_context_val d s2) else (add_named_decl d s1,s2)) global_sign (empty_named_context,empty_named_context_val) in let id = next_global_ident_away id (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in let concl = try flush_and_check_evars (project gl) concl with Uninstantiated_evar _ -> error "\"abstract\" cannot handle existentials." in let const = Pfedit.build_constant_by_tactic id secsign concl (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)) in let cd = Entries.DefinitionEntry const in let lem = mkConst (Declare.declare_constant ~internal:Declare.KernelSilent id (cd,IsProof Lemma)) in exact_no_check (applist (lem,List.rev (Array.to_list (instance_from_named_context sign)))) gl let tclABSTRACT name_op tac gl = let s = match name_op with | Some s -> s | None -> add_suffix (get_current_proof_name ()) "_subproof" in abstract_subproof s tac gl let admit_as_an_axiom gl = let current_sign = Global.named_context() and global_sign = pf_hyps gl in let sign,secsign = List.fold_right (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign & interpretable_as_section_decl (Sign.lookup_named id current_sign) d then (s1,add_named_decl d s2) else (add_named_decl d s1,s2)) global_sign (empty_named_context,empty_named_context) in let name = add_suffix (get_current_proof_name ()) "_admitted" in let na = next_global_ident_away name (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in if occur_existential concl then error"\"admit\" cannot handle existentials."; let axiom = let cd = Entries.ParameterEntry (Pfedit.get_used_variables(),concl,None) in let con = Declare.declare_constant ~internal:Declare.KernelSilent na (cd,IsAssumption Logical) in constr_of_global (ConstRef con) in exact_no_check (applist (axiom, List.rev (Array.to_list (instance_from_named_context sign)))) gl let unify ?(state=full_transparent_state) x y gl = try let flags = {default_unify_flags with modulo_delta = state; modulo_conv_on_closed_terms = Some state} in let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y in tclEVARS evd gl with e when Errors.noncritical e -> tclFAIL 0 (str"Not unifiable") gl coq-8.4pl3/tactics/eqdecide.ml40000640000175000017500000001402112255245502015425 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (clear [destVar c]))) let choose_eq eqonleft = if eqonleft then h_simplest_left else h_simplest_right let choose_noteq eqonleft = if eqonleft then h_simplest_right else h_simplest_left let mkBranches c1 c2 = tclTHENSEQ [generalize [c2]; h_simplest_elim c1; intros; onLastHyp h_simplest_case; clear_last; intros] let solveNoteqBranch side = tclTHEN (choose_noteq side) (tclTHEN introf (onLastHypId (fun id -> Extratactics.h_discrHyp id))) let h_solveNoteqBranch side = Refiner.abstract_extended_tactic "solveNoteqBranch" [] (solveNoteqBranch side) (* Constructs the type {c1=c2}+{~c1=c2} *) let mkDecideEqGoal eqonleft op rectype c1 c2 g = let equality = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in let disequality = mkApp(build_coq_not (), [|equality|]) in if eqonleft then mkApp(op, [|equality; disequality |]) else mkApp(op, [|disequality; equality |]) (* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) let mkGenDecideEqGoal rectype g = let hypnames = pf_ids_of_hyps g in let xname = next_ident_away (id_of_string "x") hypnames and yname = next_ident_away (id_of_string "y") hypnames in (mkNamedProd xname rectype (mkNamedProd yname rectype (mkDecideEqGoal true (build_coq_sumbool ()) rectype (mkVar xname) (mkVar yname) g))) let eqCase tac = (tclTHEN intro (tclTHEN (onLastHyp Equality.rewriteLR) (tclTHEN clear_last tac))) let diseqCase eqonleft = let diseq = id_of_string "diseq" in let absurd = id_of_string "absurd" in (tclTHEN (intro_using diseq) (tclTHEN (choose_noteq eqonleft) (tclTHEN red_in_concl (tclTHEN (intro_using absurd) (tclTHEN (h_simplest_apply (mkVar diseq)) (tclTHEN (Extratactics.h_injHyp absurd) (full_trivial []))))))) let solveArg eqonleft op a1 a2 tac g = let rectype = pf_type_of g a1 in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 g in let subtacs = if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] else [diseqCase eqonleft;eqCase tac;default_auto] in (tclTHENS (h_elim_type decide) subtacs) g let solveEqBranch rectype g = try let (eqonleft,op,lhs,rhs,_) = match_eqdec (pf_concl g) in let (mib,mip) = Global.lookup_inductive rectype in let nparams = mib.mind_nparams in let getargs l = list_skipn nparams (snd (decompose_app l)) in let rargs = getargs rhs and largs = getargs lhs in List.fold_right2 (solveArg eqonleft op) largs rargs (tclTHEN (choose_eq eqonleft) h_reflexivity) g with PatternMatchingFailure -> error "Unexpected conclusion!" (* The tactic Decide Equality *) let hd_app c = match kind_of_term c with | App (h,_) -> h | _ -> c let decideGralEquality g = try let eqonleft,_,c1,c2,typ = match_eqdec (pf_concl g) in let headtyp = hd_app (pf_compute g typ) in let rectype = match kind_of_term headtyp with | Ind mi -> mi | _ -> error"This decision procedure only works for inductive objects." in (tclTHEN (mkBranches c1 c2) (tclORELSE (h_solveNoteqBranch eqonleft) (solveEqBranch rectype))) g with PatternMatchingFailure -> error "The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}." let decideEqualityGoal = tclTHEN intros decideGralEquality let decideEquality rectype g = let decide = mkGenDecideEqGoal rectype g in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g (* The tactic Compare *) let compare c1 c2 g = let rectype = pf_type_of g c1 in let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in (tclTHENS (cut decide) [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); decideEquality (pf_type_of g c1)]) g (* User syntax *) TACTIC EXTEND decide_equality | [ "decide" "equality" ] -> [ decideEqualityGoal ] END TACTIC EXTEND compare | [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] END coq-8.4pl3/tactics/extratactics.mli0000640000175000017500000000135712255245502016455 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic val h_injHyp : Names.identifier -> tactic val refine_tac : Evd.open_constr -> tactic val onSomeWithHoles : ('a option -> tactic) -> 'a Evd.sigma option -> tactic coq-8.4pl3/tactics/equality.ml0000640000175000017500000016204612255245502015446 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !discriminate_introduction); optwrite = (:=) discriminate_introduction } (* Rewriting tactics *) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool type conditions = | Naive (* Only try the first occurence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) (* Warning : rewriting from left to right only works if there exists in the context a theorem named __r with type (A:)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y). If another equality myeq is introduced, then corresponding theorems myeq_ind_r, myeq_rec_r and myeq_rect_r have to be proven. See below. -- Eduardo (19/8/97) *) let rewrite_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = empty_transparent_state; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; Unification.frozen_evars = ExistentialSet.empty; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = false; Unification.modulo_eta = true; Unification.allow_K_in_toplevel_higher_order_unification = false (* allow_K does not matter in practice because calls w_typed_unify *) } let freeze_initial_evars sigma flags clause = (* We take evars of the type: this may include old evars! For excluding *) (* all old evars, including the ones occurring in the rewriting lemma, *) (* we would have to take the clenv_value *) let newevars = Evd.collect_evars (clenv_type clause) in let evars = fold_undefined (fun evk _ evars -> if ExistentialSet.mem evk newevars then evars else ExistentialSet.add evk evars) sigma ExistentialSet.empty in { flags with Unification.frozen_evars = evars } let make_flags frzevars sigma flags clause = if frzevars then freeze_initial_evars sigma flags clause else flags let side_tac tac sidetac = match sidetac with | None -> tac | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac let instantiate_lemma_all frzevars env sigma gl c ty l l2r concl = let eqclause = Clenv.make_clenv_binding { gl with sigma = sigma } (c,ty) l in let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> let l,res = split_last_two (y::z) in x::l, res | _ -> error "The term provided is not an applied relation." in let others,(c1,c2) = split_last_two args in let try_occ (evd', c') = clenv_pose_dependent_evars true {eqclause with evd = evd'} in let flags = make_flags frzevars sigma rewrite_unif_flags eqclause in let occs = Unification.w_unify_to_subterm_all ~flags env eqclause.evd ((if l2r then c1 else c2),concl) in List.map try_occ occs let instantiate_lemma env sigma gl c ty l l2r concl = let gl = { gl with sigma = sigma } in let ct = pf_type_of gl c in let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in let eqclause = Clenv.make_clenv_binding gl (c,t) l in [eqclause] let rewrite_conv_closed_unif_flags = { Unification.modulo_conv_on_closed_terms = Some full_transparent_state; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) Unification.use_metas_eagerly_in_conv_on_closed_terms = true; (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = full_transparent_state; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = false; Unification.use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) (* a preexisting evar of the goal*) Unification.use_meta_bound_pattern_unification = true; Unification.frozen_evars = ExistentialSet.empty; (* This is set dynamically *) Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = false; Unification.modulo_eta = true; Unification.allow_K_in_toplevel_higher_order_unification = false } let rewrite_elim with_evars frzevars c e gl = let flags = make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in general_elim_clause_gen (elimination_clause_scheme with_evars ~flags) c e gl let rewrite_elim_in with_evars frzevars id c e gl = let flags = make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in general_elim_clause_gen (elimination_in_clause_scheme with_evars ~flags id) c e gl (* Ad hoc asymmetric general_elim_clause *) let general_elim_clause with_evars frzevars cls rew elim = try (match cls with | None -> (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal and did not fail for useless conditional rewritings generating an extra condition *) tclNOTSAMEGOAL (rewrite_elim with_evars frzevars rew elim) | Some id -> rewrite_elim_in with_evars frzevars id rew elim) with Pretype_errors.PretypeError (env,evd, Pretype_errors.NoOccurrenceFound (c', _)) -> raise (Pretype_errors.PretypeError (env,evd,Pretype_errors.NoOccurrenceFound (c', cls))) let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl = let all, firstonly, tac = match tac with | None -> false, false, None | Some (tac, Naive) -> false, false, Some tac | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac) | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac) in let cs = (if not all then instantiate_lemma else instantiate_lemma_all frzevars) (pf_env gl) sigma gl c t l l2r (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id) in let try_clause c = side_tac (tclTHEN (Refiner.tclEVARS c.evd) (general_elim_clause with_evars frzevars cls c elim)) tac in if firstonly then tclFIRST (List.map try_clause cs) gl else tclMAP try_clause cs gl (* The next function decides in particular whether to try a regular rewrite or a generalized rewrite. Approach is to break everything, if [eq] appears in head position then regular rewrite else try general rewrite. If occurrences are set, use general rewrite. *) let general_rewrite_clause = ref (fun _ -> assert false) let register_general_rewrite_clause = (:=) general_rewrite_clause let is_applied_rewrite_relation = ref (fun _ _ _ _ -> None) let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation (* Do we have a JMeq instance on twice the same domains ? *) let jmeq_same_dom gl = function | None -> true (* already checked in Hipattern.find_eq_data_decompose *) | Some t -> let rels, t = decompose_prod_assum t in let env = Environ.push_rel_context rels (pf_env gl) in match decompose_app t with | _, [dom1; _; dom2;_] -> is_conv env (project gl) dom1 dom2 | _ -> false (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) let find_elim hdcncl lft2rgt dep cls ot gl = let inccl = not (Option.has_some cls) in let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in if (hdcncl_is (Coqlib.glob_eq) || hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot) && not dep || Flags.version_less_or_equal Flags.V8_2 then match kind_of_term hdcncl with | Ind ind_sp -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) in if lft2rgt = Some (cls=None) then let c1 = destConst pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in let l' = label_of_id (add_suffix (id_of_label l) "_r") in let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in mkConst c1' with Not_found -> let rwr_thm = string_of_label l' in error ("Cannot find rewrite principle "^rwr_thm^".") end else pr1 | _ -> (* cannot occur since we checked that we are in presence of Logic.eq or Jmeq just before *) assert false else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) | false, Some true, true -> rew_l2r_scheme_kind | false, Some true, false -> rew_r2l_scheme_kind | false, _, false -> rew_l2r_scheme_kind | false, _, true -> rew_r2l_scheme_kind (* Dependent case *) | true, Some true, true -> rew_l2r_dep_scheme_kind | true, Some true, false -> rew_l2r_forward_dep_scheme_kind | true, _, true -> rew_r2l_dep_scheme_kind | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with | Ind ind -> mkConst (find_scheme scheme_name ind) | _ -> assert false let type_of_clause gl = function | None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars frzevars dep_proof_ok gl hdcncl = let isatomic = isProd (whd_zeta hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let dep = dep_proof_ok && dep_fun c (type_of_clause gl cls) in let elim = find_elim hdcncl lft2rgt dep cls (Some t) gl in general_elim_clause with_evars frzevars tac cls sigma c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings)} gl let adjust_rewriting_direction args lft2rgt = if List.length args = 1 then begin (* equality to a constant, like in eq_true *) (* more natural to see -> as the rewriting to the constant *) if not lft2rgt then error "Rewriting non-symmetric equality not allowed from right-to-left."; None end else (* other equality *) Some lft2rgt let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) (* Main function for dispatching which kind of rewriting it is about *) let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac ((c,l) : constr with_bindings) with_evars gl = if occs <> all_occurrences then ( rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl) else let env = pf_env gl in let sigma = project gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in match match_with_equality_type t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t rels) l with_evars frzevars dep_proof_ok gl hdcncl | None -> try rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl with e when Errors.noncritical e -> (* Try to see if there's an equality hidden *) let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) match match_with_equality_type t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok gl hdcncl | None -> raise e (* error "The provided term does not end with an equality or a declared rewrite relation." *) let general_rewrite_ebindings = general_rewrite_ebindings_clause None let general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,bl) = general_rewrite_ebindings_clause None l2r occs frzevars dep_proof_ok ?tac (c,bl) let general_rewrite l2r occs frzevars dep_proof_ok ?tac c = general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,NoBindings) false let general_rewrite_ebindings_in l2r occs frzevars dep_proof_ok ?tac id = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac let general_rewrite_bindings_in l2r occs frzevars dep_proof_ok ?tac id (c,bl) = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac (c,bl) let general_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac (c,NoBindings) let general_multi_rewrite l2r with_evars ?tac c cl = let occs_of = on_snd (List.fold_left (fun acc -> function ArgArg x -> x :: acc | ArgVar _ -> acc) []) in match cl.onhyps with | Some l -> (* If a precise list of locations is given, success is mandatory for each of these locations. *) let rec do_hyps = function | [] -> tclIDTAC | ((occs,id),_) :: l -> tclTHENFIRST (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars) (do_hyps l) in if cl.concl_occs = no_occurrences_expr then do_hyps l else tclTHENFIRST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) (do_hyps l) | None -> (* Otherwise, if we are told to rewrite in all hypothesis via the syntax "* |-", we fail iff all the different rewrites fail *) let rec do_hyps_atleastonce = function | [] -> (fun gl -> error "Nothing to rewrite.") | id :: l -> tclIFTHENTRYELSEMUST (general_rewrite_ebindings_in l2r all_occurrences false true ?tac id c with_evars) (do_hyps_atleastonce l) in let do_hyps gl = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids = let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl) in do_hyps_atleastonce ids gl in if cl.concl_occs = no_occurrences_expr then do_hyps else tclIFTHENTRYELSEMUST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) do_hyps type delayed_open_constr_with_bindings = env -> evar_map -> evar_map * constr with_bindings let general_multi_multi_rewrite with_evars l cl tac = let do1 l2r f gl = let sigma,c = f (pf_env gl) (project gl) in Refiner.tclWITHHOLES with_evars (general_multi_rewrite l2r with_evars ?tac c) sigma cl gl in let rec doN l2r c = function | Precisely n when n <= 0 -> tclIDTAC | Precisely 1 -> do1 l2r c | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1))) | RepeatStar -> tclREPEAT_MAIN (do1 l2r c) | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar) | UpTo n when n<=0 -> tclIDTAC | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1))) in let rec loop = function | [] -> tclIDTAC | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l) in loop l let rewriteLR = general_rewrite true all_occurrences true true let rewriteRL = general_rewrite false all_occurrences true true (* Replacing tactics *) (* eq,sym_eq : equality on Type and its symmetry theorem c2 c1 : c1 is to be replaced by c2 unsafe : If true, do not check that c1 and c2 are convertible tac : Used to prove the equality c1 = c2 gl : goal *) let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = let try_prove_eq = match try_prove_eq_opt with | None -> tclIDTAC | Some tac -> tclCOMPLETE tac in let t1 = pf_apply get_type_of gl c1 and t2 = pf_apply get_type_of gl c2 in if unsafe or (pf_conv_x gl t1 t2) then let e = build_coq_eq () in let sym = build_coq_eq_sym () in let eq = applist (e, [t1;c1;c2]) in tclTHENS (assert_as false None eq) [onLastHypId (fun id -> tclTHEN (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) (clear [id])); tclFIRST [assumption; tclTHEN (apply sym) assumption; try_prove_eq ] ] gl else error "Terms do not have convertible types." let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl let replace_in id c2 c1 gl = multi_replace (onHyp id) c2 c1 false None gl let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = multi_replace cl c2 c1 false tac_opt gl (* End of Eduardo's code. The rest of this file could be improved using the functions match_with_equation, etc that I defined in Pattern.ml. -- Eduardo (19/8/97) *) (* Tactics for equality reasoning with the "eq" relation. This code will work with any equivalence relation which is substitutive *) (* [find_positions t1 t2] will find the positions in the two terms which are suitable for discrimination, or for injection. Obviously, if there is a position which is suitable for discrimination, then we want to exploit it, and not bother with injection. So when we find a position which is suitable for discrimination, we will just raise an exception with that position. So the algorithm goes like this: if [t1] and [t2] start with the same constructor, then we can continue to try to find positions in the arguments of [t1] and [t2]. if [t1] and [t2] do not start with the same constructor, then we have found a discrimination position if one [t1] or [t2] do not start with a constructor and the two terms are not already convertible, then we have found an injection position. A discriminating position consists of a constructor-path and a pair of operators. The constructor-path tells us how to get down to the place where the two operators, which must differ, can be found. An injecting position has two terms instead of the two operators, since these terms are different, but not manifestly so. A constructor-path is a list of pairs of (operator * int), where the int (based at 0) tells us which argument of the operator we descended into. *) exception DiscrFound of (constructor * int) list * constructor * constructor let find_positions env sigma t1 t2 = let rec findrec sorts posn t1 t2 = let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with | Construct sp1, Construct sp2 when List.length args1 = mis_constructor_nargs_env env sp1 -> let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) if is_conv env sigma hd1 hd2 then let nrealargs = constructor_nrealargs env sp1 in let rargs1 = list_lastn nrealargs args1 in let rargs2 = list_lastn nrealargs args2 in List.flatten (list_map2_i (fun i -> findrec sorts ((sp1,i)::posn)) 0 rargs1 rargs2) else if List.mem InType sorts then (* see build_discriminator *) raise (DiscrFound (List.rev posn,sp1,sp2)) else [] | _ -> let t1_0 = applist (hd1,args1) and t2_0 = applist (hd2,args2) in if is_conv env sigma t1_0 t2_0 then [] else let ty1_0 = get_type_of env sigma t1_0 in let s = get_sort_family_of env sigma ty1_0 in if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in try (* Rem: to allow injection on proofs objects, just add InProp *) Inr (findrec [InSet;InType] [] t1 t2) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) let discriminable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ -> true | _ -> false let injectable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ | Inr [] | Inr [([],_,_)] -> false | Inr _ -> true (* Once we have found a position, we need to project down to it. If we are discriminating, then we need to produce False on one of the branches of the discriminator, and True on the other one. So the result type of the case-expressions is always Prop. If we are injecting, then we need to discover the result-type. This can be difficult, since the type of the two terms at the injection-position can be different, and we need to find a dependent sigma-type which generalizes them both. We can get an approximation to the right type to choose by: (0) Before beginning, we reserve a patvar for the default value of the match, to be used in all the bogus branches. (1) perform the case-splits, down to the site of the injection. At each step, we have a term which is the "head" of the next case-split. At the point when we actually reach the end of our path, the "head" is the term to return. We compute its type, and then, backwards, make a sigma-type with every free debruijn reference in that type. We can be finer, and first do a S(TRONG)NF on the type, so that we get the fewest number of references possible. (2) This gives us a closed type for the head, which we use for the types of all the case-splits. (3) Now, we can compute the type of one of T1, T2, and then unify it with the type of the last component of the result-type, and this will give us the bindings for the other arguments of the tuple. *) (* The algorithm, then is to perform successive case-splits. We have the result-type of the case-split, and also the type of that result-type. We have a "direction" we want to follow, i.e. a constructor-number, and in all other "directions", we want to juse use the default-value. After doing the case-split, we call the afterfun, with the updated environment, to produce the term for the desired "direction". The assumption is made here that the result-type is not manifestly functional, so we can just use the length of the branch-type to know how many lambda's to stick in. *) (* [descend_then sigma env head dirn] returns the number of products introduced, and the environment which is active, in the body of the case-branch given by [dirn], along with a continuation, which expects to be fed: (1) the value of the body of the branch given by [dirn] (2) the default-value (3) the type of the default-value, which must also be the type of the body of the [dirn] branch the continuation then constructs the case-split. *) let descend_then sigma env head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in let ind,_ = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in let dirn_env = push_rel_context cstr.(dirn-1).cs_args env in (dirn_nlams, dirn_env, (fun dirnval (dfltval,resty) -> let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = let result = if i = dirn then dirnval else dfltval in it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in let brl = List.map build_branch (interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, head, Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: (1) If the position is directly beneath us, then we need to do a case-split, with result-type Prop, and stick True and False into the branches, as is convenient. (2) If the position is not directly beneath us, then we need to call descend_then, to descend one step, and then recursively construct the discriminator. *) (* [construct_discriminator env dirn headval] constructs a case-split on [headval], with the [dirn]-th branch giving [True], and all the rest giving False. *) let construct_discriminator sigma env dirn c sort = let IndType(indf,_) = try find_rectype env sigma (get_type_of env sigma c) with Not_found -> (* one can find Rel(k) in case of dependent constructors like T := c : (A:Set)A->T and a discrimination on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (ind,_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn (mkSort sort_0) deparsign in let cstrs = get_constructors env indf in let build_branch i = let endpt = if i = dirn then true_0 else false_0 in it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in let brl = List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) let rec build_discriminator sigma env dirn c sort = function | [] -> construct_discriminator sigma env dirn c sort | ((sp,cnum),argnum)::l -> let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-argnum) in let subval = build_discriminator sigma cnum_env dirn newc sort l in kont subval (build_coq_False (),mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is not allowed because of a large impredicative constructor in the path (see allowed_sorts in find_positions), the positions could still be discrimated by projecting first instead of putting the discrimination combinator inside the projecting combinator. Example of relevant situation: Inductive t:Set := c : forall A:Set, A -> nat -> t. Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H. *) let gen_absurdity id gl = if is_empty_type (pf_get_hyp_typ gl id) then simplest_elim (mkVar id) gl else errorlabstrm "Equality.gen_absurdity" (str "Not the negation of an equality.") (* Precondition: eq is leibniz equality returns ((eq_elim t t1 P i t2), absurd_term) where P=[e:t]discriminator absurd_term=False *) let ind_scheme_of_eq lbeq = let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in let kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = if kind = InProp then Elimschemes.ind_scheme_kind_from_prop else Elimschemes.ind_scheme_kind_from_type in mkConst (find_scheme kind (destInd lbeq.eq)) let discrimination_pf e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim = ind_scheme_of_eq lbeq in (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term) exception NotDiscriminable let eq_baseid = id_of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in clenv_fchain argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (e,None,t) env in let discriminator = build_discriminator sigma e_env dirn (mkVar e) sort cpath in let (pf, absurd_term) = discrimination_pf e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = clenv_value_cast_meta absurd_clause in tclTHENS (cut_intro absurd_term) [onLastHypId gen_absurdity; refine pf] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause gls = let sigma = eq_clause.evd in let env = pf_env gls in match find_positions env sigma t1 t2 with | Inr _ -> errorlabstrm "discr" (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> let sort = pf_apply get_type_of gls (pf_concl gls) in discr_positions env sigma u eq_clause cpath dirn sort gls let onEquality with_evars tac (c,lbindc) gls = let t = pf_type_of gls c in let t' = try snd (pf_reduce_to_quantified_ind gls t) with UserError _ -> t in let eq_clause = make_clenv_binding gls (c,t') lbindc in let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in let eq,eq_args = find_this_eq_data_decompose gls eqn in tclTHEN (Refiner.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') gls let onNegatedEquality with_evars tac gls = let ccl = pf_concl gls in match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with | Prod (_,t,u) when is_empty_type u -> tclTHEN introf (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) gls | _ -> errorlabstrm "" (str "Not a negated primitive equality.") let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings) let discr with_evars = onEquality with_evars discrEq let discrClause with_evars = onClause (discrSimpleClause with_evars) let discrEverywhere with_evars = (* tclORELSE *) (if discr_do_intro () then (tclTHEN (tclREPEAT introf) (Tacticals.tryAllHyps (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) Tacticals.tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars | Some c -> onInductionArg (discr with_evars) c let discrConcl gls = discrClause false onConcl gls let discrHyp id gls = discrClause false (onHyp id) gls (* returns the sigma type (sigS, sigT) with the respective constructor depending on the sort *) (* J.F.: correction du bug #1167 en accord avec Hugo. *) let find_sigma_data s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] Then we build the term [(existT A P (mkRel lind) rterm)] of type [(sigS A P)] where [A] is the type of [mkRel lind] and [P] is [\na:A.rty{1/lind}] *) let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); let {intro = exist_term; typ = sig_term} = find_sigma_data (get_sort_of env sigma rty) in let a = type_of env sigma (mkRel lind) in let (na,_,_) = lookup_rel lind env in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) let p = mkLambda (na, a, rty) in (applist(exist_term,[a;p;(mkRel lind);rterm]), applist(sig_term,[a;p])) (* check that the free-references of the type of [c] are contained in the free-references of the normal-form of that type. Strictly computing the exact set of free rels would require full normalization but this is not reasonable (e.g. in presence of records that contains proofs). We restrict ourself to a "simpl" normalization *) let minimal_free_rels env sigma (c,cty) = let cty_rels = free_rels cty in let cty' = simpl env sigma cty in let rels' = free_rels cty' in if Intset.subset cty_rels rels' then (cty,cty_rels) else (cty',rels') (* Like the above, but recurse over all the rels found until there are no more rels to be found *) let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Intset.union prev_rels direct_rels in let folder rels i = snd (minimalrec_free_rels_rec rels (c, type_of env sigma (mkRel i))) in (cty, List.fold_left folder combined_rels (Intset.elements (Intset.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Intset.empty (* [sig_clausal_form siglen ty] Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the type of ty), and return: (1) a pattern, with meta-variables in it for various arguments, which, when the metavariables are replaced with appropriate terms, will have type [ty] (2) an integer, which is the last argument - the one which we just returned. (3) a pattern, for the type of that last meta (4) a typing for each patvar WARNING: No checking is done to make sure that the sigS(or sigT)'s are actually there. - Only homogeneous pairs are built i.e. pairs where all the dependencies are of the same sort [sig_clausal_form] proceed as follows: the default tuple is constructed by taking the tuple-type, exploding the first [tuplen] [sigS]'s, and replacing at each step the binder in the right-hand-type by a fresh metavariable. In addition, on the way back out, we will construct the pattern for the tuple which uses these meta-vars. This gives us a pattern, which we use to match against the type of [dflt]; if that fails, then against the S(TRONG)NF of that type. If both fail, then we just cannot construct our tuple. If one of those succeed, then we can construct our value easily - we just use the tuple-pattern. *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let { intro = exist_term } = find_sigma_data sort_of_ty in let evdref = ref (Evd.create_goal_evar_defs sigma) in let rec sigrec_clausal_form siglen p_i = if siglen = 0 then (* is the default value typable with the expected type *) let dflt_typ = type_of env sigma dflt in if Evarconv.e_cumul env evdref dflt_typ p_i then (* the_conv_x had a side-effect on evdref *) dflt else error "Cannot solve a unification problem." else let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with | (_sigS,[a;p]) -> (a,p) | _ -> anomaly "sig_clausal_form: should be a sigma type" in let ev = Evarutil.e_new_evar evdref env a in let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match Evd.existential_opt_value !evdref (destEvar ev) with | Some w -> let w_type = type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." | None -> anomaly "Not enough components to build the dependent tuple" in let scf = sigrec_clausal_form siglen ty in Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors (say [Ci(e1,Cj(e2,Ck(...,term,...),...),...)]), returns a given subterm of the term (say [term]). Let [typ] be the type of [term]. If [term] has no dependencies in the [e1], [e2], etc, then all is simple. If not, then we need to encapsulated the dependencies into a dependent tuple in such a way that the destructor has not a dependent type and rewriting can then be applied. The destructor has the form [e]Cases e of | ... | Ci (x1,x2,...) => Cases x2 of | ... | Cj (y1,y2,...) => Cases y2 of | ... | Ck (...,z,...) => z | ... end | ... end | ... end and the dependencies is expressed by the fact that [z] has a type dependent in the x1, y1, ... Assume [z] is typed as follows: env |- z:zty If [zty] has no dependencies, this is simple. Otherwise, assume [zty] has free (de Bruijn) variables in,...i1 then the role of [make_iterated_tuple sigma env (term,typ) (z,zty)] is to build the tuple [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))] where P1 is zty[i1/x1], P2 is {x1 | P1[i2/x2]} etc. To do this, we find the free (relative) references of the strong NF of [z]'s type, gather them together in left-to-right order (i.e. highest-numbered is farthest-left), and construct a big iterated pair out of it. This only works when the references are all themselves to members of [Set]s, because we use [sigS] to construct the tuple. Suppose now that our constructed tuple is of length [tuplen]. We need also to construct a default value for the other branches of the destructor. As default value, we take a tuple of the form [existT [xn]Pn ?n (... existT [x2]P2 ?2 (existT [x1]P1 ?1 term))] but for this we have to solve the following unification problem: typ = zty[i1/?1;...;in/?n] This is done by [sig_clausal_form]. *) let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Sort.list (<) (Intset.elements rels) in let (tuple,tuplety) = List.fold_left (make_tuple env sigma) (z,zty) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in (tuple,tuplety,dfltval) let rec build_injrec sigma env dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-argnum) in let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in (kont subval (dfltval,tuplety), tuplety,dfltval) with UserError _ -> failwith "caught" let build_injector sigma env dflt c cpath = let (injcode,resty,_) = build_injrec sigma env dflt c cpath in (injcode,resty) (* let try_delta_expand env sigma t = let whdt = whd_betadeltaiota env sigma t in let rec hd_rec c = match kind_of_term c with | Construct _ -> whdt | App (f,_) -> hd_rec f | Cast (c,_,_) -> hd_rec c | _ -> t in hd_rec whdt *) (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type in hd position, otherwise delta expansion is not done *) let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) match decompose_app t with | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) | _ -> t let inject_at_positions env sigma (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (e,None,t) env in let injectors = map_succeed (fun (cpath,t1',t2') -> (* arbitrarily take t1' as the injector default value *) let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in let pf_typ = get_type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in (pf,ty)) posns in if injectors = [] then errorlabstrm "Equality.inj" (str "Failed to decompose the equality."); tclTHEN (tclMAP (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf]) injectors) (tac (List.length injectors)) exception Not_dep_pair let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in let env = eq_clause.env in match find_positions env sigma t1 t2 with | Inl _ -> errorlabstrm "Inj" (str"Not a projectable equality but a discriminable one.") | Inr [] -> errorlabstrm "Equality.inj" (str"Nothing to do, it is an equality between convertible terms.") | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> errorlabstrm "Equality.inj" (str"Nothing to inject.") | Inr posns -> (* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ? let t1 = try_delta_expand env sigma t1 in let t2 = try_delta_expand env sigma t2 in *) try ( (* fetch the informations of the pair *) let ceq = constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let eqTypeDest = fst (destApp t) in let _,ar1 = destApp t1 and _,ar2 = destApp t2 in let ind = destInd ar1.(0) in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in (* check whether the equality deals with dep pairs or not *) (* if yes, check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) let new_eq_args = [|type_of env sigma (ar1.(3));ar1.(3);ar2.(3)|] in if ( (eqTypeDest = sigTconstr()) && (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind=true) && (is_conv env sigma (ar1.(2)) (ar2.(2)) = true)) then ( (* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*) let qidl = qualid_of_reference (Ident (dummy_loc,id_of_string "Eqdep_dec")) in Library.require_library [qidl] (Some false); (* cut with the good equality and prove the requested goal *) tclTHENS (cut (mkApp (ceq,new_eq_args)) ) [tclIDTAC; tclTHEN (apply ( mkApp(inj2, [|ar1.(0);mkConst (find_scheme (!eq_dec_scheme_kind_name()) ind); ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) )) (Auto.trivial [] []) ] (* not a dep eq or no decidable type found *) ) else (raise Not_dep_pair) ) with e when Errors.noncritical e -> inject_at_positions env sigma u eq_clause posns (fun _ -> intros_pattern no_move ipats) let inj ipats with_evars = onEquality with_evars (injEq ipats) let injClause ipats with_evars = function | None -> onNegatedEquality with_evars (injEq ipats) | Some c -> onInductionArg (inj ipats with_evars) c let injConcl gls = injClause [] false None gls let injHyp id gls = injClause [] false (Some (ElimOnIdent (dummy_loc,id))) gls let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause gls = let sort = pf_apply get_type_of gls (pf_concl gls) in let sigma = clause.evd in let env = pf_env gls in match find_positions env sigma t1 t2 with | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn sort gls | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) ntac 0 gls | Inr posns -> inject_at_positions env sigma u clause (List.rev posns) ntac gls let dEqThen with_evars ntac = function | None -> onNegatedEquality with_evars (decompEqThen ntac) | Some c -> onInductionArg (onEquality with_evars (decompEqThen ntac)) c let dEq with_evars = dEqThen with_evars (fun x -> tclIDTAC) let swap_equality_args = function | MonomorphicLeibnizEq (e1,e2) -> [e2;e1] | PolymorphicLeibnizEq (t,e1,e2) -> [t;e2;e1] | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1] let swap_equands gls eqn = let (lbeq,eq_args) = find_eq_data eqn in applist(lbeq.eq,swap_equality_args eq_args) let swapEquandsInConcl gls = let (lbeq,eq_args) = find_eq_data (pf_concl gls) in let sym_equal = lbeq.sym in refine (applist(sym_equal,(swap_equality_args eq_args@[Evarutil.mk_new_meta()]))) gls (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) let bareRevSubstInConcl lbeq body (t,e1,e2) gls = (* find substitution scheme *) let eq_elim = find_elim lbeq.eq (Some false) false None None gls in (* build substitution predicate *) let p = lambda_create (pf_env gls) (t,body) in (* apply substitution scheme *) refine (applist(eq_elim,[t;e1;p;Evarutil.mk_new_meta(); e2;Evarutil.mk_new_meta()])) gls (* [subst_tuple_term dep_pair B] Given that dep_pair looks like: (existT e1 (existT e2 ... (existT en en+1) ... )) of type {x1:T1 & {x2:T2(x1) & ... {xn:Tn(x1..xn-1) & en+1 } } } and B might contain instances of the ei, we will return the term: ([x1:ty1]...[xn+1:tyn+1]B (projT1 (mkRel 1)) (projT1 (projT2 (mkRel 1))) ... (projT1 (projT2^n (mkRel 1))) (projT2 (projT2^n (mkRel 1))) That is, we will abstract out the terms e1...en+1 of types t1 (=_beta T1), ..., tn+1 (=_beta Tn+1(e1..en)) as usual, but will then produce a term in which the abstraction is on a single term - the debruijn index [mkRel 1], which will be of the same type as dep_pair (note that the abstracted body may not be typable!). ALGORITHM for abstraction: We have a list of terms, [e1]...[en+1], which we want to abstract out of [B]. For each term [ei], going backwards from [n+1], we just do a [subst_term], and then do a lambda-abstraction to the type of the [ei]. *) let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = let iterated_decomp = try let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in let car_code = applist (p1,[a;p;inner_code]) and cdr_code = applist (p2,[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with PatternMatchingFailure -> [] in [((ex,exty),inner_code)]::iterated_decomp in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env dep_pair1 typ in let decomps2 = decomp_tuple_term env dep_pair2 typ in (* We adjust to the shortest decomposition *) let n = min (List.length decomps1) (List.length decomps2) in let decomp1 = List.nth decomps1 (n-1) in let decomp2 = List.nth decomps2 (n-1) in (* We rewrite dep_pair1 ... *) let e1_list,proj_list = List.split decomp1 in (* ... and use dep_pair2 to compute the expected goal *) let e2_list,_ = List.split decomp2 in (* We build the expected goal *) let abst_B = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in let pred_body = beta_applist(abst_B,proj_list) in let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in pred_body,expected_goal (* Like "replace" but decompose dependent equalities *) exception NothingToRewrite let cutSubstInConcl_RL eqn gls = let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in let body,expected_goal = pf_apply subst_tuple_term gls e2 e1 (pf_concl gls) in if not (dependent (mkRel 1) body) then raise NothingToRewrite; tclTHENFIRST (bareRevSubstInConcl lbeq body eq) (convert_concl expected_goal DEFAULTcast) gls (* |- (P e1) BY CutSubstInConcl_LR (eq T e1 e2) |- (P e2) |- (eq T e1 e2) *) let cutSubstInConcl_LR eqn gls = (tclTHENS (cutSubstInConcl_RL (swap_equands gls eqn)) ([tclIDTAC; swapEquandsInConcl])) gls let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL let cutSubstInHyp_LR eqn id gls = let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in let idtyp = pf_get_hyp_typ gls id in let body,expected_goal = pf_apply subst_tuple_term gls e1 e2 idtyp in if not (dependent (mkRel 1) body) then raise NothingToRewrite; cut_replacing id expected_goal (tclTHENFIRST (bareRevSubstInConcl lbeq body eq) (refine_no_check (mkVar id))) gls let cutSubstInHyp_RL eqn id gls = (tclTHENS (cutSubstInHyp_LR (swap_equands gls eqn) id) ([tclIDTAC; swapEquandsInConcl])) gls let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL let try_rewrite tac gls = try tac gls with | PatternMatchingFailure -> errorlabstrm "try_rewrite" (str "Not a primitive equality here.") | e when catchable_exception e -> errorlabstrm "try_rewrite" (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") | NothingToRewrite -> errorlabstrm "try_rewrite" (strbrk "Nothing to rewrite.") let cutSubstClause l2r eqn cls gls = match cls with | None -> cutSubstInConcl l2r eqn gls | Some id -> cutSubstInHyp l2r eqn id gls let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls) let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls gls = let eq = pf_apply get_type_of gls c in tclTHENS (cutSubstClause l2r eq cls) [tclIDTAC; exact_no_check c] gls let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) let rewriteInConcl l2r c = rewriteClause l2r c None (* Naming scheme for rewrite and cutrewrite tactics give equality give proof of equality / cutSubstClause substClause raw | cutSubstInHyp substInHyp \ cutSubstInConcl substInConcl / cutRewriteClause rewriteClause user| cutRewriteInHyp rewriteInHyp \ cutRewriteInConcl rewriteInConcl raw = raise typing error or PatternMatchingFailure user = raise user error specific to rewrite *) (**********************************************************************) (* Substitutions tactics (JCF) *) let unfold_body x gl = let hyps = pf_hyps gl in let xval = match Sign.lookup_named x hyps with (_,Some xval,_) -> xval | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") in let aft = afterHyp x gl in let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in tclTHENLIST [tclMAP (fun h -> reduct_in_hyp rfun h) hl; reduct_in_concl (rfun,DEFAULTcast)] gl let restrict_to_eq_and_identity eq = (* compatibility *) if eq <> constr_of_global glob_eq && eq <> constr_of_global glob_identity then raise PatternMatchingFailure exception FoundHyp of (identifier * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *) let is_eq_x gl x (id,_,c) = try let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) with PatternMatchingFailure -> () (* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) gl = (* The set of hypotheses using x *) let depdecls = let test (id,_,c as dcl) = if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl else failwith "caught" in List.rev (map_succeed test (pf_hyps gl)) in let dephyps = List.map (fun (id,_,_) -> id) depdecls in (* Decides if x appears in conclusion *) let depconcl = occur_var (pf_env gl) x (pf_concl gl) in (* The set of non-defined hypothesis: they must be abstracted, rewritten and reintroduced *) let abshyps = map_succeed (fun (id,v,_) -> if v=None then mkVar id else failwith "caught") depdecls in (* a tactic that either introduce an abstracted and rewritten hyp, or introduce a definition where x was replaced *) let introtac = function (id,None,_) -> intro_using id | (id,Some hval,htyp) -> letin_tac None (Name id) (replace_term (mkVar x) rhs hval) (Some (replace_term (mkVar x) rhs htyp)) nowhere in let need_rewrite = dephyps <> [] || depconcl in tclTHENLIST ((if need_rewrite then [generalize abshyps; general_rewrite dir all_occurrences true dep_proof_ok (mkVar hyp); thin dephyps; tclMAP introtac depdecls] else [tclIDTAC]) @ [tclTRY (clear [x;hyp])]) gl (* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one_var dep_proof_ok x gl = let hyps = pf_hyps gl in let (_,xval,_) = pf_get_hyp gl x in (* If x has a body, simply replace x with body and clear x *) if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else (* x is a variable: *) let varx = mkVar x in (* Find a non-recursive definition for x *) let (hyp,rhs,dir) = try let test hyp _ = is_eq_x gl varx hyp in Sign.fold_named_context test ~init:() hyps; errorlabstrm "Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") with FoundHyp res -> res in subst_one dep_proof_ok x (hyp,rhs,dir) gl let subst_gen dep_proof_ok ids = tclTHEN tclNORMEVAR (tclMAP (subst_one_var dep_proof_ok) ids) (* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst = subst_gen true type subst_tactic_flags = { only_leibniz : bool; rewrite_dependent_proof : bool } let default_subst_tactic_flags () = if Flags.version_strictly_greater Flags.V8_2 then { only_leibniz = false; rewrite_dependent_proof = true } else { only_leibniz = true; rewrite_dependent_proof = false } let subst_all ?(flags=default_subst_tactic_flags ()) gl = let test (_,c) = try let lbeq,(_,x,y) = find_eq_data_decompose gl c in if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> match kind_of_term y with Var y -> y | _ -> failwith "caught" with PatternMatchingFailure -> failwith "caught" in let ids = map_succeed test (pf_hyps_types gl) in let ids = list_uniquize ids in subst_gen flags.rewrite_dependent_proof ids gl (* Rewrite the first assumption for which the condition faildir does not fail and gives the direction of the rewrite *) let cond_eq_term_left c t gl = try let (_,x,_) = snd (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" with PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try let (_,_,x) = snd (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try let (_,x,y) = snd (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" with PatternMatchingFailure -> failwith "not an equality" let rewrite_multi_assumption_cond cond_eq_term cl gl = let rec arec = function | [] -> error "No such assumption." | (id,_,t) ::rest -> begin try let dir = cond_eq_term t gl in general_multi_rewrite dir false (mkVar id,NoBindings) cl gl with | Failure _ | UserError _ -> arec rest end in arec (pf_hyps gl) let replace_multi_term dir_opt c = let cond_eq_fun = match dir_opt with | None -> cond_eq_term c | Some true -> cond_eq_term_left c | Some false -> cond_eq_term_right c in rewrite_multi_assumption_cond cond_eq_fun let _ = Tactics.register_general_multi_rewrite (fun b evars t cls -> general_multi_rewrite b evars t cls) let _ = Tactics.register_subst_one (fun b -> subst_one b) coq-8.4pl3/tactics/elimschemes.ml0000640000175000017500000001144112255245502016077 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let ida = pf_nth_hyp_id gl 1 and idna = pf_nth_hyp_id gl 2 in exact_no_check (applist(mkVar idna,[mkVar ida])) gl))); tclIDTAC])); tclIDTAC])) gls (* Contradiction *) let filter_hyp f tac gl = let rec seek = function | [] -> raise Not_found | (id,_,t)::rest when f t -> tac id gl | _::rest -> seek rest in seek (pf_hyps gl) let contradiction_context gl = let env = pf_env gl in let sigma = project gl in let rec seek_neg l gl = match l with | [] -> error "No such contradiction" | (id,_,typ)::rest -> let typ = whd_betadeltaiota env sigma typ in if is_empty_type typ then simplest_elim (mkVar id) gl else match kind_of_term typ with | Prod (na,t,u) when is_empty_type u -> (try filter_hyp (fun typ -> pf_conv_x_leq gl typ t) (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) gl with Not_found -> seek_neg rest gl) | _ -> seek_neg rest gl in seek_neg (pf_hyps gl) gl let is_negation_of env sigma typ t = match kind_of_term (whd_betadeltaiota env sigma t) with | Prod (na,t,u) -> is_empty_type u & is_conv_leq env sigma typ t | _ -> false let contradiction_term (c,lbind as cl) gl = let env = pf_env gl in let sigma = project gl in let typ = pf_type_of gl c in let _, ccl = splay_prod env sigma typ in if is_empty_type ccl then tclTHEN (elim false cl None) (tclTRY assumption) gl else try if lbind = NoBindings then filter_hyp (is_negation_of env sigma typ) (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) gl else raise Not_found with Not_found -> error "Not a contradiction." let contradiction = function | None -> tclTHEN intros contradiction_context | Some c -> contradiction_term c coq-8.4pl3/tactics/nbtermdn.mli0000640000175000017500000000273612255245502015572 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* sig module Term_dn : sig type term_label = | GRLabel of global_reference | ProdLabel | LambdaLabel | SortLabel end type 'na t type 'na frozen_t val create : unit -> 'na t val add : 'na t -> ('na * (constr_pattern * Y.t)) -> unit val rmv : 'na t -> 'na -> unit val in_dn : 'na t -> 'na -> bool val remap : 'na t -> 'na -> (constr_pattern * Y.t) -> unit val lookup : 'na t -> constr -> (constr_pattern * Y.t) list val app : ('na -> (constr_pattern * Y.t) -> unit) -> 'na t -> unit val dnet_depth : int ref val freeze : 'na t -> 'na frozen_t val unfreeze : 'na frozen_t -> 'na t -> unit val empty : 'na t -> unit val to2lists : 'na t -> ('na * (constr_pattern * Y.t)) list * (Term_dn.term_label option * Btermdn.Make(Y).t) list end coq-8.4pl3/tactics/extraargs.mli0000640000175000017500000000551712255245502015761 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds val occurrences : (int list or_var) Pcoq.Gram.entry val rawwit_occurrences : (int list or_var) raw_abstract_argument_type val wit_occurrences : (int list) typed_abstract_argument_type val pr_occurrences : int list Glob_term.or_var -> Pp.std_ppcmds val rawwit_glob : constr_expr raw_abstract_argument_type val wit_glob : (Tacinterp.interp_sign * glob_constr) typed_abstract_argument_type val glob : constr_expr Pcoq.Gram.entry type 'id gen_place= ('id * hyp_location_flag,unit) location type loc_place = identifier Util.located gen_place type place = identifier gen_place val rawwit_hloc : loc_place raw_abstract_argument_type val wit_hloc : place typed_abstract_argument_type val hloc : loc_place Pcoq.Gram.entry val pr_hloc : loc_place -> Pp.std_ppcmds val in_arg_hyp: (Names.identifier Util.located list option * bool) Pcoq.Gram.entry val globwit_in_arg_hyp : (Names.identifier Util.located list option * bool) glob_abstract_argument_type val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause val glob_in_arg_hyp_to_clause : (Names.identifier list option * bool) -> Tacticals.clause val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry val rawwit_by_arg_tac : raw_tactic_expr option raw_abstract_argument_type val wit_by_arg_tac : glob_tactic_expr option typed_abstract_argument_type val pr_by_arg_tac : (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> raw_tactic_expr option -> Pp.std_ppcmds (** Spiwack: Primitive for retroknowledge registration *) val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry val rawwit_retroknowledge_field : Retroknowledge.field raw_abstract_argument_type val wit_retroknowledge_field : Retroknowledge.field typed_abstract_argument_type coq-8.4pl3/tactics/autorewrite.mli0000640000175000017500000000372712255245502016334 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raw_rew_rule list -> unit (** The AutoRewrite tactic. The optional conditions tell rewrite how to handle matching and side-condition solving. Default is Naive: first match in the clause, don't look at the side-conditions to tell if the rewrite succeeded. *) val autorewrite : ?conds:conditions -> tactic -> string list -> tactic val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic (** Rewriting rules *) type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; rew_l2r: bool; rew_tac: glob_tactic_expr } val find_rewrites : string -> rew_rule list val find_matches : string -> constr -> rew_rule list val auto_multi_rewrite : ?conds:conditions -> string list -> Tacticals.clause -> tactic val auto_multi_rewrite_with : ?conds:conditions -> tactic -> string list -> Tacticals.clause -> tactic val print_rewrite_hintdb : string -> unit open Clenv type hypinfo = { hyp_cl : clausenv; hyp_prf : constr; hyp_ty : types; hyp_car : constr; hyp_rel : constr; hyp_l2r : bool; hyp_left : constr; hyp_right : constr; } val find_applied_relation : bool -> Util.loc -> Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo coq-8.4pl3/tactics/leminv.ml0000640000175000017500000002343212255245502015076 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (*