Ltac dup_tactic N :=
  match nat_from_number N with
  | 0 => idtac
  | S 0 => idtac
  | S ?N' => apply dup_lemma; [ | dup_tactic N' ]
  end.(* ---------------------------------------------------------------------- *)
(** ** Check no evar in goal *)

Ltac check_noevar M :=
  match M with M => idtac end.Ltac check_noevar_hyp H := (* todo: imlement using check_noevar *)
  let T := type of H in
  match type of H with T => idtac end.Ltac check_noevar_goal := (* todo: imlement using check_noevar *)
  match goal with |- ?G => match G with G => idtac end end.(* ---------------------------------------------------------------------- *)
(** ** Tagging of hypotheses *)

(** [get_last_hyp tt] is a function that returns the last hypothesis
    at the bottom of the context. It is useful to obtain the default
    name associated with the hypothesis, e.g.
    [intro; let H := get_last_hyp tt in let H' := fresh "P" H in ...] *)

Ltac get_last_hyp tt :=
  match goal with H: _ |- _ => constr:(H) end.(* ---------------------------------------------------------------------- *)
(** ** Tagging of hypotheses *)

(** [ltac_tag_subst] is a specific marker for hypotheses
    which is used to tag hypotheses that are equalities to
    be substituted. *)

Definition ltac_tag_subst (A:Type) (x:A) := x.(** [ltac_to_generalize] is a specific marker for hypotheses
    to be generalized. *)

Definition ltac_to_generalize (A:Type) (x:A) := x.Ltac gen_to_generalize :=
  repeat match goal with
    H: ltac_to_generalize _ |- _ => generalize H; clear H end.Ltac mark_to_generalize H :=
  let T := type of H in
  change T with (ltac_to_generalize T) in H.(* ---------------------------------------------------------------------- *)
(** ** Deconstructing terms *)

(** [get_head E] is a tactic that returns the head constant of the
    term [E], ie, when applied to a term of the form [P x1 ... xN]
    it returns [P]. If [E] is not an application, it returns [E].
    Warning: the tactic seems to loop in some cases when the goal is
    a product and one uses the result of this function. *)

Ltac get_head E :=
  match E with
  | ?P _ _ _ _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ => constr:(P)
  | ?P _ _ _ => constr:(P)
  | ?P _ _ => constr:(P)
  | ?P _ => constr:(P)
  | ?P => constr:(P)
  end.(** [get_fun_arg E] is a tactic that decomposes an application
  term [E], ie, when applied to a term of the form [X1 ... XN]
  it returns a pair made of [X1 .. X(N-1)] and [XN]. *)

Ltac get_fun_arg E :=
  match E with
  | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X7 ?X => constr:((X1 X2 X3 X4 X5 X6,X))
  | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X => constr:((X1 X2 X3 X4 X5,X))
  | ?X1 ?X2 ?X3 ?X4 ?X5 ?X => constr:((X1 X2 X3 X4,X))
  | ?X1 ?X2 ?X3 ?X4 ?X => constr:((X1 X2 X3,X))
  | ?X1 ?X2 ?X3 ?X => constr:((X1 X2,X))
  | ?X1 ?X2 ?X => constr:((X1,X))
  | ?X1 ?X => constr:((X1,X))
  end.(* ---------------------------------------------------------------------- *)
(** ** An alias for [eq] *)

(** [eq'] is an alias for [eq] to be used for equalities in
    inductive definitions, so that they don't get mixed with
    equalities generated by [inversion]. *)

Definition eq' := @eq.(** [lets_base H E] adds an hypothesis [H : T] to the context, where [T] is
    the type of term [E]. If [H] is an introduction pattern, it will
    destruct [H] according to the pattern. *)

Ltac lets_base I E := generalize E; intros I.(** [false_post] is the underlying tactic used to prove goals
    of the form [False]. In the default implementation, it proves
    the goal if the context contains [False] or an hypothesis of the
    form [C x1 .. xN  =  D y1 .. yM], or if the [congruence] tactic
    finds a proof of [x <> x] for some [x]. *)

Ltac false_post :=
  solve [ assumption | discriminate | congruence ].(** [false_invert] proves any goal provided there is at least
    one hypothesis [H] in the context that can be proved absurd
    by calling [inversion H]. *)

Ltac false_invert_tactic :=
  match goal with H:_ |- _ =>
    solve [ inversion H
          | clear H; false_invert_tactic
          | fail 2 ] end.(* ---------------------------------------------------------------------- *)
(** ** Instantiation and forward-chaining *)

(** The instantiation tactics are used to instantiate a lemma [E]
    (whose type is a product) on some arguments. The type of [E] is
    made of implications and universal quantifications, e.g.
    [forall x, P x -> forall y z, Q x y z -> R z].

    The first possibility is to provide arguments in order: first [x],
    then a proof of [P x], then [y] etc... In this mode, called "Args",
    all the arguments are to be provided. If a wildcard is provided
    (written [__]), then an existential variable will be introduced in
    place of the argument.

    It often saves a lot of time to give only the dependent variables,
    (here [x], [y] and [z]), and have the hypotheses generated as
    subgoals. In this "Vars" mode, only variables are to be provided.
    For instance, lemma [E] applied to [3] and [4] is a term
    of type [forall z, Q 3 4 z -> R z], and [P 3] is a new subgoal.
    It is possible to use wildcards to introduce existential variables.

    However, there are situations where some of the hypotheses already
    exists, and it saves time to instantiate the lemma [E] using the
    hypotheses. For instance, suppose [F] is a term of type [P 2].
    Then the application of [E] to [F] in this "Hyps" mode is a term of type
    [forall y z, Q 2 y z -> R z]. Each wildcard use
    will generate an assertion instead, for instance if [G] has type
    [Q 2 3 4], then the application of [E] to a wildcard and to [G]
    in mode-h is a term of type [R 4], and [P 2] is a new subgoal.

    It is very convenient to give some arguments the lemma should be
    instantiated on, and let the tactic find out automatically where
    underscores should be insterted. Underscore arguments [__] are
    interpret as follows: an underscore means that we want to skip the
    argument that has the same type as the next real argument provided
    (real means not an underscore). If there is no real argument after
    underscore, then the underscore is used for the first possible argument.

    The general syntax is [tactic (>> E1 .. EN)] where [tactic] is
    the name of the tactic (possibly with some arguments) and [Ei]
    are the arguments. Moreover, some tactics accept the syntax
    [tactic E1 .. EN] as short for [tactic (>>Hnts E1 .. EN)] for
    values of [N] up to 5.

    Finally, if the argument [EN] given is a triple-underscore [___],
    then it is equivalent to providing a list of wildcards, with
    the appropriate number of wildcards. This means that all
    the remaining arguments of the lemma will be instantiated. *)

(* Underlying implementation *)

Ltac app_assert t P cont :=
  let H := fresh "TEMP" in
  assert (H : P); [ | cont(t H); clear H ].Ltac app_evar t A cont :=
  let x := fresh "TEMP" in
  evar (x:A);
  let t' := constr:(t x) in
  let t'' := (eval unfold x in t') in
  subst x; cont t''.Ltac app_arg t P v cont :=
  let H := fresh "TEMP" in
  assert (H : P); [ apply v | cont(t H); try clear H ].Ltac build_app_alls t final :=
  let rec go t :=
    match type of t with
    | ?P -> ?Q => app_assert t P go
    | forall _:?A, _ => app_evar t A go
    | _ => final t
    end in
  go t.Ltac boxerlist_next_type vs :=
  match vs with
  | nil => constr:(ltac_wild)
  | (boxer ltac_wild)::?vs' => boxerlist_next_type vs'
  | (boxer ltac_wilds)::_ => constr:(ltac_wild)
  | (@boxer ?T _)::_ => constr:(T)
  end.Ltac build_app_hnts t vs final :=
  let rec go t vs :=
    match vs with
    | nil => first [ final t | fail 1 ]
    | (boxer ltac_wilds)::_ => first [ build_app_alls t final | fail 1 ]
    | (boxer ?v)::?vs' =>
      let cont t' := go t' vs in
      let cont' t' := go t' vs' in
      let T := type of t in
      let T := eval hnf in T in
      match v with
      | ltac_wild =>
         first [ let U := boxerlist_next_type vs' in
           match U with
           | ltac_wild =>
             match T with
             | ?P -> ?Q => first [ app_assert t P cont' | fail 3 ]
             | forall _:?A, _ => first [ app_evar t A cont' | fail 3 ]
             end
           | _ =>
             match T with  (* should test T for unifiability *)
             | U -> ?Q => first [ app_assert t U cont' | fail 3 ]
             | forall _:U, _ => first [ app_evar t U cont' | fail 3 ]
             | ?P -> ?Q => first [ app_assert t P cont | fail 3 ]
             | forall _:?A, _ => first [ app_evar t A cont | fail 3 ]
             end
           end
         | fail 2 ]
      | _ =>
          match T with
          | ?P -> ?Q => first [ app_arg t P v cont'
                              | app_assert t P cont
                              | fail 3 ]
          | forall _:?A, _ => first [ cont' (t v)
                                    | app_evar t A cont
                                    | fail 3 ]
          end
      end
    end in
  go t vs.Ltac build_app args final :=
  first [
    match args with (@boxer ?T ?t)::?vs =>
      let t := constr:(t:T) in
      build_app_hnts t vs final
    end
  | fail 1 "Instantiation fails for:" args].Ltac unfold_head_until_product T :=
  eval hnf in T.Ltac args_unfold_head_if_not_product args :=
  match args with (@boxer ?T ?t)::?vs =>
    let T' := unfold_head_until_product T in
    constr:((@boxer T' t)::vs)
  end.Ltac args_unfold_head_if_not_product_but_params args :=
  match args with
  | (boxer ?t)::(boxer ?v)::?vs =>
     args_unfold_head_if_not_product args
  | _ => constr:(args)
  end.(** [lets H: (>> E0 E1 .. EN)] will instantiate lemma [E0]
    on the arguments [Ei] (which may be wildcards [__]),
    and name [H] the resulting term. [H] may be an introduction
    pattern, or a sequence of introduction patterns [I1 I2 IN],
    or empty.
    Syntax [lets H: E0 E1 .. EN] is also available. If the last
    argument [EN] is [___] (triple-underscore), then all
    arguments of [H] will be instantiated. *)

Ltac lets_build I Ei :=
  let args := list_boxer_of Ei in
  let args := args_unfold_head_if_not_product_but_params args in
(*    let Ei''' := args_unfold_head_if_not_product Ei'' in*)
  build_app args ltac:(fun R => lets_base I R).(** [forwards H: (>> E0 E1 .. EN)] is short for
    [forwards H: (>> E0 E1 .. EN ___)].
    The arguments [Ei] can be wildcards [__] (except [E0]).
    [H] may be an introduction pattern, or a sequence of
    introduction pattern, or empty.
    Syntax [forwards H: E0 E1 .. EN] is also available. *)

Ltac forwards_build_app_arg Ei :=
  let args := list_boxer_of Ei in
  let args := (eval simpl in (args ++ ((boxer ___)::nil))) in
  let args := args_unfold_head_if_not_product args in
  args.Ltac forwards_then Ei cont :=
  let args := forwards_build_app_arg Ei in
  let args := args_unfold_head_if_not_product_but_params args in
  build_app args cont.Ltac forwards_nounfold_then Ei cont :=
  let args := list_boxer_of Ei in
  let args := (eval simpl in (args ++ ((boxer ___)::nil))) in
  build_app args cont;
  fast_rm_inside Ei.(** [applys (>> E0 E1 .. EN)] instantiates lemma [E0]
    on the arguments [Ei] (which may be wildcards [__]),
    and apply the resulting term to the current goal,
    using the tactic [applys] defined earlier on.
    [applys E0 E1 E2 .. EN] is also available. *)

Ltac applys_build Ei :=
  let args := list_boxer_of Ei in
  let args := args_unfold_head_if_not_product_but_params args in
  build_app args ltac:(fun R =>
   first [ apply R | eapply R | rapply R ]).Ltac applys_base E :=
  match type of E with
  | list Boxer => applys_build E
  | _ => first [ rapply E | applys_build E ]
  end; fast_rm_inside E.(** [fapplys (>> E0 E1 .. EN)] instantiates lemma [E0]
    on the arguments [Ei] and on the argument [___] meaning
    that all evars should be explicitly instantiated,
    and apply the resulting term to the current goal.
    [fapplys E0 E1 E2 .. EN] is also available. *)

Ltac fapplys_build Ei :=
  let args := list_boxer_of Ei in
  let args := (eval simpl in (args ++ ((boxer ___)::nil))) in
  let args := args_unfold_head_if_not_product_but_params args in
  build_app args ltac:(fun R => apply R).(** [specializes H (>> E1 E2 .. EN)] will instantiate hypothesis [H]
    on the arguments [Ei] (which may be wildcards [__]). If the last
    argument [EN] is [___] (triple-underscore), then all arguments of
    [H] get instantiated. *)

Ltac specializes_build H Ei :=
  let H' := fresh "TEMP" in rename H into H';
  let args := list_boxer_of Ei in
  let args := constr:((boxer H')::args) in
  let args := args_unfold_head_if_not_product args in
  build_app args ltac:(fun R => lets H: R);
  clear H'.Ltac specializes_base H Ei :=
  specializes_build H Ei; fast_rm_inside Ei.(* ---------------------------------------------------------------------- *)
(** ** Application of tautologies *)

(** [logic E], where [E] is a fact, is equivalent to
    [assert H:E; [tauto | eapply H; clear H]. It is useful for instance
    to prove a conjunction [A /\ B] by showing first [A] and then [A -> B],
    through the command [logic (foral A B, A -> (A -> B) -> A /\ B)] *)

Ltac logic_base E cont :=
  assert (H:E); [ cont tt | eapply H; clear H ].

(* Specifications: *)
Lemma equates_0 : forall (P Q:Prop), P -> P = Q -> Q.
Lemma equates_1 : forall (P:A0->Prop) x1 y1, P y1 -> x1 = y1 -> P x1.
Lemma equates_2 : forall y1 (P:A0->forall(x1:A1),Prop) x1 x2, P y1 x2 -> x1 = y1 -> P x1 x2.
Lemma equates_3 : forall y1 (P:A0->forall(x1:A1)(x2:A2 x1),Prop) x1 x2 x3, P y1 x2 x3 -> x1 = y1 -> P x1 x2 x3.
Lemma equates_4 : forall y1 (P:A0->forall(x1:A1)(x2:A2 x1)(x3:A3 x2),Prop) x1 x2 x3 x4, P y1 x2 x3 x4 -> x1 = y1 -> P x1 x2 x3 x4.
Lemma equates_5 : forall y1 (P:A0->forall(x1:A1)(x2:A2 x1)(x3:A3 x2)(x4:A4 x3),Prop) x1 x2 x3 x4 x5, P y1 x2 x3 x4 x5 -> x1 = y1 -> P x1 x2 x3 x4 x5.
Lemma equates_6 : forall y1 (P:A0->forall(x1:A1)(x2:A2 x1)(x3:A3 x2)(x4:A4 x3)(x5:A5 x4),Prop) x1 x2 x3 x4 x5 x6, P y1 x2 x3 x4 x5 x6 -> x1 = y1 -> P x1 x2 x3 x4 x5 x6.