(* This tactic recognizes an application of the user's [traverse_term]
   function that is really a [subst] operation, and folds it. *)

Ltac recognize_subst :=
  rewrite recognize_subst by eauto with typeclass_instances;
  try rewrite lift_zero; (* useful when [k1] is zero *)
  repeat rewrite plus_0_l.(* useful when [k1] is zero *)

Ltac recognize_subst_in h :=
  rewrite recognize_subst in h by eauto with typeclass_instances;
  try rewrite lift_zero in h; (* useful when [k1] is zero *)
  repeat rewrite plus_0_l in h.(* useful when [k1] is zero *)

(* This tactic is used to simplify an application of [subst] to a concrete
   term, such as [TApp t1 t2], where [TApp] is a user-defined constructor of
   the user-defined type of [term]s. We assume that the user has manually
   rewritten one occurrence of [subst] using the lemma [expand_subst], so as to
   indicate where simplification is desired. Thus, one instance of [traverse]
   must be visible in a hypothesis or in the goal. We start there and do the
   rest of the work. *)

Ltac simpl_subst :=
  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 => subst_idx (lift l 0 ?v) (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 ...) (traverse_term ...)].
       There remains to recognize the definition of [subst]. *)
    plus_0_r; (* useful when we have traversed a binder: 1 + 0 is 1 *)
    (* use [recognize_subst] 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_subst V _ _ T _ _ _ _ _) by eauto with typeclass_instances
    end;
    repeat rewrite plus_0_l; (* useful when [k1] is zero and we are at a leaf *)
    repeat rewrite lift_zero (* 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 => subst_idx (lift l 0 ?v) (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 ...) (traverse_term ...)].
       There remains to recognize the definition of [subst]. *)
    plus_0_r_in h; (* useful when we have traversed a binder: 1 + 0 is 1 *)
    (* use [recognize_subst] 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_subst 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 *)
    repeat rewrite lift_zero in h (* useful when [k1] is zero and we are at a leaf *)
  
  end.(* This tactic attempts to simplify all occurrences of [subst] in the goal. *)

Ltac simpl_subst_goal :=
  (* this replaces [subst] with applications of [traverse] *)
  repeat rewrite @expand_subst;
  (* 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_subst;
  (* if we have exposed applications of [subst_idx], try simplifying them away *)
  repeat subst_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 [subst] in the goal
   and the hypotheses. *)

Ltac simpl_subst_all :=
  repeat rewrite @expand_subst in *;
  simpl (@traverse _ _ _) in *;
  repeat simpl_subst;
  repeat subst_idx_all;
  simpl var in *.(* This tactic attempts to simplify all occurrences of [subst] in a specific
   hypothesis. *)

Ltac simpl_subst_in h :=
  repeat rewrite @expand_subst in h;
  simpl (@traverse _ _ _) in h;
  repeat simpl_subst;
  repeat subst_idx_in h;
  simpl var in h.(* ---------------------------------------------------------------------------- *)

(* Our definition of [subst] in terms of [traverse] satisfies all of the desired
   properties. *)

Instance SubstVar_Traverse:
  forall `{Var V, Traverse V V},
  TraverseIdentifiesVar ->
  TraverseVarIsIdentity ->
  SubstVar.Instance SubstLift_Traverse:
  forall `{Var V, Traverse V V, Traverse V T},
  @TraverseFunctorial V _ T _ ->
  @TraverseIdentifiesVar V _ _ ->
  @TraverseVarIsIdentity V _ T _ ->
  @SubstLift T _ V _.Instance LiftSubst1_Traverse:
  forall `{Var V, Traverse V V, Traverse V T},
  @TraverseRelative V V _ ->
  @TraverseRelative V T _ -> (* TraverseExtensional *)
  @TraverseFunctorial V _ V _ ->
  @TraverseFunctorial V _ T _ ->
  @TraverseIdentifiesVar V _ _ ->
  @LiftSubst1 V _ T _ _.Instance LiftSubst2_Traverse:
  forall `{Var V, Traverse V V, Traverse V T},
  @TraverseRelative V V _ ->
  @TraverseRelative V T _ -> (* TraverseExtensional *)
  @TraverseFunctorial V _ V _ ->
  @TraverseFunctorial V _ T _ ->
  @TraverseIdentifiesVar V _ _ ->
  @LiftSubst2 V _ T _ _.(* [LiftSubst1] and [LiftSubst2] imply [LiftSubst]. No surprise, since the
   latter law is just a combination of the former two. *)

Instance LiftSubst_LiftSubst12 `{Lift V, Lift T, Subst V T} :
  LiftSubst1 ->
  LiftSubst2 ->
  LiftSubst.Instance SubstSubst_Traverse:
  forall `{Var V, Traverse V V, Traverse V T},
  @TraverseRelative V V _ ->
  @TraverseRelative V T _ -> (* TraverseExtensional *)
  @TraverseIdentifiesVar V _ _ ->
  @TraverseVarIsIdentity V _ V _ ->
  @TraverseFunctorial V _ V _ ->
  @TraverseFunctorial V _ T _ ->
  @SubstSubst V _ _ T _.Instance Pun1_Traverse:
  forall `{Var V, Traverse V V, Traverse V T},
  @TraverseFunctorial V _ T _ ->
  @TraverseVarIsIdentity V _ T _ ->
  @TraverseIdentifiesVar V _ _ ->
  @Pun1 V _ T _ _.Instance Pun2_Traverse:
  forall `{Var V, Traverse V V, Traverse V T},
  @TraverseFunctorial V _ T _ ->
  @TraverseVarIsIdentity V _ T _ ->
  @TraverseIdentifiesVar V _ _ ->
  @Pun2 V _ T _ _.Instance PunPun_Traverse:
  forall `{Var V, Traverse V V, Traverse V T},
  @TraverseRelative V T _ -> (* TraverseExtensional *)
  @TraverseFunctorial V _ T _ ->
  @TraverseIdentifiesVar V _ _ ->
  @PunPun V _ T _ _.

(* Specifications: *)
Lemma closed_increment: forall `{Lift T}, LiftLift -> forall k t, closed k t -> closed (1 + k) t.
Lemma closed_monotonic: forall `{Lift T}, LiftLift -> forall k t, closed k t -> forall j, j >= k -> closed j t.
Lemma closed_lift_invariant: forall `{Lift T}, forall { _ : LiftZero }, forall { _ : LiftLift }, forall { _ : LiftLiftFuse }, forall k t, closed k t -> forall j, j >= k -> forall w, lift w j t = t.
Lemma closed_subst_invariant: forall `{Lift T, Subst V T}, forall { _ : LiftLift}, forall { _ : SubstLift}, forall k t, closed k t -> forall j, j >= k -> forall v, subst v j t = t.
Lemma closed_var: forall k x : nat, x >= k -> closed k x -> False.
Lemma lift_preserves_closed: forall `{Lift T}, @LiftLift T _ -> forall k (t : T), closed k t -> closed (S k) (shift 0 t).
Lemma subst_preserves_closed: forall `{Lift V, Lift T, Subst V T}, @LiftSubst2 V _ T _ _ -> forall k (v : V) (t : T), closed k v -> closed (S k) t -> closed k (subst v 0 t).
Lemma fold_closed: forall `{Lift T}, forall k t, shift k t = t -> closed k t.