From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import family_of_sets.

Section FundamentalOfFamilySet.

  Variable U:Type.
  Variables X Y I:Ensemble U.
  (* F:U -> Ensemble U となるような写像を作る *)
  Definition FunctionOfFamilySet := U -> Ensemble U.

  Variable IndexedFunction : Ensemble U -> Ensemble U.
  Definition FunctionOfFamilySetUpCast (i:U) := IndexedFunction {|i|}.

  Goal forall (i:U)
              (Xn:Ensemble (Ensemble (Ensemble (Ensemble U))))
              (XX:Ensemble (Ensemble U)),
      i ∈ I -> MappingFamilyOfSets Xn FunctionOfFamilySetUpCast I XX <-> Xn ≔ IndexedFunction ⊦ (SetOfSingleton I) ⟼ XX.
  Proof.
    move => i Xn XX HiI.
    rewrite /iff.
    split => H.
    inversion H as [Hf HfS].
    split.
    apply /Extensionality_Ensembles.
    split => Z HZ.
    rewrite Hf in HZ.
    inversion HZ.
    inversion H0.
    split.
    split.
    rewrite H2.
    reflexivity.
    done.
    inversion HZ as [Ii Xi].
    rewrite Hf.
    inversion H0.
    apply ordered_pair_in_direct_product_iff_and in H3.
    inversion H3.
    inversion H4 as [i0].
    split.
    split.
    rewrite H2.
    rewrite -H7.
    reflexivity.
    apply ordered_pair_in_direct_product_iff_and.
    rewrite H7.
    apply H3.
    move => I0 HI0inII.
    inversion HI0inII as [i0].
    apply HfS.
    apply H0.
    split.
    inversion H.
    apply /Extensionality_Ensembles.
    split => Z HZ.
    rewrite H0 in HZ.
    inversion HZ as [I0 Xi].
    inversion H2.
    apply ordered_pair_in_direct_product_iff_and in H5.
    inversion H5.
    inversion H6 as [i0].
    split.
    split.
    rewrite H4.
    rewrite -H9.
    reflexivity.
    apply ordered_pair_in_direct_product_iff_and.
    rewrite H9.
    apply H5.
    inversion HZ.
    rewrite H0.
    inversion H2.
    split.
    split.
    rewrite H4.
    reflexivity.
    done.
    move => i0 Hi0inI.
    inversion H as [Hf HfS].
    apply HfS.
    split.
    apply Hi0inI.
  Qed.

  Goal forall (i:U)
              (Xn:Ensemble (Ensemble (Ensemble (Ensemble U))))
              (XX:Ensemble (Ensemble U)),
      i ∈ I /\ MappingFamilyOfSets Xn FunctionOfFamilySetUpCast I XX -> IndexedSet Xn i ∈ XX.
  Proof.
    move => i Xn XX [H [Hf HfS]].
    have L1: exists Xi:Ensemble U, ((|{|i|}, Xi|)) ∈ Xn.
    apply HfS.
    done.
    inversion L1 as [Xi].
    have L2: Xi = IndexedSet Xn i.
    apply /Extensionality_Ensembles.
    split => x H'.
    suff: ((|{|i|}, Xi|)) ∈ Xn /\ x ∈ Xi.
    apply Definition_of_IndexedSet.
    done.
    inversion H' as [x' Xi' []].
    rewrite Hf in H0.
    inversion H0.
    apply ordered_pair_iff in H4.
    inversion H4.
    inversion H5.
    inversion Hf in H1.
    inversion H1.
    apply ordered_pair_iff in H11.
    inversion H11.
    inversion H12.
    rewrite -H7.
    rewrite H8.
    apply (eq_singleton_eq_element_iff i0 i) in H6.
    apply (eq_singleton_eq_element_iff i1 i) in H13.
    rewrite H6 -H13 -H15 H14.
    done.
    rewrite -L2.
    rewrite Hf in H0.
    inversion H0 as [x' Xi' []].
    apply ordered_pair_iff in H3.
    inversion H3.
    apply ordered_pair_in_direct_product_iff_and in H2.
    inversion H2.
    rewrite H5 in H7.
    done.
  Qed.

  Goal forall (i:U)
              (Xn:Ensemble (Ensemble (Ensemble (Ensemble U))))
              (XX:Ensemble (Ensemble U)),
      i ∈ I /\ MappingFamilyOfSets Xn FunctionOfFamilySetUpCast I XX -> IndexedSet Xn i ∈ FamilyOfSets Xn.
  Proof.
    move => i Xn XX [H [Hf HfS]].
    have L1: exists Xi:Ensemble U, ((|{|i|}, Xi|)) ∈ Xn.
    apply HfS.
    done.
    inversion L1 as [Xi].
    have L2: Xi = IndexedSet Xn i.
    apply /Extensionality_Ensembles.
    split => x H'.
    suff: ((|{|i|}, Xi|)) ∈ Xn /\ x ∈ Xi.
    apply Definition_of_IndexedSet.
    done.
    inversion H' as [x' Xi' []].
    rewrite Hf in H0.
    inversion H0.
    apply ordered_pair_iff in H4.
    inversion H4.
    inversion H5.
    inversion Hf in H1.
    inversion H1.
    apply ordered_pair_iff in H11.
    inversion H11.
    inversion H12.
    rewrite -H7.
    rewrite H8.
    apply (eq_singleton_eq_element_iff i0 i) in H6.
    apply (eq_singleton_eq_element_iff i1 i) in H13.
    rewrite H6 -H13 -H15 H14.
    done.
    rewrite -L2.
    split.
    exists i.
    apply H0.
  Qed.

End FundamentalOfFamilySet.


Require Import Sty Subst Shape Msg Var.

Create HintDb nsequiv discriminated.

Inductive NSequiv : Sty -> Sty -> Prop :=
| NSequiv_send_S :
    forall B S S',
    NSequiv S S' ->
    NSequiv (send B S) (send B S')
| NSequiv_send_B :
    forall B B' S S',
    B <> B' ->
    NSequiv (send B S) (send B' S')
| NSequiv_recv_S :
    forall B S S',
    NSequiv S S' ->
    NSequiv (recv B S) (recv B S')
| NSequiv_recv_B :
    forall B B' S S',
    B <> B' ->
    NSequiv (recv B S) (recv B' S')
| NSequiv_echoice_l :
    forall S1 S2 S1' S2',
    NSequiv S1 S1' ->
    NSequiv (echoice S1 S2) (echoice S1' S2')
| NSequiv_echoice_r :
    forall S1 S2 S1' S2',
    NSequiv S2 S2' ->
    NSequiv (echoice S1 S2) (echoice S1' S2')
| NSequiv_ichoice_l :
    forall S1 S2 S1' S2',
    NSequiv S1 S1' ->
    NSequiv (ichoice S1 S2) (ichoice S1' S2')
| NSequiv_ichoice_r :
    forall S1 S2 S1' S2',
    NSequiv S2 S2' ->
    NSequiv (ichoice S1 S2) (ichoice S1' S2')
| NSequiv_mu_l :
    forall X S S',
    NSequiv (subst X (mu X S) S) S' ->
    NSequiv (mu X S) S'
| NSequiv_mu_r :
    forall X S S',
    NSequiv S (subst X (mu X S') S') ->
    NSequiv S (mu X S')
| NSequiv_shape :
    forall S S',
    shape S  <> muS ->
    shape S' <> muS ->
    shape S <> shape S' ->
    NSequiv S S'
.
Hint Constructors NSequiv : nsequiv.


Require Import Basics.
Require Import Paths.
Require Import HIT.
Require Import Polygraphs.
Require Import PolyMorphs.

(** This file contains the definition fo the unit of the adjunction, together with the proof of the first triangular identity. To do that, we first define and show some properties of the inclusion of n-polygraphs into (n+1)-polygraphs **)

Definition EmptyA (n : nat) (T : Type) : Aug T n := mkAug False (fun x => False_rect _ x.1).

Definition Empty {n : nat} (p : Pol n) : Pol (S n) :=  Ext p (EmptyA (S n) (Free p)).

Definition FreeEmptyA (n : nat) (T : Type) : T -> FreeA (EmptyA n T) := inl.

Definition FreeEmpty {n :nat} (p : Pol n) : Free p -> Free (Empty p) := FreeEmptyA (S n) (Free p).

Definition EmptyMA (n : nat) (T : Type) (aug : Aug T n) : MAug (fun x => x) (EmptyA n T) aug.
Proof.
  simpl. unshelve econstructor.
  - exact (False_rect _).
  - simpl. intro. contradiction.
Defined.

Lemma EmptyExtensionInitial {n : nat} {p : Pol n} (aug : Aug (Free p) (S n)) : MPol (Empty p) (Ext p aug).
Proof.
  unfold Empty.
  unshelve econstructor.
  - exact (fstd IdAndFreeM p).
  - simpl. change (MAug (FreeM (fstd IdAndFreeM p)) (EmptyA (S n) (Free p)) aug).
    simple refine (eq_rect (fun W => MAug W (EmptyA (S n) (Free p)) aug) _ _).
    + exact (fun x => x).
    + exact (EmptyMA _ _ _).
    + exact ((sndd IdAndFreeM p) ^).
Defined.

Definition injectA {n : nat} {F : Type} (aug : Aug F n) : F -> FreeA aug := compose (FreeMA (EmptyMA n F aug)) (FreeEmptyA n F).

Definition injectPol {n :nat} (p : Pol n) (aug : Aug (Free p) (S n)) : Free p -> Free (Ext p aug) := injectA aug.

(** Unit and triangular identity **)

Definition UnitA  {n : nat} {F T : Type}  (aug : Aug F n) (f : FreeA aug -> T) :
  aug - (injectA aug) -- (ForgetA f n).
Proof.
  unshelve econstructor.
  - intro e. simple refine (mkPullB _ _ _).
    + intro b. apply f. simpl. simple refine (inr _). exact (e, b).
    + intro. simple refine (inl _). exact (d aug (e, X)).
    + apply funext. intro. unfold nFaces. unfold compose. exact (f_equal f (incoh (e, x))^).
  - simpl. intros. reflexivity.
Defined.

Definition TriangleA  {n : nat} {F T : Type}  (aug : Aug F n) (f : FreeA aug -> T) :
  compose (CounitA n f) (FreeMA (UnitA aug f)) = f.
Proof.
  apply funext. simple refine (eqMorphPushout _ _ _).
  - reflexivity.
  - intro b2. unfold compose. simpl. destruct b2. reflexivity.
  - intros [a a']. simpl.
    simple refine (concat_1p _ @ _).
    match goal with
    | |- _ = f_equal (compose ?f ?g) ?p => simple refine (_ @ (ap_compose g f p)^)
    end.
    unfold compose.
    match goal with
    | |- _ = f_equal ?f _ => simple refine (_ @ f_equal (@f_equal _ _ f _ _) Pushout_rect_compute_coh^)
    end.
    simpl.
    rewrite concat_1p.
    unfold CounitA.
    simple refine (_ @ Pushout_rect_compute_coh^). simpl.
    simple refine (_ @ (concat_ap_V _ _)^).
    simple refine (_ @ (f_equal (fun W => W ^) (funextcompute _ a')^)). simpl.
    match goal with
    | |- _ = (f_equal f ?p ^)^ =>
      simple refine (_ @ f_equal (fun W => W^ ) (concat_ap_V f p)^);
        exact ((concat_VV _)^)
    end.
Defined.

(** The previous two lemmas seem like the correct notions of units and triangle identity for augmentations. However, it turns out that the proof of polygraphs requires the following two more complicated versions **)

Definition UnitBisA {n : nat} {F : Type} (aug : Aug F (S n)) (f : F -> (Free (Forget (FreeA aug) n)))
           (H : compose (Counit (FreeA aug) n) f = injectA aug):
  aug - f -- (ForgetA (Counit (FreeA aug) n) (S n)).
Proof.
  unshelve econstructor.
  -  intro e. simpl. simple refine (mkPullB _ _ _).
     + intro x. exact (inr (e, x)).
     + intro x. simpl.
       apply f. exact (d aug (e, x)).
     + unfold nFaces. unfold compose. apply funext. intro x.
       simple refine (_ @ (f_equal (fun W => W (d aug (e, x))) H^)).
       exact ((incoh (e, x))^).
  - reflexivity.
Defined.

Lemma TriangleABis {n : nat} {F : Type} (aug : Aug F (S n)) (f : F -> (Free (Forget (FreeA aug) n)))
           (H : compose (Counit (FreeA aug) n) f = injectA aug):
           compose (CounitA (S n) (Counit (FreeA aug) n))
                   (FreeMA (UnitBisA aug f H)) = (fun x : FreeA aug => x).
Proof.
  apply funext. simple refine (eqMorphPushout _ _ _).
  - intro b1. unfold compose. simpl. exact (f_equal (fun W => W b1) H).
  - intro b2. unfold compose. simpl. destruct b2. reflexivity.
  - intros a. unfold compose. simpl.
    match goal with
    | |- _ = f_equal (fun x => CounitA ?a1 ?a2  (@?W x)) (incoh a) =>
      change (f_equal (fun x => CounitA a1 a2 (W x)) (incoh a)) with
          (f_equal (compose (CounitA a1 a2) W) (incoh a));
        simple refine (_ @ (ap_compose W (CounitA a1 a2) (incoh a))^)
    end. unfold compose. unfold CounitA.
    match goal with
    | |- _ = f_equal ?f _  => simple refine (_ @ (f_equal (fun W => f_equal f W) Pushout_rect_compute_coh^))
    end. simpl.
    match goal with
    | |- _ = f_equal ?f (1 @ ?p)  => simple refine (_ @ (f_equal (fun W => f_equal f W) (concat_1p p )^))
    end.
    match goal with
    | |- _ = f_equal (Pushout_rect ?a1 ?a2 ?a3) (incoh ?a4) =>
      simple refine (_ @ (Pushout_rect_compute_coh (f1 := (fun x  => pi2 x.1 x.2)) )^)
    end.
    simpl.
    match goal with
    | |- _ = f_equal ?f ?p ^ => simple refine (_ @ (concat_ap_V f p)^)
    end.
    match goal with
    | |- _ = (f_equal (fun W => W a.2) (funext ?p))^ =>
      simple refine (_ @ (f_equal (fun W => W^) (funextcompute p a.2)^))
    end.
    match goal with
    | |- ?p @ _ = _ => simple refine ((f_equal (fun W => p @ W) (f_equal_id _)) @ _)
    end.
    simple refine (_ @ (concat_V _ _)^).
    match goal with
    | |- _ = ?p ^ @ ?q ^ ^ =>
      simple refine (_ @ f_equal (fun W => p ^ @ W) (concat_VV _)^);
        simple refine (_ @ f_equal (fun W => W ^ @ q) (concat_ap_V _ _)^);
        exact (f_equal (fun W => W @ q) (concat_VV _)^)
    end.
Defined.

Fixpoint UnitPol {n : nat} (p : Pol n) {struct n} : {f :  MPol p (Forget (Free p) n) |
                                                              compose (Counit (Free p) n) (FreeM f) = (fun x => x)}.
Proof.
  destruct n.
  - simple refine (mkDPair _ _).
    + destruct p using case0. econstructor. exact (fun x => x).
    + destruct p using case0. exact 1.
  - simple refine (mkDPair _ _); destruct p as [p aug] using caseS'.
    + simpl. unshelve econstructor.
      * exact (ComposeM (fstd (UnitPol n p)) (ForgetM n (injectPol p aug) ) ).
      * simpl.  simple refine (UnitBisA _ _ _).
        match goal with
          |- compose ?f _ = _ => simple refine (f_equal (fun W => compose f W) (FreeComposeM _ _) @ _)
        end.
        match goal with
        | |- compose ?f (compose ?g ?h) = _ => change (compose f (compose g h)) with (compose (compose f g) h);
                                               simple refine (f_equal (fun W => compose W h) (CounitM _ _) @ _)
        end.
        match goal with
        | |- compose (compose ?f ?g) ?h = _ => change (compose (compose f g) h) with (compose f (compose g h));
                                           exact (f_equal (fun W => compose f W) (sndd (UnitPol _ _)))
        end.
    + simpl.
      simple refine (TriangleABis _ _ _).
Defined.

Notation Unit p := (fstd (UnitPol p)).
Notation FreeTriangular p := (sndd (UnitPol p)).


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Set Implicit Arguments.

Import WfExtensionality.

Require Export common.CpdtTactics.
Require Export common.wyv_common.
Require Export common.rhs_mat_tree.

Lemma subtype_nom_nom_reduce :
  forall T1 L1 T1', T1 = (t_nom L1 T1') ->
               forall T2 L2 T2', T2 = (t_nom L2 T2') ->
                            subtype T1 T2 = (eq_label L1 L2) && (eq_tree T1' T2').
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import LibLN.
Set Implicit Arguments.

Inductive avar: Set :=
| avar_b: nat -> avar
| avar_f: var -> avar.

Inductive typ: Set :=
| typ_top: typ
| typ_bot: typ
| typ_var: avar -> typ
| typ_fun: typ -> typ -> typ
| typ_pair: typ -> typ -> typ
(*  \mu alpha . T1 -> T2 *)
| typ_mu : typ -> typ -> typ.

Definition ctx := env typ.

Definition open_rec_avar (k: nat) (u: var) (a: avar) : avar :=
  match a with
  | avar_b i => If k = i then avar_f u else avar_b i
  | avar_f x => avar_f x
  end.

Fixpoint open_rec_typ (k: nat) (u: var) (T: typ): typ :=
  match T with
  | typ_top        => typ_top
  | typ_bot        => typ_bot
  | typ_var a      => typ_var (open_rec_avar k u a)
  | typ_fun T1 T2  => typ_fun  (open_rec_typ k u T1) (open_rec_typ k u T2)
  | typ_pair T1 T2 => typ_pair (open_rec_typ k u T1) (open_rec_typ k u T2)
  | typ_mu T1 T2   => typ_mu (open_rec_typ (S k) u T1) (open_rec_typ (S k) u T2)
  end.

Definition open_avar u a := open_rec_avar  0 u a.
Definition open_typ  u t := open_rec_typ   0 u t.

(* G A |- T wf
   G: env
   A: wf-ness assumptions
   T: type to be checked *)
Inductive wf_typ: ctx -> fset typ -> typ -> Prop :=
| wf_top: forall G A, wf_typ G A typ_top
| wf_bot: forall G A, wf_typ G A typ_bot
| wf_var: forall G A a T,
    binds a T G ->
    wf_typ G A T -> (* <-- makes finite proofs of recursive types impossible
                           (unless we have an assumption mechanism) *)
    wf_typ G A (typ_var (avar_f a))
| wf_hyp: forall G A T,
    T \in A ->
    wf_typ G A T
| wf_fun : forall G A T1 T2, wf_typ G A T1 -> wf_typ G A T2 -> wf_typ G A (typ_fun  T1 T2)
| wf_pair: forall G A T1 T2, wf_typ G A T1 -> wf_typ G A T2 -> wf_typ G A (typ_pair T1 T2)
| wf_mu: forall L G A T1 T2,
    (forall a, a \notin L ->
       wf_typ (G & a ~ (typ_mu T1 T2)) (A \u \{ typ_mu T1 T2 }) (open_typ a T1)) ->
    (forall a, a \notin L ->
       wf_typ (G & a ~ (typ_mu T1 T2)) (A \u \{ typ_mu T1 T2 }) (open_typ a T2)) ->
    wf_typ G A (typ_mu T1 T2).

Ltac do_open :=
  repeat match goal with
  | _: _ |- context[open_avar _ _] => unfold open_avar; simpl
  | _: _ |- context[open_typ  _ _] => unfold open_typ ; simpl
  | _: _ |- context[(If _ = _ then _ else _)] => case_if; simpl
  end.

Ltac prove_binds := solve [
  unfold binds; rewrite EnvOps.get_def; unfold get_impl;
  repeat (rewrite <- cons_to_push || case_if); auto].

Module ex1.

(* stream = top -> top * stream *)
Example stream := typ_mu typ_top (typ_pair typ_top (typ_var (avar_b 0))).

Example stream_wf: wf_typ empty \{} stream.
  unfold stream.
  apply wf_mu with \{}; intros a _; do_open.
  - apply wf_top.
  - apply wf_pair.
    + apply wf_top.
    + eapply wf_var.
      * prove_binds.
      * apply wf_hyp. rewrite in_union. right. rewrite in_singleton. reflexivity.
Qed.

End ex1.

Hint Constructors wf_typ.

(* ###################################################################### *)
(** ** Free variables *)

Definition fv_avar (a: avar) : vars :=
  match a with
  | avar_b i => \{}
  | avar_f x => \{x}
  end.

Fixpoint fv_typ (T: typ) : vars :=
  match T with
  | typ_top        => \{}
  | typ_bot        => \{}
  | typ_var a      => (fv_avar a)
  | typ_fun T U    => (fv_typ T) \u (fv_typ U)
  | typ_pair T U   => (fv_typ T) \u (fv_typ U)
  | typ_mu T U     => (fv_typ T) \u (fv_typ U)
  end.

Definition fv_ctx_types(G: ctx): vars := (fv_in_values (fun T => fv_typ T) G).

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars      => x         ) in
  let B := gather_vars_with (fun x : var       => \{ x }    ) in
  let C := gather_vars_with (fun x : ctx       => (dom x) \u (fv_ctx_types x)) in
  let E := gather_vars_with (fun x : avar      => fv_avar  x) in
  let I := gather_vars_with (fun x : typ       => fv_typ   x) in
  constr:(A \u B \u C \u E \u I).

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

(* Locate "_ \- _". called remove (set difference) *)

Lemma add_hyps: forall A1 A2 G T,
  wf_typ G A1 T ->
  wf_typ G (A1 \u A2) T.
Proof.
  introv Wf. induction Wf; eauto.
  + (* case wf_hyp *)
    apply wf_hyp. rewrite in_union. auto.
  + (* case wf_mu *)
    rename H0 into IH1, H2 into IH2, H into Wf1, H1 into Wf2.
    rewrite <- union_assoc in *.
    rewrite (union_comm \{ typ_mu T1 T2 } A2) in *.
    rewrite union_assoc in *.
    eauto.
Qed.

Lemma weaken_wf: forall G A T, wf_typ G A T -> forall G1 G2 G3,
  G = G1 & G3 ->
  ok (G1 & G2 & G3) ->
  wf_typ (G1 & G2 & G3) A T.
Proof.
  introv Wf. induction Wf; intros; subst G; eauto.
  + (* case wf_var *)
    eapply wf_var.
    - apply* binds_weaken.
    - apply* IHWf.
  + (* case wf_mu *)
    rename H0 into IH1, H2 into IH2, H into Wf1, H1 into Wf2.
    apply_fresh wf_mu as a; rewrite <- concat_assoc.
    - refine (IH1 a _ G1 G2 (G3 & a ~ typ_mu T1 T2) _ _);
      try rewrite concat_assoc; auto.
    - refine (IH2 a _ G1 G2 (G3 & a ~ typ_mu T1 T2) _ _);
      try rewrite concat_assoc; auto.
Qed.

Lemma weaken_wf_end: forall G1 G2 A T,
  wf_typ G1 A T ->
  ok (G1 & G2) ->
  wf_typ (G1 & G2) A T.
Proof.
  introv Wf Ok.
  lets Wf': (@weaken_wf _ _ _ Wf G1 G2 empty).
  repeat rewrite concat_empty_r in Wf'.
  auto.
Qed.

Lemma remove_from_hyps: forall G A T U,
  wf_typ G A T ->
  wf_typ G \{} U ->
  ok G ->
  wf_typ G (A \- \{ U }) T.
Proof.
  introv Wf WfU Ok. induction Wf; eauto.
  + (* case wf_hyp *)
    destruct (classicT (T = U)) as [Eq | Ne].
    - subst T. rewrite <- (union_empty_l (A \- \{ U })). apply add_hyps. exact WfU.
    - apply wf_hyp. rewrite in_remove. apply (conj H). rewrite notin_singleton. exact Ne.
  + (* case wf_mu *)
    rename H0 into IH1, H2 into IH2, H into Wf1, H1 into Wf2.
    destruct (classicT ((typ_mu T1 T2) = U)) as [Eq | Ne].
    - rewrite <- (union_empty_l (A \- \{ U })). subst U. apply add_hyps. exact WfU.
    - assert (Eq: (A \u \{ typ_mu T1 T2}) \- \{ U} = (A \- \{ U } \u \{ typ_mu T1 T2})). {
        apply fset_extens; unfold subset; intros X H;
        repeat (rewrite in_remove in * || rewrite in_union in *).
        + auto_star.
        + destruct H as [[H1 H2] | H].
          - auto.
          - rewrite in_singleton in H. subst X. split.
            * right. rewrite in_singleton. reflexivity.
            * rewrite notin_singleton. exact Ne.
      }
      rewrite Eq in *.
      apply_fresh wf_mu as a;
      assert (Ok': ok (G & a ~ typ_mu T1 T2)) by auto;
      lets WfU': (weaken_wf_end WfU Ok').
      * apply* IH1.
      * apply* IH2.
Qed.

Lemma singleton_remove: forall (T: Type) (v: T),
  \{ v } \- \{ v } = \{}.
Proof.
  intros. apply fset_extens; unfold subset; intros.
  - rewrite in_remove in H. destruct H as [H1 H2]. rewrite in_singleton in H1. subst.
    exfalso. rewrite notin_singleton in H2. apply H2. reflexivity.
  - exfalso. apply (notin_empty H).
Qed.

Lemma invert_wf_mu: forall G T1 T2,
  wf_typ G \{} (typ_mu T1 T2) ->
  ok G ->                        (*   empty (that's the whole point) *)
  exists L,                      (*     |                            *)
    (forall a, a \notin L ->     (*     V                            *)
       wf_typ (G & a ~ (typ_mu T1 T2)) \{} (open_typ a T1)) /\
    (forall a, a \notin L ->
       wf_typ (G & a ~ (typ_mu T1 T2)) \{} (open_typ a T2)).
Proof.
  introv Wf. inversion Wf; subst.
  - exfalso. rewrite in_empty in H. exact H.
  - intro Ok. exists (L \u (dom G)).
    split;
    [(rename H3 into IH; clear H4) | (rename H4 into IH; clear H3)];
    intros a aFr;
    assert (aL: a \notin L) by auto;
    specialize (IH a aL);
    rewrite union_empty_l in IH;
    assert (Ok': ok (G & a ~ typ_mu T1 T2)) by auto;
    lets Wf': (weaken_wf_end Wf Ok');
    lets P: (remove_from_hyps IH Wf' Ok');
    rewrite singleton_remove in P;
    exact P.
Qed.

Print Assumptions invert_wf_mu.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Injection.

Set Printing Universes.
Set Primitive Projections.
Set Universe Polymorphism.

Section pair.
  Polymorphic Universes i j.
  Variable (T : Type@{i}) (U : Type@{j}).

  Polymorphic Record pprod : Type@{max (i, j)} := ppair
  { pfst : T
  ; psnd : U }.

End pair.

Arguments pprod _ _ : assert.
Arguments ppair {_ _} _ _.
Arguments pfst {_ _} _.
Arguments psnd {_ _} _.

Section equality.
  Polymorphic Lemma eq_pair_rw
  : forall T U (a b : T) (c d : U) (pf : (ppair a c) = (ppair b d)),
    exists (pf' : a = b) (pf'' : c = d),
      pf = match pf' , pf'' with
           | eq_refl , eq_refl => eq_refl
           end.
  Proof.
    clear.
    intros.
    exists (f_equal pfst pf).
    exists (f_equal psnd pf).
    change (pf =
            match
              @f_equal (pprod T U) T (@pfst T U) (ppair a c) (ppair b d) pf in (_ = t)
              return ((ppair a c) = (ppair t d))
            with
            | eq_refl =>
              match
                @f_equal (pprod T U) U (@psnd T U) (ppair a c) (ppair b d) pf in (_ = u)
                return ((ppair a c) = (ppair (pfst (ppair a c)) u))
              with
              | eq_refl => @eq_refl (pprod T U) (ppair a c)
              end
            end).
    generalize dependent (ppair a c).
    intros; subst. reflexivity.
  Defined.
End equality.

Section Injective.
  Polymorphic Universes i j.
  Context {T : Type@{i}} {U : Type@{j}}.

  Global Instance Injective_pprod (a : T) (b : U) c d
  : Injective (ppair a b = ppair c d).
  Proof.
  refine {| result := a = c /\ b = d |}.
    intros.
    change a with (pfst@{i j} {| pfst := a ; psnd := b |}).
    change b with (psnd@{i j} {| pfst := a ; psnd := b |}) at 2.
    rewrite H. split; reflexivity.
  Defined.
End Injective.

Section PProdEq.
  Polymorphic Universes i j.
  Context {T : Type@{i}} {U : Type@{j}}.
  Context {EDT : RelDec (@eq T)}.
  Context {EDU : RelDec (@eq U)}.
  Context {EDCT : RelDec_Correct EDT}.
  Context {EDCU : RelDec_Correct EDU}.

  Polymorphic Definition ppair_eqb (p1 p2 : pprod T U) : bool :=
    pfst p1 ?[ eq ] pfst p2 && psnd p1 ?[ eq ] psnd p2.

  (** Specialization for equality **)
  Global Polymorphic Instance RelDec_eq_ppair : RelDec (@eq (@pprod T U)) :=
  { rel_dec := ppair_eqb }.

  Global Polymorphic Instance RelDec_Correct_eq_ppair
  : RelDec_Correct RelDec_eq_ppair.
  Proof.
    constructor. intros p1 p2. destruct p1, p2. simpl.
    unfold ppair_eqb. simpl.
    rewrite Bool.andb_true_iff.
    repeat rewrite rel_dec_correct.
    split.
    { destruct 1. f_equal; assumption. }
    { intros. inv_all. tauto. }
  Qed.

End PProdEq.


(***************************************************************************
* Formalization of lambda j						   *
*									   *
* General rewriting lemmas		                                   *
*									   *
* 			                                                   *
***************************************************************************)

Require Import Metatheory.
Require Import LambdaES_Defs.
Require Import LambdaES_Infra.
Require Import LambdaES_FV.
Require Import Rewriting_Defs.

(** Given a reduction, the composition of two star closure is still a star closure *)

Lemma star_transitive_closure:
    forall (Red: pterm -> pterm -> Prop) (t u v : pterm),
     Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
 intros Red t u v H0 H1.
 induction H1.
   apply star_trans_reduction.
   apply one_step_reduction.
   assumption.
   apply star_trans_reduction.
   apply transitive_reduction with (u := t0); trivial.
Qed.

Lemma transitive_closure_composition :
    forall Red t u v, trans_closure Red t u -> trans_closure Red u v -> trans_closure Red t v.
Proof.
  intros.
  induction H.
    apply transitive_reduction with (u := u); trivial.
    apply transitive_reduction with (u := u) ; auto.
Qed.

Lemma star_transitive_closure_composition_1 :
    forall Red t u v, trans_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros.
  induction H0.
    apply star_trans_reduction; trivial.
    apply star_trans_reduction.
    apply transitive_closure_composition with (u := t0); trivial.
Qed.

Lemma star_transitive_closure_composition_2 :
    forall Red t u v, star_closure Red t u -> trans_closure Red u v -> star_closure Red t v.
Proof.
  intros.
  induction H.
    apply star_trans_reduction; trivial.
    apply star_trans_reduction.
    apply transitive_closure_composition with (u := u); trivial.
Qed.

Lemma star_closure_composition:
    forall Red t u v, star_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros.
  induction H.
  assumption.
  apply star_transitive_closure_composition_1 with (u := u); assumption.
Qed.

Lemma transitive_star_derivation:
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v -> exists u, Red t u /\  star_closure Red u v.
Proof.
  intros.
  case H. intros t' u' H0.
  exists u'. split; trivial.
  apply reflexive_reduction.
  intros t' u' v' H0 H1. exists u'.
  split; trivial.
  apply star_trans_reduction; trivial.
Qed.

Lemma transitive_star_derivation':
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v <-> (Red t v \/ (exists u, Red t u /\  (exists u', star_closure Red u u' /\ Red u' v))).
Proof.
 intros. split. intros. destruct H.
 left; trivial. right. exists u. split; trivial.
 clear H. induction H0. exists t0. split; trivial.
 apply reflexive_reduction. destruct IHtrans_closure.
 exists x. split. apply star_transitive_closure with (u := u); trivial.
 apply H1. apply H1. intros. case H. intro.
 apply one_step_reduction; trivial. intro.
 destruct H0. destruct H0. destruct H1. destruct H1. destruct H1.
 apply transitive_reduction with (u := t0); trivial.
 apply one_step_reduction; trivial.
 apply transitive_reduction with (u := t0); trivial.
 apply transitive_closure_composition with (u := u); trivial.
 apply one_step_reduction; trivial.
Qed.

Lemma star_transitive_derivation: forall (Red : pterm -> pterm -> Prop) (t u: pterm),
      star_closure Red t u <-> (t = u \/ trans_closure Red t u).
Proof.
 intros. split. intro. destruct H.
 left. reflexivity. right; trivial.
 intro. case H.
 clear H. intro H. rewrite H. apply reflexive_reduction.
 clear H. intro H. apply star_trans_reduction; trivial.
Qed.

Lemma contextual_R1_R2: forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', contextual_closure R1 t t' -> contextual_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply redex. apply H; trivial.
 apply app_left; trivial.
 apply app_right; trivial.
 apply abs_in with (L := L); trivial.
 apply subst_left with (L := L); trivial.
 apply subst_right; trivial.
Qed.

Lemma trans_R1_R2 : forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', trans_closure R1 t t' -> trans_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply one_step_reduction. apply H; trivial.
 apply transitive_reduction with (u := u); trivial.
 apply H; trivial.
Qed.

Lemma star_R1_R2: forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', star_closure R1 t t' -> star_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply reflexive_reduction.
 apply star_trans_reduction.
 apply trans_R1_R2 with (R1 := R1); trivial.
Qed.

Lemma ctx_red_h_mult_app : forall R t t' lu, term %% lu -> (contextual_closure R) t t' -> (contextual_closure R) (t // lu) (t' // lu).
Proof.
 intros R t t' lu Tlu H. induction lu; simpl in *|-*; trivial.
 destruct Tlu. apply app_left; trivial.
 apply IHlu; trivial.
Qed.

Lemma Lctx_red_h_mult_app : forall R t t' lu, Lterm %% lu -> (L_contextual_closure R) t t' -> (L_contextual_closure R) (t // lu) (t' // lu).
Proof.
 intros R t t' lu Tlu H. induction lu; simpl in *|-*; trivial.
 destruct Tlu. apply L_app_left; trivial.
 apply IHlu; trivial.
Qed.

Lemma Lctx_red_t_mult_app : forall R t lu lu', Lterm t -> Lterm %% lu -> R_list (L_contextual_closure R) lu lu' -> (L_contextual_closure R) (t // lu) (t // lu').
Proof.
 intros R t lu lu' Tt Tlu H. unfold R_list in H.
 case H; clear H; intros t0 H.
 case H; clear H; intros t1 H.
 case H; clear H; intros l0 H.
 case H; clear H; intros l1 H.
 destruct H. destruct H0.
 rewrite H. rewrite H0. rewrite H in Tlu.
 clear H H0. induction l0; simpl. destruct l1; simpl.
 apply L_app_right; trivial.
 apply L_app_right; trivial.
 simpl in Tlu. apply Lterm_app. rewrite Lterm_mult_app.
 destruct Tlu. destruct H0.
 split; trivial. apply Tlu.
 simpl in Tlu. destruct Tlu.
 apply L_app_left; trivial.
 apply IHl0; trivial.
Qed.

(* ********************************************************************** *)
(** Some relations between the properties of relations *)

Lemma red_all_to_out : forall (R : pterm -> pterm -> Prop),
  red_all R -> red_refl R -> red_out R.
Proof.
  intros_all. auto*.
Qed.

Lemma red_out_to_out' : forall (R : pterm -> pterm -> Prop),
  red_out R -> red_out' R.
Proof.
 intros_all. apply H; trivial.
Qed.

Lemma red_out'_to_rename : forall (R : pterm -> pterm -> Prop),
  red_out' R -> red_rename R.
Proof.
  intros_all.
  rewrite* (@subst_intro x t).
  rewrite* (@subst_intro x t').
Qed.

Lemma red_out_to_rename : forall (R : pterm -> pterm -> Prop),
  red_out R -> red_rename R.
Proof.
  intros. apply red_out'_to_rename.
  apply red_out_to_out'; trivial.
Qed.

Lemma L_red_out_to_rename : forall (R : pterm -> pterm -> Prop),
  L_red_out R -> red_rename R.
Proof.
  intros_all.
  rewrite* (@subst_intro x t).
  rewrite* (@subst_intro x t').
Qed.

Lemma red_all_to_through : forall (R : pterm -> pterm -> Prop),
  red_regular R -> red_all R -> red_through R.
Proof.
  intros_all. lets: (H _ _ H4).
  rewrite* (@subst_intro x t1).
  rewrite* (@subst_intro x u1).
Qed.

Lemma red_out_to_swap : forall (R : pterm -> pterm -> Prop),
  red_out R -> red_swap R.
Proof.
  intros_all. pick_fresh z.
  apply notin_union in Fr; destruct Fr.
  apply notin_union in H1; destruct H1.
  apply notin_union in H1; destruct H1.
  apply notin_singleton in H1.
  apply notin_singleton in H4.
  repeat rewrite <- swap_eq_subst with (z := z); trivial.
  repeat apply H; trivial.
Qed.

Lemma red_rename_to_rename' : forall (R : pterm -> pterm -> Prop),
  red_rename R -> red_rename' R. Print red_rename'.
Proof.
 intros_all. apply H with (x := x); trivial.
Qed.

Lemma red_swap_to_rename' : forall (R : pterm -> pterm -> Prop),
  red_swap R -> red_rename' R.
Proof.
  intros_all. unfold red_swap in H.
  case (x == y); intro H'. rewrite <- H'; trivial.
  apply (H x (t ^ x) (t' ^ x) y) in H4. unfold open in *|-*.
  rewrite open_swap_comm in H4.  rewrite open_swap_comm in H4.
  simpl in H4. case (x == y); case (x == x) in H4; intros; try contradiction. clear e n.
  rewrite swap_fresh in H4; trivial. rewrite swap_fresh in H4; trivial.
  apply False_ind. apply n; trivial.
Qed.

Lemma red_out'_to_swap : forall (R : pterm -> pterm -> Prop),
  red_out' R -> red_swap R.
Proof.
  intros_all. pick_fresh z.
  apply notin_union in Fr; destruct Fr.
  apply notin_union in H1; destruct H1.
  apply notin_union in H1; destruct H1.
  apply notin_singleton in H1.
  apply notin_singleton in H4.
  repeat rewrite <- swap_eq_subst with (z := z); trivial.
  repeat apply H; trivial.
Qed.

Lemma red_regular_ctx: forall (R : pterm -> pterm -> Prop),
  red_regular R -> red_regular (contextual_closure R).
 Proof.
  intros_all. induction H0.
  apply H; trivial.
  case IHcontextual_closure; clear IHcontextual_closure.
  intros H2 H3. split;
  apply term_distribute_over_application; split ; trivial.
  case IHcontextual_closure; clear IHcontextual_closure.
  intros H2 H3. split;
  apply term_distribute_over_application; split ; trivial.
  split; apply body_to_term_abs; unfold body; exists L;
  intros; apply H1; trivial.
  split; apply body_to_subs; trivial; unfold body; exists L;
  intros; apply H2; trivial.
  split; apply body_to_subs; trivial; apply IHcontextual_closure.
Qed.

Lemma red_regular_Lctx : forall (R : pterm -> pterm -> Prop),
  L_red_regular R -> L_red_regular (L_contextual_closure R).
Proof.
  intros_all. induction H0.
  apply H; trivial.
  destruct IHL_contextual_closure.
  split; apply Lterm_app; trivial. split; apply Lterm_app; trivial.
  apply IHL_contextual_closure. apply IHL_contextual_closure.
  split; apply Lterm_abs with (L := L); apply H1; trivial.
Qed.

Lemma red_regular'_pctx : forall (R : pterm -> pterm -> Prop),
  red_regular' R -> red_regular' (p_contextual_closure R).
Proof.
  intros_all. induction H0.
  apply H; trivial.
  split. intro H1.
  apply term_distribute_over_application.
  apply term_distribute_over_application in H1.
  destruct H1. split.
  apply IHp_contextual_closure1; trivial.
  apply IHp_contextual_closure2; trivial.
  intro H1.
  apply term_distribute_over_application.
  apply term_distribute_over_application in H1.
  destruct H1. split.
  apply IHp_contextual_closure1; trivial.
  apply IHp_contextual_closure2; trivial.
  split. intro H2.
  apply body_to_term_abs. apply term_abs_to_body in H2.
  unfold body. exists (L \u (fv t)). intros x Fr.
  apply notin_union in Fr. destruct Fr. apply (H1 x); trivial.
  apply body_to_term; trivial.
  intro H2.
  apply body_to_term_abs. apply term_abs_to_body in H2.
  unfold body. exists (L \u (fv t')). intros x Fr.
  apply notin_union in Fr. destruct Fr. apply (H1 x); trivial.
  apply body_to_term; trivial.
  split. intro H3. apply subs_to_body in H3. destruct H3.
  apply body_to_subs. unfold body. exists (L \u (fv t)). intros x Fr.
  apply notin_union in Fr. destruct Fr. apply (H1 x); trivial.
  apply body_to_term; trivial. apply IHp_contextual_closure; trivial.
  intro H3. apply subs_to_body in H3. destruct H3.
  apply body_to_subs. unfold body. exists (L \u (fv t')). intros x Fr.
  apply notin_union in Fr. destruct Fr. apply (H1 x); trivial.
  apply body_to_term; trivial. apply IHp_contextual_closure; trivial.
Qed.

Lemma red_regular_trs : forall (R : pterm -> pterm -> Prop),
  red_regular R -> red_regular (trans_closure R).
Proof.
 intros_all. induction H0.
 apply H; trivial.
 apply H in H0. split;
 [apply H0 | apply IHtrans_closure].
Qed.

Lemma red_regular'_trs : forall (R : pterm -> pterm -> Prop),
  red_regular' R -> red_regular' (trans_closure R).
Proof.
 intros_all. induction H0.
 apply H; trivial.
 apply H in H0. split.
 intro. apply IHtrans_closure. apply H0. trivial.
 intro. apply H0. apply IHtrans_closure. trivial.
Qed.

Lemma red_out_ctx : forall (R : pterm -> pterm -> Prop),
  red_out R -> red_out (contextual_closure R).
Proof.
 intros_all. induction H1.
 apply redex. apply H; trivial.
 simpl. apply app_left; trivial.
 apply term'_to_term.
 unfold term'. apply lc_at_subst;
 apply term_to_term'; trivial.
 simpl. apply app_right; trivial.
 apply term'_to_term.
 unfold term'. apply lc_at_subst;
 apply term_to_term'; trivial.
 simpl. apply abs_in with (L := L \u {{x}}).
 intros x0 Fr. apply notin_union in Fr. case Fr.
 clear Fr. intros H3 H4.
 apply notin_singleton in H4.
 rewrite subst_open_var; trivial.
 rewrite subst_open_var; trivial.
 apply H2; trivial.
 simpl. apply subst_left with (L := L \u {{x}}).
 apply term'_to_term.
 unfold term'. apply lc_at_subst;
 apply term_to_term'; trivial.
 intros x0 Fr. apply notin_union in Fr. case Fr.
 clear Fr. intros H4 H5.
 apply notin_singleton in H5.
 rewrite subst_open_var; trivial.
 rewrite subst_open_var; trivial.
 apply H3; trivial.
 simpl. apply subst_right; trivial.
 apply body'_to_body.
 unfold body'. apply lc_at_subst.
 apply body_to_body'; trivial.
 apply term_to_term' in H0. unfold term' in H0.
 apply lc_at_weaken_ind with (k1 := 0); trivial; omega.
Qed.

Lemma red_out_pctx : forall (R : pterm -> pterm -> Prop),
  red_out R -> red_out (p_contextual_closure R).
Proof.
 intros_all. induction H1; simpl.
 apply p_redex. apply H; trivial.
 apply p_app; trivial.
 apply p_abs_in with (L := L \u {{x}}).
 intros x0 Fr. apply notin_union in Fr. destruct Fr.
 apply notin_singleton in H4.
 rewrite subst_open_var; trivial.
 rewrite subst_open_var; trivial.
 apply H2; trivial.
 apply p_subst with (L := L \u {{x}}); trivial.
 intros x0 Fr. apply notin_union in Fr. destruct Fr.
 apply notin_singleton in H5.
 rewrite subst_open_var; trivial.
 rewrite subst_open_var; trivial.
 apply H2; trivial.
Qed.

Lemma red_out_Lctx : forall (R : pterm -> pterm -> Prop),
  L_red_out R -> L_red_out (L_contextual_closure R).
Proof.
 intros_all. induction H1.
 apply L_redex. apply H; trivial.
 simpl. apply L_app_left; trivial.
 apply subst_Lterm; trivial.
 simpl. apply L_app_right; trivial.
 apply subst_Lterm; trivial.
 simpl. apply L_abs_in with (L := L \u {{x}}).
 intros x0 Fr. apply notin_union in Fr. destruct Fr.
 apply notin_singleton in H4.
 assert (Q: term u). apply Lterm_is_term; trivial.
 rewrite subst_open_var; trivial.
 rewrite subst_open_var; trivial.
 apply H2; trivial.

Qed.

Lemma red_out_trs : forall (R : pterm -> pterm -> Prop),
  red_out R -> red_out (trans_closure R).
Proof.
 intros_all. induction H1.
 apply one_step_reduction. apply H; trivial.
 apply transitive_reduction with (u := [x ~> u]u0); trivial.
 apply H; trivial.
Qed.

Lemma red_not_fv_ctx : forall (R : pterm -> pterm -> Prop),
  red_not_fv R -> red_not_fv (contextual_closure R).
Proof.
 intros R H. unfold red_not_fv in *|-*.
 intros x t t' H'. induction H'.
 apply H; trivial.
 simpl. intro H1.
 apply notin_union. apply notin_union in H1.
 split. apply IHH'. apply H1. apply H1.
 simpl. intro H1.
 apply notin_union. apply notin_union in H1.
 split. apply H1. apply IHH'. apply H1.
 simpl. intro H2. case var_fresh with (L := {{x}} \u L).
 intros z Fr. apply notin_union in Fr. case Fr; clear Fr.
 intros H3 H4. apply notin_singleton in H3.
 apply fv_notin_open with (z := z); auto. apply H1; trivial.
 apply fv_notin_open; auto.
 simpl. intro H3.
 apply notin_union. apply notin_union in H3.
 split. case var_fresh with (L := {{x}} \u L).
 intros z Fr. apply notin_union in Fr. case Fr; clear Fr.
 intros H4 H5. apply notin_singleton in H4.
 apply fv_notin_open with (z := z); auto. apply H2; trivial.
 apply fv_notin_open; auto. apply H3. apply H3.
 simpl. intro H1.
 apply notin_union. apply notin_union in H1.
 split. apply H1. apply IHH'. apply H1.
Qed.

Lemma red_fv_ctx : forall (R : pterm -> pterm -> Prop),
  red_fv R -> red_fv (contextual_closure R).
Proof.
 intros R H. unfold red_not_fv in *|-*.
 intros x t t' H'. induction H'; simpl.
 apply H; trivial. intro H1.
 apply in_union. apply in_union in H1.
 case H1; clear H1; intro H1.
 left. apply IHH'; trivial. right; trivial. intro H1.
 apply in_union. apply in_union in H1.
 case H1; clear H1; intro H1.
 left; trivial. right; apply IHH'; trivial. intro H2.
 case var_fresh with (L := {{x}} \u L). intros z Fr.
 apply notin_union in Fr. case Fr; clear Fr; intros H3 H4.
 apply notin_singleton in H3. apply fv_open_in_neq with (y := z); auto.
 apply H1; trivial. apply fv_open_in_neq with (y := z); auto.
 intro H3. apply in_union. apply in_union in H3.
 case H3; clear H3; intro H3. left.
 case var_fresh with (L := {{x}} \u L). intros z Fr.
 apply notin_union in Fr. case Fr; clear Fr; intros H4 H5.
 apply notin_singleton in H4. apply fv_open_in_neq with (y := z); auto.
 apply H2; trivial. apply fv_open_in_neq with (y := z); auto. right; trivial.
 intro H1. apply in_union. apply in_union in H1.
 case H1; clear H1; intro H1. left; trivial. right; apply IHH'; trivial.
Qed.

Lemma red_swap_ctx: forall (R : pterm -> pterm -> Prop),
  red_swap R -> red_swap (contextual_closure R).
Proof.
 intros R H. unfold red_swap in *|-*.
 intros x t t' y H'. induction H'; simpl.
 apply redex. apply H; trivial.
 apply app_left; trivial. apply swap_term; trivial.
 apply app_right; trivial. apply swap_term; trivial.
 apply abs_in with (L := L \u {{x}} \u {{y}}). intros z Hz.
 apply notin_union in Hz; destruct Hz.
 apply notin_union in H2; destruct H2.
 apply notin_singleton in H3. apply notin_singleton in H4.
 rewrite open_swap; trivial. rewrite open_swap; trivial.
 apply H1; trivial.
 apply subst_left with (L := L \u {{x}} \u {{y}}). apply swap_term; trivial.
 intros z Hz.
 apply notin_union in Hz; destruct Hz.
 apply notin_union in H3; destruct H3.
 apply notin_singleton in H4. apply notin_singleton in H5.
 rewrite open_swap; trivial. rewrite open_swap; trivial.
 apply H2; trivial.
 apply subst_right; trivial.
 inversion H0. clear H0. exists (x0 \u {{x}} \u {{y}}). intros z Hz.
 apply notin_union in Hz; destruct Hz.
 apply notin_union in H0; destruct H0.
 apply notin_singleton in H2. apply notin_singleton in H3.
 rewrite open_swap; trivial. apply swap_term. apply H1; trivial.
Qed.

Lemma red_swap_trs: forall (R : pterm -> pterm -> Prop),
  red_swap R -> red_swap (trans_closure R).
Proof.
 intros R H. unfold red_swap in *|-*. intros x t t' y H'.
 induction H'. apply one_step_reduction. apply H; trivial.
 apply transitive_reduction with (u := ([(x,y)]u)); trivial.
 apply H; trivial.
Qed.

Lemma ctx_abs_in_close : forall x R L t t', red_regular R -> red_out R ->
                        contextual_closure R t t' -> x \notin L ->
                        contextual_closure R (pterm_abs (close t x)) (pterm_abs (close t' x)).
Proof.
 intros x R L t t' H0 H1 H2 Fr.
 apply abs_in with (L := L). intros z Fr'.
 apply red_out_ctx in H1. apply red_out_to_rename in H1.
 apply H1 with (x := x). apply fv_close'. apply fv_close'.
 replace (close t x ^ x) with t. replace (close t' x ^ x) with t'; trivial.
 apply open_close_var. apply red_regular_ctx in H0. apply H0 in H2. apply H2.
 apply open_close_var. apply red_regular_ctx in H0. apply H0 in H2. apply H2.
Qed.

Lemma trs_Lctx_app_left : forall R t t' u, Lterm u ->
                       trans_closure (L_contextual_closure R) t t' ->
                       trans_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t' u).
Proof.
 intros. induction H0. apply one_step_reduction.
 apply L_app_left; trivial.
 apply transitive_reduction with (u := pterm_app u0 u); trivial.
 apply L_app_left; trivial.
Qed.

Lemma str_Lctx_app_left : forall R t t' u, Lterm u ->
                       star_closure (L_contextual_closure R) t t' ->
                       star_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t' u).
Proof.
 intros. induction H0. apply reflexive_reduction. apply star_trans_reduction.
 apply trs_Lctx_app_left; trivial.
Qed.

Lemma trs_Lctx_app_right : forall R t u u', Lterm t ->
                       trans_closure (L_contextual_closure R) u u' ->
                       trans_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t u').
Proof.
 intros. induction H0. apply one_step_reduction.
 apply L_app_right; trivial.
 apply transitive_reduction with (u := pterm_app t u); trivial.
 apply L_app_right; trivial.
Qed.

Lemma str_Lctx_app_right : forall R t u u', Lterm t ->
                       star_closure (L_contextual_closure R) u u' ->
                       star_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t u').
Proof.
 intros. induction H0. apply reflexive_reduction. apply star_trans_reduction.
 apply trs_Lctx_app_right; trivial.
Qed.

Lemma Lctx_abs_in_close : forall x R L t t', L_red_regular R -> L_red_out R ->
                         L_contextual_closure R t t' -> x \notin L ->
                         L_contextual_closure R (pterm_abs (close t x)) (pterm_abs (close t' x)).
Proof.
 intros x R L t t' H0 H1 H2 Fr.
 apply L_abs_in with (L := L). intros z Fr'.
 apply red_out_Lctx in H1. apply L_red_out_to_rename in H1.
 apply H1 with (x := x). apply fv_close'. apply fv_close'.
 replace (close t x ^ x) with t. replace (close t' x ^ x) with t'; trivial.
 apply open_close_var. apply red_regular_Lctx in H0. apply H0 in H2. apply Lterm_is_term. apply H2.
 apply open_close_var. apply red_regular_Lctx in H0. apply H0 in H2. apply Lterm_is_term. apply H2.
Qed.

Lemma trs_Lctx_abs_in : forall R L t t', L_red_regular R -> L_red_out R ->
                       (forall x, x \notin L ->  trans_closure (L_contextual_closure R) (t ^ x) (t' ^ x)) -> trans_closure (L_contextual_closure R) (pterm_abs t) (pterm_abs t').
Proof.
 intros R L t t' H0 H1 H2.  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 H. destruct H.
 assert (Q: trans_closure (L_contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht0 Ht1.
 replace t with (close t0 x). replace t' with (close t1 x). clear Ht0 Ht1. induction Q.
 apply one_step_reduction. apply Lctx_abs_in_close with (L := L); trivial.
 apply transitive_reduction with (u := pterm_abs (close u x)); trivial.
 apply Lctx_abs_in_close with (L := L); trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
Qed.

Lemma str_Lctx_abs_in : forall R L t t', L_red_regular R -> L_red_out R ->
                       (forall x, x \notin L ->  star_closure (L_contextual_closure R) (t ^ x) (t' ^ x)) -> star_closure (L_contextual_closure R) (pterm_abs t) (pterm_abs t').
Proof.
 intros R L t t' H0 H1 H2.  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 H. destruct H.
 assert (Q: star_closure (L_contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht0 Ht1.
 replace t with (close t0 x). replace t' with (close t1 x). clear Ht0 Ht1. induction Q.
 apply reflexive_reduction. apply star_trans_reduction. induction H2.
 apply one_step_reduction. apply Lctx_abs_in_close with (L := L); trivial.
 apply transitive_reduction with (u := pterm_abs (close u x)); trivial.
 apply Lctx_abs_in_close with (L := L); trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
Qed.

Lemma pctx_abs_in_close : forall x R L t t', red_regular' R -> red_out R -> term t ->
                         p_contextual_closure R t t' -> x \notin L ->
                         p_contextual_closure R (pterm_abs (close t x)) (pterm_abs (close t' x)).
Proof.
 intros x R L t t' H0 H1 T H2 Fr.
 apply p_abs_in with (L := L). intros z Fr'.
 apply red_out_pctx in H1. apply red_out_to_rename in H1.
 apply H1 with (x := x). apply fv_close'. apply fv_close'.
 replace (close t x ^ x) with t. replace (close t' x ^ x) with t'; trivial.
 apply open_close_var. apply red_regular'_pctx in H0. apply H0 in H2. apply H2; trivial.
 apply open_close_var; trivial.
Qed.

Lemma trs_pctx_abs_in_close : forall x R L t t', red_regular' R -> red_out R -> term t ->
                         trans_closure (p_contextual_closure R) t t' -> x \notin L ->
                         trans_closure (p_contextual_closure R) (pterm_abs (close t x)) (pterm_abs (close t' x)).
Proof.
 intros x R L t t' H0 H1 T H Fr. induction H.
 apply one_step_reduction. apply pctx_abs_in_close with (L := L); trivial.
  apply transitive_reduction with (u := pterm_abs (close u x)).
 apply pctx_abs_in_close with (L := L); trivial.
 apply IHtrans_closure. apply red_regular'_pctx in H0.
 apply H0 in H. apply H; trivial.
Qed.

Lemma trs_pctx_abs_in : forall R L t t', red_regular' R -> red_out R -> body t ->
                       (forall x, x \notin L ->  trans_closure (p_contextual_closure R) (t ^ x) (t' ^ x)) ->
                       trans_closure (p_contextual_closure R) (pterm_abs t) (pterm_abs t').
Proof.
 intros R L t t' H0 H1 B H2.  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 H. destruct H.
 assert (Q: trans_closure (p_contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht1 Ht0.
 replace t with (close t0 x). replace t' with (close t1 x).
 assert (T : term t0). rewrite Ht0. apply body_to_term; trivial.
 clear Ht0 Ht1. induction Q.
 apply one_step_reduction. apply pctx_abs_in_close with (L := L); trivial.
 apply transitive_reduction with (u := pterm_abs (close u x)); trivial.
 apply pctx_abs_in_close with (L := L); trivial. apply IHQ.
 apply red_regular'_pctx in H0. apply H0 in H2. apply H2; trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
Qed.

Lemma str_pctx_abs_in : forall R L t t', red_regular' R -> red_out R -> body t ->
                       (forall x, x \notin L ->  star_closure (p_contextual_closure R) (t ^ x) (t' ^ x)) ->
                       star_closure (p_contextual_closure R) (pterm_abs t) (pterm_abs t').
Proof.
 intros R L t t' H0 H1 B H2.  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 H. destruct H.
 assert (Q: star_closure (p_contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht1 Ht0.
 replace t with (close t0 x). replace t' with (close t1 x).
 assert (T : term t0). rewrite Ht0. apply body_to_term; trivial.
 clear Ht0 Ht1. induction Q.
 apply reflexive_reduction. apply star_trans_reduction. induction H2.
 apply one_step_reduction. apply pctx_abs_in_close with (L := L); trivial.
 apply transitive_reduction with (u := pterm_abs (close u x)); trivial.
 apply pctx_abs_in_close with (L := L); trivial.
 apply IHtrans_closure.
 apply red_regular'_pctx in H0. apply H0 in H2. apply H2; trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
Qed.

Lemma ctx_subst_left_close : forall x R L t t' u, red_regular R -> red_out R -> term u ->
                         contextual_closure R t t' -> x \notin L ->
                         contextual_closure R ((close t x)[u]) ((close t' x)[u]).
Proof.
 intros x R L t t' u H0 H1 T H2 Fr.
 apply subst_left with (L := L); trivial. intros z Fr'.
 apply red_out_ctx in H1. apply red_out_to_rename in H1.
 apply H1 with (x := x). apply fv_close'. apply fv_close'.
 replace (close t x ^ x) with t. replace (close t' x ^ x) with t'; trivial.
 apply open_close_var. apply red_regular_ctx in H0. apply H0 in H2. apply H2.
 apply open_close_var. apply red_regular_ctx in H0. apply H0 in H2. apply H2.
Qed.

Lemma trs_ctx_subst_left : forall R L t t' u, red_regular R -> red_out R -> term u ->
                       (forall x, x \notin L ->  trans_closure (contextual_closure R) (t ^ x) (t' ^ x)) ->
                       trans_closure (contextual_closure R) (t[u]) (t'[u]).
Proof.
 intros R L t t' u H0 H1 T H2.  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 H. destruct H.
 assert (Q: trans_closure (contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht0 Ht1.
 replace t with (close t0 x). replace t' with (close t1 x). clear Ht0 Ht1. induction Q.
 apply one_step_reduction. apply ctx_subst_left_close with (L := L); trivial.
 apply transitive_reduction with (u := (close u0 x)[u]); trivial.
 apply ctx_subst_left_close with (L := L); trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
Qed.

Lemma str_ctx_subst_left : forall R L t t' u, red_regular R -> red_out R -> term u ->
                       (forall x, x \notin L ->  star_closure (contextual_closure R) (t ^ x) (t' ^ x)) ->
                       star_closure (contextual_closure R) (t[u]) (t'[u]).
Proof.
 intros R L t t' u H0 H1 T H2.  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 H. destruct H.
 assert (Q: star_closure (contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht1 Ht0.
 replace t with (close t0 x). replace t' with (close t1 x). clear Ht0 Ht1. destruct Q.
 apply reflexive_reduction. apply star_trans_reduction. induction H2.
 apply one_step_reduction. apply ctx_subst_left_close with (L := L); trivial.
 apply transitive_reduction with (u := (close u0 x)[u]); trivial.
 apply ctx_subst_left_close with (L := L); trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
Qed.

Lemma pctx_subst_close : forall x R L t t' u u', red_regular' R -> red_out R -> term t -> term u ->
                         p_contextual_closure R u u' ->
                         p_contextual_closure R t t' -> x \notin L ->
                         p_contextual_closure R ((close t x)[u]) ((close t' x)[u']).
Proof.
 intros x R L t t' u u' H0 H1 Tt Tu H2 H3 Fr.
 apply p_subst with (L := L); trivial. intros z Fr'.
 apply red_out_pctx in H1. apply red_out_to_rename in H1.
 apply H1 with (x := x). apply fv_close'. apply fv_close'.
 replace (close t x ^ x) with t. replace (close t' x ^ x) with t'; trivial.
 apply open_close_var. apply red_regular'_pctx in H0. apply H0 in H3. apply H3; trivial.
 apply open_close_var; trivial.
Qed.

Lemma trs_pctx_subst_close : forall x R L t t' u u',
                         red_regular' R -> red_out R -> (forall t0, R t0 t0) ->
                         term t -> term u ->
                         trans_closure (p_contextual_closure R) t t' ->
                         trans_closure (p_contextual_closure R) u u' -> x \notin L ->
                         trans_closure (p_contextual_closure R) ((close t x)[u]) ((close t' x)[u']).
Proof.
 intros x R L t t' u u' H0 H1 H2 Tt Tu H3 H4 Fr. induction H3. induction H4.
 apply one_step_reduction. apply pctx_subst_close with (L := L); trivial.
  apply transitive_reduction with (u := (close t x)[u]).
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHtrans_closure. apply red_regular'_pctx in H0.
 apply H0 in H3. apply H3; trivial.
 apply transitive_reduction with (u := (close u0 x)[u]).
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHtrans_closure. apply red_regular'_pctx in H0.
 apply H0 in H. apply H; trivial.
Qed.

Lemma trs_pctx_subst : forall R L t t' u u', red_regular' R -> red_out R -> (forall t0, R t0 t0) ->
                        body t -> term u ->
                       (forall x, x \notin L ->  trans_closure (p_contextual_closure R) (t ^ x) (t' ^ x)) ->
                       trans_closure (p_contextual_closure R) u u' ->
                       trans_closure (p_contextual_closure R) (t[u]) (t'[u']).
Proof.
 intros R L t t' u u' H0 H1 H2 B Tu H3 H4.  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 H. destruct H.
 assert (Q: trans_closure (p_contextual_closure R) (t ^ x) (t' ^ x)). apply H3; trivial. clear H3.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht1 Ht0.
 replace t with (close t0 x). replace t' with (close t1 x).
 assert (T : term t0). rewrite Ht0. apply body_to_term; trivial.
 clear Ht0 Ht1. induction Q. induction H4.
 apply one_step_reduction. apply pctx_subst_close with (L := L); trivial.
 apply transitive_reduction with (u := (close t0 x)[u]); trivial.
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHtrans_closure. apply red_regular'_pctx in H0. apply H0 in H4. apply H4; trivial.
 apply transitive_reduction with (u := (close u0 x)[u]); trivial.
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHQ. apply red_regular'_pctx in H0. apply H0 in H3. apply H3; trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
Qed.

Lemma str_pctx_subst : forall R L t t' u u', red_regular' R -> red_out R -> (forall t0, R t0 t0) ->
                        body t -> term u ->
                       (forall x, x \notin L ->  star_closure (p_contextual_closure R) (t ^ x) (t' ^ x)) ->
                       star_closure (p_contextual_closure R) u u' ->
                       star_closure (p_contextual_closure R) (t[u]) (t'[u']).
Proof.
 intros R L t t' u u' H0 H1 H2 B Tu H3 H4.  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 H. destruct H.
 assert (Q: star_closure (p_contextual_closure R) (t ^ x) (t' ^ x)). apply H3; trivial. clear H3.
 gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht1 Ht0.
 replace t with (close t0 x). replace t' with (close t1 x).
 assert (T : term t0). rewrite Ht0. apply body_to_term; trivial.
 clear Ht0 Ht1. destruct H4. destruct Q. apply reflexive_reduction.
 apply star_trans_reduction. induction H3.
 apply one_step_reduction. apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply transitive_reduction with (u := (close u x)[t2]); trivial.
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHtrans_closure. apply red_regular'_pctx in H0. apply H0 in H3. apply H3; trivial.
 destruct Q. apply star_trans_reduction. induction H3. apply one_step_reduction.
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply transitive_reduction with (u := (close t0 x)[u]); trivial.
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHtrans_closure. apply red_regular'_pctx in H0. apply H0 in H3. apply H3; trivial.
 apply star_trans_reduction. induction H3. induction H4.
 apply one_step_reduction. apply pctx_subst_close with (L := L); trivial.
 apply transitive_reduction with (u := (close u0 x)[t1]); trivial.
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHtrans_closure. apply red_regular'_pctx in H0. apply H0 in H4. apply H4; trivial.
 apply transitive_reduction with (u := (close t0 x)[u]); trivial.
 apply pctx_subst_close with (L := L); trivial. apply p_redex. apply H2.
 apply IHtrans_closure. apply red_regular'_pctx in H0. apply H0 in H3. apply H3; trivial.
 rewrite Ht1. rewrite <- close_open_term; trivial.
 rewrite Ht0. rewrite <- close_open_term; trivial.
Qed.

(* ********************************************************************** *)
(** About SN & NF **)

Lemma NF_to_SN0 : forall R t, NF R t -> SN_ind 0 R t.
Proof.
 intros R t H.
 apply SN_intro.
 intros t' H'. unfold NF in H.
 assert (Q : ~ R t t'). apply H.
 contradiction.
Qed.

Lemma SN0_to_NF : forall R t, SN_ind 0 R t -> NF R t.
Proof.
 intros R t H. unfold NF.
 intros t' H'. inversion H.
 case H0 with (t' := t'). assumption.
 intros n H''. omega.
Qed.

Lemma NF_eq_SN0 : forall R t, NF R t <-> SN_ind 0 R t.
Proof. intros R t. split; [apply NF_to_SN0 | apply SN0_to_NF]. Qed.

Lemma WSN : forall n k R t, k <= n -> SN_ind k R t -> SN_ind n R t.
Proof.
 intros n k R t H.
 destruct H; trivial. intro H'.
 apply SN_intro. intros t' H''. destruct H'.
 case (H0 t'); trivial. intros n' H'''. exists n'.
 split; try omega. apply H'''.
Qed.

Lemma SN_one_step : forall n (R : pterm -> pterm -> Prop) t u, R t u -> SN_ind (S n) R t -> SN_ind n R u.
Proof.
 intros n R t u H H'.
 destruct H'. case (H0 u); trivial.
 intro n'. intro H'. apply WSN with (k := n'). omega.
 apply H'.
Qed.

Lemma SN_trs : forall n R t u, trans_closure R t u ->
                               SN_ind n R t -> (exists k, k < n /\ SN_ind k R u).
Proof.
 intros. generalize n H0; clear n H0.
 induction H; intros. destruct n. apply False_ind. apply SN0_to_NF in H0.
 apply (H0 u); trivial. apply SN_one_step with (u := u) in H0; trivial.
 exists n. split; try omega; trivial.
 destruct H1. case (H1 u); trivial; clear H1. intros n' H1. destruct H1.
 case IHtrans_closure with (n := n'); trivial. intros k' H3. destruct H3.
 exists k'. split; try omega; trivial.
Qed.

Lemma SN_app : forall n R t u, red_regular R ->  term t -> term u ->
               SN_ind n (contextual_closure R) (pterm_app t u) ->
               SN_ind n (contextual_closure R) t /\ SN_ind n (contextual_closure R) u.
 Proof.
 intros n R t u Reg.
 generalize t u; clear t u.
 induction n.  intros. split; rewrite <- NF_eq_SN0 in *|-*; unfold NF in *|-*.
 intros t' H'. apply (H1 (pterm_app t' u)). apply app_left; trivial.
 intros u' H'. apply (H1 (pterm_app t u')). apply app_right; trivial.
 intros t u Tt Tu H. destruct H. split.
 apply SN_intro. intros t' H'. exists n. split; try omega.
 apply IHn with (t := t') (u := u); trivial. apply red_regular_ctx in Reg.
 apply Reg in H'. apply H'. case (H (pterm_app t' u)). apply app_left; trivial.
 intros k H''. apply WSN with (k := k). omega. apply H''.
 apply SN_intro. intros u' H'. exists n. split; try omega.
 apply IHn with (t := t) (u := u'); trivial. apply red_regular_ctx in Reg.
 apply Reg in H'. apply H'. case (H (pterm_app t u')). apply app_right; trivial.
 intros k H''. apply WSN with (k := k). omega. apply H''.
Qed.

Lemma L_SN_app : forall n R t u, L_red_regular R ->  Lterm t -> Lterm u ->
               SN_ind n (L_contextual_closure R) (pterm_app t u) ->
               SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) u.
 Proof.
 intros n R t u Reg.
 generalize t u; clear t u.
 induction n.  intros. split; rewrite <- NF_eq_SN0 in *|-*; unfold NF in *|-*.
 intros t' H'. apply (H1 (pterm_app t' u)). apply L_app_left; trivial.
 intros u' H'. apply (H1 (pterm_app t u')). apply L_app_right; trivial.
 intros t u Tt Tu H. destruct H. split.
 apply SN_intro. intros t' H'. exists n. split; try omega.
 apply IHn with (t := t') (u := u); trivial. apply red_regular_Lctx in Reg.
 apply Reg in H'. apply H'. case (H (pterm_app t' u)). apply L_app_left; trivial.
 intros k H''. apply WSN with (k := k). omega. apply H''.
 apply SN_intro. intros u' H'. exists n. split; try omega.
 apply IHn with (t := t) (u := u'); trivial. apply red_regular_Lctx in Reg.
 apply Reg in H'. apply H'. case (H (pterm_app t u')). apply L_app_right; trivial.
 intros k H''. apply WSN with (k := k). omega. apply H''.
Qed.

Lemma SN_abs : forall x n R t, red_regular R -> red_out R ->
               SN_ind n (contextual_closure R) (pterm_abs t) ->
               x \notin (fv t) -> SN_ind n (contextual_closure R) (t ^ x).
Proof.
 intros x n R t Reg Out.
 generalize t; clear t.
 apply red_regular_ctx in Reg.
 apply red_out_ctx in Out.
 apply red_out_to_rename in Out.
 induction n. intros.
 apply SN0_to_NF in H.
 apply NF_to_SN0; unfold NF in *|-*.
 intros t' H'. gen_eq t0 : (close t' x). intro H1.
 replace t' with (t0 ^ x) in H'.
 assert (Q: contextual_closure R (pterm_abs t) (pterm_abs t0)).
    apply abs_in with (L := {{x}}). intros z H2.
    apply notin_singleton in H2. apply Out with (x := x); trivial.
    rewrite H1. apply fv_close'.
 assert (Q': ~ contextual_closure R (pterm_abs t) (pterm_abs t0)).
    apply H.
 contradiction. rewrite H1. rewrite open_close_var with (x := x).
 reflexivity. apply Reg in H'. apply H'.
 intros. destruct H. apply SN_intro.
 intros. exists n. split; try omega.
 gen_eq t0 : (close t' x). intro H2.
 replace t' with (t0 ^ x). replace t' with (t0 ^ x) in H1.
 apply IHn; trivial. case (H (pterm_abs t0)); trivial.
 apply abs_in with (L := {{x}}).
 intros z H3. apply notin_singleton in H3.
 apply Out with (x := x); trivial.
 rewrite H2. apply fv_close'.
 intros k H3. apply WSN with (k := k); try omega.
 apply H3. rewrite H2. apply fv_close'.
 rewrite H2. rewrite open_close_var with (x := x).
 reflexivity. apply Reg in H1. apply H1.
 rewrite H2. rewrite open_close_var with (x := x).
 reflexivity. apply Reg in H1. apply H1.
Qed.

Lemma L_SN_abs : forall x n R t, L_red_regular R -> L_red_out R ->
               SN_ind n (L_contextual_closure R) (pterm_abs t) ->
               x \notin (fv t) -> SN_ind n (L_contextual_closure R) (t ^ x).
Proof.
 intros x n R t Reg Out.
 generalize t; clear t.
 apply red_regular_Lctx in Reg.
 apply red_out_Lctx in Out.
 apply L_red_out_to_rename in Out.
 induction n. intros.
 apply SN0_to_NF in H.
 apply NF_to_SN0; unfold NF in *|-*.
 intros t' H'. gen_eq t0 : (close t' x). intro H1.
 replace t' with (t0 ^ x) in H'.
 assert (Q: L_contextual_closure R (pterm_abs t) (pterm_abs t0)).
    apply L_abs_in with (L := {{x}}). intros z H2.
    apply notin_singleton in H2. apply Out with (x := x); trivial.
    rewrite H1. apply fv_close'.
 assert (Q': ~ L_contextual_closure R (pterm_abs t) (pterm_abs t0)).
    apply H.
 contradiction. rewrite H1. rewrite open_close_var with (x := x).
 reflexivity. apply Reg in H'. apply Lterm_is_term. apply H'.
 intros. destruct H. apply SN_intro.
 intros. exists n. split; try omega.
 gen_eq t0 : (close t' x). intro H2.
 replace t' with (t0 ^ x). replace t' with (t0 ^ x) in H1.
 apply IHn; trivial. case (H (pterm_abs t0)); trivial.
 apply L_abs_in with (L := {{x}}).
 intros z H3. apply notin_singleton in H3.
 apply Out with (x := x); trivial.
 rewrite H2. apply fv_close'.
 intros k H3. apply WSN with (k := k); try omega.
 apply H3. rewrite H2. apply fv_close'.
 rewrite H2. rewrite open_close_var with (x := x).
 reflexivity. apply Lterm_is_term. apply Reg in H1. apply H1.
 rewrite H2. rewrite open_close_var with (x := x).
 reflexivity. apply Lterm_is_term. apply Reg in H1. apply H1.
Qed.

Lemma SN_sub : forall x n R t u, red_regular R -> red_out R ->
               body t -> term u -> x \notin (fv t) ->
               SN_ind n (contextual_closure R) (t[u]) ->
               SN_ind n (contextual_closure R) (t ^ x) /\
               SN_ind n (contextual_closure R) u.
Proof.
 intros x n R t u Reg Out.
 generalize t u; clear t u.
 apply red_regular_ctx in Reg.
 apply red_out_ctx in Out.
 apply red_out_to_rename in Out.
 induction n. intros.
 apply SN0_to_NF in H2. split; intros;
 apply NF_to_SN0; unfold NF in *|-*.
 intros t' H'. gen_eq t0 : (close t' x). intro H3.
 replace t' with (t0 ^ x) in H'.
 assert (Q: contextual_closure R (t[u])(t0[u])).
    apply subst_left with (L := {{x}}); trivial. intros z H4.
    apply notin_singleton in H4. apply Out with (x := x); trivial.
    rewrite H3. apply fv_close'.
 assert (Q': ~ contextual_closure R (t[u]) (t0[u])).
    apply H2.
 contradiction. rewrite H3. rewrite open_close_var with (x := x).
 reflexivity. apply Reg in H'. apply H'.
 intros t' H'.
 assert (Q: contextual_closure R (t[u])(t[t'])).
   apply subst_right; trivial.
 assert (Q': ~ contextual_closure R (t[u])(t[t'])).
   apply H2.
 contradiction.
 intros. destruct H2. split. intros. apply SN_intro.
 intros. exists n. split; try omega.
 gen_eq t0 : (close t' x). intro H4.
 replace t' with (t0 ^ x). replace t' with (t0 ^ x) in H3.
 assert (Q : x \notin fv t0). rewrite H4. apply fv_close'.
 apply (IHn t0 u); trivial. apply Reg in H3.
 apply body'_to_body. case H3; clear H3. intros H3 H5.
 apply term_to_term' in H5. unfold body'. unfold term' in H5.
 unfold open in H5. apply lc_at_open in H5; trivial.
 case (H2 (t0[u])); trivial.
 apply subst_left with (L := {{x}}); trivial.
 intros z H5. apply notin_singleton in H5.
 apply Out with (x := x); trivial.
 intros k H5. apply WSN with (k := k); try omega. apply H5.
 rewrite H4. rewrite open_close_var with (x := x).
 reflexivity. apply Reg in H3. apply H3.
 rewrite H4. rewrite open_close_var with (x := x).
 reflexivity. apply Reg in H3. apply H3.
 apply SN_intro.
 intros t' H'. exists n.
 split; try omega.
 apply IHn with (t := t) (u := t'); trivial.
 apply Reg in H'. apply H'.
 case (H2 (t[t'])).
 apply subst_right; trivial.
 intros k H''. apply WSN with (k := k).
 omega. apply H''.
Qed.

(*** about SN and NF in lists ***)

Lemma NF_eq_SN0_list : forall R lt, NF R %% lt <-> SN_ind 0 R %% lt.
Proof.
 intros R lt. induction lt; simpl; split; trivial.
 intro H. destruct H. split.
 apply NF_to_SN0; trivial. apply IHlt; trivial.
 intro H. destruct H. split.
 apply SN0_to_NF; trivial. apply IHlt; trivial.
Qed.

Lemma WSN_list : forall n k R lt, k <= n -> SN_ind k R %% lt -> SN_ind n R %% lt.
Proof.
 intros n k R lt H. induction lt; simpl; trivial.
 intro H'. destruct H'. split. apply WSN with (k := k); trivial.
 apply IHlt; trivial.
Qed.

Lemma SN_list : forall R lt, SN R %% lt <-> exists n, SN_ind n R %% lt.
Proof.
 intros R lt. induction lt; simpl; split; intros; trivial.
 exists 0; trivial. destruct IHlt. destruct H. case H0; clear H0; trivial.
 intros n H0. case H; clear H. intros n' H. exists (n + n').
 split. apply WSN with (k := n'); try omega; trivial.
 apply WSN_list with (k := n); try omega; trivial. split.
 case H; clear H. intros n H. destruct H. exists n; trivial.
 case H; clear H. intros n H. destruct H. apply IHlt. exists n; trivial.
Qed.

Lemma SN_mult_app : forall n R t l, red_regular R ->  term t -> term %% l ->
               SN_ind n (contextual_closure R) (t // l) ->
               SN_ind n (contextual_closure R) t /\ SN_ind n (contextual_closure R) %% l.
Proof.
 intros n R t l Reg. generalize n t; clear n t.
 induction l; simpl. intros n t T H0 H. split; trivial.
 intros n t T H0 H. destruct H0. apply SN_app in H; trivial. destruct H.
 assert (Q : SN_ind n (contextual_closure R) t /\ SN_ind n (contextual_closure R) %% l).
  apply IHl; trivial.
 clear IHl. destruct Q. split; trivial. split; trivial.
 rewrite term_mult_app. split; trivial.
Qed.

Lemma L_SN_mult_app : forall n R t l, L_red_regular R ->  Lterm t -> Lterm %% l ->
               SN_ind n (L_contextual_closure R) (t // l) ->
               SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) %% l.
Proof.
 intros n R t l Reg. generalize n t; clear n t.
 induction l; simpl. intros n t T H0 H. split; trivial.
 intros n t T H0 H. destruct H0. apply L_SN_app in H; trivial. destruct H.
 assert (Q : SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) %% l).
  apply IHl; trivial.
 clear IHl. destruct Q. split; trivial. split; trivial.
 rewrite Lterm_mult_app. split; trivial.
Qed.


From Undecidability.H10 Require Import H10 dio_single dio_logic.
Require Import Undecidability.PCP.Util.PCP_facts.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes Undecidability.Shared.Libs.PSL.FiniteTypes.Arbitrary.
From Undecidability.Synthetic Require Export DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability.L.Datatypes Require Import LNat Lists LProd.
From Undecidability.L Require Import Tactics.LTactics Computability.MuRec Computability.Synthetic Tactics.GenEncode.
From Undecidability.Shared.Libs.DLW.Vec Require Import pos.
Import ListAutomationNotations.

Require Import Nat Datatypes.

(* * Diophantine Equations *)

Inductive poly : Set :=
    poly_cnst : nat -> poly
  | poly_var : nat -> poly
  | poly_add : poly -> poly -> poly
  | poly_mul : poly -> poly -> poly.

MetaCoq Run (tmGenEncode "enc_poly" poly).
#[export] Hint Resolve enc_poly_correct : Lrewrite.

#[global]
Instance term_poly_cnst: computable poly_cnst. Proof. extract constructor. Qed.
#[global]
Instance term_poly_var : computable poly_var. Proof. extract constructor. Qed.
#[global]
Instance term_poly_add : computable poly_add. Proof. extract constructor. Qed.
#[global]
Instance term_poly_mul : computable poly_mul. Proof. extract constructor. Qed.

Fixpoint eval (p : poly) (L : list nat) :=
  match p with
  | poly_cnst n => n
  | poly_var n => nth n L 0
  | poly_add p1 p2 => eval p1 L + eval p2 L
  | poly_mul p1 p2 => eval p1 L * eval p2 L
  end.
#[global]
Instance term_eval : computable eval. Proof. extract. Qed.

Definition poly_add' '(x,y) : poly  := poly_add x y.
#[global]
Instance term_poly_add' : computable poly_add'. Proof. extract. Qed.

Definition poly_mul' '(x,y) : poly := poly_mul x y.
#[global]
Instance term_poly_mul' : computable poly_mul'. Proof. extract. Qed.

Fixpoint L_poly n : list (poly) :=
  match n with
  | 0 => []
  | S n => L_poly n ++  map poly_cnst (L_nat n)
                                   ++ map poly_var (L_nat n)
                                   ++ map poly_add' (list_prod (L_poly n) (L_poly n))
                                   ++ map poly_mul' (list_prod (L_poly n) (L_poly n))
  end.

#[global]
Instance term_L_poly : computable L_poly. Proof. extract. Qed.

#[global]
Instance enum_poly :
  list_enumerator__T L_poly poly.
Proof.
  intros p. induction p.
  + destruct (el_T n) as [m].
    exists (1 + m). cbn. in_app 2. in_collect n. exact H.
  + destruct (el_T n) as [m].
    exists (1 + m). cbn. in_app 3. eauto.
  + destruct IHp1 as [m1]. destruct IHp2 as [m2].
    exists (1 + m1 + m2). cbn. in_app 4. in_collect (p1, p2); eapply cum_ge'; eauto; lia.
  + destruct IHp1 as [m1]. destruct IHp2 as [m2].
    exists (1 + m1 + m2). cbn. in_app 5. in_collect (p1, p2); eapply cum_ge'; eauto; lia.
Defined. (* because instance *)

Fixpoint conv n (p : dio_single.dio_polynomial (pos n) (pos 0)) : poly.
Proof.
  destruct p as [ | p | p | ].
  - exact (poly_cnst n0).
  - exact (poly_var (pos.pos2nat p)).
  - invert pos p.
  - destruct d.
    + exact (poly_add (conv _ p1) (conv _ p2)).
    + exact (poly_mul (conv _ p1) (conv _ p2)).
Defined. (* because term *)

Fixpoint L_from (n : nat) : (pos n -> nat) -> list nat.
Proof.
  intros phi. destruct n.
  - exact [].
  - refine (_ :: L_from _ _)%list.
    + exact (phi pos.pos_fst).
    + intros. eapply phi. econstructor 2. exact H.
Defined. (* because term *)

Lemma L_nth n phi (p : pos n) : nth (pos2nat p) (L_from phi) 0 = phi p.
Proof.
  induction n.
  - invert pos p.
  - cbn. invert pos p.
    + cbn. now rewrite pos.pos2nat_fst.
    + now rewrite pos.pos2nat_nxt, IHn.
Qed.

Lemma phi_to_L n : forall phi, forall p, dp_eval phi (fun _ => 0) p = eval (@conv n p) (L_from phi).
Proof.
  induction p; cbn.
  - reflexivity.
  - now rewrite L_nth.
  - invert pos p.
  - destruct d; cbn; congruence.
Qed.

Lemma eval_L_from n p L :
  eval (@conv n p) (L_from (fun p : pos n => nth (pos2nat p) L 0)) = eval (conv p) L.
Proof.
  induction p; cbn.
  - reflexivity.
  - revert L; induction n; intros; cbn.
    + invert pos v.
    + invert pos v.
      * rewrite pos2nat_fst. reflexivity.
      * rewrite pos2nat_nxt in *.
        destruct L.
        -- cbn. clear. induction n.
           ++ cbn. invert pos v.
           ++ cbn. invert pos v. rewrite !pos.pos2nat_fst.
              now rewrite pos.pos2nat_nxt.
              now rewrite pos.pos2nat_nxt.
        -- cbn. now rewrite <- IHn with (L := L).
  - invert pos p.
  - destruct d; cbn; congruence.
Qed.

Lemma red :
  H10 ⪯ (fun '(p1, p2) => exists L, eval p1 L = eval p2 L).
Proof.
  unshelve eexists.
  - intros (n & p1 & p2). exact (conv p1, conv p2).
  - intros (n & p1 & p2). cbn.
    unfold dio_single_pred. cbn. split.
    + intros [phi]. exists (L_from phi). now rewrite <- !phi_to_L.
    + intros [L]. exists (fun n => nth (pos.pos2nat n) L 0).
      now rewrite !phi_to_L, !eval_L_from.
Qed.

Definition test_eq := (fun '(p1,p2,L) => Nat.eqb (eval p1 L) (eval p2 L)).

#[global]
Instance term_test_eq : computable test_eq.
Proof.
  extract.
Qed.

Definition cons' : nat * list nat -> list nat := fun '(n, L) => n :: L.

#[global]
Instance term_cons' : computable cons'.
Proof.
  extract.
Qed.

Definition T_list_nat := @L_list nat opt_to_list.

#[global]
Instance computable_cumul {X} `{registered X} : computable (@cumul X).
Proof.
  extract.
Qed.

#[global]
Instance term_T_list : computable T_list_nat.
Proof.
  unfold T_list_nat, L_list.
  change (computable
    (fix T_list (n : nat) : list (list nat) :=
       match n with
       | 0 => [[]]
       | S n0 => (T_list n0 ++ map cons' (L_nat n0 × T_list n0))%list
       end)).
  extract.
Qed.

Lemma H10_enumerable : L_enumerable (fun '(p1, p2) => exists L, eval p1 L = eval p2 L).
Proof.
  eapply L_enumerable_ext.
  eapply projection with (Y := list nat).
  instantiate (1 := fun '( (p1,p2), L) => eval p1 L = eval p2 L).
  2:{ intros []. firstorder. }
  eapply L_enumerable_enum.
  exists (fix L n := match n with 0 => [] | S n => L n ++ filter test_eq (list_prod (list_prod (L_poly n) (L_poly n)) (T_list_nat  n)) end)%list.
  repeat split.
  - extract.
  - eauto.
  - destruct x as [[p1 p2] L]. intros.
    destruct (enum_poly p1) as [m1], (enum_poly p2) as [m2], (enumerator__T_list opt_to_list _ L) as [m3].
    exists (1 + m1 + m2 + m3). in_app 2.
    fold plus. eapply in_filter_iff. split.
    + rewrite !in_prod_iff. repeat split; eapply cum_ge'; try eassumption; eauto; lia.
    + unfold test_eq. edestruct (Nat.eqb_spec (eval p1 L) (eval p2 L)); eauto.
  - destruct x as [[p1 p2] L]. intros [m].
    induction m.
    + inv H.
    + eapply in_app_iff in H as [|].
      * eauto.
      * eapply in_filter_iff in H as []. unfold test_eq in H0.
        destruct (Nat.eqb_spec (eval p1 L) (eval p2 L)); eauto.
Qed.

Fixpoint poly_eqb p1 p2 :=
  match p1, p2 with
  | poly_cnst n1, poly_cnst n2 => Nat.eqb n1 n2
  | poly_var v1, poly_var v2 => Nat.eqb v1 v2
  | poly_add p1 p2, poly_add p1' p2' => poly_eqb p1 p1' && poly_eqb p2 p2'
  | poly_mul p1 p2, poly_mul p1' p2' => poly_eqb p1 p1' && poly_eqb p2 p2'
  | _,_ => false
  end.

Lemma poly_eqb_spec p1 p2 :
  reflect (p1 = p2) (poly_eqb p1 p2).
Proof.
  revert p2; induction p1; destruct p2; cbn.
  all: try destruct d; try destruct d0; try now (econstructor; congruence).
  - destruct (Nat.eqb_spec n n0); subst; econstructor; congruence.
  - destruct (Nat.eqb_spec n n0); subst; econstructor; congruence.
  - destruct (IHp1_1 p2_1), (IHp1_2 p2_2); cbn; econstructor; congruence.
  - destruct (IHp1_1 p2_1), (IHp1_2 p2_2); cbn; econstructor; congruence.
Qed.

#[global]
Instance term_poly_beq : computable poly_eqb.
Proof.
  extract.
Qed.

Theorem H10_converges :
  H10 ⪯ converges.
Proof.
  eapply reduces_transitive. eapply red.
  eapply L_enumerable_halt.
  2: eapply H10_enumerable.
  exists (fun '( (p1, p2), (p1', p2')) => poly_eqb p1 p1' && poly_eqb p2 p2'). split.
  - econstructor. extract.
  - intros ( (p1, p2), (p1', p2')).
    destruct (poly_eqb_spec p1 p1'), (poly_eqb_spec p2 p2'); cbn; firstorder congruence.
Qed.
(* Print Assumptions eval_L_from. *)