Set Implicit Arguments.

Require Import List.

Require Import eqtype.

Inductive uniq (A : Type) : list A -> Prop :=
| uniq_nil : uniq nil
| uniq_cons : forall x l, ~In x l -> uniq l -> uniq (x :: l).

Lemma filter_uniq (A : Type) (l : list A) (f : A -> bool) :
  uniq l -> uniq (filter f l).
Proof.
  induction l; auto.
  inversion 1; subst. simpl. destruct (f a). constructor; auto.
  intros H4. rewrite filter_In in H4. destruct H4. apply H2; auto.
  apply IHl; auto.
Qed.

Lemma filterEq_notIn (A : eqType) (l : list A) (a : A) :
  ~In a l ->
  filter (fun a' => negb (a == a')) l = l.
Proof.
  induction l; auto. simpl. destruct (eqP a a0); simpl.
  { subst a0. intros Contra. elimtype False. apply Contra. left; auto.
  }
  intros Contra. f_equal. rewrite IHl; auto.
Qed.

Lemma length_filterEq_uniq (A : eqType) (l : list A) (a : A) :
  uniq l ->
  In a l ->
  S (length (filter (fun a' => negb (a == a')) l)) = length l.
Proof.
  induction 1. inversion 1. inversion 1; subst; simpl.
  { destruct (eqP a a); simpl. rewrite filterEq_notIn; auto.
    elimtype False; apply n; auto.
  }
  destruct (eqP a x); simpl. subst x. contradiction.
  f_equal. apply IHuniq; auto.
Qed.

Module FinType.
  Record mixin_of (T : Type) :=
    Mixin { mx_enum : list T
          ; _ : forall t : T, In t mx_enum
          ; _ : uniq mx_enum
          }.

  Section classDef.
    Record class_of (T : Type) :=
      Class { base : EqType.class_of T
            ; mixin : mixin_of T
            }.

    Structure type : Type := Pack { sort; _ : class_of sort; _ : Type}.
    Local Coercion sort : type >-> Sortclass.

    Variable (T : Type) (cT : type).

    Definition class : class_of cT :=
      match cT as cT' return class_of cT' with
        | @Pack _ c _ => c
      end.

    Definition clone (c : class_of T) (ph : phant_id class c) := @Pack T c T.

    Definition pack (m0 : mixin_of T) :=
      fun bT b (_ : phant_id (EqType.class bT) b) =>
        fun m (_ : phant_id m0 m) => Pack (@Class T b m) T.

    Definition enum := mx_enum (mixin class).
  End classDef.

  Module Exports.
    Coercion sort : type >-> Sortclass.

    Definition eqType_of (fT : type) : eqType := EqType.Pack (base (class fT)) fT.
    Canonical Structure eqType_of.

    Notation finType := FinType.type.
    Notation finTypeMixin := FinType.Mixin.
    Notation FinType T m := (@pack T _ _ _ id m id).

    Notation "[ 'finType' 'of' T 'for' cT ]" := (@clone T cT _ id)
      (at level 0, format "[ 'finType'  'of'  T  'for'  cT ]").
    Notation "[ 'finType' 'of' T ]" := (@clone T _ _ id)
      (at level 0, format "[ 'finType'  'of'  T ]").

    Definition enum := enum.

    Section laws.
      Context {T : finType}.

      Lemma enumP : forall t : T, In t (@enum T).
      Proof. destruct T; destruct c; destruct mixin0; auto. Qed.

      Lemma uniqP : uniq (@enum T).
      Proof. destruct T; destruct c; destruct mixin0; auto. Qed.
    End laws.

    Arguments enum [cT].
  End Exports.
End FinType.

Export FinType.Exports.

(* The cardinality of a finType *)

Definition card (A : finType) := length (enum (cT:=A)).

Inductive bij {A B : eqType} : list A -> list B -> Prop :=
| bij_nil : bij nil nil
| bij_cons : forall a b l1 l2,
               uniq (a :: l1) ->
               uniq l2 ->
               In b l2 ->
               bij l1 (filter (fun b' => negb (b == b')) l2) ->
               bij (a :: l1) l2.

Lemma bijP (A B : finType) (f : A -> B) :
  (forall b, exists a, f a = b) ->
  (forall a1 a2, f a1 = f a2 -> a1 = a2) ->
  bij (enum (cT:=A)) (enum (cT:=B)).
Proof.
  intros H H2.
  generalize (uniqP (T:=A)). intros H3.
  generalize (uniqP (T:=B)). intros H4.
  generalize (enumP (T:=A)). intros H5.
  generalize (enumP (T:=B)). intros H6.
  revert H4. induction H3.
Abort.  (* TODO *)

Lemma bij_card (A B : finType) :
  bij (enum (cT:=A)) (enum (cT:=B)) ->
  card A = card B.
Proof.
  intros H; unfold card. induction H; auto.
  simpl. rewrite IHbij. rewrite length_filterEq_uniq; auto.
Qed.

(* finType unit *)

Program Definition finType_unit_mixin := @finTypeMixin _ (tt::nil) _ _.
Next Obligation.
  destruct t; left; auto.
Qed.
Next Obligation.
  constructor; auto.
  constructor.
Qed.

Definition finType_unit : finType :=
  Eval hnf in FinType unit finType_unit_mixin.

Canonical Structure finType_unit.

Lemma card_unit : card [finType of unit] = 1.
Proof.
  unfold card; auto.
Qed.

(* finType bool *)

Program Definition finType_bool_mixin := @finTypeMixin _ (false::true::nil) _ _.
Next Obligation.
  destruct t.
  right; left; auto.
  left; auto.
Qed.
Next Obligation.
  constructor; auto.
  intros H; inversion H; try congruence. inversion H0.
  constructor; auto.
  constructor.
Qed.

Definition finType_bool : finType :=
  Eval hnf in FinType bool finType_bool_mixin.

Canonical Structure finType_bool.

Lemma card_bool : card [finType of bool] = 2.
Proof.
  unfold card.
  unfold enum.
  simpl; auto.
Qed.

(* finType prod *)

Fixpoint all_pairs_aux (A B : Type) (x : A) (l2 : list B) : list (A*B) :=
  match l2 with
    | nil => nil
    | y :: l2' => (x,y) :: all_pairs_aux x l2'
  end.

Lemma all_pairs_auxP (A B : Type) (x : A) (l2 : list B) (b : B) :
  In b l2 ->
  In (x,b) (all_pairs_aux x l2).
Proof.
  induction l2; auto; simpl; inversion 1; subst; auto.
Qed.

Fixpoint all_pairs (A B : Type) (l1 : list A) (l2 : list B) : list (A*B) :=
  match l1 with
    | nil => nil
    | x :: l1' => all_pairs_aux x l2 ++ all_pairs l1' l2
  end.

Lemma all_pairsP (A B : Type) (l1 : list A) (l2 : list B) (a : A) (b : B) :
  In a l1 ->
  In b l2 ->
  In (a,b) (all_pairs l1 l2).
Proof.
  induction l1; auto; inversion 1; subst.
  { intros H2; simpl; rewrite in_app_iff; left.
    apply all_pairs_auxP; auto.
  }
  intros H1; simpl; rewrite in_app_iff; right.
  apply IHl1; auto.
Qed.

Fixpoint remove_dups {A : Type} {B : eqType} (f : A -> B) (l : list A) :=
  match l with
    | nil => nil
    | x :: l' => x :: filter (fun y => negb (f x == f y)) (remove_dups f l')
  end.

Lemma remove_dupsP (A : eqType) (l : list A) x :
  In x l ->
  In x (remove_dups id l).
Proof.
  induction l; auto; destruct (eqP x a).
  { subst x; intros H; simpl. left; auto.
  }
  inversion 1; subst. elimtype False; auto.
  simpl. right. rewrite filter_In. split; auto.
  unfold id. destruct (eqP a x); auto.
Qed.

Lemma remove_dups_uniq (A : eqType) (l : list A) : uniq (remove_dups id l).
Proof.
  induction l.
  { simpl; constructor.
  }
  simpl; constructor.
  intros H. rewrite filter_In in H. destruct H. unfold id in H0.
  destruct (eqP a a). simpl in H0. congruence. apply n; auto.
  apply filter_uniq; auto.
Qed.

Program Definition finType_pair_mixin (A B : finType) :=
  @finTypeMixin _ (remove_dups id (all_pairs (A:=A) (B:=B) enum enum)) _ _.
Next Obligation.
  apply remove_dupsP.
  apply all_pairsP.
  apply enumP.
  apply enumP.
Qed.
Next Obligation.
  apply remove_dups_uniq.
Qed.

Definition finType_pair (A B : finType) : finType :=
  Eval hnf in FinType (A*B) (finType_pair_mixin A B).

Canonical Structure finType_pair.

(* eqTypes lift through arrow. We put this instance in fintype.v
   because it depends on [finType]. *)

Require Import FunctionalExtensionality.

Lemma map_enum_eq {A : finType} {B : eqType} (f g : A -> B) :
  map f enum = map g enum <-> f = g.
Proof.
  generalize (enumP (T:=A)).
  generalize (enum (cT:=A)).
  intros l H. split.
  { intros H2.
    extensionality x.
    specialize (H x).
    induction l. inversion H.
    inversion H.
    { subst. clear H. simpl in H2. inversion H2; auto. }
    simpl in H2. inversion H2. apply IHl; auto.
  }
  intros <-; auto.
Qed.

Program Definition eqType_fun_mixin (A : finType) (B : eqType) :=
  @eqTypeMixin (A -> B) (fun f g => map f enum == map g enum) _.
Next Obligation.
  specialize (map_enum_eq x y).
  generalize (enum (cT:=A)).
  intros l.
  destruct (eqP (map x l) (map y l)).
  { intros; constructor; rewrite <-H; auto.
  }
  intros H; constructor; intros Contra; apply n.
  rewrite H; auto.
Qed.

Definition eqType_fun (A : finType) (B : eqType) : eqType :=
  Eval hnf in EqType (A -> B) (eqType_fun_mixin A B).

Canonical Structure eqType_fun.

(* finTypes lift through arrow.  The construction is, enumerate all
   graphs of A -> B. *)

Definition list_subset (A : Type) (l1 l2 : list A) :=
  forall x, In x l1 -> In x l2.

Lemma list_subset_refl (A : Type) (l : list A) : list_subset l l.
Proof.
  unfold list_subset; intros x; auto.
Qed.

Fixpoint all_subsets {A : Type} (l : list A) : list (list A) :=
  match l with
    | nil => nil::nil
    | x :: l' =>
      let s := all_subsets l'
      in s ++ map (fun l0 => x :: l0) s
  end.

Lemma all_subsets_list_subset A (l : list A) :
  forall l0, In l0 (all_subsets l) -> list_subset l0 l.
Proof.
  induction l.
  { simpl. intros. destruct H. subst l0. apply list_subset_refl.
    destruct H.
  }
  intros l0; simpl; rewrite in_app_iff; intros [H|H].
  { apply IHl in H. intros x H2. right. apply H; auto.
  }
  intros x H2; rewrite in_map_iff in H; destruct H as [l' [H H3]].
  subst l0. inversion H2; subst. left; auto.
  right. apply IHl in H3; apply H3; auto.
Qed.

Fixpoint listrel_in {A : eqType} (B : Type) (l : list (A*B)) (x : A) : bool :=
  match l with
    | nil => false
    | (y,_) :: l' => orb (x == y) (listrel_in l' x)
  end.

Lemma listrel_inP {A : eqType} B (l : list (A*B)) x :
  listrel_in l x = true ->
  sigT (fun y => In (x,y) l).
Proof.
  induction l; simpl.
  { inversion 1.
  }
  destruct a; intros H; destruct (eqP x s); simpl in H.
  { subst s; exists b; left; auto.
  }
  apply IHl in H; destruct H as [y H].
  exists y; right; auto.
Defined.

Definition listrel_total {A : finType} {B : Type} (l : list (A*B)) : bool :=
  forallb (fun x => listrel_in l x) (enum (cT:=A)).

Fixpoint listrel_bind_of_aux {A : eqType} (B : Type) (l : list (A*B)) (x : A) :=
  match l with
    | nil => None
    | (y,b) :: l' => if x == y then Some b else listrel_bind_of_aux l' x
  end.

Lemma listrel_total_bind_of_some {A : finType} (B : Type) (l : list (A*B)) x :
  listrel_total l = true ->
  sigT (fun y => listrel_bind_of_aux l x = Some y).
Proof.
  unfold listrel_total; intros H; rewrite forallb_forall in H.
  specialize (H x (enumP x)); induction l.
  { inversion H.
  }
  simpl in H. destruct a. destruct (eqP x s).
  { subst s. simpl. destruct (eqP x x); auto. exists b; auto.
  }
  simpl in H. apply IHl in H. destruct H as [y H]. exists y.
  simpl. destruct (eqP x s); auto. elimtype False; apply n; auto.
Defined.

Definition fun_of_listrel
           {A : finType} {B : Type}
           (l : list (A*B)) (H : listrel_total l = true) : A -> B :=
  fun a => projT1 (listrel_total_bind_of_some l a H).

Definition all_graphs (A B : finType) :=
  filter listrel_total (all_subsets (enum (cT:=[finType of (A*B)%type]))).

Lemma filter_forallb A (l : list A) (f : A -> bool) :
  forallb f (filter f l) = true.
Proof.
  induction l; auto.
  simpl. destruct (f a) eqn:H. simpl. rewrite H. auto. apply IHl.
Defined.

Lemma all_graphs_total (A B : finType) :
  forallb listrel_total (all_graphs A B) = true.
Proof.
  unfold all_graphs; rewrite filter_forallb; auto.
Defined.

Fixpoint map_filter_aux
        A B (l : list A)
        (f : A -> bool) (g : forall x : A, f x = true -> B)
        (H : forallb f l = true) {struct l} : list B.
  destruct l as [|x l'].
  refine nil.
  simpl in H. rewrite Bool.andb_comm in H. destruct (forallb f l') eqn:H2.
  refine (let l'' := map_filter_aux _ _ l' f g H2 in _).
  rewrite Bool.andb_comm in H. destruct (f x) eqn:H3.
  refine (g x H3 :: l'').
  simpl in H. congruence.
  simpl in H. congruence.
Defined.

Definition map_filter
           A B (l : list A)
           (f : A -> bool) (g : forall x : A, f x = true -> B) : list B :=
  (match filter f l as l' return l' = _ -> _ with
     | l' => fun Heq => map_filter_aux l' f g (filter_forallb _ _)
   end) eq_refl.


(********************************************************************************
* Formalization of lambda ex						        *
*									        *
* Fl\u00e1vio L. C. de Moura & Daniel L. Ventura, & Washington R. Segundo, 2013	*
*********************************************************************************)

Set Implicit Arguments.
Require Import Metatheory LambdaES_Defs LambdaES_Infra LambdaES_FV.
Require Import Rewriting_Defs Rewriting_Lib.
Require Import Equation_C Lambda Lambda_Ex.
Require Import Basic_Prop_lex.
(*Require Import IE_Property.*)

(** Full Composition **)

Lemma full_comp: forall t u, body t -> term u ->
                t[u] -->ex+ (t ^^ u).
Proof.
 intros t u H0. generalize H0.
 apply body_size_induction with (t := t); simpl; trivial.
 (* bvar *)
 intros B T.
 unfold open; simpl.
 apply one_step_reduction.
 apply ctx_to_mod_eqC.
 apply redex. apply reg_rule_var; trivial.
 (* fvar *)
 intros x B T.
 unfold open; simpl.
 apply one_step_reduction.
 apply ctx_to_mod_eqC.
 apply redex. apply reg_rule_gc; trivial.
 (* abs *)
 intros t1 B Ht1 H T.
 unfold open in *|-*; simpl.
 apply transitive_reduction with
 (u := pterm_abs ((& t1) [u])).
 apply ctx_to_mod_eqC.
 apply redex. apply reg_rule_lamb; trivial.
 apply in_trans_abs_ex with (L := (fv t1)).
 intros x Fr. unfold open; simpl.
 replace ({0 ~> pterm_fvar x}u) with u.
 rewrite subst_com  with (i := 0) (j := 1) (u := pterm_fvar x) (v := u) (t := t1); trivial.
 rewrite open_bswap; trivial.
 apply Ht1 with (t2 := & t1) (x := x); trivial.
 unfold bswap; rewrite fv_bswap_rec with (n := 0); trivial.
 rewrite size_bswap_rec with (n := 0); trivial.
 rewrite body_eq_body'; apply lc_at_open; trivial. apply lc_at_bswap; try omega; trivial.
 rewrite body_eq_body'; apply lc_at_open; trivial. apply lc_at_bswap; try omega; trivial.
 apply open_rec_term  with (k := 0) (t := u) (u := pterm_fvar x); trivial.
 (* app *)
 intros t1 t2 B1 B2 IHt1 IHt2 H T.
 apply body_distribute_over_application in H.
 case H; clear H; intros Ht1 Ht2.
 apply transitive_reduction with (u := pterm_app (t1[u]) (t2[u])).
 apply ctx_to_mod_eqC. apply redex. apply reg_rule_app; trivial.
 apply transitive_closure_composition with (u := pterm_app ({0 ~> u}t1) (t2[u])).
 apply left_trans_app_ex.
 apply body_to_subs; trivial. apply IHt1; trivial. unfold open; simpl.
 apply right_trans_app_ex.
 apply body_open_term; trivial. apply IHt2; trivial.
 (* sub *)
 intros t1 t2 B1 B2 IHt2 IHt1 H T.
 unfold open in *|-*. simpl.
 case var_fresh with (L := fv t2).
 intros y Fr. case fv_in_or_notin with (t := t2 ^ y) (x := y).
   (* y \in fv (t2 ^ t) *)
   intro Hy.
   apply transitive_reduction with (u := (& t1)[u][ t2[ u ] ]).
   apply ctx_to_mod_eqC. apply redex.
   apply reg_rule_comp; trivial. intro T'.
   apply term_eq_term' in T'. unfold term' in T'.
   generalize T'; clear T'.
   apply not_body_term_fvar with (x := y); trivial.
   rewrite body_eq_body' in B2. unfold body' in B2. trivial.
   apply transitive_closure_composition with (u := (& t1 [u]) [{0 ~> u}t2]).
   apply right_trans_subst_ex.
   rewrite body_eq_body'. unfold body'.
   simpl. apply term_is_a_body in T.
   rewrite body_eq_body' in H. unfold body' in H.
   simpl in H. split. unfold bswap.
   apply lc_at_bswap; try omega. apply H.
   rewrite <- body_eq_body'; trivial.
   apply IHt2; trivial.
   apply left_trans_subst_ex with (L:= fv (& t1)).
   apply body_open_term; trivial.
   intros x Fr'. unfold open. simpl.
   replace ({0 ~> pterm_fvar x}u) with u.
   rewrite subst_com with (i := 0) (j := 1) (u := pterm_fvar x) (v := u) (t := t1); trivial.
   rewrite open_bswap; trivial.
   rewrite body_eq_body' in H. unfold body' in H. simpl in H.
   apply IHt1 with (t2 := & t1) (x := x); trivial.
   rewrite size_bswap_rec with (n := 0); trivial.
   unfold bswap. rewrite body_eq_body'. unfold body'.
   apply lc_at_open; trivial. apply lc_at_bswap; try omega; trivial.
   unfold bswap. rewrite body_eq_body'. unfold body'.
   apply lc_at_open; trivial. apply lc_at_bswap; try omega; trivial.
   apply open_rec_term  with (k := 0) (t := u) (u := pterm_fvar x); trivial.
   (* y \notin fv (t2 ^ t) *)
   intro Hy. assert (T' : term t2).
   rewrite term_eq_term'. unfold term'.
   apply body_term_fvar with (x := y); trivial.
   rewrite body_eq_body' in B2. unfold body' in B2. trivial.
   replace ({0 ~> u}t2) with t2.
   (**)
   rewrite eqC_redex; trivial.
   (**)
   apply left_trans_subst_ex with (L:= fv (& t1)); trivial.
   intros x Fr'. unfold open. simpl.
   replace ({0 ~> pterm_fvar x}u) with u.
   rewrite subst_com with (i := 0) (j := 1) (u := pterm_fvar x) (v := u) (t := t1); trivial.
   rewrite open_bswap; trivial.
   rewrite body_eq_body' in H. unfold body' in H. simpl in H.
   apply IHt1 with (t2 := & t1) (x := x); trivial.
   rewrite size_bswap_rec with (n := 0); trivial.
   unfold bswap. rewrite body_eq_body'. unfold body'.
   apply lc_at_open; trivial. apply lc_at_bswap; try omega; trivial.
   unfold bswap. rewrite body_eq_body'. unfold body'.
   apply lc_at_open; trivial. apply lc_at_bswap; try omega; trivial.
   apply open_rec_term  with (k := 0) (t := u) (u := pterm_fvar x); trivial.
   apply open_rec_term with (k := 0) (t := t2) (u := u); trivial.
Qed.

(** Simulating One-Step Beta-Reduction **)

Lemma sim_beta_reduction : forall t t', t -->Beta t' -> t -->lex* t'.
Proof.
 intros t t' H. induction H.
 destruct H. apply star_trans_reduction.
 apply transitive_reduction with (u := t[u]).
 apply ctx_to_mod_eqC.
 apply redex. apply B_lx. apply reg_rule_b; trivial.
 apply Lbody_is_body; trivial. apply Lterm_is_term; trivial.
 apply trs_ex_to_lex.
 apply full_comp; trivial.
 apply Lbody_is_body; trivial. apply Lterm_is_term; trivial.
 apply left_star_app_lex; trivial. apply Lterm_is_term; trivial.
 apply right_star_app_lex; trivial. apply Lterm_is_term; trivial.
 apply in_star_abs_lex with (L := L); trivial.
Qed.

(** Perpetuality **)

Inductive many_step : pterm -> pterm -> Prop :=

  | p_var : forall (x : var) (t t' : pterm) (lu lv : list pterm),

               ((NF lex) %% lu) -> many_step t t' ->
(*-------------------------------------------------------------------------*)
    many_step ((pterm_app ((pterm_fvar x) // lu) t) // lv) ((pterm_app ((pterm_fvar x) // lu) t') // lv)

  | p_abs : forall L (t t' : pterm),

            (forall x, x \notin L ->  many_step (t ^ x) (t' ^ x)) ->
(*-------------------------------------------------------------------------*)
                    many_step (pterm_abs t) (pterm_abs t')

  | p_B : forall  (t u : pterm) (lu : list pterm),
(*-------------------------------------------------------------------------*)
           many_step ((pterm_app (pterm_abs t) u) // lu) (t[u] // lu)

  | p_subst1 : forall (t u : pterm) (lu : list pterm),

                              SN lex u ->
(*-------------------------------------------------------------------------*)
                 many_step (t[u] // lu) ((t ^^ u) // lu)

  | p_subst2 : forall  (t u u' : pterm) (lu : list pterm),

                   (~ SN lex u) -> many_step u u' ->
(*-------------------------------------------------------------------------*)
                 many_step (t[u] // lu) (t[u'] // lu) .

Notation "t ~> t'" := (many_step t t') (at level 66).

Lemma perp_proposition : forall t t', term t -> (t ~> t') -> (t -->lex+ t').
Proof.
 intros t t' T H. generalize T. clear T. induction H; simpl; intro T.
 apply term_mult_app in T. destruct T.
 apply term_distribute_over_application in H1. destruct H1.
 apply left_trans_m_app_lex; trivial.
 apply right_trans_app_lex; trivial.
 apply IHmany_step; trivial.
 apply in_trans_abs_lex with (L := L \u (fv t)).
 intros x Fr. apply notin_union in Fr. destruct Fr. apply H0; trivial.
 apply body_to_term; trivial. apply term_abs_to_body; trivial.
 apply term_mult_app in T. destruct T.
 apply term_distribute_over_application in H. destruct H.
 apply left_trans_m_app_lex; trivial.
 apply one_step_reduction. apply ctx_to_mod_eqC. apply redex. apply B_lx.
 apply reg_rule_b; trivial. apply term_abs_to_body; trivial.
 apply term_mult_app in T. destruct T. apply subs_to_body in H0. destruct H0.
 apply left_trans_m_app_lex; trivial.
 apply trs_ex_to_lex. apply full_comp; trivial.
 apply term_mult_app in T. destruct T. apply subs_to_body in H1. destruct H1.
 apply left_trans_m_app_lex; trivial.
 apply right_trans_subst_lex; trivial.
 apply IHmany_step; trivial.
Qed.

(** The determinism of the many step strategy **)

Lemma det_many_step : forall t u v, term t -> ((t ~> u) /\ (t ~> v) -> u = v).
Proof.
 intros t u v T H. destruct H. generalize v H0; clear v H0.
 induction H; intros.

 inversion H1.
 assert (T' : term (pterm_app (pterm_fvar x0 // lu0) t0 // lv0)).
  rewrite H2. trivial.
 apply term_mult_app in T. apply term_mult_app in T'.
 destruct T. destruct T'. inversion H6. inversion H8.
 apply term_mult_app in H12. apply term_mult_app in H16.
 clear t1 t2 t3 t4 H1 H5 H6 H8 H10 H11 H14 H15.
 destruct H12. destruct H16. clear H1 H6.
 rewrite mult_app_append' in H2. rewrite mult_app_append' in H2.
 apply mult_app_var_inj in H2. destruct H2. rewrite H1.
 rewrite mult_app_append'. rewrite mult_app_append'.
 fequals. clear x x0 v H1. generalize H0 H4. intros H0' H4'.
 apply perp_proposition in H0'; trivial.
 apply perp_proposition in H4'; trivial.
 apply P_eq_app_list with (P := NF lex) in H2; trivial.
 destruct H2. destruct H2. rewrite H1. rewrite H6.
 rewrite IHmany_step with (v := t'0); trivial. rewrite <- H2; trivial.
 intro. unfold NF in H1. destruct H4'; apply H1 with (t' := u); trivial.
 intro. unfold NF in H1. destruct H0'; apply H1 with (t' := u); trivial.

 rewrite mult_app_append' in H2. apply False_ind.
 replace (pterm_abs t0) with (pterm_abs t0 // nil) in H2.
 symmetry in H2. generalize H2.
 apply mult_app_diff_var_abs. simpl; trivial.
 rewrite mult_app_append in H3. rewrite mult_app_append' in H3.
 symmetry in H3. apply False_ind. generalize H3.
 apply mult_app_diff_var_abs.
 rewrite mult_app_append' in H2. symmetry in H2. apply False_ind.
 generalize H2. apply mult_app_diff_var_sub.
 rewrite mult_app_append' in H2. symmetry in H2. apply False_ind.
 generalize H2. apply mult_app_diff_var_sub.

 inversion H1.
 rewrite mult_app_append' in H2. apply False_ind.
 replace (pterm_abs t) with (pterm_abs t // nil) in H2.
 generalize H2. apply mult_app_diff_var_abs. simpl; trivial.
 pick_fresh z. apply notin_union in Fr. destruct Fr.
 apply notin_union in H5. destruct H5.
 apply notin_union in H5. destruct H5.
 apply notin_union in H5. destruct H5.
 apply notin_union in H5. destruct H5.
 apply notin_union in H5. destruct H5.
 assert (Q :  t' ^ z = t'0 ^ z). apply H0; trivial.
 apply body_to_term; trivial. apply term_abs_to_body; trivial.
 apply H3; trivial.  apply open_var_inj with (x := z) in Q; trivial.
 rewrite Q; trivial. rewrite mult_app_append in H3.
 replace (pterm_abs t) with (pterm_abs t // nil) in H3.
 apply mult_app_abs_inj in H3. destruct H3. destruct lu; simpl in H4;
 inversion H4. simpl; trivial.
 replace (pterm_abs t) with (pterm_abs t // nil) in H2. apply False_ind.
 symmetry in H2. generalize H2. apply mult_app_diff_abs_sub. simpl; trivial.
 replace (pterm_abs t) with (pterm_abs t // nil) in H2. apply False_ind.
 symmetry in H2. generalize H2. apply mult_app_diff_abs_sub. simpl; trivial.

 inversion H0.
 rewrite mult_app_append' in H. rewrite mult_app_append in H.
 apply False_ind. generalize H. apply mult_app_diff_var_abs.
 rewrite mult_app_append in H. replace (pterm_abs t0) with (pterm_abs t0 // nil) in H.
 apply mult_app_abs_inj in H. destruct H. destruct lu.
 simpl in H3. inversion H3. simpl in H3. inversion H3. simpl. trivial.
 rewrite mult_app_append in H1. rewrite mult_app_append in H1.
 apply mult_app_abs_inj in H1. destruct H1. apply app_inj_tail in H1.
 destruct H1. rewrite H. rewrite H1. rewrite H3. trivial.
 rewrite mult_app_append in H. symmetry in H. apply False_ind.
 generalize H. apply mult_app_diff_abs_sub.
 rewrite mult_app_append in H. symmetry in H. apply False_ind.
 generalize H. apply mult_app_diff_abs_sub.

 inversion H0.
 rewrite mult_app_append' in H1. apply False_ind.
 generalize H1. apply mult_app_diff_var_sub.
 replace (pterm_abs t0) with (pterm_abs t0 // nil) in H1.
 apply False_ind. generalize H1. apply mult_app_diff_abs_sub. simpl. trivial.
 rewrite mult_app_append in H2. apply False_ind.
 generalize H2. apply mult_app_diff_abs_sub.
 apply mult_app_sub_inj in H1. destruct H1. destruct H4.
 rewrite H1. rewrite H4. rewrite H5. trivial.
 apply mult_app_sub_inj in H1. destruct H1. destruct H5.
 rewrite H5 in H2. contradiction.

 inversion H1.
 rewrite mult_app_append' in H2. apply False_ind.
 generalize H2. apply mult_app_diff_var_sub.
 replace (pterm_abs t0) with (pterm_abs t0 // nil) in H2. apply False_ind.
 generalize H2. apply mult_app_diff_abs_sub. simpl; trivial.
 rewrite mult_app_append in H3. apply False_ind.
 generalize H3. apply mult_app_diff_abs_sub.
 apply mult_app_sub_inj in H2. destruct H2. destruct H5.
 rewrite H5 in H3. contradiction.
 apply mult_app_sub_inj in H2. destruct H2. destruct H6.
 rewrite H2. rewrite H7. rewrite IHmany_step with (v := u'0); trivial.
 apply term_mult_app in T. destruct T. inversion H8; trivial.
 rewrite <- H6; trivial.
Qed.

Theorem perpetuality : forall t t', term t -> (t ~> t') -> SN lex t' -> SN lex t.
Proof.
 intros t t' T H. induction H.

 (* p-var *)
 apply term_mult_app in T. destruct T.
 apply term_distribute_over_application in H1. destruct H1.
 apply term_mult_app in H1. destruct H1. clear H1. intro H1.
 assert (Q : SN lex t).
  apply IHmany_step; trivial. case H1; clear H1. intros n H1.
  exists n. generalize H1; clear H1.
  generalize t'. clear H0 H3 IHmany_step t t'. induction n.
  intros t' H3. apply NF_to_SN0. unfold NF.
  intros t0 H1. apply SN0_to_NF in H3. unfold NF in H3.
  apply H3 with (t'0 := (pterm_app (pterm_fvar x // lu) t0 // lv)).
  apply left_m_app_lex; trivial. apply right_app_lex; trivial.
  apply term_mult_app; split; trivial.
  intros t' H'. apply SN_intro. intros t'' H''. exists n; split; try omega.
  apply IHn. inversion H'. case (H0 (pterm_app (pterm_fvar x // lu) t'' // lv)).
  apply left_m_app_lex; trivial. apply right_app_lex; trivial.
  apply term_mult_app; split; trivial. intros k Hk. destruct Hk.
  apply WSN with (k := k); try omega; trivial.
 clear IHmany_step.
 assert (Q' : SN lex %% lv).
  apply perp_proposition in H0; trivial.
  assert (Q'' : term t').
   apply transitive_star_derivation' in H0.
   case H0; clear H0. intro H0. apply ctx_sys_Bex_regular in H0. apply H0.
   intro H0. case H0; clear H0. intros u H0. destruct H0. case H5; clear H5.
   intros u' H5. destruct H5. apply ctx_sys_Bex_regular in H6. apply H6.
  case H1; clear H1; intros n H1. rewrite SN_list. exists n.
  apply eqC_SN_app_list in H1. apply H1. apply sys_Bx_regular.
  apply term_distribute_over_application. split; trivial. rewrite term_mult_app.
  split; trivial. trivial.
 clear H0 H1. replace (pterm_app (pterm_fvar x // lu) t // lv) with ((pterm_fvar x) // (lv ++ t :: lu)).
 apply SN_mult_app_var. clear H Q Q' t'. induction lv; simpl.
 split; trivial. simpl in H2. destruct H2. split; trivial. apply IHlv; trivial. induction lv; simpl.
 split; trivial. rewrite SN_list. exists 0. rewrite <- NF_eq_SN0_list; trivial. simpl in Q'. destruct Q'.
 split; trivial. simpl in H2. destruct H2. apply IHlv; trivial. induction lv; simpl; trivial.
 simpl in H2. simpl in Q'. destruct H2. destruct Q'. rewrite IHlv; trivial.

 (* p_abs *)
 intro H'.
 assert (Q : red_regular sys_Bx); try apply sys_Bx_regular.
 assert (Q' : red_out sys_Bx); try apply sys_Bx_red_out.
 case var_fresh with (L := L \u (fv t) \u (fv t')).
 intros x Fr. apply notin_union in Fr. destruct Fr. apply notin_union in H1. destruct H1.
 apply term_abs_to_body in T. case (H0 x); trivial. apply body_to_term; trivial.
 unfold SN in H'. case H'; clear H'; intros n H'.
 apply eqC_SN_abs with (x := x) in H'; trivial. exists n. apply H'; trivial.
 intros n H4. exists n. apply lex_SN_abs with (L := {{x}} \u (fv t)); trivial.
 intros x' Fr. apply lex_SN_ind_rename with (x := x); trivial.

 (* p_B *)
 intro H. case H; clear H. intros n H. exists (S n).
 rewrite term_mult_app in T. destruct T. rewrite term_distribute_over_application in H0.
 destruct H0. apply term_abs_to_body in H0.
 generalize t u lu H0 H1 H2 H. clear t u lu H0 H1 H2 H. induction n; simpl.
 intros t u lu H H0 H1 H2. apply SN_intro. intros t' H'. exists 0; split; try omega; trivial.
 apply lex_mult_app_B in H'. generalize H2. intro H''. rewrite <- NF_eq_SN0 in H2.
 case H'; clear H'; intro H'. rewrite H'. trivial.
 case H'; clear H'; intro H'; case H'; clear H'.
 intros L H'. case H'; clear H'; intros t0 H'. destruct H'.
 apply False_ind. apply (H2 ((t0 [u]) // lu)).
 apply red_h_mult_app; trivial. apply left_subst_lex with (L := L); trivial.
 intro H'; case H'; clear H'; intros u' H'. destruct H'.
 apply False_ind. apply (H2 ((t [u']) // lu)).
 apply red_h_mult_app; trivial. apply right_subst_lex; trivial.
 intro H'; case H'; clear H'; intros lv' H'. destruct H'.
 apply False_ind. apply (H2 ((t [u]) // lv')).
 apply red_t_mult_app; trivial. apply body_to_subs; trivial.
 intros t u lu H H0 H1 H2. apply SN_intro. intros t' H'. exists (S n); split; try omega.
 generalize H2. intro H3. destruct H3. apply lex_mult_app_B in H'.
 case H'; clear H'; intro H'. rewrite H'. trivial.
 case H'; clear H'; intro H'; case H'; clear H'.
 intros L H'. case H'; clear H'; intros t0 H'. destruct H'.
 rewrite H4. apply IHn; trivial. case var_fresh with (L := fv t0 \u L).
 intros x Fr.  apply notin_union in Fr. destruct Fr.
 assert (Q : t ^ x -->lex t0 ^ x). apply (H5 x); trivial.
 apply ctx_sys_Bex_regular in Q. destruct Q. rewrite term_eq_term' in H9.
 rewrite body_eq_body'. unfold term' in H9. unfold body'. unfold open in H9.
 rewrite lc_at_open with (u := pterm_fvar x); trivial.
 case (H3 ((t0 [u]) // lu)); clear H3. apply red_h_mult_app; trivial.
 apply left_subst_lex with (L := L); trivial. intros k H6.
 destruct H6. apply WSN with (k := k); try omega; trivial.
 intro H'; case H'; clear H'; intros u' H'. destruct H'.
 rewrite H4. apply IHn; trivial.
 apply ctx_sys_Bex_regular in H5. apply H5. case (H3 ((t [u']) // lu)).
 apply red_h_mult_app; trivial. apply right_subst_lex; trivial.
 intros k H6. destruct H6. apply WSN with (k := k); try omega; trivial.
 intro H'; case H'; clear H'; intros lv' H'. destruct H'.
 rewrite H4. apply IHn; trivial. apply lex_R_list_regular in H5; apply H5; trivial.
 case (H3 ((t [u]) // lv')).
 apply red_t_mult_app; trivial. apply body_to_subs; trivial.
 intros k H6. destruct H6. apply WSN with (k := k); try omega; trivial.

 (* p_subst1 *)
 rewrite term_mult_app in T. destruct T. apply subs_to_body in H0. destruct H0.
 apply IE_property; trivial.

 (* p_subst2 *)
 intro H1. rewrite term_mult_app in T. destruct T. apply subs_to_body in H2. destruct H2.
 case H1; clear H1; intros n H1.
 assert (Tu' : term u').
  apply perp_proposition in H0; trivial.
  apply transitive_star_derivation' in H0. case H0; clear H0.
  intro H5. apply ctx_sys_Bex_regular in H5. apply H5.
  intro H5; case H5; clear H5; intros u0 H5. destruct H5.
  case H5; clear H5; intros u1 H5. destruct H5.
  apply ctx_sys_Bex_regular in H6. apply H6.
 apply eqC_SN_app_list in H1; trivial. destruct H1.
 assert (Q : SN_ind n (red_ctx_mod_eqC sys_Bx) u').
  case var_fresh with (L := (fv t)). intros x Fr.
  case (eqC_SN_sub x n sys_Bx t u'); trivial.
  apply sys_Bx_regular. apply sys_Bx_red_out.
 assert (Q' : SN lex u).
  apply IHmany_step; trivial. exists n. apply Q.
 contradiction. apply sys_Bx_regular. apply body_to_subs; trivial.
Qed.

(** Inductive Characterisation of NF lex **)

Lemma NF_ind_eq_lex : forall t, term t -> (NF_ind lex t <-> NF lex t).
Proof.
 split; intros. induction H0.
 apply NF_mult_app_var. apply P_list_eq.
 intros. apply H1; trivial. apply term_mult_app in H.
 destruct H. apply P_list_eq with (P := term) (l := l); trivial.
 unfold NF. intros. intro H2. apply lex_abs in H2.
 case H2; clear H2. intros L' H2. case H2; clear H2. intros t0 H2.
 destruct H2. case var_fresh with (L := L \u L' \u (fv t)).
 intros z Fr. apply notin_union in Fr. destruct Fr.
 apply notin_union in H4. destruct H4.
 unfold NF in H1. apply (H1 z) with (t' := t0 ^ z); trivial.
 apply body_to_term; trivial. apply term_abs_to_body; trivial.
 apply H3; trivial.
 Definition P (t : pterm) := NF lex t -> NF_ind lex t.
 assert (Q : term t ->  P t).
  clear H H0.
(**)
  apply term_size_induction3; unfold P; intros.
(**)
  apply NF_ind_app. intros. apply H; trivial.
  assert (H' : term %% l).
    apply P_list_eq with (P := term) (l := l).
    intros. apply H; trivial.
  clear H.
  induction l. simpl in H1. contradiction.
  simpl in H1. destruct H1. simpl in H0.
  rewrite <- H. clear H. intros a' H.
  apply (H0 (pterm_app (pterm_fvar x // l) a')).
  apply right_app_lex; trivial.
  simpl in H'. destruct H'. apply term_mult_app.
  split; trivial. simpl in *|-*.
  destruct H'. apply IHl; trivial.
  intros u' H'. apply (H0 (pterm_app u' a)).
  apply left_app_lex; trivial.
  case eqdec_nil with (l := l). intro Hl.
  rewrite Hl in *|-*; simpl in *|-*.
  apply NF_ind_abs with (L := fv t1). intros.
  apply H1; trivial. apply body_to_term; trivial.
  intros t' H'. gen_eq t2 : (close t' x).
  intro H''. replace t' with (t2 ^ x) in H'.
  apply (H2 (pterm_abs t2)).
  apply in_abs_lex with (L := (fv t1) \u (fv t2)).
  intros z Hz. apply notin_union in Hz. destruct Hz.
  apply ctx_sys_lex_red_rename with (x := x); trivial.
  rewrite H''. apply fv_close'. rewrite H''.
  rewrite open_close_var with (x := x); trivial.
  apply ctx_sys_Bex_regular in H'. apply H'.
  intro Hl. apply lex_abs_not_NF in H2; trivial.
  contradiction. apply term_mult_app. split.
  apply body_to_term_abs; trivial.
  apply P_list_eq with (P := term).
  intros; apply H; trivial.
  apply False_ind.
  apply lex_sub_not_NF' with (t := t1) (u := t3); trivial.
  intros t' H'. apply (H4 (t' // l)). apply left_m_app_lex; trivial.
  apply P_list_eq with (P := term); intros. apply H; trivial.
  unfold P in Q. apply Q; trivial.
Qed.

(** Inductive Characterisation of SN lex **)

 Inductive ISN : pterm -> Prop :=

  | isn_var : forall (x : var) (lu : list pterm),

                     (forall u, (In u lu) -> ISN u) ->
(*-------------------------------------------------------------------------*)
                         ISN ((pterm_fvar x) // lu)

  | isn_NF : forall (u : pterm),

                                NF lex u ->
(*-------------------------------------------------------------------------*)
                                  ISN u

  | isn_app : forall  (u v : pterm) (lu : list pterm),

                      ISN (u[v] // lu) ->
(*-------------------------------------------------------------------------*)
                      ISN ((pterm_app (pterm_abs u)  v) // lu)

  | isn_subs : forall  (u v : pterm) (lu : list pterm),

                  ISN ((u ^^ v) // lu) -> ISN v ->
(*-------------------------------------------------------------------------*)
                       ISN (u[v] // lu)

  | isn_abs : forall L (u : pterm),

                       (forall x, x \notin L -> ISN (u ^ x)) ->
(*-------------------------------------------------------------------------*)
                           ISN (pterm_abs u) .

Lemma ISN_prop : forall t, term t -> (ISN t <-> SN lex t).
Proof.
 intros t T. split. intro H. induction H.
(* -> *)
 (* isn_var *)
 rewrite term_mult_app in T. destruct T. clear H1.
 assert (Q : SN lex %% lu).
  clear H. induction lu; simpl in *|-*; trivial.
  destruct H2. split. apply H0; trivial. left. trivial.
  apply IHlu; trivial. intros u Hu Tu.
  apply H0; trivial. right; trivial.
 apply SN_mult_app_var; trivial.
 (* isn_NF *)
 exists 0. rewrite <- NF_eq_SN0; trivial.
 (* isn_app *)
 apply perpetuality with (t' := ((u [v]) // lu)); trivial.
 apply p_B. apply IHISN. rewrite term_mult_app in *|-*.
 destruct T. split; trivial. rewrite term_eq_term' in *|-*.
 unfold term' in *|-*. simpl in *|-*. trivial.
 (* isn_subs *)
 generalize T. intro T'. rewrite term_mult_app in T. destruct T.
 apply subs_to_body in H1. destruct H1.
 apply perpetuality with (t' := ((u ^^ v) // lu)); trivial.
 apply p_subst1; trivial. apply IHISN2; trivial. apply IHISN1; trivial.
 rewrite term_mult_app. split; trivial.
 apply body_open_term; trivial.
 (* isn_abs *)
 apply term_abs_to_body in T.
 case var_fresh with (L := L \u fv u). intros x Fr.
 apply notin_union in Fr. destruct Fr.
 case (H0 x); trivial. apply body_to_term; trivial.
 intros n H3. exists n. apply lex_SN_abs with (L := {{x}} \u (fv u)).
 intros x' Fr. apply lex_SN_ind_rename with (x := x); trivial.
(* <- *)
 intro H. unfold SN in H. case H; clear H; intros n H.
 generalize t T H; clear T t H. induction n; intros.
 apply isn_NF. apply SN0_to_NF. trivial.
 generalize H; clear H.
 assert (Reg : red_regular sys_Bx).
  apply  sys_Bx_regular.
 assert (Out : red_out sys_Bx).
  apply  sys_Bx_red_out.
 apply term_size_induction3 with (t := t); intros; trivial.
 (* var *)
 apply isn_var; intros.
 assert (Q : SN_ind (S n) lex  %% l).
    apply eqC_SN_app_list in H0; trivial. apply H0.
    rewrite <- P_list_eq with (P := term).
    intros u' H2. apply H; trivial.
 apply H; trivial. rewrite <- P_list_eq with (P := SN_ind (S n) lex) in Q.
 apply Q; trivial.
 (* abs *)
 case eqdec_nil with (l := l).
 intro H3. rewrite H3 in *|-*. simpl in *|-*. clear H H3.
 apply isn_abs with (L := fv t1). intros x Fr.
 apply H1; trivial. apply body_to_term; trivial.
 apply eqC_SN_abs; trivial.
 intro H3. case not_nil_append with (l := l); trivial.
 intros a Hl. case Hl; clear Hl. intros l' Hl.
 rewrite Hl in *|-*. rewrite <- mult_app_append in *|-*.
 clear H3 Hl.
 assert (Tl : term a /\ term %% l').
   split. apply H. apply in_or_app. right.
   simpl; left; trivial.
   apply P_list_eq with (P := term).
   intros u Hu. apply H. apply in_or_app. left.
   trivial.
 clear H H1. destruct Tl.
 apply isn_app. apply IHn.
 rewrite term_mult_app. split; trivial.
 apply body_to_subs; trivial.
 apply SN_one_step with (t := pterm_app (pterm_abs t1) a // l'); trivial.
 apply left_m_app_lex; trivial. apply ctx_to_mod_eqC. apply redex.
 apply B_lx. apply reg_rule_b; trivial.
 (* subs *)
 assert (Tl : term %% l).
   apply P_list_eq with (P := term).
   intros u Hu. apply H; trivial.
 apply isn_subs.
 apply IHn. apply term_mult_app. split; trivial.
 apply body_open_term; trivial.
 case SN_trs with (n := S n) (R := lex) (t := (t1 [t3]) // l) (u := (t1 ^^ t3) // l); trivial.
 apply left_trans_m_app_lex; trivial.
 apply trs_ex_to_lex. apply full_comp; trivial.
 intros k Hk. destruct Hk. apply WSN with (k := k); try omega; trivial.
 apply eqC_SN_app_list in H4; trivial. destruct H4.
 case var_fresh with (L := (fv t1)). intros x Fr.
 apply eqC_SN_sub with (x := x) in H4; trivial.
 destruct H4.  apply H1; trivial.
 apply body_to_subs; trivial.
Qed.

(** Finally, the PSN of lex-calculus **)

Theorem PSN : forall t, Lterm t -> SN Beta t -> SN lex t.
Proof.
 intros t T H.
 rewrite <- ISN_prop. apply SN_Beta_prop in H; trivial.
 induction H; trivial.
 apply isn_var. intros u Hu. rewrite Lterm_mult_app in T.
 destruct T. apply H0; trivial. clear H1 H H0.
 induction lu; simpl in *|-*. contradiction.
 destruct H2. case Hu. intro H1. rewrite <- H1; trivial.
 intro H1. apply IHlu; trivial.
 inversion T; clear T.
 apply isn_abs with (L := L \u L0 \u fv u). intros x Fr.
 apply notin_union in Fr. destruct Fr.
 apply notin_union in H3. destruct H3.
 apply H0; trivial. apply H2; trivial.
 apply isn_app; trivial.
 rewrite Lterm_mult_app in T. destruct T.
 inversion H1; clear H1.
 inversion H5; clear H5.
 apply isn_subs; trivial.
 apply IHSN_Beta2. rewrite Lterm_mult_app. split; trivial.
 apply Lbody_open_term; trivial.
 unfold Lbody. exists L. apply H7; trivial.
 apply IHSN_Beta1; trivial.
 apply Lterm_is_term; trivial.
Qed.


Set Implicit Arguments.

Require Import Variable_Sets.
Require Import deBruijn_Isomorphism.
Require Import deBruijn_Fsub_Iso.
Require Export dB_Template.

Module Export M_tt := dBTemplate Iso_trm Iso_trm.
Module Export M_yy := dBTemplate Iso_typ Iso_typ.
Module Export M_yt := dBTemplate Iso_typ Iso_trm.
Module Export M_ty := dBTemplate Iso_trm Iso_typ.

Module MT := Iso_trm.
Module MY := Iso_typ.

Notation "[[[ e ]]]" := (M_yt.Tlth e).

  (**************************************************************)
  (** * A tactic unfolding everything *)
  (**************************************************************)

  Ltac gunfold :=
    unfold M_tt.Tshift, M_yt.Tshift, M_yy.Tshift, M_ty.Tshift,
           M_tt.Tsubst, M_yt.Tsubst, M_yy.Tsubst, M_ty.Tsubst in *;
    unfold M_yy.Ysize in *;
    intros;
    repeat rewrite MT.To_From in *;
    repeat rewrite MT.From_To in *;
    repeat rewrite MY.From_To in *;
    repeat rewrite MY.From_To in *;
    simpl in *.

  (**************************************************************)
  (** * Generic lemmas about term shifting and substitution *)
  (**************************************************************)

  Lemma noRepr_Ysubst_Yshift : forall (n : nat) (T T' : MY.TT),
    noRepr MY.RR ->
    T = M_yy.Tsubst (M_yy.Tshift n T) n T'.
  Proof.
    gunfold; rewrite* <- noRepr_subst_shift.
  Qed.

  Lemma noRepr_Yshift_Yshift : forall (n n' : nat) (T : MY.TT),
    noRepr MY.RR ->
    M_yy.Tshift n (M_yy.Tshift (n + n')%nat T)
    = M_yy.Tshift (S (n + n')%nat) (M_yy.Tshift n T).
  Proof.
    gunfold; rewrite* noRepr_shift_shift.
  Qed.

  Lemma noRepr_Yshift_Ysubst_1 : forall (n n' : nat) (T T' : MY.TT),
    noRepr MY.RR ->
    M_yy.Tshift n (M_yy.Tsubst T (n + n')%nat T') =
    M_yy.Tsubst (M_yy.Tshift n T) (1 + n + n')%nat (M_yy.Tshift n T').
  Proof.
    gunfold; rewrite* noRepr_shift_subst_1.
  Qed.

  Lemma noRepr_Yshift_Ysubst_2 : forall (n n' : nat) (T T' : MY.TT),
    noRepr MY.RR ->
    (M_yy.Tshift (n + n')%nat (M_yy.Tsubst T n T')) =
    (M_yy.Tsubst (M_yy.Tshift (1 + n + n')%nat T) n (M_yy.Tshift (n + n')%nat T')).
  Proof.
    gunfold; rewrite* noRepr_shift_subst_2.
  Qed.

  Lemma noRepr_Ysubst_Ysubst : forall (n n' : nat) (T U V : MY.TT),
    noRepr MY.RR ->
    (M_yy.Tsubst (M_yy.Tsubst T n U) (n + n')%nat V) =
    (M_yy.Tsubst (M_yy.Tsubst T (1 + n + n')%nat
      (M_yy.Tshift n V)) n (M_yy.Tsubst U (n + n')%nat V)).
  Proof.
    gunfold; rewrite* noRepr_subst_subst.
  Qed.

  Lemma noRepr_Yshift_preserves_Ysize : forall (T : MY.TT) (X : nat),
    noRepr MY.RR ->
    M_yy.Ysize (M_yy.Tshift X T) = M_yy.Ysize T.
  Proof.
    gunfold; rewrite* noRepr_shift_preserves_size.
  Qed.

  Fixpoint Tget_left (e: M_yt.TEnv) (X:atom) {struct e} : option MY.TT :=
    match e with
      | nil   => None
      | (inr T) :: e' => Tget_left e' X
      | (inl T) :: e' =>
        opt_map (M_yy.Tshift 0)
        (match X with
           | O    => Some T
           | S X' => Tget_left e' X'
         end)
    end.

  Fixpoint Tget_right (e: M_yt.TEnv) (x:atom) {struct e} : option MY.TT :=
  match e with
    nil       => None
  | ((inl _)::e') => opt_map (M_yy.Tshift 0) (Tget_right e' x)
  | ((inr T)::e') =>
      match x with
      | O    => Some T
      | S x' => Tget_right e' x'
      end
  end.

  Lemma Tget_left_gTget_left : forall (e: M_yt.TEnv) (X:atom),
    Tget_left e X = M_yt.gTget_left e X.
  Proof.
    unfold M_yt.gTget_left.
    intro e.
    induction e; simpl; auto.
    destruct a; auto.
    destruct X; simpl; f_equal.
    rewrite (IHe X); simpl.
    destruct (get_left (M_yt.From_TEnv e) X); simpl; f_equal.
    unfold M_yy.Tshift. rewrite MY.From_To; auto.
  Qed.

  Lemma Tget_right_gTget_right : forall (e: M_yt.TEnv) (X:atom),
    Tget_right e X = M_yt.gTget_right e X.
  Proof.
    induction e; unfold M_yt.gTget_right; simpl; intros; auto.
    destruct a;
      [ rewrite IHe; unfold M_yt.gTget_right; simpl;
        destruct (get_right (M_yt.From_TEnv e) X); simpl; auto;
        unfold M_yy.Tshift; autorewrite with isorew; auto
      | destruct X; simpl;
        [ rewrite MY.To_From; auto
        | rewrite IHe; unfold M_yt.gTget_right; auto
        ]
      ].
  Qed.

  Lemma Tlth_preserving : forall (e e' : M_yt.TEnv),
    (forall (X : nat), Tget_left e' X = None -> Tget_left e X = None) ->
    [[[e]]] <= [[[e']]].
  Proof.
    intros.
    assert (forall X : nat, M_yt.gTget_left e' X = None -> M_yt.gTget_left e X = None).
    intros; rewrite <- Tget_left_gTget_left;
      apply H; rewrite Tget_left_gTget_left; auto.
    unfold M_yt.gTget_left, M_yt.Tlth in *; intros.
    auto with opt.
  Qed.

  Hint Resolve Tlth_preserving.

  Lemma Twf_typ_env_weaken : forall (T : MY.TT) (e e' : M_yt.TEnv),
    (forall (X : nat), Tget_left e' X = None -> Tget_left e X = None) ->
    M_yt.Twf_typ e T -> M_yt.Twf_typ e' T.
  Proof.
    intros.
    assert (forall X : nat, M_yt.gTget_left e' X = None -> M_yt.gTget_left e X = None).
    intros; rewrite <- Tget_left_gTget_left;
      apply H; rewrite Tget_left_gTget_left; auto.
    unfold M_yt.Twf_typ, M_yt.gTget_left in *.
    eauto using HO_wf_weaken_lth with opt.
  Qed.

  Lemma Twf_typ_extensionality : forall (T : MY.TT) (e e' : M_yt.TEnv),
    (forall (X : nat), Tget_left e X = Tget_left e' X) ->
    M_yt.Twf_typ e T -> M_yt.Twf_typ e' T.
  Proof.
    intros.
    assert (forall X : nat, M_yt.gTget_left e X = M_yt.gTget_left e' X).
    intros; do 2 rewrite <- Tget_left_gTget_left; apply H.
    unfold M_yt.Twf_typ, M_yt.gTget_left in *.
    eauto using HO_wf_extensionality with opt.
  Qed.

  Lemma Tget_right_remove_right_lt : forall (e : M_yt.TEnv) (x x' : nat),
    x < x' -> Tget_right (M_yt.Tremove_right e x') x = Tget_right e x.
  Proof.
    intros.
    rewrite M_yt.Tremove_right_gTremove_right.
    do 2 rewrite Tget_right_gTget_right.
    unfold M_yt.gTremove_right, M_yt.gTget_right; intros.
    autorewrite with isorew.
    auto using get_right_remove_right_lt with opt.
  Qed.

  Lemma Tget_right_remove_right_ge : forall (e : M_yt.TEnv) (x x' : nat),
    x >= x' -> Tget_right (M_yt.Tremove_right e x') x = Tget_right e (S x).
  Proof.
    intros.
    rewrite M_yt.Tremove_right_gTremove_right.
    do 2 rewrite Tget_right_gTget_right.
    unfold M_yt.gTremove_right, M_yt.gTget_right; intros.
    autorewrite with isorew.
    auto using get_right_remove_right_ge with opt.
  Qed.

  Lemma Tget_left_remove_right : forall (e : M_yt.TEnv) (X x': nat),
    Tget_left e X = Tget_left (M_yt.Tremove_right e x') X.
  Proof.
    intros.
    rewrite M_yt.Tremove_right_gTremove_right.
    do 2 rewrite Tget_left_gTget_left.
    unfold M_yt.gTremove_right, M_yt.gTget_left; intros.
    autorewrite with isorew.
    auto using get_left_remove_right with opt.
  Qed.

  (** Tinsert_left inserts an element to environment.
     It is defined by Inductive not by Fixpoint
     because there are some conditions for adding elements to environment. *)

  Inductive Tinsert_left : nat -> M_yt.TEnv -> M_yt.TEnv -> Prop :=
    Til_here :
      forall (T : MY.TT) (e : M_yt.TEnv), M_yt.Twf_typ e T -> Tinsert_left 0 e ((inl T)::e)
  | Til_right :
      forall (X : nat) (T : MY.TT) (e e' : M_yt.TEnv),
      Tinsert_left X e e' ->
      Tinsert_left X ((inr T)::e) ((inr (M_yy.Tshift X T))::e')
  | Til_left :
      forall (X : nat) (T : MY.TT) (e e' : M_yt.TEnv),
      Tinsert_left X e e' ->
      Tinsert_left (S X) ((inl T)::e) ((inl (M_yy.Tshift X T))::e').

  Lemma Tinsert_left_gTinsert_left : forall n (e e':M_yt.TEnv) ,
    Tinsert_left n e e' -> M_yt.gTinsert_left n e e'.
  Proof.
    unfold M_yt.gTinsert_left; induction 1;
    [ simpl; apply il_here;
      unfold M_yt.Twf_typ in H; auto
    | simpl; unfold M_yy.Tshift; rewrite MY.From_To; apply il_right;
      apply IHTinsert_left
    | simpl; unfold M_yy.Tshift; rewrite MY.From_To; apply il_left;
      apply IHTinsert_left
    ].
  Qed.

  Lemma gTinsert_left_Tinsert_left : forall n (e e':M_yt.TEnv) ,
    M_yt.gTinsert_left n e e' -> Tinsert_left n e e'.
  Proof.
    unfold M_yt.gTinsert_left.
    intros n e e'.
    pattern e at 2; rewrite <- (M_yt.To_From_TEnv e).
    pattern e' at 2; rewrite <- (M_yt.To_From_TEnv e').
    generalize (M_yt.From_TEnv e).
    generalize (M_yt.From_TEnv e').
    induction 1;
    [ simpl; apply Til_here;
      unfold M_yt.Twf_typ; autorewrite with isorew; auto; simpl
    | assert (MY.To (shift X MY.RR T) = M_yy.Tshift X (MY.To T));
      [unfold M_yy.Tshift; simpl; rewrite MY.From_To; auto
        |simpl; rewrite H0; apply Til_right; auto]
    | simpl; assert (MY.To (shift X MY.RR T) = M_yy.Tshift X (MY.To T));
      [unfold M_yy.Tshift; simpl; rewrite MY.From_To; auto|
        simpl; rewrite H0; apply Til_left; auto]
    ].
  Qed.

  Lemma Tinsert_T_ind : forall (e:M_yt.TEnv) (T: MY.TT)(H:HO_wf 0 (MY.From T)),
    Tinsert_left 0 e (M_yt.Tinsert 0 e T H).
  Proof.
    intros.
    apply gTinsert_left_Tinsert_left.
    unfold M_yt.Tinsert, M_yt.gTinsert_left; intros.
    autorewrite with isorew.
    auto using insert_T_ind.
  Qed.

  Lemma Tinsert_T : forall (e: M_yt.TEnv) n (T:MY.TT)(H:M_yt.Twf_typ nil T),
    [[[e]]] > 0 ->
    [[[e]]] >= n ->
    Tinsert_left n e (M_yt.Tinsert n e T H).
  Proof.
    intros.
    apply gTinsert_left_Tinsert_left.
    unfold M_yt.Tinsert, M_yt.gTinsert_left; intros.
    autorewrite with isorew.
    auto using insert_T.
  Qed.

  Lemma Tget_left_insert_left_ge : forall (X X' : nat) (e e' : M_yt.TEnv),
    noRepr MY.RR ->
    Tinsert_left X' e e' ->
    X' <= X ->
    Tget_left e' (S X) = opt_map (M_yy.Tshift  X') (Tget_left e X).
  Proof.
    intros.
    do 2 rewrite Tget_left_gTget_left.
    apply Tinsert_left_gTinsert_left in H0.
    unfold M_yy.gTinsert_left, M_yt.gTget_left; intros.
    rewrite get_left_insert_left_ge with (X':=X') (e:=M_yt.From_TEnv e);
      auto.
    induction (get_left(M_yt.From_TEnv e) X);
      unfold M_yy.Tshift; simpl; [rewrite MY.From_To | idtac]; auto.
  Qed.

  Lemma Tget_left_insert_left_lt : forall (X X' : nat) (e e' : M_yt.TEnv),
    noRepr MY.RR ->
    Tinsert_left X' e e' ->
    X < X' ->
    Tget_left e' X = opt_map (M_yy.Tshift X') (Tget_left e X).
  Proof.
    intros.
    do 2 rewrite Tget_left_gTget_left.
    apply Tinsert_left_gTinsert_left in H0.
    unfold M_yy.gTinsert_left, M_yt.gTget_left; intros.
    rewrite get_left_insert_left_lt with (X':=X') (e:=M_yt.From_TEnv e);
      auto.
    induction (get_left(M_yt.From_TEnv e) X);
      unfold M_yy.Tshift; simpl; [rewrite MY.From_To | idtac]; auto.
  Qed.

  Lemma Tget_right_insert_left : forall (x X' : nat) (e e' : M_yt.TEnv),
    noRepr MY.RR ->
    Tinsert_left X' e e' ->
    Tget_right e' x = opt_map (M_yy.Tshift X') (Tget_right e x).
  Proof.
    intros.
    do 2 rewrite Tget_right_gTget_right.
    apply Tinsert_left_gTinsert_left in H0.
    unfold M_yy.gTinsert_left, M_yt.gTget_right; intros.
    rewrite get_right_insert_left with (X':=X') (e:=M_yt.From_TEnv e);
      auto.
    induction (get_right(M_yt.From_TEnv e) x);
      unfold M_yy.Tshift; simpl; [rewrite MY.From_To | idtac]; auto.
  Qed.

  Lemma Tinsert_left_length : forall X (e e':M_yt.TEnv),
    Tinsert_left X e e' -> [[[e']]] >= S X.
  Proof.
    intros.
    apply Tinsert_left_gTinsert_left in H.
    unfold M_yy.gTinsert_left, M_yt.Tlth.
    eauto using insert_left_lth.
  Qed.

  Lemma Tinsert_left_length_1 : forall X (e e':M_yt.TEnv),
    Tinsert_left X e e' -> [[[e']]] = S [[[e]]].
  Proof.
    intros.
    apply Tinsert_left_gTinsert_left in H.
    unfold M_yy.gTinsert_left, M_yt.Tlth.
    eauto using insert_left_lth_1.
  Qed.

  Lemma Tinsert_left_wf_typ : forall (T : MY.TT) (X : nat) (e e' : M_yt.TEnv) (U:MY.TT),
    M_yt.Twf_typ nil U ->
    Tinsert_left X e e' ->
    M_yt.Twf_typ e T ->
    M_yt.Twf_typ e' (M_yy.Tshift X T).
  Proof.
    intros.
    apply Tinsert_left_gTinsert_left in H0.
    unfold M_yt.Twf_typ, M_yy.gTinsert_left, M_yy.Tshift; intros.
    rewrite MY.From_To.
    eauto using insert_left_HO_wf.
  Qed.

  Lemma Tinsert_left_wf_env : forall (X : nat) (e e' : M_yt.TEnv) (U: MY.TT),
    M_yt.Twf_typ nil U ->
    Tinsert_left X e e' ->
    M_yt.Twf_env e ->
    M_yt.Twf_env e'.
  Proof.
    intros.
    apply Tinsert_left_gTinsert_left in H0.
    apply M_yt.Twf_env_gTwf_env in H1.
    apply M_yt.gTwf_env_Twf_env.
    unfold M_yt.Twf_typ, M_yy.gTinsert_left, M_yt.gTwf_env.
    eauto using insert_left_wf_env.
  Qed.

  Lemma Twf_typ_weakening_left : forall (e : M_yt.TEnv) (T U U' : MY.TT),
    M_yt.Twf_typ nil U' ->
    M_yt.Twf_typ e T ->
    M_yt.Twf_typ e U ->
    M_yt.Twf_typ ((inl U) :: e) (M_yy.Tshift 0 T).
  Proof.
    unfold M_yt.Twf_typ, M_yy.Tshift; simpl; intros.
    rewrite MY.From_To.
    apply HO_wf_weakening_left with (U:= MY.From U)(U':= MY.From U'); auto.
  Qed.

  Lemma Tget_right_wf : forall (e : M_yt.TEnv) (n : nat) (T U: MY.TT),
    M_yt.Twf_typ nil U ->
    M_yt.Twf_env e ->
    Tget_right e n = Some T ->
    M_yt.Twf_typ e T.
  Proof.
    intros.
    rewrite Tget_right_gTget_right in H1.
    apply M_yt.Twf_env_gTwf_env in H0.
    unfold M_yt.Twf_typ, gTwf_env, M_yt.gTget_right in *; simpl; intros.
    apply get_right_wf with (n:=n) (U:=MY.From U);auto.
    induction (get_right (M_yt.From_TEnv e) n);
      [ inversion H1; rewrite MY.From_To; auto
      | discriminate].
  Qed.

  Lemma Tget_left_some_gt : forall (e: M_yt.TEnv) (X:atom) (U U':MY.TT),
    noRepr MY.RR ->
    M_yt.Twf_typ nil U' ->
    Tget_left e X = Some U ->
    [[[e]]] > X.
  Proof.
    intros.
    rewrite Tget_left_gTget_left in H1.
    unfold M_yt.Twf_typ, M_yt.gTget_left, M_yt.Tlth in *; intros.
    apply get_left_gt with (U:=MY.From U) (U':=MY.From U'); auto.
    destruct (get_left (M_yt.From_TEnv e) X); try discriminate.
    inversion H1; rewrite MY.From_To; auto.
  Qed.

  (**************************************************************)
  (** * Simplification tactics for generic contepts *)
  (**************************************************************)

  Ltac gfold :=
    match goal with
      | |- context [HO_wf [[M_yt.From_TEnv ?e]] (MY.From ?T)] =>
        assert (Tem: HO_wf [[M_yt.From_TEnv e]] (MY.From T) = M_yt.Twf_typ e T);
          [ unfold M_yt.Twf_typ; auto |
            rewrite Tem; clear Tem]
      | |- context [M_yt.Ysize (MY.From ?T)] =>
        assert (Tem: M_yt.Ysize (MY.From T) = size T);
          [ unfold size; auto |
            rewrite Tem; clear Tem]
      | |- context [ [[M_yt.From_TEnv ?e]] ] =>
        assert (Tem: [[M_yt.From_TEnv e]] = [[[e]]]);
          [ unfold M_yt.Tlth; auto |
            rewrite Tem; clear Tem]
    end.

  Ltac gsimpl :=
    unfold M_tt.Tsubst, M_yy.Tsubst, M_ty.Tsubst, M_yt.Tsubst,
      M_tt.Tshift, M_ty.Tshift, M_yy.Tshift, M_yt.Tshift,
      M_yt.Twf_typ, M_yt.Ysize, M_yt.Tlth;
      simpl;
      repeat rewrite conv_id;
      repeat rewrite <- M_tt.From_Tshift;
      repeat rewrite <- M_yy.From_Tshift;
      repeat rewrite <- M_ty.From_Tshift;
      repeat rewrite <- M_yt.From_Tshift;
      repeat rewrite <- M_tt.From_Tsubst;
      repeat rewrite <- M_yy.From_Tsubst;
      repeat rewrite <- M_ty.From_Tsubst;
      repeat rewrite <- M_yt.From_Tsubst;
      repeat rewrite MY.From_To;
      repeat rewrite MY.To_From;
      repeat rewrite MT.From_To;
      repeat rewrite MT.To_From;
      repeat gfold.

  Ltac gcase :=
    match goal with
      | |- context [le_gt_dec ?n ?n'] =>
        destruct (le_gt_dec n n');auto
      | |- context [lt_eq_lt_dec ?n ?n'] =>
        destruct (lt_eq_lt_dec n n') as [| s ]; destruct s; auto
    end.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E : Universe, ((wd_ E C /\ (wd_ A D /\ (wd_ D C /\ (wd_ A C /\ (wd_ D B /\ (wd_ A B /\ (wd_ D E /\ (wd_ B C /\ (col_ E C B /\ col_ D E C))))))))) -> col_ B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall X A B C D U V : Universe, ((wd_ A B /\ (wd_ C D /\ (wd_ B X /\ (wd_ D X /\ (col_ X A B /\ (col_ X C D /\ (col_ U A B /\ col_ V C D))))))) -> col_ V D X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import HoTT.
From HoTT.Categories Require Import
     Functor.
From GR Require Import
     general_category
     bicategory.bicategory
     bicategory.locally_strict
     bicategory.strict
     bicategory.univalent
     bicategory.adjoint
     bicategory.adjoint_unique.

Section FullSub.
  Variable (C : BiCategory)
           (P : Obj C -> hProp).

  Definition full_sub_d : BiCategory_d.
  Proof.
    make_bicategory.
    - exact {X : C & P X}.
    - exact (fun X Y => C⟦X.1,Y.1⟧).
    - exact (fun X => id₁ X.1).
    - exact (fun X Y Z => hcomp X.1 Y.1 Z.1).
    - exact (fun X Y Z f g p => morphism_of (hcomp X.1 Y.1 Z.1) p).
    - exact (fun X Y f => left_unit f).
    - exact (fun X Y f => left_unit_inv f).
    - exact (fun X Y f => right_unit f).
    - exact (fun X Y f => right_unit_inv f).
    - exact (fun W X Y Z f g h => assoc f g h).
    - exact (fun W X Y Z f g h => assoc_inv f g h).
  Defined.

  Definition full_sub_d_is_bicategory : is_bicategory full_sub_d.
  Proof.
    make_is_bicategory ; intros ; apply C.
  Qed.

  Definition full_sub
    : BiCategory
    := Build_BiCategory
         full_sub_d
         full_sub_d_is_bicategory.

  Definition full_sub_strict (SC : IsStrict C)
    : IsStrict full_sub.
  Proof.
    make_strict ; intros ; cbn in * ; apply SC.
  Defined.

  Global Instance locally_univalent_full_sub
         `{Univalence}
         {HC : Univalent C}
    : LocallyUnivalent full_sub.
  Proof.
    intros X Y.
    apply HC.
  Defined.

  Lemma id_to_adjequiv_full_sub
        `{Univalence}
         {HC : Univalent C}
        {X Y : full_sub}
        (p : X = Y)
    : id_to_adjequiv X Y (path_sigma_hprop X Y p..1)
      =
      id_to_adjequiv X.1 Y.1 p..1.
  Proof.
    induction p ; cbn.
    rewrite path_sigma_hprop_1.
    apply path_adjoint_equivalence.
    reflexivity.
  Qed.

  Global Instance univalent_0_full_sub
         `{Univalence}
         {HC : Univalent C}
    : Univalent_0 full_sub.
  Proof.
    intros X Y.
    simple refine (isequiv_adjointify _ _ _ _) ; cbn.
    - exact (fun e => path_sigma_hprop _ _ (adjequiv_to_id X.1 Y.1 e)).
    - intros e.
      apply path_adjoint_equivalence ; f_ap.
      refine (_ @ @eisretr _ _ (id_to_adjequiv X.1 Y.1) _ e).
      refine (_ @ (id_to_adjequiv_full_sub
                     (path_sigma_hprop _ _ (adjequiv_to_id X.1 Y.1 e)))
                @ _).
      + rewrite pr1_path_path_sigma_hprop.
        reflexivity.
      + rewrite pr1_path_path_sigma_hprop.
        reflexivity.
    - intros p.
      induction p ; cbn.
      rewrite <- path_sigma_hprop_1.
      f_ap.
      rewrite <- (eissect (id_to_adjequiv _ _)) ; cbn.
      f_ap.
      apply path_adjoint_equivalence.
      reflexivity.
  Defined.

  Global Instance univalent_full_sub
         `{Univalence}
         {HC : Univalent C}
    : Univalent full_sub.
  Proof.
    split ; apply _.
  Defined.

  Global Instance locally_strict_full_sub
         `{LocallyStrict C}
    : LocallyStrict full_sub.
  Proof.
    intros X Y ; cbn.
    apply _.
  Defined.

  Definition is_2category_full_sub
             {H : is_2category C}
    : is_2category full_sub.
  Proof.
    destruct H.
    split.
    - apply _.
    - apply full_sub_strict.
      assumption.
  Qed.

  Definition adjoint_to_full_sub
             {X Y : C}
             (HX : P X)
             (HY : P Y)
             (f : C⟦X,Y⟧)
             (Hf : @is_left_adjoint C _ _ f)
    : @is_left_adjoint full_sub (X;HX) (Y;HY) f
    := Hf.

  Definition adjoint_equivalence_to_full_sub
             {X Y : C}
             (HX : P X)
             (HY : P Y)
             (f : C⟦X,Y⟧)
             (Hf : @is_adjoint_equivalence C _ _ f)
    : @is_adjoint_equivalence full_sub (X;HX) (Y;HY) f
    := Hf.

  Definition adjoint_equivalent_to_full_sub
             {X Y : C}
             (HX : P X)
             (HY : P Y)
             (f : X ≃ Y)
    : @adjoint_equivalence full_sub (X;HX) (Y;HY)
    := f.

  Global Instance full_sub_isomorphism
         {X Y : C}
         {f g : C⟦X,Y⟧}
         (HX : P X)
         (HY : P Y)
         (α : f ==> g)
         `{@IsIsomorphism (C⟦X,Y⟧) f g α}
    : @IsIsomorphism (full_sub⟦(X;HX),(Y;HY)⟧) _ _ α
    := _.
End FullSub.


Require Import Autosubst.Autosubst.
Require Import Zee.lattice Zee.lang Zee.dec Zee.vals Zee.frame Zee.maplike Zee.sem Zee.typesystem Coq.Strings.String.
Require Import Arith List Coq.Program.Basics Coq.Lists.ListSet Lia Coq.ZArith.BinInt.
Require Import Coq.Classes.RelationClasses.

Section Example1.
  Context {A : Set} {BinOpS : Set} `{lattice A}.
  Context {MINUS MULT : BinOpS}.
  Definition Lab := @Lab A.
  Definition Ty := @Ty A.
  Definition LabVar := @LabVar A.
  Definition SecTy := @SecTy A.
  Definition SecTyV := @SecTyV A.
  Definition AtomSecTy := @AtomSecTy A.
  Definition Cmd := @Cmd A BinOpS.
  Definition Expr := @Expr A BinOpS.
  Definition V := @V A.

  Context {δ : string -> option Z}.
  Context {F: string -> option (list (string * Lab) *
                               list (string * Lab) *
                               list (string * SecTy) * Lab * Lab * Cmd) }.
  Context {eval_binop: BinOpS -> V -> V -> V}.
  Context {type_binop: BinOpS -> SecTy -> SecTy -> SecTy -> Prop}.
  Context {VarT ArgT LocT MemT : Type}
          {H_var_finmaplike: FinMapLike VarT string (A + SecTyV)}
          {H_arg_finmaplike: FinMapLike ArgT string SecTyV}
          {H_loc_finmaplike: FinMapLike LocT string SecTyV}
          {H_mem_maplike: MapLike MemT nat V}.
  Definition Frame := @Frame A VarT ArgT LocT MemT _ _ _ _.
  Definition PFrame := @PFrame A VarT ArgT LocT _ _ _.
  Definition EFrame := @EFrame A MemT _.

  Notation "'〚' o '〛'" := (eval_binop o).
  Notation "o ':' s1 ',' s2 '⤇' s" := (type_binop o s1 s2 s) (at level 70, s at next level).

  Definition Var := @Var A BinOpS.
  Definition Num := @Num A BinOpS.
  Coercion Var: string >-> lang.Expr.
  Coercion Num: nat >-> lang.Expr.
  Coercion STy: lang.Ty >-> Funclass.
  Coercion eval_binop : BinOpS >-> Funclass.

  Definition factorial : Cmd :=
    LET "fac_var0" AS (IntTy ⊥) ::= 1
    IN LET "fac_var1" AS (IntTy ⊥) ::= "fac_arg0"
       IN WHILE "fac_var1" DO
            &("fac_var0") *= BinOp MULT "fac_var0" "fac_var1" ;;
            &("fac_var1") *= BinOp MINUS "fac_var1" 1
          END
       ENDLET;;
       Var "fac_arg1" *= Var "fac_var0"
    ENDLET.
    Hint Unfold factorial.

    Definition program : Cmd :=
      LET "program_var0" AS (IntTy ⊥) ::= Num 0
      IN CALL "fac" nil nil (Num 3 :: &("program_var0") :: nil);;
         LET "program_var1" AS (IntTy ⊥) ::= "program_var0"
         IN SKIP ENDLET
      ENDLET.
    Hint Unfold program.

    Definition step_many := @step_many A BinOpS _ δ F eval_binop _ _ _ _ _ _ _ _.
    Notation "cfg1 '-->[' n ']' cfg2" := (step_many cfg1 cfg2 n) (at level 80).
    Notation "cfg1 '-->*' cfg2" := (exists n, cfg1 -->[n] cfg2) (at level 80).

    Definition wt := @wt A BinOpS _ F type_binop.
    Notation "'[' Γ ',' Π ',' ϕ ',' pc ',' fr ']' '⊢' c" := (wt Γ Π ϕ pc fr c) (at level 70, c at next level).

    Lemma fac_is_wt:
      (forall k1 k2 o, o : (IntTy k1), (IntTy k2) ⤇ (ASecTy (IntTy (k1 ⊔ k2)))) ->
      [∅["fac_arg0" ↦ ASecTy (IntTy ⊥)]
        ["fac_arg1" ↦ ASecTy (STy (ε @ (ASecTy (IntTy ⊥))) ⊥)],
       ∅, nil, ⊥, ⊥] ⊢ factorial.
    Proof.
      intros.
      unfold factorial.
      eapply WtLet.
      - constructor.
      - constructor; repeat constructor.
      - constructor.
        constructor.
        rewrite -> idem_join.
        reflexivity.
      - rewrite -> idem_join.
        reflexivity.
      - eapply WtSeq.
        + eapply WtLet.
          * constructor.
            reflexivity.
          * constructor; repeat constructor.
          * constructor.
            constructor.
            rewrite -> idem_join.
            reflexivity.
          * rewrite -> idem_join.
            reflexivity.
          * eapply WtWhile.
            -- constructor.
               reflexivity.
            -- eapply WtSeq.
               ++ eapply WtWrite.
                  ** constructor.
                     reflexivity.
                  ** eapply wt_binop.
                     {
                       constructor.
                       reflexivity.
                     }
                     {
                       constructor.
                       reflexivity.
                     }
                     {
                       eauto.
                     }
                  ** constructor.
                     constructor.
                     do 2 rewrite -> idem_join.
                     reflexivity.
               ++ eapply WtWrite.
                  ** constructor.
                     reflexivity.
                  ** eapply wt_binop.
                     {
                       constructor.
                       reflexivity.
                     }
                     {
                       constructor.
                     }
                     {
                       eauto.
                     }
                  ** constructor.
                     constructor.
                     do 2 rewrite -> idem_join.
                     reflexivity.
        + eapply WtWrite.
          * constructor.
            reflexivity.
          * constructor.
            reflexivity.
          * constructor.
            constructor.
            rewrite -> idem_join.
            reflexivity.
    Qed.

    Lemma program_is_wt:
      F "fac" = Some (nil, nil, ("fac_arg0", ASecTy (IntTy ⊥)) :: ("fac_arg1", ASecTy (STy (ε @ (ASecTy (IntTy ⊥))) ⊥)) :: nil, ⊥, ⊥, factorial) ->
      [∅, ∅, nil, ⊥, ⊥] ⊢ program.
    Proof.
      intros.
      unfold program.
      eapply WtLet.
      - constructor.
      - constructor. constructor; constructor.
      - constructor.
        constructor.
        rewrite -> idem_join.
        reflexivity.
      - rewrite -> idem_join.
        reflexivity.
      - eapply WtSeq.
        + eapply WtCall.
          * eassumption.
          * reflexivity.
          * reflexivity.
          * reflexivity.
          * intros.
            eapply nth_error_In in H1.
            firstorder.
          * intros.
            eapply nth_error_In in H1.
            firstorder.
          * intros.
            destruct i.
            {
              cbn in * |-.
              inversion H1; subst; clear H1.
              inversion H2; subst; clear H2.
              constructor.
            }
            destruct i.
            {
              cbn in * |-.
              inversion H1; subst; clear H1.
              inversion H2; subst; clear H2.
              constructor.
              reflexivity.
            }
            cbn in * |-.
            eapply nth_error_In in H1.
            firstorder.
          * split.
            -- cbn.
               reflexivity.
            -- cbn.
               reflexivity.
          * cbn.
            reflexivity.
        + eapply WtLet.
          * constructor.
            reflexivity.
          * constructor; repeat constructor.
          * constructor.
            constructor.
            rewrite -> idem_join.
            reflexivity.
          * rewrite -> idem_join.
            reflexivity.
          * eapply WtSkip.
    Qed.

    Goal
      δ "fac_var0" = Some 0%Z ->
      δ "fac_var1" = Some 1%Z ->
      δ "fac_arg0" = Some (Z.neg 3)%Z ->
      δ "fac_arg1" = Some (Z.neg 2)%Z ->
      δ "program_var0" = Some 0%Z ->
      δ "program_var1" = Some 1%Z ->
      (forall n m, 〚 MINUS 〛 n m =
              match (n, m) with
                (VNum n, VNum m) => VNum (n - m)
              | _ => VNum 0
              end) ->
      (forall n m, 〚 MULT 〛 n m =
              match (n, m) with
                (VNum n, VNum m) => VNum (n * m)
              | _ => VNum 0
              end) ->
      F "fac" = Some (nil, nil, ("fac_arg0", ASecTy (IntTy ⊥)) :: ("fac_arg1", ASecTy (STy (ε @ (ASecTy (IntTy ⊥))) ⊥)) :: nil, ⊥, ⊥, factorial) ->
      exists stk q,
        ⟨program, initial_stk program, 0, 0⟩ -->* ⟨CStop, stk, q, 1⟩ /\
        stk ? (1 + fp_of (initial_stk program)) = Some (VNum 6).
    Proof.
      intros.
      do 2 eexists.
      split.
      {
        eexists.
        unfold program.
        cbn in *.
        eapply StepManyS.
        - step_let.
        - cbn. eapply StepManyS.
          + step_seq.
            step_seq.
            eapply SCall.
            * eassumption.
            * instantiate (1 := nil).
              reflexivity.
            * instantiate (1 := nil).
              reflexivity.
            * instantiate (1 := VNum 3 :: _ :: nil).
              reflexivity.
            * cbn in *.
              intros i ℓ k [? ?].
              eapply nth_error_In in H9.
              firstorder.
            * cbn in *.
              intros i τ s [? ?].
              eapply nth_error_In in H9.
              firstorder.
            * cbn in *.
              intros i v e [? ?].
              destruct i.
              -- cbn in *.
                 inversion H9; inversion H10; subst; clear H9 H10.
                 constructor.
              -- destruct i.
                 ++ cbn in *.
                    inversion H9; inversion H10; subst; clear H9 H10.
                    constructor.
                    ** eassumption.
                 ++ cbn in *.
                    eapply nth_error_In in H9.
                    firstorder.
            * cbn. reflexivity.
            * cbn. reflexivity.
            * eapply MakePArgCons.
              -- constructor.
                 constructor; constructor.
              -- eapply MakePArgCons.
                 ++ constructor.
                    constructor; repeat constructor.
                 ++ constructor.
            * cbn. reflexivity.
            * cbn. reflexivity.
            * cbn. reflexivity.
            * cbn.
              rewrite -> H3.
              rewrite -> H2.
              reflexivity.
            * reflexivity.
            * cbn. reflexivity.
            * easy.
            * easy.
          + cbn.
            eapply StepManyS.
            * unfold factorial.
              repeat step_seq; try easy.
              step_let.
              easy.
            * eapply StepManyS.
              repeat step_seq; try easy.
              step_let.
              easy.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              eapply SSeq1.
              step_while.
              all: try (easy).
              eapply StepManyS.
              repeat step_seq; try easy.
              step_write.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              step_write.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              eapply SSeq1.
              repeat rewrite -> H6, H7. step_while.
              all: try (easy).
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              step_write.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              step_write.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              eapply SSeq1.
              repeat rewrite -> H6, H7. step_while.
              all: try (easy).
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              step_write.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              step_write.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              repeat rewrite -> H6, H7.
              eapply SSeq2.
              step_while.
              easy.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              constructor.
              cbn. eapply StepManyS.
              repeat step_seq; try easy.
              repeat rewrite -> (values_add _ _ _ _).
              repeat rewrite -> values_empty.
              match goal with
                [ |- ⟨_, ?fr1 :: ?fr2 :: ?stk, _, _⟩ --> _] =>
                replace (fr1 :: fr2 :: stk) with ((fr1 :: nil) ++ (fr2 :: stk))
                  by reflexivity
              end; eapply SWrite.
              -- simpl. reflexivity.
              -- eval_var.
              -- eval_var.
              -- cbn. lia.
              -- cbn. lia.
              -- eapply StepManyS.
                 repeat step_seq; try easy.
                 constructor.
                 cbn. eapply StepManyS.
                 repeat step_seq; try easy.
                 constructor.
                 cbn. eapply StepManyS.
                 repeat step_seq; try easy.
                 step_let.
                 easy.
                 cbn. eapply StepManyS.
                 repeat step_seq; try easy.
                 constructor.
                 eapply StepManyS.
                 repeat step_seq; try easy.
                 constructor.
                 cbn. eapply StepManyS.
                 constructor.
                 eapply StepMany0.
      }
      {
        simpl_mapsto.
        reflexivity.
      }
    Qed.

End Example1.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) lv2) (plus lv1 (plus lv2 (mult lv1 lv0)))).
Admitted.
QuickChick conj13eqsynthconj2.


Require Coq.ZArith.ZArith.

Lemma unit_eq (x y:unit) : x = y. destruct x, y; reflexivity. Qed.
Hint Resolve unit_eq.

Hint Extern 0 (_ = _ :> bool) => (
  match goal with
  | [H:Bool.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (Bool.eqb_true_iff _ _) H)
  | [H:Bool.eqb ?b ?a = true |- ?a = ?b ] => symmetry; apply (proj1 (Bool.eqb_true_iff _ _) H)
  end).

Hint Extern 0 (_ = _ :> nat) => (
  match goal with
  | [H:Nat.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (PeanoNat.Nat.eqb_eq _ _) H)
  | [H:Nat.eqb ?b ?a = true |- ?a = ?b ] => symmetry; apply (proj1 (PeanoNat.Nat.eqb_eq _ _) H)
  end).

Hint Extern 0 (_ <= _) => (
  match goal with
  | [H:Nat.ltb ?a ?b = true |- ?a < ?b ] => apply (proj1 (PeanoNat.Nat.ltb_lt _ _) H)
  end).

Hint Extern 0 (_ <= _) => (
  match goal with
  | [H:Nat.leb ?a ?b = true |- ?a <= ?b ] => apply (proj1 (PeanoNat.Nat.leb_le _ _) H)
  end).

Hint Extern 0 (_ = _ :> BinNums.N) => (
  match goal with
  | [H:BinNat.N.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (BinNat.N.eqb_eq _ _) H)
  | [H:BinNat.N.eqb ?b ?a = true |- ?a = ?b ] => symmetry; apply (proj1 (BinNat.N.eqb_eq _ _) H)
  end).
Hint Extern 0 (_ = _ :> BinInt.Z) => (
  match goal with
  | [H:BinInt.Z.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (BinInt.Z.eqb_eq _ _) H)
  | [H:BinInt.Z.eqb ?a ?b = true |- ?b = ?a ] => symmetry; apply (proj1 (BinInt.Z.eqb_eq _ _) H)
  end).
Hint Extern 0 (BinInt.Z.lt _ _) => (
  match goal with
  | [H:BinInt.Z.ltb ?a ?b = true |- BinInt.Z.lt ?a ?b ] => apply (proj1 (BinInt.Z.ltb_lt _ _) H)
  | [H:BinInt.Z.gtb ?b ?a = true |- BinInt.Z.lt ?a ?b ] => apply (proj1 (BinInt.Z.gtb_lt _ _) H)
  end).
Hint Extern 0 (BinInt.Z.le _ _) => (
  match goal with
  | [H:BinInt.Z.leb ?a ?b = true |- BinInt.Z.le ?a ?b ] => apply (proj1 (BinInt.Z.leb_le _ _) H)
  | [H:BinInt.Z.geb ?b ?a = true |- BinInt.Z.le ?a ?b ] => apply (proj1 (BinInt.Z.geb_le _ _) H)
  end).

Hint Extern 0 (_ = _ :> BinPos.positive) => (
  match goal with
  | [H:BinPos.Pos.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (BinPos.Pos.eqb_eq _ _) H)
  | [H:BinPos.Pos.eqb ?a ?b = true |- ?b = ?a ] => symmetry; apply (proj1 (BinPos.Pos.eqb_eq _ _) H)
  end).
Hint Extern 0 (BinPos.Pos.lt _ _) => (
  match goal with
  | [H:BinPos.Pos.ltb ?a ?b = true |- BinPos.Pos.lt ?a ?b ] => apply (proj1 (BinPos.Pos.ltb_lt _ _) H)
  end).
Hint Extern 0 (BinPos.Pos.le _ _) => (
  match goal with
  | [H:BinPos.Pos.leb ?a ?b = true |- BinPos.Pos.le ?a ?b ] => apply (proj1 (BinPos.Pos.leb_le _ _) H)
  end).


Require Import Coq.Lists.List.
Require Export ParDB.Spec.
Require Export ParDB.Lemmas.
Require Export ParDB.Inst.

Require Export SpecSyntax.
Require Export SpecTyping.
Require Export LemmasTyping.
Require Export Agreement.

Definition CoVarClosed (Γ: Env) : Prop :=
  ∀ c σ τ k, ¬ ⟨ c : σ ~ τ ∷ k ∈ Γ ⟩.

Lemma covarclosed_nil :
  CoVarClosed nil.
Proof. inversion 1. Qed.
Hint Resolve covarclosed_nil : ws.

Lemma covarclosed_up_tyvar {Γ k} :
  CoVarClosed Γ → CoVarClosed (Γ ► k).
Proof.
  unfold CoVarClosed, not; intros clΓ;
    inversion 1; subst; eauto.
Qed.
Hint Resolve covarclosed_up_tyvar : ws.

Local Ltac crushCoVarLookup :=
  match goal with
    | [H: ⟨ _ : _ ~ _ ∷ _ ∈ ?Γ ⟩ |- _] =>
      let clΓ := fresh "clΓ" in
        assert (clΓ: CoVarClosed Γ) by eauto with ws;
        elimtype False; apply (clΓ _ _ _ _ H)
  end.

Ltac crushIH :=
  repeat
    match goal with
      | [IH: WfEnv ?Γ → _ |- _ ] =>
        let wΓ := fresh "wΓ" in
        assert (wΓ: WfEnv Γ) by eauto with ws;
          specialize (IH wΓ); clear wΓ
      | [IH: CoVarClosed ?Γ → _ |- _ ] =>
        let clΓ := fresh "clΓ" in
        assert (clΓ: CoVarClosed Γ) by eauto with ws;
          specialize (IH clΓ); clear clΓ
    end.

Local Ltac crush :=
  intros;
  crushIH;
  repeat
    (cbn in *;
     repeat crushSyntaxMatch;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasRewriteH;
     repeat crushSyntaxRefold;
     repeat crushTypingMatchH;
     subst*;
     try discriminate;
     try crushCoVarLookup;
     eauto with ws;
     destruct_conjs;
     idtac
    );
  eauto 200 with ws.

Lemma arr_consistency {Γ γs σ1 σ2 τ} (clΓ: CoVarClosed Γ)
  (wγs: ⟨ Γ ⊢ γs : arr σ1 σ2 ↝* τ ∷ kstar ⟩) :
  ∃ ν1 ν2, τ = arr ν1 ν2 ∧
    (∃ γs1, ⟨ Γ ⊢ γs1 : σ1 ↝* ν1 ∷ kstar ⟩) ∧
    (∃ γs2, ⟨ Γ ⊢ γs2 : σ2 ↝* ν2 ∷ kstar ⟩).
Proof. depind wγs; crush. Qed.

Lemma arrτ_consistency {Γ γs k σ τ} (clΓ: CoVarClosed Γ)
  (wγs: ⟨ Γ ⊢ γs : arrτ k σ ↝* τ ∷ kstar ⟩) :
  ∃ ν, τ = arrτ k ν ∧
    (∃ γs, ⟨ Γ ► k ⊢ γs : σ ↝* ν ∷ kstar ⟩).
Proof. depind wγs; crush. Qed.

Lemma arrγ_consistency {Γ γs σ1 σ2 σ3 τ k} (clΓ: CoVarClosed Γ)
  (wγs: ⟨ Γ ⊢ γs : arrγ σ1 σ2 k σ3 ↝* τ ∷ kstar ⟩) :
  ∃ ν1 ν2 ν3, τ = arrγ ν1 ν2 k ν3 ∧
    (∃ γs1, ⟨ Γ ⊢ γs1 : σ1 ↝* ν1 ∷ k ⟩) ∧
    (∃ γs2, ⟨ Γ ⊢ γs2 : σ2 ↝* ν2 ∷ k ⟩) ∧
    (∃ γs3, ⟨ Γ ⊢ γs3 : σ3 ↝* ν3 ∷ kstar ⟩).
Proof. depind wγs; crush. Qed.

(*************************************************************************)

Definition upRedSub (ζγ: Sub Exp) : Sub Exp :=
  ((ζγ >=> wkm Exp) · corefl (var 0)).

Fixpoint apRedSub (ζγ: Sub Exp) (τ: Exp) {struct τ} : Exp :=
  match τ with
    | var α              =>  ζγ α
    | τabs k τ           =>  coτabs k (apRedSub (upRedSub ζγ) τ)
    | τapp τ1 τ2         =>  coτapp (apRedSub ζγ τ1) (apRedSub ζγ τ2)
    | arr  τ1 τ2         =>  coarr  (apRedSub ζγ τ1) (apRedSub ζγ τ2)
    | arrτ k τ           =>  coarrτ k (apRedSub (upRedSub ζγ) τ)
    | arrγ τ1 τ2 k τ3    =>  coarrγ (apRedSub ζγ τ1) (apRedSub ζγ τ2) k (apRedSub ζγ τ3)
    | coτabs k γ         =>  coτabs k (apRedSub (upRedSub ζγ) γ)
    | coτapp γ1 γ2       =>  coτapp (apRedSub ζγ γ1) (apRedSub ζγ γ2)
    | coarr  γ1 γ2       =>  coarr  (apRedSub ζγ γ1) (apRedSub ζγ γ2)
    | coarrτ k γ         =>  coarrτ k (apRedSub (upRedSub ζγ) γ)
    | coarrγ γ1 γ2 k γ3  =>  coarrγ (apRedSub ζγ γ1) (apRedSub ζγ γ2) k (apRedSub ζγ γ3)
    | coinvarr₁ γ        =>  coinvarr₁ (apRedSub ζγ γ)
    | coinvarr₂ γ        =>  coinvarr₂ (apRedSub ζγ γ)
    | coinvarrτ γ1 γ2    =>  coinvarrτ (apRedSub ζγ γ1) (apRedSub ζγ γ2)
    | coinvarrγ₁ γ       =>  coinvarrγ₁ (apRedSub ζγ γ)
    | coinvarrγ₂ γ       =>  coinvarrγ₂ (apRedSub ζγ γ)
    | coinvarrγ₃ γ       =>  coinvarrγ₃ (apRedSub ζγ γ)
    | cobeta k γ1 γ2     =>  cobeta k (apRedSub (upRedSub ζγ) γ1) (apRedSub ζγ γ2)
    | corefl τ           =>  apRedSub ζγ τ
    | _ => var 0
  end.

Record WtRedSub (Γ Δ: Env) (ζγ ζ1 ζ2: Sub Exp) : Prop :=
  { wrs_tyvar : ∀ {α k},
                  ⟨ α ∷ k ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζγ α : ζ1 α ↝ ζ2 α ∷ k ⟩;
    wrs_covar : ∀ {c τ1 τ2 k},
                  ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζγ c : τ1[ζ1] ↝ τ2[ζ2] ∷ k ⟩;
    wrs_left :> ⟨ ζ1 : Γ => Δ ⟩;
    wrs_right :> ⟨ ζ2 : Γ => Δ ⟩;
  }.

Hint Resolve wrs_tyvar : ws.
Hint Resolve wrs_covar : ws.
Hint Resolve wrs_left : ws.
Hint Resolve wrs_right : ws.

Lemma wtRedSub_up_tyvar {Γ Δ ζγ ζ1 ζ2} (wζ: WtRedSub Γ Δ ζγ ζ1 ζ2) :
  ∀ k, WtRedSub (Γ ► k) (Δ ► k) (upRedSub ζγ) ζ1↑ ζ2↑.
Proof.
  rewrite ?up_def.
  constructor; intros.
  - inversion H; clear H; crush.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - rewrite <- ?up_def; crush.
  - rewrite <- ?up_def; crush.
Qed.
Hint Resolve wtRedSub_up_tyvar : ws.

Lemma wtredsub_snoc_tyvar {Γ Δ ζγ ζ1 ζ2 γ σ τ k} :
  ⟨ Δ ⊢ γ : σ ↝ τ ∷ k ⟩ → ⟨ Δ ⊢ σ ∷ k ⟩ → ⟨ Δ ⊢ τ ∷ k ⟩ →
  WtRedSub Γ Δ ζγ ζ1 ζ2 →
  WtRedSub (Γ ► k) Δ (ζγ · γ) (ζ1 · σ) (ζ2 · τ).
Proof.
  intros; constructor; crush.
  rewrite ?ap_comp.
  rewrite ?wkm_snoc_cancel.
  crush.
Qed.

Lemma ty_redsub {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ∀ Δ ζγ ζ1 ζ2,
    WtRedSub Γ Δ ζγ ζ1 ζ2 →
    ⟨ Δ ⊢ apRedSub ζγ τ : τ[ζ1] ↝ τ[ζ2] ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve ty_redsub : ws.

Lemma red_redsub {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩) :
  ∀ Δ ζγ ζ1 ζ2,
    WtRedSub Γ Δ ζγ ζ1 ζ2 →
    ⟨ Δ ⊢ apRedSub ζγ γ : τ1[ζ1] ↝ τ2[ζ2] ∷ k ⟩.
Proof. induction wγ; crush. Qed.
Hint Resolve red_redsub : ws.

(* Record WtRSSub (Γ Δ: Env) (ζγs: Sub (list Exp)) (ζ1 ζ2: Sub Exp) : Prop := *)
(*   { wrss_tyvar : ∀ {α k}, *)
(*                    ⟨ α ∷ k ∈ Γ ⟩ → *)
(*                    ⟨ Δ ⊢ ζγs α : ζ1 α ↝* ζ2 α ∷ k ⟩; *)
(*     wrss_covar : ∀ {c τ1 τ2 k}, *)
(*                    ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ → *)
(*                    ⟨ Δ ⊢ ζγs c : τ1[ζ1] ↝* τ2[ζ2] ∷ k ⟩; *)
(*     wrss_left :> ⟨ ζ1 : Γ => Δ ⟩; *)
(*     wrss_right :> ⟨ ζ2 : Γ => Δ ⟩; *)
(*   }. *)

(* Hint Resolve wrss_tyvar : ws. *)
(* Hint Resolve wrss_covar : ws. *)
(* Hint Resolve wrss_left : ws. *)
(* Hint Resolve wrss_right : ws. *)

(* Lemma wtRSSub_up_tyvar {Γ Δ ζγs ζ1 ζ2} (wζ: WtRSSub Γ Δ ζγs ζ1 ζ2) : *)
(*   ∀ k, WtRSSub (Γ ► k) (Δ ► k) (List.map upRedSub ζγs) ζ1↑ ζ2↑. *)
(* Proof. *)
(*   rewrite ?up_def. *)
(*   constructor; intros. *)
(*   - inversion H; clear H; crush. *)
(*     rewrite <- ?(ap_wkm_ix (X:=Exp)). *)
(*     crush. *)
(*   - inversion H; clear H; crush. *)
(*     rewrite ?ap_comp. *)
(*     rewrite ?wkm_snoc_cancel. *)
(*     rewrite <- ?ap_comp. *)
(*     rewrite <- ?(ap_wkm_ix (X:=Exp)). *)
(*     crush. *)
(*   - rewrite <- ?up_def; crush. *)
(*   - rewrite <- ?up_def; crush. *)
(* Qed. *)
(* Hint Resolve wtRedSub_up_tyvar : ws. *)

(* Lemma wtredsub_snoc_tyvar {Γ Δ ζγ ζ1 ζ2 γ σ τ k} : *)
(*   ⟨ Δ ⊢ γ : σ ↝ τ ∷ k ⟩ → ⟨ Δ ⊢ σ ∷ k ⟩ → ⟨ Δ ⊢ τ ∷ k ⟩ → *)
(*   WtRedSub Γ Δ ζγ ζ1 ζ2 → *)
(*   WtRedSub (Γ ► k) Δ (ζγ · γ) (ζ1 · σ) (ζ2 · τ). *)
(* Proof. *)
(*   intros; constructor; crush. *)
(*   rewrite ?ap_comp. *)
(*   rewrite ?wkm_snoc_cancel. *)
(*   crush. *)
(* Qed. *)

(* Lemma ty_redsub {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) : *)
(*   ∀ Δ ζγ ζ1 ζ2, *)
(*     WtRedSub Γ Δ ζγ ζ1 ζ2 → *)
(*     ⟨ Δ ⊢ apRedSub ζγ τ : τ[ζ1] ↝ τ[ζ2] ∷ k ⟩. *)
(* Proof. induction wτ; crush. Qed. *)
(* Hint Resolve ty_redsub : ws. *)

(* Lemma red_redsub {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩) : *)
(*   ∀ Δ ζγ ζ1 ζ2, *)
(*     WtRedSub Γ Δ ζγ ζ1 ζ2 → *)
(*     ⟨ Δ ⊢ apRedSub ζγ γ : τ1[ζ1] ↝ τ2[ζ2] ∷ k ⟩. *)
(* Proof. induction wγ; crush. Qed. *)
(* Hint Resolve red_redsub : ws. *)

Inductive DomBinding : Type :=
  | tyv
  | cov
  | tmv.

Definition Dom : Type := list DomBinding.

Definition domBinding (b: Binding) : DomBinding :=
  match b with
    | tyvar k => tyv
    | covar τ1 τ2 k => cov
    | tmvar τ => tmv
  end.

Definition dom (Γ: Env) : Dom :=
  List.map domBinding Γ.

Fixpoint coidm (D: Dom) : Sub Exp :=
  match D with
    | nil        => idm Exp
    | cons tyv D => (coidm D >=> wkm Exp) · corefl (var 0)
    | cons cov D => (coidm D >=> wkm Exp) · var 0
    | cons tmv D => (coidm D >=> wkm Exp) · var 0
  end.

Lemma coidm_covar {Γ c σ τ k} (wc: ⟨ c : σ ~ τ ∷ k ∈ Γ ⟩) :
  ⟨ Γ ⊢ coidm (dom Γ) c : σ ↝ τ ∷ k ⟩.
Proof.
  induction wc; crush.
  - rewrite <- ?(ap_wkm_ix (X:=Exp)).
    eapply red_ren; crush.
  - rewrite <- ?(ap_wkm_ix (X:=Exp)).
    eapply red_ren; crush.
  - rewrite <- ?(ap_wkm_ix (X:=Exp)).
    eapply red_ren; crush.
Qed.

Lemma wtredsub_idm Γ :
  WtRedSub Γ Γ (coidm (dom Γ)) (idm Exp) (idm Exp).
Proof.
  induction Γ.
  - constructor; crush.
    inversion H.
  - destruct a; crush.
    + rewrite <- up_idm, up_def.
      eapply wtredsub_snoc_tyvar; eauto with ws.
      constructor; crush.
      * rewrite <- ?(ap_wkm_ix (X:=Exp)).
        change (var (wk α)) with (var α)[wkm Ix].
        eapply red_ren; crush.
      * rewrite <- ?apply_wkm_comm, ?ap_id.
        rewrite <- ?(ap_wkm_ix (X:=Exp)).
        eapply red_ren; crush.
        apply coidm_covar; auto.
    + change (var 0) with (vr 0).
      rewrite <- up_def. constructor; crush.
      * change (var (S i)) with (var i)[wkm Ix].
        eapply red_ren; crush.
      * rewrite <- ?(ap_wkm_ix (X:=Exp)).
        eapply red_ren; crush.
        apply coidm_covar; auto.
    + constructor; crush.
      * rewrite <- ?(ap_wkm_ix (X:=Exp)).
        change (var (S i)) with (var i)[wkm Ix].
        eapply red_ren; crush.
      * rewrite <- ?(ap_wkm_ix (X:=Exp)).
        eapply red_ren; crush.
        apply coidm_covar; auto.
Qed.

Lemma wtRedSub_beta1 {Γ γ τ σ k} :
  ⟨ Γ ⊢ γ : σ ↝ τ ∷ k ⟩ →
  ⟨ Γ ⊢ σ ∷ k ⟩ →
  ⟨ Γ ⊢ τ ∷ k ⟩ →
  WtRedSub (Γ ► k) Γ (coidm (dom Γ) · γ) (beta1 σ) (beta1 τ).
Proof.
  intros wγ wσ wτ.
  destruct (wtredsub_idm Γ) as [coidm_tyvar coidm_covar coidm_left coidm_right].
  constructor; crush.
  replace τ0 with τ0[idm Exp] by apply ap_id.
  replace τ3 with τ3[idm Exp] by apply ap_id.
  eauto.
Qed.
Hint Resolve wtRedSub_beta1 : ws.

(* Takahashi's complete developments adapted to coercions. *)
Fixpoint complete_ty (τ : Exp) : Exp :=
  match τ with
    | var α               => var α
    | τabs k τ            => τabs k (complete_ty τ)
    | τapp (τabs k τ1) τ2 => (complete_ty τ1)[beta1 (complete_ty τ2)]
    | τapp τ1 τ2          => τapp (complete_ty τ1) (complete_ty τ2)
    | arr τ1 τ2           => arr (complete_ty τ1) (complete_ty τ2)
    | arrτ k τ            => arrτ k (complete_ty τ)
    | arrγ τ1 τ2 k τ3     => arrγ (complete_ty τ1) (complete_ty τ2) k (complete_ty τ3)
    | _                   => τ
  end.

Fixpoint complete_ty_co (τ: Exp) : Exp :=
  match τ with
    | var α               => corefl (var α)
    | τabs k τ            => coτabs k (complete_ty_co τ)
    | τapp (τabs k τ1) τ2 => cobeta k (complete_ty_co τ1) (complete_ty_co τ2)
    | τapp τ1 τ2          => coτapp (complete_ty_co τ1) (complete_ty_co τ2)
    | arr τ1 τ2           => coarr (complete_ty_co τ1) (complete_ty_co τ2)
    | arrτ k τ            => coarrτ k (complete_ty_co τ)
    | arrγ τ1 τ2 k τ3     => coarrγ (complete_ty_co τ1) (complete_ty_co τ2) k (complete_ty_co τ3)
    | _                   => cast (var 1) (var 1)
  end.

Fixpoint complete_co (D: Dom) (γ : Exp) : Exp :=
  match γ with
    | var c                         => var c
    | coτabs k γ                    => coτabs k (complete_co (cons tyv D) γ)
    | coτapp (coτabs k γ1) γ2       => cobeta k (complete_co (cons tyv D) γ1) (complete_co D γ2)
    (* | coτapp (corefl (τabs k τ)) γ2 => cobeta (complete_ty_co τ) (complete_co γ2) *)
    | coτapp γ1 γ2                  => coτapp (complete_co D γ1) (complete_co D γ2)
    | coarr γ1 γ2                   => coarr (complete_co D γ1) (complete_co D γ2)
    | coarrτ k γ                    => coarrτ k (complete_co (cons tyv D) γ)
    | coarrγ γ1 γ2 k γ3             => coarrγ (complete_co D γ1) (complete_co D γ2) k (complete_co D γ3)
    | cobeta k γ1 γ2                => apRedSub (coidm D · complete_co D γ2) (complete_co (cons tyv D) γ1)
    | corefl τ                      => complete_ty_co τ
    | _ => cast (var 2) (var 2)
  end.

Lemma complete_ty_co_sound {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ⟨ Γ ⊢ complete_ty_co τ : τ ↝ complete_ty τ ∷ k ⟩.
Proof.
  induction wτ; crush.
  inversion wτ1; crush.
Qed.

Lemma complete_co_triangle {Γ γ σ τ k} (r: ⟨ Γ ⊢ γ : σ ↝ τ ∷ k ⟩)
  (wΓ: WfEnv Γ) (clΓ: CoVarClosed Γ) :
  ⟨ Γ ⊢ complete_co (dom Γ) γ : τ ↝ complete_ty σ ∷ k ⟩.
Proof.
  induction r; crush;
    eauto 20 using red_co, co_agreement_right,
    wtredsub_idm, wtredsub_snoc_tyvar, red_redsub with ws.
  - inversion r1; crush.
Qed.

Lemma red_diamond {Γ σ γ η τ ν k} (wΓ: WfEnv Γ) (clΓ: CoVarClosed Γ)
  (wγ: ⟨ Γ ⊢ γ : σ ↝ τ ∷ k ⟩)
  (wη: ⟨ Γ ⊢ η : σ ↝ ν ∷ k ⟩) :
  ∃ υ,
    (∃ η', ⟨ Γ ⊢ η' : τ ↝ υ ∷ k ⟩) ∧
    (∃ γ', ⟨ Γ ⊢ γ' : ν ↝ υ ∷ k ⟩).
Proof.
  exists (complete_ty σ); split.
  - exists (complete_co (dom Γ) γ).
    eauto using complete_co_triangle.
  - exists (complete_co (dom Γ) η).
    eauto using complete_co_triangle.
Qed.

Lemma red_strip {Γ γs η σ τ ν k}
  (wΓ: WfEnv Γ) (clΓ: CoVarClosed Γ)
  (wγs: ⟨ Γ ⊢ γs : σ ↝* τ ∷ k ⟩)
  (wη:  ⟨ Γ ⊢ η : σ ↝ ν ∷ k ⟩) :
  ∃ υ,
    (∃ η',  ⟨ Γ ⊢ η'  : τ ↝  υ ∷ k ⟩) ∧
    (∃ γs', ⟨ Γ ⊢ γs' : ν ↝* υ ∷ k ⟩).
Proof.
  induction wγs as [|σ τ τ' γs γ k wγs IHwγs wγ]; cbn.
  - exists ν; split.
    + exists η; crush.
    + exists nil; crush;
        eauto using red_co, co_agreement_right with ws.
  - (*      γs       γ
         σ   →   τ   →   τ'

       η ↓       ⇣η'      ⇣η''

         ν   →   υ   →   υ'
            γs'      γ'
    *)
    destruct (IHwγs wη) as (υ & (η' & wη') & (γs' & wγs')).
    destruct (red_diamond wΓ clΓ wγ wη') as (υ' & (η'' & wη'') & (γ' & wγ')).
    exists υ'.
    split.
    + exists η''; eauto with ws.
    + exists (cons γ' γs'); eauto with ws.
Qed.

Lemma red_confluence {Γ γs ηs σ τ ν k}
  (wΓ: WfEnv Γ) (clΓ: CoVarClosed Γ)
  (wγs: ⟨ Γ ⊢ γs : σ ↝* τ ∷ k ⟩)
  (wηs: ⟨ Γ ⊢ ηs : σ ↝* ν ∷ k ⟩) :
  ∃ υ,
    (∃ ηs', ⟨ Γ ⊢ ηs' : τ ↝* υ ∷ k ⟩) ∧
    (∃ γs', ⟨ Γ ⊢ γs' : ν ↝* υ ∷ k ⟩).
Proof.
  induction wγs as [|σ τ τ' γs γ k wγs IHwγs wγ]; cbn.
  - exists ν; split.
    + exists ηs; crush.
    + exists nil; crush;
        eauto using redstar_co, co_agreement_right with ws.
  - specialize (IHwγs wηs).
    destruct IHwγs as (υ & (ηs' & wηs') & (γs' & wγs')).
    destruct (red_strip wΓ clΓ wηs' wγ) as (υ' & (γ' & wγ') & (ηs'' & wηs'')).
    exists υ'; split.
    + exists ηs''; eauto with ws.
    + exists (cons γ' γs'); eauto with ws.
Qed.

Definition rssubst₁ (Γ: Env) (σγs: list Exp) (τ: Exp) : list Exp :=
   List.map (apRedSub (coidm (dom Γ) · redrefl τ)) σγs.
Definition rssubst₂ (Γ: Env) (σ: Exp) (τγs: list Exp) : list Exp :=
   List.map (fun γ => apRedSub (coidm (dom Γ) · γ) σ) τγs.
Definition rssubst (Γ: Env) (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rssubst₁ Γ σγs τ1) (rssubst₂ Γ σ2 τγs).

Lemma RsSubst₁ {Γ σγs σ σ' τ k1 k2} (wΓ: WfEnv Γ) :
  ⟨ Γ ► k1 ⊢ σγs : σ ↝* σ' ∷ k2 ⟩ →
  ⟨ Γ ⊢ τ ∷ k1 ⟩ →
  ⟨ Γ ⊢ rssubst₁ Γ σγs τ : σ[beta1 τ] ↝* σ'[beta1 τ] ∷ k2 ⟩.
Proof. intros wσγs; depind wσγs; crush. Qed.
Lemma RsSubst₂ {Γ σ τγs τ τ' k1 k2} (wΓ: WfEnv Γ) :
  ⟨ Γ ► k1 ⊢ σ ∷ k2 ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k1 ⟩ →
  ⟨ Γ ⊢ rssubst₂ Γ σ τγs : σ[beta1 τ] ↝* σ[beta1 τ'] ∷ k2 ⟩.
Proof.
  intros wσ wτγs; depind wτγs; crush;
  eauto 20 using red_co, co_agreement_right,
    wtredsub_idm, wtredsub_snoc_tyvar, red_redsub with ws.
Qed.
Lemma RsSubst {Γ σγs σ σ' τγs τ τ' k1 k2} (wΓ: WfEnv Γ) :
  ⟨ Γ ► k1 ⊢ σγs : σ ↝* σ' ∷ k2 ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k1 ⟩ →
  ⟨ Γ ⊢ rssubst Γ σγs σ σ' τγs τ τ' : σ[beta1 τ] ↝* σ'[beta1 τ'] ∷ k2 ⟩.
Proof.
  intros.
  eapply RsTrans.
  - eapply RsSubst₁; crush; eauto using redstar_co, co_agreement_left with ws.
  - eapply RsSubst₂; crush; eauto using redstar_co, co_agreement_right with ws.
Qed.

Lemma co_red {Γ γ σ τ k} (wγ : ⟨ Γ ⊢ γ : σ ~ τ ∷ k⟩)
  (wΓ: WfEnv Γ) (clΓ: CoVarClosed Γ) :
  ∃ υ,
    (∃ ηs, ⟨ Γ ⊢ ηs : τ ↝* υ ∷ k ⟩) ∧
    (∃ γs, ⟨ Γ ⊢ γs : σ ↝* υ ∷ k ⟩).
Proof.
  induction wγ; cbn; crushIH.
  - elimtype False; eapply clΓ; eauto.
  - destruct IHwγ as (υ & (ηs & wηs) & (γs & wγs)).
    exists (τabs k1 υ); split.
    + exists (rsτabs k1 ηs); eauto using RsTAbs.
    + exists (rsτabs k1 γs); eauto using RsTAbs.
  - destruct IHwγ1 as (υ1 & (γs21 & wγ21) & (γs11 & wγ11)).
    destruct IHwγ2 as (υ2 & (γs22 & wγ22) & (γs12 & wγ12)).
    exists (τapp υ1 υ2); split.
    + exists (rsτapp γs21 τ21 υ1 γs22 τ22 υ2).
      eapply RsTApp; crush; eauto using redstar_co, co_agreement_right.
    + exists (rsτapp γs11 τ11 υ1 γs12 τ12 υ2).
      eapply RsTApp; crush; eauto using redstar_co, co_agreement_left, co_agreement_right.
  - destruct IHwγ1 as (υ1 & (γs21 & wγ21) & (γs11 & wγ11)).
    destruct IHwγ2 as (υ2 & (γs22 & wγ22) & (γs12 & wγ12)).
    exists (arr υ1 υ2); split.
    + exists (rsarr γs21 τ21 υ1 γs22 τ22 υ2).
      eapply RsArr; crush; eauto using redstar_co, co_agreement_right.
    + exists (rsarr γs11 τ11 υ1 γs12 τ12 υ2).
      eapply RsArr; crush; eauto using redstar_co, co_agreement_left, co_agreement_right.
  - destruct IHwγ as (υ & (ηs & wηs) & (γs & wγs)).
    exists (arrτ k υ); split.
    + exists (rsarrτ k ηs).
      eapply RsArrT; eauto.
    + exists (rsarrτ k γs).
      eapply RsArrT; eauto.
  - destruct IHwγ1 as (υ1 & (γs1' & wγs1') & (γs1 & wγs1)).
    destruct IHwγ2 as (υ2 & (γs2' & wγs2') & (γs2 & wγs2)).
    destruct IHwγ3 as (υ3 & (γs3' & wγs3') & (γs3 & wγs3)).
    exists (arrγ υ1 υ2 k υ3); split.
    + exists (rsarrγ γs1' τ1' υ1 γs2' τ2' υ2 k γs3' τ3' υ3).
      eapply RsArrG; crush; eauto using redstar_co, co_agreement_left, co_agreement_right.
    + exists (rsarrγ γs1 τ1 υ1 γs2 τ2 υ2 k γs3 τ3 υ3).
      eapply RsArrG; crush; eauto using redstar_co, co_agreement_left, co_agreement_right.
  - destruct IHwγ as (? & (? & wηs) & (? & wγs)).
    apply arr_consistency in wγs; eauto.
    apply arr_consistency in wηs; eauto.
    crush.
  - destruct IHwγ as (? & (? & wηs) & (? & wγs)).
    apply arr_consistency in wγs; eauto.
    apply arr_consistency in wηs; eauto.
    crush.
  - destruct IHwγ1 as (υ & (ηs & wηs) & (γs & wγs)).
    apply arrτ_consistency in wγs; eauto.
    apply arrτ_consistency in wηs; eauto.
    destruct wγs as (υ1  & Heq1 & (γs1 & wγs1)).
    destruct wηs as (υ1' & Heq2 & (γs2 & wγs2)).
    destruct IHwγ2 as (υ2 & (ηs' & wηs') & (γs' & wγs')).
    exists (υ1[beta1 υ2]); split.
    + exists (rssubst Γ γs2 τ2 υ1 ηs' τ4 υ2).
      eapply RsSubst; crush.
    + exists (rssubst Γ γs1 τ1 υ1 γs' τ3 υ2).
      eapply RsSubst; crush.
  - destruct IHwγ as (υ & (ηs & wηs) & (γs & wγs)).
    apply arrγ_consistency in wγs; eauto.
    apply arrγ_consistency in wηs; eauto.
    crush.
  - destruct IHwγ as (υ & (ηs & wηs) & (γs & wγs)).
    apply arrγ_consistency in wγs; eauto.
    apply arrγ_consistency in wηs; eauto.
    crush.
  - destruct IHwγ as (υ & (ηs & wηs) & (γs & wγs)).
    apply arrγ_consistency in wγs; eauto.
    apply arrγ_consistency in wηs; eauto.
    crush.
  - destruct IHwγ1 as (υ1 & (γs1' & wγs1') & (γs1 & wγs1)).
    destruct IHwγ2 as (υ2 & (γs2' & wγs2') & (γs2 & wγs2)).
    exists (υ1[beta1 υ2]); split.
    + exists (rssubst Γ γs1' τ1' υ1 γs2' τ2' υ2).
      eapply RsSubst; crush.
    + exists (rsbeta k1 γs1 τ1 υ1 γs2 τ2 υ2); eapply RsBeta; crush;
        eauto using redstar_co, co_agreement_left, co_agreement_right with ws.
  - exists τ; split.
    + exists nil; crush.
    + exists nil; crush.
  - crush.
  - destruct IHwγ1 as (υl & (γsl1 & wγsl1) & (γsl2 & wγsl2)).
    destruct IHwγ2 as (υr & (γsr1 & wγsr1) & (γsr2 & wγsr2)).
    destruct (red_confluence wΓ clΓ wγsl1 wγsr2) as (υ & (ηsl & wηsl) & (ηsr & wηsr)).
    exists υ; split.
    + exists (rstrans γsr1 ηsr).
      eapply RsTrans; crush.
    + exists (rstrans γsl2 ηsl).
      eapply RsTrans; crush.
Qed.

Ltac consistency :=
  repeat
    (match goal with
       | [H: ⟨ _ ⊢ _ : _ ~ _ ∷ _ ⟩ |- _] =>
         eapply co_red in H
       | [H: ⟨ _ ⊢ _ : arr _ _ ↝ _ ∷ _ ⟩ |- _] =>
         inversion H; clear H
       | [H: ⟨ _ ⊢ _ : arr _ _ ↝* _ ∷ _ ⟩ |- _] =>
         eapply arr_consistency in H
       | [H: ⟨ _ ⊢ _ : arrτ _ _ ↝* _ ∷ _ ⟩ |- _] =>
         eapply arrτ_consistency in H
       | [H: ⟨ _ ⊢ _ : arrγ _ _ _ _ ↝* _ ∷ _ ⟩ |- _] =>
         eapply arrγ_consistency in H
     end; crush); eauto 20 with ws.