(* This auxiliary tactic simplifies expressions of the form [x + 0] in
   the goal. It does *not* affect [x + ?y] where [y] is a
   meta-variable. *)

Ltac plus_0_r :=
  repeat match goal with |- context[?x + 0] => rewrite (plus_0_r x) end.Ltac plus_0_r_in h :=
  repeat match type of h with context[?x + 0] => rewrite (plus_0_r x) in h end.(* 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.(* 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
}.

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.