(* This tactic recognizes an application of the user's [traverse_term] function that is really a [lift] operation, and folds it. *)
Ltac recognize_lift :=
rewrite recognize_lift by eauto with typeclass_instances;
repeat rewrite plus_0_l. (* useful when [k1] is zero *)
Ltac recognize_lift_in h :=
rewrite recognize_lift in h by eauto with typeclass_instances;
repeat rewrite plus_0_l in h. (* useful when [k1] is zero *)
(* The tactic [simpl_lift] is used to simplify an application of [lift] to a concrete term, such as [TApp t ...], where [TApp] is a user-defined constructor of the user-defined type of [term]s. We assume that the user has manually rewritten one or several occurrences of [lift] using the lemma [expand_lift], so as to indicate where simplification is desired. Thus, one or several instances of [traverse] must be visible in a hypothesis or in the goal. We further assume that [simpl (@traverse _ _ _)] has been used so as to replace the generic [traverse] with user-defined [_traverse] functions. We start there and do the rest of the work. *)
(* A difficulty arises when the goal or hypothesis contains instances of [lift] at multiple types. In that case, after expanding [traverse], we find multiple user-defined [_traverse] functions, each of which we must deal with in turn.  After dealing with one specific [_traverse] function, we use [recognize_lift] at a specific type in order to eliminate all occurrences of this particular [_traverse] function. We are then able to iterate this process without looping. *)
Ltac simpl_lift :=
match goal with
(* Case: [_traverse] appears in the goal. *)
(* this binds the meta-variable [_traverse] to the user's [traverse_term] *)
|- context[?_traverse (fun l x : nat => var (lift ?w (l + ?k) x)) _ _] =>
(* this causes the reduction of the fixpoint: *)
unfold _traverse; fold _traverse;
(* we now have a term of the form [TApp (traverse_term ...) ...]. There remains to recognize the definition of [lift]. *)
plus_0_r; (* useful when we have traversed a binder: 1 + 0 is 1 *)
(* use [recognize_lift] at the specific type of the [_traverse] function that we have just simplified *)
match type of _traverse with (nat -> nat -> ?V) -> nat -> ?T -> ?T =>
repeat rewrite (@recognize_lift V _ T _ _) by eauto with typeclass_instances
end;
repeat rewrite plus_0_l (* useful when [k1] is zero and we are at a leaf *)
(* Case: [_traverse] appears in a hypothesis. *)
(* this binds the meta-variable [_traverse] to the user's [traverse_term] *)
| h: context[?_traverse (fun l x : nat => var (lift ?w (l + ?k) x)) _ _] |- _ =>
(* this causes the reduction of the fixpoint: *)
unfold _traverse in h; fold _traverse in h;
(* we now have a term of the form [TApp (traverse_term ...) ...]. There remains to recognize the definition of [lift]. *)
plus_0_r_in h; (* useful when we have traversed a binder: 1 + 0 is 1 *)
(* use [recognize_lift] at the specific type of the [_traverse] function that we have just simplified *)
match type of _traverse with (nat -> nat -> ?V) -> nat -> ?T -> ?T =>
repeat rewrite (@recognize_lift V _ T _ _)  in h by eauto with typeclass_instances
end;
repeat rewrite plus_0_l in h (* useful when [k1] is zero and we are at a leaf *)
end.
(* This tactic attempts to all occurrences of [lift] in the goal. *)
Ltac simpl_lift_goal :=
(* this replaces [lift] with applications of [traverse] *)
repeat rewrite @expand_lift;
(* this replaces the generic [traverse] with the user's [_traverse] functions *)
simpl (@traverse _ _ _);
(* this simplifies applications of each [_traverse] function and folds them back *)
repeat simpl_lift;
(* if we have exposed applications of [lift_idx], try simplifying them away *)
repeat lift_idx;
(* if this exposes uses of [var], replace them with the user's [TVar] constructor *)
simpl var.
Hint Extern 1 (lift _ _ _ = _) => simpl_lift_goal : simpl_lift_goal.
Hint Extern 1 (_ = lift _ _ _) => simpl_lift_goal : simpl_lift_goal.
(* This tactic attempts to simplify all occurrences of [lift] in the goal and the hypotheses. *)
Ltac simpl_lift_all :=
repeat rewrite @expand_lift in *;
simpl (@traverse _ _ _) in *;
repeat simpl_lift;
repeat lift_idx_all;
simpl var in *.
(* This tactic attempts to simplify all occurrences of [lift] in a specific hypothesis. *)
Ltac simpl_lift_in h :=
repeat rewrite @expand_lift in h;
simpl (@traverse _ _ _) in h;
repeat simpl_lift;
repeat lift_idx_in h;
simpl var in h.
(* ---------------------------------------------------------------------------- *)
(* Our definition of [lift] in terms of [traverse] satisfies all of the desired properties. *)
Instance LiftVar_Traverse:
forall `{Var V, Traverse V V},
TraverseIdentifiesVar ->
@LiftVar V _ _.
Instance LiftZero_Traverse:
forall `{Var V, Traverse V V},
TraverseVarIsIdentity ->
@LiftZero V _.
Instance LiftInjective_Traverse:
forall `{Var V, Traverse V T},
TraverseVarInjective ->
@LiftInjective T _.
Instance LiftLift_Traverse:
forall `{Var V, Traverse V V, Traverse V T},
@TraverseFunctorial V _ T _ ->
@TraverseRelative V T _ -> (* TraverseExtensional *)
@TraverseIdentifiesVar V _ _ ->
@LiftLift T _.
Instance LiftLiftFuse_Traverse:
forall `{Var V, Traverse V V, Traverse V T},
@TraverseFunctorial V _ T _ ->
@TraverseRelative V T _ -> (* TraverseExtensional *)
@TraverseIdentifiesVar V _ _ ->
@LiftLiftFuse T _.
(* ---------------------------------------------------------------------------- *)
(* This is our generic definition of [subst] in terms of [traverse]. *)
Instance Subst_Traverse `{Var V, Traverse V V, Traverse V T} : Subst V T := {
subst v k t :=
traverse (fun l x => subst_idx (lift l 0 v) (l + k) x) 0 t
}.
(* This lemma repeats the definition (!) and is useful when rewriting. *)

(* Specifications: *)
Lemma expand_subst:
forall `{Var V, Traverse V V, Traverse V T},
forall v k t,
subst v k t =
traverse (fun l x => subst_idx (lift l 0 v) (l + k) x) 0 t.