Ltac equates_lemma n :=
  match nat_from_number n with
  | 0 => constr:(equates_0)
  | 1 => constr:(equates_1)
  | 2 => constr:(equates_2)
  | 3 => constr:(equates_3)
  | 4 => constr:(equates_4)
  | 5 => constr:(equates_5)
  | 6 => constr:(equates_6)
  end.Ltac equates_one n :=
  let L := equates_lemma n in
  eapply L.Ltac equates_several E cont :=
  let all_pos := match type of E with
    | List.list Boxer => constr:(E)
    | _ => constr:((boxer E)::nil)
    end in
  let rec go pos :=
     match pos with
     | nil => cont tt
     | (boxer ?n)::?pos' => equates_one n; [ instantiate; go pos' | ]
     end in
  go all_pos.(* ********************************************************************** *)
(** * Introduction and generalization *)

(* ---------------------------------------------------------------------- *)
(** ** Introduction *)

(** [introv] is used to name only non-dependent hypothesis.
 - If [introv] is called on a goal of the form [forall x, H],
   it should introduce all the variables quantified with a
   [forall] at the head of the goal, but it does not introduce
   hypotheses that preceed an arrow constructor, like in [P -> Q].
 - If [introv] is called on a goal that is not of the form
   [forall x, H] nor [P -> Q], the tactic unfolds definitions
   until the goal takes the form [forall x, H] or [P -> Q].
   If unfolding definitions does not produces a goal of this form,
   then the tactic [introv] does nothing at all. *)

(* [introv_rec] introduces all visible variables.
   It does not try to unfold any definition. *)

Ltac introv_rec :=
  match goal with
  | |- ?P -> ?Q => idtac
  | |- forall _, _ => intro; introv_rec
  | |- _ => idtac
  end.(* [introv_noarg] forces the goal to be a [forall] or an [->],
   and then calls [introv_rec] to introduces variables
   (possibly none, in which case [introv] is the same as [hnf]).
   If the goal is not a product, then it does not do anything. *)

Ltac introv_noarg :=
  match goal with
  | |- ?P -> ?Q => idtac
  | |- forall _, _ => introv_rec
  | |- ?G => hnf;
     match goal with
     | |- ?P -> ?Q => idtac
     | |- forall _, _ => introv_rec
     end
  | |- _ => idtac
  end.(* simpler yet perhaps less efficient imlementation *)
  Ltac introv_noarg_not_optimized :=
    intro; match goal with H:_|-_ => revert H end; introv_rec.(* [introv_arg H] introduces one non-dependent hypothesis
   under the name [H], after introducing the variables
   quantified with a [forall] that preceeds this hypothesis.
   This tactic fails if there does not exist a hypothesis
   to be introduced. *)

Ltac introv_arg H :=
  hnf; match goal with
  | |- ?P -> ?Q => intros H
  | |- forall _, _ => intro; introv_arg H
  end.(** [def_to_eq E X H] applies when [X := E] is a local
    definition. It adds an assumption [H: X = E]
    and then clears the definition of [X].
    [def_to_eq_sym] is similar except that it generates
    the equality [H: E = X]. *)

Ltac def_to_eq X HX E :=
  assert (HX : X = E) by reflexivity; clearbody X.Ltac def_to_eq_sym X HX E :=
  assert (HX : E = X) by reflexivity; clearbody X.(** [sets_let X] finds the first let-expression in the goal
    and names its body [X]. [sets_eq_let X] is similar,
    except that it generates an explicit equality.
    Tactics [sets_let X in H] and [sets_eq_let X in H]
    allow specifying a particular hypothesis (by default,
    the first one that contains a [let] is considered).

    Known limitation: it does not seem possible to support
    naming of multiple let-in constructs inside a term, from ltac. *)

Ltac sets_let_base tac :=
  match goal with
  | |- context[let _ := ?E in _] => tac E; cbv zeta
  | H: context[let _ := ?E in _] |- _ => tac E; cbv zeta in H
  end.Ltac sets_let_in_base H tac :=
  match type of H with context[let _ := ?E in _] =>
    tac E; cbv zeta in H end.(** [asserts_rewrite E] asserts that an equality [E] holds (generating a
    corresponding subgoal) and rewrite it straight away in the current
    goal. It avoids giving a name to the equality and later clearing it.
    Syntax for rewriting from right to left and/or into an hypothese
    is similar to the one of [rewrite]. Note: the tactic [replaces]
    plays a similar role. *)

Ltac asserts_rewrite_tactic E action :=
  let EQ := fresh in (assert (EQ : E);
  [ idtac | action EQ; clear EQ ]).(** [cuts_rewrite E] is the same as [asserts_rewrite E] except
    that subgoals are permuted. *)

Ltac cuts_rewrite_tactic E action :=
  let EQ := fresh in (cuts EQ: E;
  [ action EQ; clear EQ | idtac ]).(** [rewrite_except H EQ] rewrites equality [EQ] everywhere
    but in hypothesis [H]. *)

Ltac rewrite_except H EQ :=
  let K := fresh in let T := type of H in
  set (K := T) in H;
  rewrite EQ in *; unfold K in H; clear K.(* ---------------------------------------------------------------------- *)
(** ** Unfolding *)

(** [unfolds] unfolds the head definition in the goal, i.e. if the
    goal has form [P x1 ... xN] then it calls [unfold P].
    If the goal is an equality, it tries to unfold the head constant
    on the left-hand side, and otherwise tries on the right-hand side.
    If the goal is a product, it calls [intros] first. *)

Ltac apply_to_head_of E cont :=
  let go E :=
    let P := get_head E in cont P in
  match E with
  | forall _,_ => intros; apply_to_head_of E cont
  | ?A = ?B => first [ go A | go B ]
  | ?A => go A
  end.Ltac unfolds_base :=
  match goal with |- ?G =>
   apply_to_head_of G ltac:(fun P => unfold P) end.(** [unfolds in H] unfolds the head definition of hypothesis [H], i.e. if
    [H] has type [P x1 ... xN] then it calls [unfold P in H]. *)

Ltac unfolds_in_base H :=
  match type of H with ?G =>
   apply_to_head_of G ltac:(fun P => unfold P in H) end.(** Implementation of [substs below], which allows to call
    [subst] on all the hypotheses that lie beyond a given
    position in the proof context. *)

Ltac substs_below limit :=
  match goal with H: ?T |- _ =>
  match T with
  | limit => idtac
  | ?x = ?y =>
    first [ subst x; substs_below limit
          | subst y; substs_below limit
          | generalizes H; substs_below limit; intro ]
  end end.(** [subst_hyp H] substitutes the equality contained in [H].
    The behaviour is extended in LibData --TODO *)

Ltac subst_hyp_base H :=
  match type of H with
  | ?x = ?y => first [ subst x | subst y ]
  end.(** [subst_local] substitutes all local definition from the context *)

Ltac subst_local :=
  repeat match goal with H:=_ |- _ => subst H end.(** [subst_eq E] takes an equality [x = t] and replace [x]
    with [t] everywhere in the goal *)

Ltac subst_eq_base E :=
  let H := fresh "TEMP" in lets H: E; subst_hyp H.(** [pi_rewrite E] replaces [E] of type [Prop] with a fresh
    unification variable, and is thus a practical way to
    exploit proof irrelevance, without writing explicitly
    [rewrite (proof_irrelevance E E')]. Particularly useful
    when [E'] is a big expression. *)

Ltac pi_rewrite_base E rewrite_tac :=
  let E' := fresh in let T := type of E in evar (E':T);
  rewrite_tac (@proof_irrelevance _ E E'); subst E'.(* ---------------------------------------------------------------------- *)
(** ** Proving equalities *)

(** [fequal] is a variation on [f_equal] which has a better behaviour
    on equalities between n-ary tuples. *)

Ltac fequal_base :=
  let go := f_equal; [ fequal_base | ] in
  match goal with
  | |- (_,_,_) = (_,_,_) => go
  | |- (_,_,_,_) = (_,_,_,_) => go
  | |- (_,_,_,_,_) = (_,_,_,_,_) => go
  | |- (_,_,_,_,_,_) = (_,_,_,_,_,_) => go
  | |- _ => f_equal
  end.(** [fequals] is the same as [fequal] except that it tries and solve
    all trivial subgoals, using [reflexivity] and [congruence]
    (as well as the proof-irrelevance principle).
    [fequals] applies to goals of the form [f x1 .. xN = f y1 .. yN]
    and produces some subgoals of the form [xi = yi]). *)

Ltac fequal_post :=
  first [ reflexivity | congruence | apply proof_irrelevance | idtac ].(* ---------------------------------------------------------------------- *)
(** ** Inversion with substitution *)

(** Our inversion tactics is able to get rid of dependent equalities
    generated by [inversion], using proof irrelevance. *)

(* --we do not import Eqdep because it imports nasty hints automatically
    Require Import Eqdep. *)

Axiom inj_pair2 : forall (U : Type) (P : U -> Type) (p : U) (x y : P p),
       existT P p x = existT P p y -> x = y.(* Proof. apply Eqdep.EqdepTheory.inj_pair2. Qed.*)

Ltac inverts_tactic H i1 i2 i3 i4 i5 i6 :=
  let rec go i1 i2 i3 i4 i5 i6 :=
    match goal with
    | |- (ltac_Mark -> _) => intros _
    | |- (?x = ?y -> _) => let H := fresh in intro H;
                           first [ subst x | subst y ];
                           go i1 i2 i3 i4 i5 i6
    | |- (existT ?P ?p ?x = existT ?P ?p ?y -> _) =>
         let H := fresh in intro H;
         generalize (@inj_pair2 _ P p x y H);
         clear H; go i1 i2 i3 i4 i5 i6
    | |- (?P -> ?Q) => i1; go i2 i3 i4 i5 i6 ltac:(intro)
    | |- (forall _, _) => intro; go i1 i2 i3 i4 i5 i6
    end in
  generalize ltac_mark; invert keep H; go i1 i2 i3 i4 i5 i6;
  unfold eq' in *.(** [inverts H as] performs an inversion on hypothesis [H], substitutes
    generated equalities, and put in the goal the other freshly-created
    hypotheses, for the user to name explicitly.
    [inverts keep H as] is the same except that it does not clear [H].
    --TODO: reimplement [inverts] above using this one *)

Ltac inverts_as_tactic H :=
  let rec go tt :=
    match goal with
    | |- (ltac_Mark -> _) => intros _
    | |- (?x = ?y -> _) => let H := fresh "TEMP" in intro H;
                           first [ subst x | subst y ];
                           go tt
    | |- (existT ?P ?p ?x = existT ?P ?p ?y -> _) =>
         let H := fresh in intro H;
         generalize (@inj_pair2 _ P p x y H);
         clear H; go tt
    | |- (forall _, _) =>
       intro; let H := get_last_hyp tt in mark_to_generalize H; go tt
    end in
  pose ltac_mark; inversion H;
  generalize ltac_mark; gen_until_mark;
  go tt; gen_to_generalize; unfolds ltac_to_generalize;
  unfold eq' in *.(* ---------------------------------------------------------------------- *)
(** ** Injection with substitution *)

(** Underlying implementation of [injects] *)

Ltac injects_tactic H :=
  let rec go _ :=
    match goal with
    | |- (ltac_Mark -> _) => intros _
    | |- (?x = ?y -> _) => let H := fresh in intro H;
                           first [ subst x | subst y | idtac ];
                           go tt
    end in
  generalize ltac_mark; injection H; go tt.(** [case_if_post] is to be defined later as a tactic to clean
    up goals. *)

Ltac case_if_post := idtac.(** [case_if] looks for a pattern of the form [if ?B then ?E1 else ?E2]
    in the goal, and perform a case analysis on [B] by calling
    [destruct B]. It looks in the goal first, and otherwise in the
    first hypothesis that contains and [if] statement.
    [case_if in H] can be used to specify which hypothesis to consider.
    Syntaxes [case_if as Eq] and [case_if in H as Eq] allows to name
    the hypothesis coming from the case analysis. *)

Ltac case_if_on_tactic E Eq :=
  match type of E with
  | {_}+{_} => destruct E as [Eq | Eq]
  | _ => let X := fresh in
         sets_eq <- X Eq: E;
         destruct X
  end; case_if_post.(** [cases_if] is similar to [case_if] with two main differences:
    if it creates an equality of the form [x = y] or [x == y],
     it substitutes it in the goal *)

Ltac cases_if_on_tactic E Eq :=
  match type of E with
  | {_}+{_} => destruct E as [Eq|Eq]; try subst_hyp Eq
  | _ => let X := fresh in
         sets_eq <- X Eq: E;
         destruct X
  end; case_if_post.(** [destruct_if] looks for a pattern of the form [if ?B then ?E1 else ?E2]
    in the goal, and perform a case analysis on [B] by calling
    [destruct B]. It looks in the goal first, and otherwise in the
    first hypothesis that contains and [if] statement. *)

Ltac destruct_if_post := tryfalse.(** [destruct_head_match] performs a case analysis on the argument
    of the head pattern matching when the goal has the form
    [match ?E with ...] or [match ?E with ... = _] or
    [_ = match ?E with ...]. Due to the limits of Ltac, this tactic
    will not fail if a match does not occur. Instead, it might
    perform a case analysis on an unspecified subterm from the goal.
    --- Warning: experimental. *)

Ltac find_head_match T :=
  match T with context [?E] =>
    match T with
    | E => fail 1
    | _ => constr:(E)
    end
  end.Ltac destruct_head_match_core cont :=
  match goal with
  | |- ?T1 = ?T2 => first [ let E := find_head_match T1 in cont E
		          | let E := find_head_match T2 in cont E ]
  | |- ?T1 => let E := find_head_match T1 in cont E
  end;
  destruct_if_post.(** [cases_if'] is similar to [cases_if] except that it generates
    the symmetric equality. *)

Ltac cases_if_on' E Eq :=
  match type of E with
  | {_}+{_} => destruct E as [Eq|Eq]; try subst_hyp Eq
  | _ => let X := fresh in
         sets_eq X Eq: E;
         destruct X
  end; case_if_post.Ltac inductions_post :=
  unfold eq' in *.(* ********************************************************************** *)
(** * Decidable equality *)

(** [decides_equality] is the same as [decide equality] excepts that it
    is able to unfold definitions at head of the current goal. *)

Ltac decides_equality_tactic :=
  first [ decide equality | progress(unfolds); decides_equality_tactic ].

Lemma iff_intro_swap : forall (P Q : Prop), (Q -> P) -> (P -> Q) -> (P <-> Q).