Require Import Rbase Ranalysis Lra.
Require Import Rfunctions Rfunction_facts Rextensionality.
Require Import Rinterval Ranalysis_def Ranalysis_def_simpl Ranalysis_facts.
Require Import Ranalysis_continuity Ranalysis_derivability Ranalysis_monotonicity.
Require Import Rfunction_classes_def.
Require Import Ass_handling.
Require Import MyR_dist.

Local Open Scope R_scope.

(** * Extensionality of the properties. *)

Lemma D_ext: forall n f g, f == g -> D n f -> D n g.
Proof.
intro n ; induction n ; intros f g f_eq_g Dnf.
 constructor.
 inversion_clear Dnf.
 assert (g_deriv : derivable g) by (eapply derivable_ext ; eassumption).
 apply (D_S _ _ g_deriv), IHn with (derive _ pr).
 intro x ; unfold derive ; rewrite (pr_nu_var2 _ _ _ (pr x) (g_deriv x) f_eq_g) ;
 reflexivity.
 assumption.
Qed.

Lemma D_Rball_ext: forall c r n f g,
  Rball_eq c r f g -> D_Rball c r n f -> D_Rball c r n g.
Proof.
intros c r n ; induction n ; intros f g Heq Hf.
 constructor.
 inversion_clear Hf.
 assert (g_deriv: derivable_Rball c r g) by (eapply derivable_in_ext_strong ; eassumption).
 apply (Db_S _ _ _ _ g_deriv), IHn with (derive_Rball _ _ _ pr).
 intros x x_in ; eapply derive_Rball_ext_strong ; eassumption.
 assumption.
Qed.

Lemma C_ext : forall n f g, f == g -> C n f -> C n g.
Proof.
intro n ; induction n ; intros f g f_eq_g Cnf.
 inversion Cnf ; constructor ; eapply continuity_ext ; eassumption.
 inversion_clear Cnf.
 assert (g_deriv : derivable g) by (eapply derivable_ext ; eassumption).
 apply (C_S _ _ g_deriv).
 apply IHn with (derive _ pr).
 intro x ; unfold derive ; rewrite (pr_nu_var2 _ _ _ (pr x) (g_deriv x) f_eq_g) ;
 reflexivity.
 assumption.
Qed.

Lemma C_Rball_ext: forall c r n f g,
  Rball_eq c r f g -> C_Rball c r n f -> C_Rball c r n g.
Proof.
intros c r n ; induction n ; intros f g Heq Hf ; inversion_clear Hf.
 constructor ; eapply continuity_in_ext_strong ; eassumption.
 assert (g_deriv: derivable_Rball c r g) by (eapply derivable_in_ext_strong ; eassumption).
 apply (Cb_S _ _ _ _ g_deriv), IHn with (derive_Rball _ _ _ pr).
 intros x x_in ; eapply derive_Rball_ext_strong ; eassumption.
 assumption.
Qed.

(** * Relations between the D and the C class. *)

(** For the full classes. *)

Lemma C_implies_D : forall n f, C n f -> D n f.
Proof.
intro n ; induction n ; intros f H.
 constructor.
 inversion H ; apply D_S with pr ; apply IHn ; assumption.
Qed.

Lemma D_S_implies_C : forall n f, D (S n) f -> C n f.
Proof.
intro n ; induction n ; intros f H ; inversion H.
 constructor ; apply derivable_continuous ; assumption.
 apply C_S with pr ; apply IHn ; assumption.
Qed.

Lemma C_infty_implies_D_infty : forall f, C_infty f -> D_infty f.
Proof.
intros f H n ; apply C_implies_D ; trivial.
Qed.

Lemma D_infty_implies_C_infty : forall f, D_infty f -> C_infty f.
Proof.
intros f H n ; apply D_S_implies_C ; trivial.
Qed.

(** Corresponding lemmas for the restrictions. *)

Lemma C_Rball_implies_D_Rball : forall n f c r,
  C_Rball c r n f -> D_Rball c r n f.
Proof.
intro n ; induction n ; intros f c r H.
 constructor.
 inversion H ; eapply Db_S with pr ; apply IHn ; assumption.
Qed.

Lemma D_Rball_S_implies_C_Rball : forall c r n f,
  D_Rball c r (S n) f -> C_Rball c r n f.
Proof.
intros c r n ; induction n ; intros f Hf ; inversion Hf.
 constructor ; apply derivable_in_continuity_in ; assumption.
 apply Cb_S with pr ; apply IHn ; assumption.
Qed.

Lemma C_Rball_infty_implies_D_Rball_infty : forall c r f,
  C_Rball_infty c r f -> D_Rball_infty c r f.
Proof.
intros ; intro ; apply C_Rball_implies_D_Rball ; trivial.
Qed.

(** Links between the full classes and the restrictions. *)

Lemma C_C_Rball: forall c r n f, C n f -> C_Rball c r n f.
Proof.
intros c r n ; induction n ; intros f Cnf ; inversion_clear Cnf.
 constructor ; apply continuity_continuity_in ; assumption.
 apply Cb_S with (derivable_derivable_in f (Rball c r) pr).
 eapply C_Rball_ext ; [| eapply IHn ; eassumption].
 apply derive_derive_Rball.
Qed.

(** * Basic Properties *)

Lemma D_pred : forall n f, D (S n) f -> D n f.
Proof.
intros ; apply C_implies_D, D_S_implies_C ; assumption.
Qed.

Lemma D_Rball_pred: forall c r n f,
  D_Rball c r (S n) f -> D_Rball c r n f.
Proof.
intros ; apply C_Rball_implies_D_Rball,
 D_Rball_S_implies_C_Rball ; assumption.
Qed.

Lemma C_pred : forall n f, C (S n) f -> C n f.
Proof.
 intros ; apply D_S_implies_C, C_implies_D ; assumption.
Qed.

Lemma C_Rball_pred : forall c r n f,
  C_Rball c r (S n) f -> C_Rball c r n f.
Proof.
 intros ; apply D_Rball_S_implies_C_Rball, C_Rball_implies_D_Rball ; assumption.
Qed.

Lemma D_le: forall m n f, (n <= m)%nat -> D m f -> D n f.
Proof.
intro m ; induction m ; intros n f Hnm Dmf.
 destruct n ; [apply Dmf | elim (le_Sn_O _ Hnm)].
 destruct (eq_nat_dec n (S m)) as [Heq | Hneq].
  subst ; assumption.
  apply IHm ; [| apply D_pred] ; intuition.
Qed.

Lemma D_Rball_le: forall c r m n f, (n <= m)%nat ->
  D_Rball c r m f -> D_Rball c r n f.
Proof.
intros c r m ; induction m ; intros n f Hnm Dmf.
 destruct n ; [apply Dmf | elim (le_Sn_O _ Hnm)].
 destruct (eq_nat_dec n (S m)) as [Heq | Hneq].
  subst ; assumption.
  apply IHm ; [| apply D_Rball_pred] ; intuition.
Qed.

Lemma C_le : forall m n f, (n <= m)%nat -> C m f -> C n f.
Proof.
intro m ; induction m ; intros n f H Cmf.
 destruct n ; [apply Cmf | elim (le_Sn_O _ H)].
 destruct (eq_nat_dec n (S m)) as [Heq | Hneq].
  subst ; assumption.
  apply IHm ; [| apply C_pred] ; intuition.
Qed.

Lemma C_Rball_le : forall c r m n f, (n <= m)%nat ->
  C_Rball c r m f -> C_Rball c r n f.
Proof.
intros c r m ; induction m ; intros n f H Cmf.
 destruct n ; [apply Cmf | elim (le_Sn_O _ H)].
 destruct (eq_nat_dec n (S m)) as [Heq | Hneq].
  subst ; assumption.
  apply IHm ; [| apply C_Rball_pred] ; intuition.
Qed.

(** * Compatibility of C, D with common operators *)

Lemma D_opp: forall n f, D n f -> D n (- f)%F.
Proof.
intro n ; induction n ; intros f Dnf.
 inversion_clear Dnf ; constructor ; reg.
 inversion_clear Dnf ; pose (pr2 := derivable_opp _ pr) ;
 apply D_S with pr2 ; apply D_ext with (- derive f pr)%F.
  intro x ; symmetry ; unfold derive ; rewrite derive_pt_eq ;
  apply derivable_pt_lim_opp; destruct (pr x) as [? Hd]; apply Hd.
  apply IHn ; assumption.
Qed.

Lemma D_Rball_opp: forall c r n f,
  D_Rball c r n f -> D_Rball c r n (- f)%F.
Proof.
intros c r n ; induction n ; intros f Hf ; inversion_clear Hf.
 constructor.
 apply Db_S with (derivable_in_opp _ _ pr) ;
 apply D_Rball_ext with (- derive_Rball c r f pr)%F.
 symmetry ; apply Req_Rball_eq ; intro ; apply derive_Rball_opp.
 apply IHn ; assumption.
Qed.

Lemma C_opp: forall n f, C n f -> C n (- f)%F.
Proof.
intro n ; induction n ; intros f Cnf.
 inversion_clear Cnf ; constructor ; reg.
 inversion_clear Cnf ; pose (pr2 := derivable_opp _ pr) ;
 apply C_S with pr2 ; apply C_ext with (- derive f pr)%F.
  intro x ; symmetry ; unfold derive ; rewrite derive_pt_eq ;
  apply derivable_pt_lim_opp; destruct (pr x) as [? Hd]; apply Hd.
  apply IHn ; assumption.
Qed.

Lemma C_Rball_opp: forall c r n f,
  C_Rball c r n f -> C_Rball c r n (- f)%F.
Proof.
intros c r n ; induction n ; intros f Hf ; inversion_clear Hf.
 constructor ; intros x Dx ; apply limit_Ropp ; ass_apply ; assumption.
 apply Cb_S with (derivable_in_opp _ _ pr) ;
 apply C_Rball_ext with (- derive_Rball c r f pr)%F.
 symmetry ; apply Req_Rball_eq ; intro ; apply derive_Rball_opp.
 apply IHn ; assumption.
Qed.

Lemma D_plus: forall n f g,
  D n f -> D n g -> D n (f + g)%F.
Proof.
intro n ; induction n ; intros f g Dnf Dng ;
 inversion_clear Dnf ; inversion_clear Dng.

 constructor.

 apply D_S with (derivable_plus _ _ pr pr0) ;
 apply D_ext with (plus_fct (derive f pr) (derive g pr0)).
 intro x ; symmetry ; transitivity (derive f pr x + derive g pr0 x).
 unfold derive ; rewrite derive_pt_eq ;
 apply derivable_pt_lim_plus ; eapply derive_pt_eq_1 ;
 reflexivity.
 auto.
 apply IHn ; assumption.
Qed.

Lemma D_Rball_plus:  forall c r n f g,
  D_Rball c r n f -> D_Rball c r n g ->
  D_Rball c r n (f + g)%F.
Proof.
intros c r n ; induction n ; intros f g Dnf Dng ;
 inversion_clear Dnf ; inversion_clear Dng.

 constructor.

 apply Db_S with (derivable_in_plus _ _ _ pr pr0) ;
 apply D_Rball_ext with (derive_Rball c r f pr + derive_Rball c r g pr0)%F.
 intros x x_in ; symmetry ; apply derive_Rball_plus ; assumption.
 apply IHn ; assumption.
Qed.

Lemma C_plus : forall n f g,
  C n f -> C n g -> C n (f + g)%F.
Proof.
intro n ; induction n ; intros f g Cnf Cng ;
 inversion_clear Cnf ; inversion_clear Cng.

 constructor ; reg.

 apply C_S with (derivable_plus _ _ pr pr0) ;
 apply C_ext with (plus_fct (derive f pr) (derive g pr0)).
 intro x ; symmetry ; transitivity (derive f pr x + derive g pr0 x).
 unfold derive ; rewrite derive_pt_eq ;
 apply derivable_pt_lim_plus ; eapply derive_pt_eq_1 ;
 reflexivity.
 auto.
 apply IHn ; assumption.
Qed.

Lemma C_Rball_plus:  forall c r n f g,
  C_Rball c r n f -> C_Rball c r n g ->
  C_Rball c r n (f + g)%F.
Proof.
intros c r n ; induction n ; intros f g Cnf Cng ;
 inversion_clear Cnf ; inversion_clear Cng.

 constructor ; intros x x_in ; apply limit_plus ;
  ass_apply ; assumption.

 apply Cb_S with (derivable_in_plus _ _ _ pr pr0) ;
 apply C_Rball_ext with (derive_Rball c r f pr + derive_Rball c r g pr0)%F.
 intros x x_in ; symmetry ; apply derive_Rball_plus ; assumption.
 apply IHn ; assumption.
Qed.

Lemma D_minus: forall n f g,
  D n f -> D n g -> D n (f - g)%F.
Proof.
intros ; unfold minus_fct, Rminus ; apply D_plus ;
 [| apply D_opp] ; assumption.
Qed.

Lemma D_Rball_minus:  forall c r n f g,
  D_Rball c r n f -> D_Rball c r n g ->
  D_Rball c r n (f - g)%F.
Proof.
intros ; unfold minus_fct, Rminus ; apply D_Rball_plus ;
 [| apply D_Rball_opp] ; assumption.
Qed.

Lemma C_minus : forall n f g,
  C n f -> C n g -> C n (f - g)%F.
Proof.
intros ; unfold minus_fct, Rminus ; apply C_plus ;
 [| apply C_opp] ; assumption.
Qed.

Lemma C_Rball_minus:  forall c r n f g,
  C_Rball c r n f -> C_Rball c r n g ->
  C_Rball c r n (f - g)%F.
Proof.
intros ; unfold minus_fct, Rminus ; apply C_Rball_plus ;
 [| apply C_Rball_opp] ; assumption.
Qed.

Lemma D_scal : forall n f a,
  D n f -> D n (mult_real_fct a f).
Proof.
intro n ; induction n ; intros f a Dnf ; inversion_clear Dnf.
 constructor.

 apply D_S with (derivable_scal _ _ pr) ;
 apply D_ext with  (mult_real_fct a (derive f pr)).
  unfold mult_real_fct ; intro x ; symmetry ; unfold derive ;
  rewrite derive_pt_eq ; apply derivable_pt_lim_scal ;
  eapply derive_pt_eq_1 ; auto.
 apply IHn ; assumption.
Qed.

Lemma D_Rball_scal : forall c r n f a,
  D_Rball c r n f -> D_Rball c r n (mult_real_fct a f).
Proof.
intros c r n ; induction n ; intros f a Dnf ; inversion_clear Dnf.
 constructor.

 apply Db_S with (derivable_in_scal _ _ _ pr) ;
 apply D_Rball_ext with  (mult_real_fct a (derive_Rball c r f pr)).
 intros x x_in ; symmetry ; apply derive_Rball_scal.

 apply IHn ; assumption.
Qed.

Lemma C_scal : forall n f a,
  C n f -> C n (mult_real_fct a f).
Proof.
intro n ; induction n ; intros f a Cnf ; inversion_clear Cnf.
 constructor ; reg.

 apply C_S with (derivable_scal _ _ pr) ;
 apply C_ext with  (mult_real_fct a (derive f pr)).
  unfold mult_real_fct ; intro x ; symmetry ; unfold derive ;
  rewrite derive_pt_eq ; apply derivable_pt_lim_scal ;
  eapply derive_pt_eq_1 ; auto.
 apply IHn ; assumption.
Qed.

(* TODO: move this *)

Lemma limit_scal: forall a f D x l,
  limit1_in f D l x ->
  limit1_in (mult_real_fct a f) D (a * l) x.
Proof.
intros a f D x l Hf eps eps_pos ; destruct (Req_dec a 0).
 exists 1 ; split ; [lra | intros y [y_in y_bd]] ;
  unfold mult_real_fct ; simpl ; subst ;
  rewrite R_dist_scal_compat, Rabs_R0, Rmult_0_l ;
  assumption.
 pose (eps' := eps / Rabs a) ; assert (eps'_pos: 0 < eps').
  apply Rlt_mult_inv_pos ; [| apply Rabs_pos_lt] ; assumption.
 destruct (Hf _ eps'_pos) as [alpha [alpha_pos Halpha]] ; exists alpha ;
  split ; [assumption |] ; intros y Hy ; unfold mult_real_fct ; simpl.
 rewrite R_dist_scal_compat ; apply Rlt_le_trans with (Rabs a * eps').
  apply Rmult_lt_compat_l ; [apply Rabs_pos_lt ; assumption |] ;
  apply Halpha ; assumption.
  right ; unfold eps' ; field ; apply Rabs_no_R0 ; assumption.
Qed.

Lemma C_Rball_scal : forall c r n f a,
  C_Rball c r n f -> C_Rball c r n (mult_real_fct a f).
Proof.
intros c r n ; induction n ; intros f a Cnf ; inversion_clear Cnf.
 constructor ; intros x x_in ; eapply limit_scal ; do 2 ass_apply.

 apply Cb_S with (derivable_in_scal _ _ _ pr) ;
 apply C_Rball_ext with  (mult_real_fct a (derive_Rball c r f pr)).
 intros x x_in ; symmetry ; apply derive_Rball_scal.

 apply IHn ; assumption.
Qed.

Lemma D_mult : forall n f g,
  D n f -> D n g -> D n (f * g)%F.
Proof.
intro n ; induction n ; intros f g Dnf Dng ;
 inversion Dnf ; inversion Dng ; subst.
  constructor.

  assert (pr1 : derivable (f * g)%F) by reg ;
  apply D_S with pr1 ;
  apply D_ext with (fun x => (derive f pr) x * g x + f x * (derive g pr0) x)%R.
  intro x ; symmetry ; unfold derive ;
  rewrite derive_pt_eq ; eapply derive_pt_eq_1 ;
  apply derive_pt_mult.

  apply D_plus ; apply IHn ; [| apply D_pred | apply D_pred |] ;
  assumption.
Qed.

Lemma D_Rball_mult : forall c r n f g,
  D_Rball c r n f -> D_Rball c r n g -> D_Rball c r n (f * g)%F.
Proof.
intros c r n ; induction n ; intros f g Dnf Dng ;
 inversion Dnf ; inversion Dng ; subst.
  constructor.

  assert (pr1 : derivable_in (Rball c r) (f * g)%F)
   by (apply derivable_in_mult ; assumption).
  apply Db_S with pr1 ;
  apply D_Rball_ext with (fun x => (derive_Rball c r f pr) x * g x
  + f x * (derive_Rball c r g pr0) x)%R.
  apply Req_Rball_eq ; intro ; symmetry ; apply derive_Rball_mult.
  apply D_Rball_plus ; apply IHn ; [| apply D_Rball_pred | apply D_Rball_pred |] ;
  assumption.
Qed.

Lemma C_mult : forall n f g,
  C n f -> C n g -> C n (f * g)%F.
Proof.
intro n ; induction n ; intros f g Cnf Cng ;
 inversion Cnf ; inversion Cng ; subst.
  constructor ; reg.

  assert (pr1 : derivable (f * g)%F) by reg ;
  apply C_S with pr1 ;
  apply C_ext with (fun x => (derive f pr) x * g x + f x * (derive g pr0) x)%R.
  intro x ; symmetry ; unfold derive ;
  rewrite derive_pt_eq ; eapply derive_pt_eq_1 ;
  apply derive_pt_mult.

  apply C_plus ; apply IHn ; [| apply C_pred | apply C_pred |] ;
  assumption.
Qed.

Lemma C_Rball_mult : forall c r n f g,
  C_Rball c r n f -> C_Rball c r n g -> C_Rball c r n (f * g)%F.
Proof.
intros c r n ; induction n ; intros f g Cnf Cng ;
 inversion Cnf ; inversion Cng ; subst.
  constructor ; intros x x_in ; apply limit_mul ; ass_apply ; assumption.

  assert (pr1 : derivable_in (Rball c r) (f * g)%F)
   by (apply derivable_in_mult ; assumption).
  apply Cb_S with pr1 ;
  apply C_Rball_ext with (fun x => (derive_Rball c r f pr) x * g x
  + f x * (derive_Rball c r g pr0) x)%R.
  apply Req_Rball_eq ; intro ; symmetry ; apply derive_Rball_mult.
  apply C_Rball_plus ; apply IHn ; [| apply C_Rball_pred | apply C_Rball_pred |] ;
  assumption.
Qed.

Lemma D_comp : forall n f g,
  D n f -> D n g -> D n (comp f g).
Proof.
 intro n ; induction n ; intros f g Dnf Dng ;
 inversion Dnf ; inversion Dng ; subst.
  constructor.

  apply D_S with (derivable_comp _ _ pr0 pr) ;
  apply D_ext with (fun x => (derive f pr) (g x) * (derive g pr0) x)%R.
  intro x ; symmetry ; unfold derive ; rewrite Rmult_comm ; apply derive_pt_comp.

   eapply D_mult.
   fold (comp (derive f pr) g).
   apply IHn ; [| apply D_pred] ; assumption.
   assumption.
Qed.

Lemma C_comp : forall n f g,
  C n f -> C n g -> C n (comp f g).
Proof.
 intro n ; induction n ; intros f g Cnf Cng ;
 inversion Cnf ; inversion Cng ; subst.
  constructor ; reg.

  apply C_S with (derivable_comp _ _ pr0 pr) ;
  apply C_ext with (fun x => (derive f pr) (g x) * (derive g pr0) x)%R.
  intro x ; symmetry ; unfold derive ; rewrite Rmult_comm ; apply derive_pt_comp.

   eapply C_mult.
   fold (comp (derive f pr) g).
   apply IHn ; [| apply C_pred] ; assumption.
   assumption.
Qed.

Hint Resolve D_opp : CD_hint.
Hint Resolve C_opp : CD_hint.
Hint Resolve D_plus : CD_hint.
Hint Resolve C_plus : CD_hint.
Hint Resolve D_minus : CD_hint.
Hint Resolve C_minus : CD_hint.
Hint Resolve D_scal : CD_hint.
Hint Resolve C_scal : CD_hint.
Hint Resolve D_mult : CD_hint.
Hint Resolve C_mult : CD_hint.
Hint Resolve D_comp : CD_hint.
Hint Resolve C_comp : CD_hint.

(** * Compatibility with derivation *)

Lemma D_derive: forall n f (pr : derivable f),
  D (S n) f -> D n (derive f pr).
Proof.
intros n f pr Dnf ; inversion_clear Dnf ; eapply D_ext ;
 [| eassumption] ; intro ; eapply pr_nu.
Qed.

Lemma D_Rball_derive: forall c r n f pr,
  D_Rball c r (S n) f ->
  D_Rball c r n (derive_Rball c r f pr).
Proof.
intros c r n f pr Dnf ; inversion_clear Dnf ;
 eapply D_Rball_ext ; [| eassumption] ;
 eapply Req_Rball_eq, derive_Rball_ext ; reflexivity.
Qed.

Lemma C_derive : forall n f (pr : derivable f),
  C (S n) f -> C n (derive f pr).
Proof.
intros n f pr Cnf ; inversion_clear Cnf ; eapply C_ext ;
 [| eassumption] ; intro ; eapply pr_nu.
Qed.

Lemma C_Rball_derive: forall c r n f pr,
  C_Rball c r (S n) f ->
  C_Rball c r n (derive_Rball c r f pr).
Proof.
intros c r n f pr Cnf ; inversion_clear Cnf ;
 eapply C_Rball_ext ; [| eassumption] ;
 eapply Req_Rball_eq, derive_Rball_ext ; reflexivity.
Qed.

(** Compatibility of C_infty, D_infty with common operators *)

Lemma D_infty_opp : forall f, D_infty f -> D_infty (- f)%F.
Proof.
intros f Df n ; apply D_opp ; trivial.
Qed.

Ltac intro_all := try (intro ; intro_all).

Lemma D_Rball_infty_opp: forall c r f,
  D_Rball_infty c r f ->
  D_Rball_infty c r (- f)%F.
Proof.
intro_all ; apply D_Rball_opp ; ass_apply.
Qed.

Lemma C_infty_opp : forall f, C_infty f -> C_infty (- f)%F.
Proof.
intros f Cf n ; apply C_opp ; trivial.
Qed.

Lemma C_Rball_infty_opp: forall c r f,
  C_Rball_infty c r f ->
  C_Rball_infty c r (- f)%F.
Proof.
intro_all ; apply C_Rball_opp ; ass_apply.
Qed.

Lemma D_infty_plus : forall f g,
  D_infty f -> D_infty g -> D_infty (f + g)%F.
Proof.
 intros f g Df Dg n ; apply D_plus ; trivial.
Qed.

Lemma D_Rball_infty_plus : forall c r f g,
  D_Rball_infty c r f ->
  D_Rball_infty c r g ->
  D_Rball_infty c r (f + g)%F.
Proof.
 intro_all ; apply D_Rball_plus ; ass_apply.
Qed.

Lemma C_infty_plus : forall f g,
  C_infty f -> C_infty g -> C_infty (plus_fct f g).
Proof.
 intros f g Cf Cg n ; apply C_plus ; trivial.
Qed.

Lemma C_Rball_infty_plus : forall c r f g,
  C_Rball_infty c r f ->
  C_Rball_infty c r g ->
  C_Rball_infty c r (f + g)%F.
Proof.
 intro_all ; apply C_Rball_plus ; ass_apply.
Qed.

Lemma D_infty_minus : forall f g,
  D_infty f -> D_infty g -> D_infty (f - g)%F.
Proof.
 intros f g Df Dg n ; apply D_minus ; trivial.
Qed.

Lemma D_Rball_infty_minus : forall c r f g,
  D_Rball_infty c r f ->
  D_Rball_infty c r g ->
  D_Rball_infty c r (f - g)%F.
Proof.
 intro_all ; apply D_Rball_minus ; ass_apply.
Qed.

Lemma C_infty_minus : forall f g,
  C_infty f -> C_infty g -> C_infty (minus_fct f g).
Proof.
 intros f g Cf Cg n ; apply C_minus ; trivial.
Qed.

Lemma C_Rball_infty_minus : forall c r f g,
  C_Rball_infty c r f ->
  C_Rball_infty c r g ->
  C_Rball_infty c r (f - g)%F.
Proof.
 intro_all ; apply C_Rball_minus ; ass_apply.
Qed.

Lemma D_infty_scal : forall f a,
  D_infty f -> D_infty (mult_real_fct a f).
Proof.
 intros f a Df n ; apply D_scal ; trivial.
Qed.

Lemma D_Rball_infty_scal : forall c r f a,
  D_Rball_infty c r f ->
  D_Rball_infty c r (mult_real_fct a f).
Proof.
 intro_all ; apply D_Rball_scal ; ass_apply.
Qed.

Lemma C_infty_scal : forall f a,
  C_infty f -> C_infty (mult_real_fct a f).
Proof.
 intros f a Cf n ; apply C_scal ; trivial.
Qed.

Lemma C_Rball_infty_scal : forall c r f a,
  C_Rball_infty c r f ->
  C_Rball_infty c r (mult_real_fct a f).
Proof.
 intro_all ; apply C_Rball_scal ; ass_apply.
Qed.

Lemma D_infty_mult : forall f g,
  D_infty f -> D_infty g -> D_infty (f * g)%F.
Proof.
 intros f g Df Dg n ; apply D_mult ; trivial.
Qed.

Lemma D_Rball_infty_mult : forall c r f g,
  D_Rball_infty c r f ->
  D_Rball_infty c r g ->
  D_Rball_infty c r (f * g)%F.
Proof.
 intro_all ; apply D_Rball_mult ; ass_apply.
Qed.

Lemma C_infty_mult : forall f g,
  C_infty f -> C_infty g -> C_infty (mult_fct f g).
Proof.
 intros f g Cf Cg n ; apply C_mult ; trivial.
Qed.

Lemma C_Rball_infty_mult : forall c r f g,
  C_Rball_infty c r f ->
  C_Rball_infty c r g ->
  C_Rball_infty c r (f * g)%F.
Proof.
 intro_all ; apply C_Rball_mult ; ass_apply.
Qed.

Lemma D_infty_comp : forall f g,
  D_infty f -> D_infty g -> D_infty (comp f g).
Proof.
 intros f g Df Dg n ; apply D_comp ; trivial.
Qed.

Lemma C_infty_comp : forall f g,
  C_infty f -> C_infty g -> C_infty (comp f g).
Proof.
 intros f g Cf Cg n ; apply C_comp ; trivial.
Qed.


Require Export Metalib.Metatheory.
Require Import Definitions.
Require Import LibTactics.
Require Export Metalib.LibLNgen.
Require Import String.

(** Computing free type variables in a type *)

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | t_int       => {}
  | t_dyn     => {}
  | t_unit     => {}
  | t_bvar J      => {}
  | t_fvar X      => {{ X }}
  | t_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | t_all T1      => (fv_tt T1)
  | t_ref T1      => (fv_tt T1)
  end.

Fixpoint fv_te (e : exp) {struct e} : atoms :=
match e with
| e_bvar i       => {}
| e_fvar x       => {}
| e_lit i        => {}
| e_unit        => {}
| e_loc l        => {}
| e_abs A e1 B   => (fv_tt A) `union` (fv_te e1) `union` (fv_tt B)
| e_app e1 e2    => (fv_te e1) `union` (fv_te e2)
| e_anno e A     => (fv_te e) `union` (fv_tt A)
| e_tabs e A     => (fv_te e) `union` (fv_tt A)
| e_tapp e A     => (fv_te e) `union` (fv_tt A)
| e_ref e     => (fv_te e)
| e_get e     => (fv_te e)
| e_set e1 e2    => (fv_te e1) `union` (fv_te e2)
end.

(** Computing free expr variables in a expr *)

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
match e with
| e_bvar i       => {}
| e_fvar x       => {{ x }}
| e_lit i        => {}
| e_unit        => {}
| e_loc l        => {}
| e_abs A e1 B   => (fv_ee e1)
| e_app e1 e2    => (fv_ee e1) `union` (fv_ee e2)
| e_anno e A     => (fv_ee e)
| e_tabs e A     => (fv_ee e)
| e_tapp e A     => (fv_ee e)
| e_ref e     => (fv_ee e)
| e_get e     => (fv_ee e)
| e_set e1 e2    => (fv_ee e1) `union` (fv_ee e2)
end.

(** Substitution for free type variables in types. *)

Fixpoint subst_tt (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | t_int         => t_int
  | t_dyn         => t_dyn
  | t_unit         => t_unit
  | t_bvar J      => t_bvar J
  | t_fvar X      => if X == Z then U else (t_fvar X)
  | t_arrow T1 T2 => t_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | t_all T1      => t_all (subst_tt Z U T1)
  | t_ref T1      => t_ref (subst_tt Z U T1)
  end.

Fixpoint subst_te (z : var) (u : typ) (e : exp) {struct e} : exp :=
  match e with
  | e_bvar i       => e_bvar i
  | e_fvar x       => e_fvar x
  | e_lit i        => e_lit i
  | e_unit         => e_unit
  | e_loc l        => e_loc l
  | e_abs A e1 B   => e_abs (subst_tt z u A) (subst_te z u e1) (subst_tt z u B)
  | e_app e1 e2    => e_app (subst_te z u e1) (subst_te z u e2)
  | e_anno e A     => e_anno (subst_te z u e) (subst_tt z u A)
  | e_tabs e A     => e_tabs (subst_te z u e) (subst_tt z u A)
  | e_tapp e A     => e_tapp (subst_te z u e) (subst_tt z u A)
  | e_ref t1    => e_ref (subst_te z u t1)
  | e_get t1    => e_get (subst_te z u t1)
  | e_set t1 t2 => e_set (subst_te z u t1) (subst_te z u t2)
  end.

(** Substitution for free expr variables in exprs. *)

Fixpoint subst_ee (z : var) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | e_bvar i       => e_bvar i
  | e_fvar x       => if x == z then u else (e_fvar x)
  | e_lit i        => e_lit i
  | e_unit         => e_unit
  | e_loc l        => e_loc l
  | e_abs A e1 B   => e_abs A (subst_ee z u e1) B
  | e_app e1 e2    => e_app (subst_ee z u e1) (subst_ee z u e2)
  | e_anno e A     => e_anno (subst_ee z u e) A
  | e_tabs e A     => e_tabs (subst_ee z u e) A
  | e_tapp e A     => e_tapp (subst_ee z u e) A
  | e_ref t1    => e_ref (subst_ee z u t1)
  | e_get t1    => e_get (subst_ee z u t1)
  | e_set t1 t2 => e_set (subst_ee z u t1) (subst_ee z u t2)
  end.

Definition subst_tb (Z : var) (P : typ) (b : binding) : binding :=
  match b with
  | bind_tvar => bind_tvar
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

(* *********************************************************************** *)
(** * Size *)

Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
match A1 with
  | t_fvar X1 => 1
  | t_bvar n1 => 1
  | t_int => 1
  | t_dyn => 1
  | t_unit => 1
  | t_all A => 1 + (size_typ A)
  | t_arrow A2 B1 => 1 + (size_typ A2) + (size_typ B1)
  | t_ref A => 1 + (size_typ A)
end.

Fixpoint size_exp (e1 : exp) {struct e1} : nat :=
match e1 with
  | e_fvar x1 => 1
  | e_bvar n1 => 1
  | e_lit i1 => 1
  | e_unit => 1
  | e_abs A1 e2 B1 => 1 + (size_typ A1) + (size_exp e2) + (size_typ B1)
  | e_app e2 e3 => 1 + (size_exp e2) + (size_exp e3)
  | e_anno e2 A1 => 1 + (size_exp e2) + (size_typ A1)
  | e_tabs e2 B1 => 1 + (size_exp e2) + (size_typ B1)
  | e_tapp e2 A1 => 1 + (size_exp e2) + (size_typ A1)
  | e_loc l => 1
  | e_ref e => 1 + (size_exp e)
  | e_get e => 1 + (size_exp e)
  | e_set e2 e3 => 1 + (size_exp e2) + (size_exp e3)
end.

(** Computing free type variables in a env *)

Fixpoint fv_tt_env (E : env) {struct E} : atoms :=
  match E with
  | nil                      => {}
  | cons (x, bind_typ t) E' => fv_tt t `union` fv_tt_env E'
  | cons (x, bind_tvar) E'  => fv_tt_env E'
  end.

Ltac gather_atoms ::=
let A := gather_atoms_with (fun x : atoms => x) in
let B := gather_atoms_with (fun x : atom => singleton x) in
let C := gather_atoms_with (fun x : exp => fv_te x) in
let D := gather_atoms_with (fun x : exp => fv_ee x) in
let E := gather_atoms_with (fun x : typ => fv_tt x) in
let F := gather_atoms_with (fun x : env => dom x) in
let G := gather_atoms_with(fun x : env => fv_tt_env x) in
constr:(A `union` B `union` C `union` D `union` E `union` F `union` G).

(* ********************************************************************** *)
(** ** Properties of type substitution in types *)

Lemma open_tt_rec_type_aux : forall T j V i U,
i <> j ->
open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
T = open_tt_rec i U T.
Proof with congruence || eauto.
induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
Case "typ_bvar".
  destruct (j === n)... destruct (i === n)...
Qed.

Lemma open_tt_rec_type : forall T U k,
type T ->
T = open_tt_rec k U T.
Proof with auto.
intros T U k Htyp. revert k.
induction Htyp; intros k; simpl; f_equal...
Case "typ_all".
  unfold open_tt in *.
  pick fresh X.
  apply (open_tt_rec_type_aux T2 0 (t_fvar X))...
Qed.

Lemma subst_tt_fresh : forall Z U T,
 Z `notin` fv_tt T ->
 T = subst_tt Z U T.
Proof with auto.
induction T; simpl; intro H; f_equal...
Case "typ_fvar".
  destruct (a == Z)...
  contradict H; fsetdec.
Qed.

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
type P ->
subst_tt X P (open_tt_rec k T2 T1) =
  open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto.
intros T1 T2 X P k WP. revert k.
induction T1; intros k; simpl; f_equal...
-
  destruct (k === n); subst...
-
 destruct (a == X); subst... apply open_tt_rec_type...
Qed.

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
type P ->
subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto.
intros.
unfold open_tt.
apply subst_tt_open_tt_rec...
Qed.

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
Y <> X ->
type P ->
open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with congruence || auto.
intros X Y P T Neq Wu.
unfold open_tt.
rewrite subst_tt_open_tt_rec...
simpl.
destruct (Y == X)...
Qed.

Lemma subst_tt_intro_rec : forall X T2 U k,
X `notin` fv_tt T2 ->
open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (t_fvar X) T2).
Proof with congruence || auto.
induction T2; intros U k Fr; simpl in *; f_equal...
- destruct (k === n)... simpl. destruct (X == X)...
- destruct (a == X)... contradict Fr; fsetdec.
Qed.

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 (t_fvar X)).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in expressions *)

Lemma open_te_rec_expr_aux : forall e j u i P ,
open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
e = open_te_rec i P e.
Proof with congruence || eauto.
induction e; intros j u i P H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_te_rec_type_aux : forall e j Q i P,
i <> j ->
open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
e = open_te_rec i P e.
Proof.
induction e; intros j Q i P Neq Heq; simpl in *; inversion Heq;
  f_equal; eauto using open_tt_rec_type_aux.
Qed.

Lemma open_te_rec_expr : forall e U k,
expr e ->
e = open_te_rec k U e.
Proof.
intros e U k WF. revert k.
induction WF; intros k; simpl; f_equal;
auto using open_tt_rec_type;
try solve [
  unfold open_ee in *;
  pick fresh x;
  eapply open_te_rec_expr_aux with (j := 0) (u := e_fvar x);
  auto
| unfold open_te in *;
  pick fresh X;
  eapply open_te_rec_type_aux with (j := 0) (Q := t_fvar X);
  auto
].
unfold open_tt in *;
pick fresh X.
eapply open_tt_rec_type_aux with (j := 0) (V := t_fvar X); eauto.
forwards*: H1 X.
forwards*: open_tt_rec_type H2.
Qed.

Lemma subst_te_open_te_rec : forall e T X U k,
type U ->
subst_te X U (open_te_rec k T e) =
  open_te_rec k (subst_tt X U T) (subst_te X U e).
Proof.
intros e T X U k WU. revert k.
induction e; intros k; simpl; f_equal; auto using subst_tt_open_tt_rec.
Qed.

Lemma subst_te_open_te_var : forall (X Y:atom) U e,
Y <> X ->
type U ->
open_te (subst_te X U e) Y = subst_te X U (open_te e Y).
Proof with congruence || auto.
intros X Y U e Neq WU.
unfold open_te.
rewrite subst_te_open_te_rec...
simpl.
destruct (Y == X)...
Qed.

Lemma subst_te_intro_rec : forall X e U k,
X `notin` fv_te e ->
open_te_rec k U e = subst_te X U (open_te_rec k (t_fvar X) e).
Proof.
induction e; intros U k Fr; simpl in *; f_equal;
  auto using subst_tt_intro_rec.
Qed.

Lemma subst_te_intro : forall X e U,
X `notin` fv_te e ->
open_te e U = subst_te X U (open_te e (t_fvar X)).
Proof with auto.
intros.
unfold open_te.
apply subst_te_intro_rec...
Qed.

Lemma subst_te_open_ee_rec : forall e1 e2 Z P k,
subst_te Z P (open_ee_rec k e2 e1) =
  open_ee_rec k (subst_te Z P e2) (subst_te Z P e1).
Proof with auto.
induction e1; intros e2 Z P k; simpl; f_equal...
Case "exp_bvar".
  destruct (k === n)...
Qed.

Lemma subst_te_open_ee : forall e1 e2 Z P,
subst_te Z P (open_ee e1 e2) = open_ee (subst_te Z P e1) (subst_te Z P e2).
Proof with auto.
intros.
unfold open_ee.
apply subst_te_open_ee_rec...
Qed.

Lemma subst_te_open_ee_var : forall Z (x:atom) P e,
open_ee (subst_te Z P e) x = subst_te Z P (open_ee e x).
Proof with auto.
intros.
rewrite subst_te_open_ee...
Qed.

(* ********************************************************************** *)
(** ** Properties of expression substitution in expressions *)

Lemma subst_ee_fresh : forall (x: atom) u e,
x `notin` fv_ee e ->
e = subst_ee x u e.
Proof with auto.
intros x u e; induction e; simpl; intro H; f_equal...
Case "exp_fvar".
  destruct (a==x)...
  contradict H; fsetdec.
Qed.

Lemma subst_ee_intro_rec : forall x e u k,
x `notin` fv_ee e ->
open_ee_rec k u e = subst_ee x u (open_ee_rec k (e_fvar x) e).
Proof with congruence || auto.
induction e; intros u k Fr; simpl in *; f_equal...
-
   destruct (k === n)... simpl. destruct (x == x)...
-
  destruct (a == x)... contradict Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall x e u,
x `notin` fv_ee e ->
open_ee e u = subst_ee x u (open_ee e (e_fvar x)).
Proof with auto.
intros.
unfold open_ee.
apply subst_ee_intro_rec...
Qed.

Lemma open_ee_rec_expr_aux : forall e j v u i,
i <> j ->
open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
e = open_ee_rec i u e.
Proof with congruence || eauto.
induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...
Case "exp_bvar".
  destruct (j===n)... destruct (i===n)...
Qed.

Lemma open_ee_rec_type_aux : forall e j V u i,
open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
e = open_ee_rec i u e.
Proof.
induction e; intros j V u i H; simpl; inversion H; f_equal; eauto.
Qed.

Lemma open_ee_rec_expr : forall u e k,
expr e ->
e = open_ee_rec k u e.
Proof with auto.
intros u e k Hexpr. revert k.
induction Hexpr; intro k; simpl; f_equal; auto*;
try solve [
  unfold open_ee in *;
  pick fresh x;
  eapply open_ee_rec_expr_aux with (j := 0) (v := e_fvar x);
  auto
| unfold open_te in *;
  pick fresh X;
  eapply open_ee_rec_type_aux with (j := 0) (V := t_fvar X);
  auto
].
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
expr u ->
subst_ee x u (open_ee_rec k e2 e1) =
  open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with auto.
intros e1 e2 x u k WP. revert k.
induction e1; intros k; simpl; f_equal...
Case "exp_bvar".
  destruct (k === n); subst...
Case "exp_fvar".
  destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
expr u ->
subst_ee x u (open_ee e1 e2) =
  open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with auto.
intros.
unfold open_ee.
apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall x y u e,
 y <> x ->
 expr u ->
(subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof with congruence || auto.
intros x y u e Neq Wu.
unfold open_ee.
rewrite subst_ee_open_ee_rec...
simpl.
destruct (y == x)...
Qed.

Lemma subst_ee_open_te_rec : forall e P z u k,
expr u ->
subst_ee z u (open_te_rec k P e) = open_te_rec k P (subst_ee z u e).
Proof with auto.
induction e; intros P z u k H; simpl; f_equal...
Case "exp_fvar".
  destruct (a == z)... apply open_te_rec_expr...
Qed.

Lemma subst_ee_open_te : forall e P z u,
expr u ->
subst_ee z u (open_te e P) = open_te (subst_ee z u e) P.
Proof with auto.
intros.
unfold open_te.
apply subst_ee_open_te_rec...
Qed.

Lemma subst_ee_open_te_var : forall z X u e,
expr u ->
open_te (subst_ee z u e) X = subst_ee z u (open_te e X).
Proof with auto.
intros z X u e H.
rewrite subst_ee_open_te...
Qed.

Scheme typ_ind' := Induction for typ Sort Prop.

Definition typ_mutind :=
fun H1 H2 H3 H4 H5 H6 H7 =>
typ_ind' H1 H2 H3 H4 H5 H6 H7.

Scheme exp_ind' := Induction for exp Sort Prop.

Definition exp_mutind :=
fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 =>
exp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12.

Ltac default_auto ::= auto with arith lngen.

Lemma fv_ee_open_ee_lower_aux : forall e1 n e2, (*3178*)
fv_ee e1 [<=] fv_ee (open_ee_rec n e2 e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

Lemma fv_ee_open_te_lower_aux : forall e1 n e2, (*3178*)
fv_ee e1 [<=] fv_ee (open_te_rec n e2 e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

Lemma fv_tt_open_tt_lower_aux : forall A n B, (*3178*)
fv_tt A [<=] fv_tt (open_tt_rec n B A).
Proof.
apply_mutual_ind typ_mutind;
default_simp; fsetdec.
Qed.

Lemma fv_ee_open_ee_lower : forall e1 e2,
fv_ee e1 [<=] fv_ee (open_ee e1 e2).
Proof.
intros.
unfold open_ee.
apply* fv_ee_open_ee_lower_aux.
Qed.

Lemma fv_ee_open_te_lower :
forall e1 A1,
fv_ee e1 [<=] fv_ee (open_te e1 A1).
Proof.
intros.
unfold open_te; simpl; try fsetdec.
apply* fv_ee_open_te_lower_aux.
Qed.

Lemma fv_tt_open_tt_lower :
forall e1 A1,
fv_tt e1 [<=] fv_tt (open_tt e1 A1).
Proof.
intros.
unfold open_tt; simpl; try fsetdec.
apply* fv_tt_open_tt_lower_aux.
Qed.

Lemma size_exp_open_exp_wrt_exp_rec_var_mutual :
(forall e1 x1 n1,
  size_typ (open_tt_rec n1 (t_fvar x1) e1) = size_typ e1).
Proof.
apply_mutual_ind typ_mutind;
default_simp.
Qed.

Lemma size_exp_open_exp_wrt_exp_rec_var :
forall e1 x1 n1,
  size_typ (open_tt_rec n1 (t_fvar x1) e1) = size_typ e1.
Proof.
pose proof size_exp_open_exp_wrt_exp_rec_var_mutual as H; intuition eauto.
Qed.

Lemma size_open_tt :
forall e1 x1,
  size_typ (open_tt e1 (t_fvar x1)) = size_typ e1.
Proof.
  unfold open_tt;intros.
  rewrite size_exp_open_exp_wrt_exp_rec_var.
  reflexivity.
Qed.

Definition irred e mu mu': Prop := forall b, ~(step (e, mu) (b, mu')).

Lemma step_not_value: forall (v:exp) mu mu',
  value v -> irred v mu mu'.
Proof.
introv.
unfold irred.
inductions v; introv H;
inverts* H;
unfold not;intros.
- inverts* H;
  try solve[
  destruct F; unfold fill in H0; inverts* H0];
  try solve[inverts* H7];
  try solve[inverts* H2;inverts H4].
Qed.

(* Notation "Γ ⊢ E => A" := (typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E <= A" := (typing Γ E Chk A) (at level 45). *)
(* Notation "E |- A ~~ B" := (consist E A B) (at level 49). *)
(* Notation "A << B" := (tpre A B) (at level 45).
Notation "e1 <<< e2" := (epre e1 e2) (at level 45). *)

Notation "[ z ~> u ] e" := (subst_ee z u e) (at level 0).
Notation "t ^^ u"       := (open_ee t u) (at level 67).
Notation "e ^ x"        := (open_ee e (e_fvar x)).

Notation "v |-> A v'" := (TypedReduce v A v') (at level 68).
Notation "e ~-> r" := (step e r) (at level 68).

(* Notation "t ->* r" := (steps t r) (at level 68).

Lemma star_one:
forall a b, step a (r_e b) -> steps a (r_e b).
Proof.
eauto using steps.
Qed.

Lemma star_trans:
forall a b, steps a (r_e b) -> forall c, steps b (r_e c) -> steps a (r_e c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma star_transb:
forall a b, steps a (r_e b) -> steps b r_blame -> steps a r_blame.
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Hint Resolve star_one star_trans star_transb: core. *)

(* *********************************************************************** *)
(** * ## Properties of [body_e] *)

(** The two kinds of facts we need about [body_e] are the following:
      - How to use it to derive that terms are locally closed.
      - How to derive it from the facts that terms are locally closed.

    Since we use it only in the context of [exp_let] and [exp_sum]
    (see the definition of reduction), those two constructors are the
    only ones we consider below. *)

  (* *********************************************************************** *)
  (** * ## Automation *)

  (** We add as hints the fact that local closure is preserved under
      substitution.  This is part of our strategy for automatically
      discharging local-closure proof obligations. *)

  Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
    unsimpl (subst_tb X U (F T)) : core.


Require Import VST.floyd.proofauto.
Require Import Coq.Classes.EquivDec.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.

Local Open Scope Z_scope.

Section PathCost.

  Context {V E DV DG : Type}.

  Context {V_EqDec : EqDec V eq}.
  Context {E_EqDec : EqDec E eq}.

  Definition path_cost (g: LabeledGraph V E DV Z DG) (path: @path V E) : Z :=
    fold_left Z.add (map (elabel g) (snd path)) 0.

  Lemma path_cost_zero:
    forall (g: LabeledGraph V E DV Z DG) src,
      path_cost g (src, []) = 0.
  Proof.
    intros. unfold path_cost; trivial.
  Qed.

  Lemma one_step_path_Znth:
    forall (g: LabeledGraph V E DV Z DG) s e,
      path_cost g (s, e :: nil) = elabel g e.
  Proof.
    intros. unfold path_cost; simpl.
    apply Z.add_0_l.
  Qed.

  Lemma acc_pos: forall (g: LabeledGraph V E DV Z DG) l z,
      (forall e : E, In e l -> 0 <= elabel g e) ->
      0 <= z ->
      0 <= fold_left Z.add (map (elabel g) l) z.
  Proof.
    intro. induction l; intros; simpl; auto. apply IHl.
    - intros. apply H. now apply in_cons.
    - assert (In a (a :: l)) by apply in_eq.
      specialize (H _ H1). lia.
  Qed.

  Lemma path_cost_init:
    forall l init s,
      fold_left Z.add l (init + s) =
      init + (fold_left Z.add l s).
  Proof.
    intros.
    generalize dependent s.
    induction l.
    - intros; simpl. trivial.
    - intros; simpl.
      rewrite <- Z.add_assoc.
      rewrite IHl. lia.
  Qed.

  Lemma path_cost_path_glue:
    forall (g: LabeledGraph V E DV Z DG) p1 p2,
      path_cost g (path_glue p1 p2) =
      path_cost g p1 + path_cost g p2.
  Proof.
    intros.
    unfold path_cost at 1, path_glue at 1.
    simpl. rewrite map_app.
    rewrite fold_left_app.
    assert ((fold_left Z.add (map (elabel g) (snd p1)) 0) = (path_cost g p1))
      by now unfold path_cost.
    rewrite H.
    unfold path_cost at 3.
    remember (map (elabel g) (snd p2)) as l2.
    remember (path_cost g p1) as c1.
    replace c1 with (c1 + 0) at 1 by lia.
    rewrite path_cost_init; trivial.
  Qed.

End PathCost.


Require Export Ordinals.

(* NON-NEGATIVE INTEGERS *)

Module NInt.

(* VIII Axiom of infinity : For some y, y is a set, Φ ∈ y and (x ∪ {x}) ∈ y
   whenever x ∈ y. *)

Axiom Axiom_Infinity : exists y, Ensemble y /\ Φ ∈ y /\
  (forall x, x ∈ y -> (x ∪ [x]) ∈ y).

Hint Resolve Axiom_Infinity : set.

(* 129 Definition  x is an integer if and only if x is an ordinal and E⁻¹
   well-orders x. *)

Definition NInteger x : Prop := Ordinal x /\ WellOrdered (E ⁻¹) x.

Hint Unfold NInteger : set.

(* 130 Definition  x is an E-last member of y is and only if x is an E⁻¹-first
   member of y. *)

Definition LastMember x E y : Prop := FirstMember x (E ⁻¹) y.

Hint Unfold LastMember : set.

(* 131 Definition  W = { x : x is an integer }. *)

Definition W : Class := \{ λ x, NInteger x \}.

Hint Unfold W : set.

(* 132 Theorem  A member of an integer is an integer. *)

Theorem Theorem132 : forall x y, NInteger x -> y∈x -> NInteger y.
Proof.
  intros.
  unfold NInteger in H; unfold NInteger; destruct H.
  double H; apply Lemma_xy with (y:= y∈x) in H2; auto.
  apply Theorem111 in H2; split; auto.
  unfold WellOrdered in H1; unfold WellOrdered.
  unfold Ordinal in H; destruct H.
  unfold full in H3; apply H3 in H0.
  destruct H1; split; intros.
  - unfold Connect in H1; unfold Connect; intros.
    apply H1; destruct H5; unfold Subclass in H0.
    apply H0 in H5; apply H0 in H6; split; auto.
  - destruct H5; apply H4; split; auto.
    apply (Theorem28 _ y _); auto.
Qed.

Hint Resolve Theorem132 : set.

(* 133 Theorem  If y∈R and x is an E-last member of y, then y = x+1. *)

Theorem Theorem133 : forall x y,
  y ∈ R /\ LastMember x E y -> y = PlusOne x.
Proof.
  intros; destruct H.
  unfold LastMember, FirstMember in H0.
  unfold R in H; apply Axiom_Scheme in H; destruct H, H0.
  double H1; add (x ∈ y) H3; apply Theorem111 in H3.
  assert (x ∈ R). { unfold R; apply Axiom_Scheme; Ens. }
  apply Theorem123 in H4; unfold FirstMember in H4; destruct H4.
  assert (y ∈ \{ λ z, z ∈ R /\ x ≺ z \}).
  { apply Axiom_Scheme; repeat split; auto.
    unfold R; apply Axiom_Scheme; split; auto. }
  apply H5 in H6; clear H5; generalize (Theorem113); intros.
  destruct H5; clear H7; apply Theorem107 in H5.
  unfold WellOrdered in H5; destruct H5; clear H7.
  unfold Connect in H5; apply Axiom_Scheme in H4; destruct H4, H7.
  clear H8; assert (y ∈ R /\ (PlusOne x) ∈ R).
  { split; auto; unfold R; apply Axiom_Scheme; Ens. }
  apply H5 in H8; clear H5; destruct H8; try contradiction.
  destruct H5; auto; unfold Rrelation, E in H5.
  apply Axiom_SchemeP in H5; destruct H5.
  apply H2 in H8; elim H8; unfold Rrelation, Inverse.
  apply Axiom_SchemeP; split; try apply Theorem49; Ens.
  unfold E; apply Axiom_SchemeP; split; try apply Theorem49; Ens.
  unfold PlusOne; apply Theorem4; right.
  unfold Singleton; apply Axiom_Scheme; Ens.
Qed.

Hint Resolve Theorem133 : set.

(* 134 Theorem  If x ∈ W, then x+1 ∈ W. *)

Theorem Theorem134 : forall x, x ∈ W -> (PlusOne x) ∈ W.
Proof.
  intros.
  unfold W in H; apply Axiom_Scheme in H; destruct H.
  unfold NInteger in H0; destruct H0.
  unfold W; apply Axiom_Scheme; split.
  - unfold PlusOne; apply Axiom_Union; split; auto.
    apply Theorem42 in H; auto.
  - unfold NInteger; split.
    + assert (x ∈ R). { apply Axiom_Scheme; Ens. }
      apply Lemma123 in H2; apply Axiom_Scheme in H2; apply H2.
    + unfold WellOrdered in H1; unfold WellOrdered.
      destruct H1; split; intros.
      { clear H2; unfold Connect in H1; unfold Connect; intros.
        unfold PlusOne in H2; destruct H2; apply Theorem4 in H2.
        apply Theorem4 in H3; destruct H2, H3.
        - apply H1; auto.
        - unfold Singleton in H3; apply Axiom_Scheme in H3; destruct H3.
          rewrite <- H4 in H2; try apply Theorem19; Ens.
          right; left; unfold Rrelation, Inverse, E.
          apply Axiom_SchemeP; split; try apply Theorem49; Ens.
          apply Axiom_SchemeP; split; try apply Theorem49; Ens.
        - unfold Singleton in H2; apply Axiom_Scheme in H2; destruct H2.
          rewrite <- H4 in H3; try apply Theorem19; Ens.
          left; unfold Rrelation, Inverse, E.
          apply Axiom_SchemeP; split; try apply Theorem49; Ens.
          apply Axiom_SchemeP; split; try apply Theorem49; Ens.
        - unfold Singleton in H2; apply Axiom_Scheme in H2; destruct H2.
          unfold Singleton in H3; apply Axiom_Scheme in H3; destruct H3.
          right; right; rewrite H4, H5; try apply Theorem19; Ens. }
      { destruct H3; unfold PlusOne in H3.
        generalize (classic (x ∈ y)); intro; destruct H5.
        - exists x; unfold FirstMember; split; intros; auto.
          intro; unfold Rrelation in H7; apply Axiom_SchemeP in H7.
          destruct H7; apply Axiom_SchemeP in H8; destruct H8.
          apply H3 in H6; apply Theorem4 in H6; destruct H6.
          + eapply Theorem102; eauto.
          + apply Axiom_Scheme in H6; destruct H6.
            rewrite H10 in H9; try apply Theorem19; Ens.
            apply Theorem101 in H9; auto.
        - apply H2; split; auto; unfold Subclass; intros; double H6.
          apply H3 in H6; apply Theorem4 in H6; destruct H6; auto.
          apply Axiom_Scheme in H6; destruct H6; apply Theorem19 in H.
          rewrite <- H8 in H5; auto; contradiction. }
Qed.

Hint Resolve Theorem134 : set.

(* 135 Theorem  Φ ∈ W and if x ∈ W, then Φ ≠ x+1. *)

Theorem Theorem135 : forall x,
  Φ ∈ W /\ (x ∈ W -> Φ ≠ PlusOne x).
Proof.
  intros; split; intros.
  - unfold W; apply Axiom_Scheme; split.
    + generalize Axiom_Infinity; intros; destruct H, H, H0; Ens.
    + unfold NInteger; split.
      * unfold Ordinal; split.
        -- unfold Connect; intros; destruct H.
           generalize (Theorem16 u); contradiction.
        -- unfold full; intros.
           generalize (Theorem16 m); contradiction.
      * unfold WellOrdered; split; intros.
        -- unfold Connect; intros; destruct H.
           generalize (Theorem16 u); contradiction.
        -- destruct H; generalize (Theorem26 y); intros.
           absurd (y = Φ); try apply Theorem27; auto.
  - intro; unfold PlusOne in H0; assert (x ∈ Φ).
    { rewrite H0; apply Theorem4; right.
      unfold Singleton; apply Axiom_Scheme; split; Ens. }
    generalize (Theorem16 x); intro; contradiction.
Qed.

Hint Resolve Theorem135 : set.

(* 136 Theorem  If x and y are members of W and x + 1 = y + 1, then x = y. *)

Theorem Theorem136 : forall x y,
  x ∈ W /\ y ∈ W -> PlusOne x = PlusOne y -> x = y.
Proof.
  intros; destruct H.
  unfold W in H, H1; apply Axiom_Scheme in H.
  apply Axiom_Scheme in H1; destruct H, H1.
  unfold NInteger in H2, H3; destruct H2, H3.
  assert (x∈R /\ y∈R).
  { split; unfold R; apply Axiom_Scheme; auto. }
  destruct H6; apply Theorem124 in H6.
  apply Theorem124 in H7; rewrite <- H6, <- H7.
  rewrite H0; auto.
Qed.

Hint Resolve Theorem136 : set.

(* 137 Theorem  If x ⊂ W, Φ∈x and u+1∈x whenever u∈x, then x = W. *)

Corollary Property_W : Ordinal W.
Proof.
  unfold Ordinal; split.
  - unfold Connect; intros; destruct H; unfold W in H, H0.
    apply Axiom_Scheme in H; apply Axiom_Scheme in H0; destruct H, H0.
    unfold NInteger in H1, H2; destruct H1, H2; add (Ordinal v) H1.
    apply Theorem110 in H1; destruct H1 as [H1|[H1|H1]]; try tauto.
    + left; unfold Rrelation, E; apply Axiom_SchemeP.
      split; auto; apply Theorem49; split; auto.
    + right; left; unfold Rrelation, E; apply Axiom_SchemeP.
      split; auto; apply Theorem49; split; auto.
  - unfold full; intros; unfold Subclass; intros.
    unfold W in H; apply Axiom_Scheme in H; destruct H.
    apply (Theorem132 _ z) in H1; auto.
    unfold W; apply Axiom_Scheme; Ens.
Qed.

Theorem Theorem137 : forall x,
  x ⊂ W -> Φ ∈ x ->
  (forall u, u ∈ x -> (PlusOne u) ∈ x) -> x = W.
Proof.
  intros.
  generalize (classic (x = W)); intros; destruct H2; auto.
  assert (exists y, FirstMember y E (W ~ x)).
  { assert (WellOrdered E W).
    { apply Theorem107; apply Property_W. }
    unfold WellOrdered in H3; destruct H3; apply H4; split.
    - unfold Subclass; intros; unfold Difference in H5.
      apply Theorem4' in H5; apply H5.
    - intro; apply Property_Φ in H; apply H in H5.
      symmetry in H5; contradiction. }
  destruct H3 as [y H3]; unfold FirstMember in H3; destruct H3.
  unfold Difference in H3; apply Theorem4' in H3; destruct H3.
  unfold W in H3; apply Axiom_Scheme in H3; destruct H3; double H6.
  unfold NInteger in H7; destruct H7; unfold WellOrdered in H8.
  destruct H8; assert (y ⊂ y /\ y ≠ Φ).
  { split; try unfold Subclass; auto.
    intro; rewrite H10 in H5; unfold Complement in H5.
    apply Axiom_Scheme in H5; destruct H5; contradiction. }
  apply H9 in H10; clear H9; destruct H10 as [u H9].
  assert (u ∈ x).
  { unfold FirstMember in H9; destruct H9; clear H10.
    generalize (classic (u∈x)); intros; destruct H10; auto.
    assert (u ∈ (W ~ x)).
    { unfold Difference; apply Theorem4'; split.
      - unfold W; apply Axiom_Scheme; split; Ens.
        apply Theorem132 in H9; auto.
      - unfold Complement; apply Axiom_Scheme; Ens. }
    apply H4 in H11; elim H11; unfold Rrelation, E.
    apply Axiom_SchemeP; split; try apply Theorem49; Ens. }
  assert (y ∈ R /\ LastMember u E y).
  { split; auto; unfold R; apply Axiom_Scheme; Ens. }
  apply Theorem133 in H11; apply H1 in H10; rewrite <- H11 in H10.
  clear H11; unfold Complement in H5; apply Axiom_Scheme in H5.
  destruct H5; unfold NotIn in H11; contradiction.
Qed.

Hint Resolve Theorem137 : set.

(* 138 Theorem  W ∈ R. *)

Theorem Theorem138 : W ∈ R.
Proof.
  unfold R; apply Axiom_Scheme; split; try apply Property_W.
  generalize Axiom_Infinity; intros; destruct H, H, H0.
  assert (W ∩ x = W).
  { apply Theorem137; intros.
    - unfold Subclass; intros; apply Theorem4' in H2; apply H2.
    - apply Theorem4'; split; auto; apply Theorem135; auto.
    - apply Theorem4' in H2; destruct H2; apply Theorem134 in H2.
      apply H1 in H3; apply Theorem4'; split; auto. }
  rewrite <- H2; apply Theorem33 with (x:=x); auto.
  unfold Subclass; intros; apply Theorem4' in H3; apply H3.
Qed.

Hint Resolve Theorem138 : set.

End NInt.

Export NInt.


(****************************************************************

   File: EqualUntypedG_ITP10.v
   Author: Amy Felty

   original: January 2010
   Apr 2021: Current Coq Version: V8.13.1

   Example from:
   Amy Felty and Brigitte Pientka, Reasoning with Higher-Order
   Abstract Syntax and Contexts: A Comparison, In International
   Conference on Interactive Theorem Proving (ITP), 2010.

   We formalized the proof of Theorem 1 in Section 2.1 using
   generalized contexts.  This formal proof is mentioned briefly at
   the end of Section 4.

   Contents:
   1. Generalized Contexts
   2. Admissibility of reflexivity for algorithmic equality
   3. Admissibility of transitivity for algorithmic equality
   4. Correctness of algorithmic equality with respect to declaritive
      equality.
   5. Adequacy

  ***************************************************************)

From HybridSys Require Export sl.

#[global] Hint Resolve level_CON level_VAR level_BND level_APP level_ABS : hybrid.
#[global] Hint Resolve proper_APP abstr_proper : hybrid.
#[global] Hint Unfold proper: hybrid.

Section encoding.

(****************************************************************
   Constants for Lambda Terms
  ****************************************************************)

Inductive Econ: Set := cAPP: Econ | cLAM: Econ.
Definition uexp : Set := expr Econ.

Definition Var : var -> uexp := (VAR Econ).
Definition Bnd : bnd -> uexp := (BND Econ).
Definition app : uexp -> uexp -> uexp :=
  fun M1:uexp => fun M2:uexp => (APP (APP (CON cAPP) M1) M2).
Definition lam : (uexp -> uexp) -> uexp :=
  fun M:uexp->uexp => (APP (CON cLAM) (lambda M)).

(****************************************************************
   Some Properties of Constructors
  ****************************************************************)

Lemma proper_Var: forall x:var, (proper (Var x)).
Proof.
unfold Var; auto with hybrid.
Qed.

Lemma proper_lam : forall (e:uexp->uexp),
  abstr e -> proper (lam e).
Proof.
unfold lam; auto with hybrid.
Qed.

Lemma proper_app : forall e1 e2:uexp,
  proper e1 -> proper e2 -> proper (app e1 e2).
Proof.
unfold app; auto with hybrid.
Qed.

(****************************************************************
   The atm type and instantiation of oo.
  ****************************************************************)

Inductive atm : Set :=
   is_tm : uexp -> atm
 | equal_d : uexp -> uexp -> atm
 | eq_a : uexp -> uexp -> atm.

Definition oo_ := oo atm Econ.
Definition atom_ : atm -> oo_ := atom Econ.
Definition T_ : oo_ := T atm Econ.

(****************************************************************
   Definition of prog
  ****************************************************************)

Inductive prog : atm -> oo_ -> Prop :=
  (* well-formedness of terms (app and lam) *)
  | tm_app : forall T1 T2:uexp,
      prog (is_tm (app T1 T2))
        (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)))
  | tm_lam : forall T:uexp->uexp, abstr T ->
      prog (is_tm (lam T))
        (All (fun x:uexp =>
          (Imp (is_tm x) (atom_ (is_tm (T x))))))
  (* declarative equality *)
  | e_l :forall T T':uexp->uexp, abstr T -> abstr T' ->
      prog (equal_d (lam T) (lam T'))
        (All (fun x:uexp =>
          (Imp (is_tm x)
            (Imp (equal_d x x) (atom_ (equal_d (T x) (T' x)))))))
  | e_a : forall T1 T2 E1 E2:uexp,
      prog (equal_d (app T1 T2) (app E1 E2))
        (Conj (atom_ (equal_d T1 E1)) (atom_ (equal_d T2 E2)))
  | e_r : forall T:uexp,
      prog (equal_d T T) (atom_ (is_tm T))
  | e_t : forall T T' S:uexp,
      prog (equal_d T S) (Conj (atom_ (equal_d T T')) (atom_ (equal_d T' S)))
  (* algorithmic equality *)
  | eq_lam :forall T T':uexp->uexp, abstr T -> abstr T' ->
      prog (eq_a (lam T) (lam T'))
        (All (fun x:uexp =>
          (Imp (eq_a x x) (atom_ (eq_a (T x) (T' x))))))
  | eq_app : forall T1 T2 E1 E2:uexp,
      prog (eq_a (app T1 T2) (app E1 E2))
        (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2))).

(****************************************************************
   Instantiation of seq
  ****************************************************************)

Definition seq_ : nat -> list atm -> oo_ -> Prop := seq prog.
Definition seq'_ := seq' prog.
Definition seq0 (B : oo_) : Prop := seq'_ nil B.

End encoding.

#[global] Hint Resolve proper_Var : hybrid.
#[global] Hint Resolve tm_app tm_lam e_l e_a e_r e_t eq_lam eq_app : hybrid.
#[global] Hint Unfold oo_ atom_ T_: hybrid.
#[global] Hint Unfold seq_ seq'_ seq0: hybrid.

(****************************************************************
   1. Generalized Contexts
  ****************************************************************)

Section weaken_strengthen_cinv.

Fixpoint eq_strengthen (G:list atm) {struct G} : list atm
  := match G with
       nil => nil
     | (a::G') => match a with
                    (is_tm x) => (eq_strengthen G')
                  | (equal_d x y) => (eq_strengthen G')
                  | a' => (a'::eq_strengthen G')
                  end
     end.

Fixpoint weaken (G:list atm) {struct G} : list atm
  := match G with
       nil => nil
     | (a::G') => match a with
                    (is_tm x) => (is_tm x::eq_a x x::weaken G')
                  | (equal_d x y) => (equal_d x y::eq_a x x::weaken G')
                  | a' => (a'::weaken G')
                  end
     end.

(* used in proofs of admissibility of reflexivity, admissibility of
   transitivity, and completeness *)
Definition eq_a_context_inv : list atm -> Prop :=
  fun G:list atm => (forall (T T':uexp), In (eq_a T T') G -> T=T').

(* used only in completeness proof *)
Definition equal_d_context_inv : list atm -> Prop :=
  fun G:list atm => (forall (T T':uexp), In (equal_d T T') G -> T=T').

Definition ceq_context_inv : list atm -> Prop :=
  fun G:list atm => (eq_a_context_inv G /\ equal_d_context_inv G).

(* used in proofs of admissibility of reflexivity and in completeness *)
Lemma eq_strengthen_weaken : forall (G:list atm) (a : atm),
   In a (eq_strengthen (weaken G)) -> In a (weaken G).
Proof.
induction G.
- intro a; simpl; tauto.
- case a.
  + intros u a0; simpl; intros [h1 | h1].
    * tauto.
    * right; right; apply IHG; auto.
  + intros u u0 a0; simpl; intros [h1 | h1].
    * tauto.
    * right; right; apply IHG; auto.
  + intros u u0 a0; simpl; intros [h1 | h1].
    * tauto.
    * right; apply IHG; auto.
Qed.

Lemma eq_strengthen_aux :
forall (G:list atm) (T T':uexp),
   In (eq_a T T') G -> In (eq_a T T') (eq_strengthen G).
Proof.
induction G.
- intros T T'; simpl; tauto.
- case a.
  + simpl; intros u T T' [h1 | h1].
    * discriminate h1.
    * apply IHG; auto.
  + simpl; intros u u0 T T' [h1 | h1].
    * discriminate h1.
    * apply IHG; auto.
  + simpl; intros u u0 T T' [h1 | h1].
    * injection h1; intros; subst; clear h1.
      left; auto.
    * right; apply IHG; auto.
Qed.

(* used in proofs of admissibility of reflexivity and in completeness *)
Lemma eq_strengthen_lem :
forall (i:nat) (G:list atm) (T T':uexp),
   seq_ i G (atom_ (eq_a T T')) ->
   seq_ i (eq_strengthen G) (atom_ (eq_a T T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (G:list atm) (T T':uexp),
      seq_ i G (atom_ (eq_a T T')) ->
      seq_ i (eq_strengthen G) (atom_ (eq_a T T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h G T T' h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T'0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h1.
    specialize H4 with (1:=h1).
    inversion H4; subst; clear H4.
    apply s_imp; auto.
    assert (h2: seq prog i0 (eq_strengthen (eq_a x x :: G))
                    (atom_ (eq_a (T0 x) (T'0 x)))).
    { apply h; auto; try lia. }
    simpl in h2; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2)));
      auto with hybrid.
    apply s_and; auto.
    * apply h; auto; try lia.
    * apply h; auto; try lia.
(* context case *)
- specialize eq_strengthen_aux with (1:=H2); auto.
  case (eq_strengthen (A'::L)).
  + simpl; tauto.
  + intros a G h1.
    apply s_init; auto.
Qed.

End weaken_strengthen_cinv.

(****************************************************************
 2. Admissibility of Reflexivity
  ****************************************************************)

Section ref.

(************)
(* Contexts *)
(************)

Lemma eq_sub_cInv : forall (G:list atm) (a:atm),
  eq_a_context_inv (a::G) -> eq_a_context_inv G.
Proof.
unfold eq_a_context_inv; simpl.
intros G a h1 T T' h2.
apply h1; tauto.
Qed.

Lemma is_tm_eq_a_weaken : forall (G:list atm) (T:uexp),
  eq_a_context_inv G ->
  In (is_tm T) (weaken G) -> In (eq_a T T) (weaken G).
Proof.
induction G.
- intro T; simpl; tauto.
- intro T; case a.
  + intros u cInv; simpl; intros [h1 | [h1 | h1]].
    * injection h1; intros; subst; tauto.
    * discriminate h1.
    * right; right; apply IHG; auto.
      apply eq_sub_cInv with (is_tm u); auto.
  + intros u u0 cInv; simpl; intros [h1 | [h1 | h1]].
    * discriminate h1.
    * discriminate h1.
    * right; right; apply IHG; auto.
      apply eq_sub_cInv with (equal_d u u0); auto.
  + intros u u0 cInv; simpl; intros [h1 | h1].
    * discriminate h1.
    * right; apply IHG; auto.
      apply eq_sub_cInv with (eq_a u u0); auto.
Qed.

Lemma ref_extended_cInv : forall (G:list atm) (x:uexp),
  eq_a_context_inv G ->
  eq_a_context_inv (is_tm x :: G).
Proof.
unfold eq_a_context_inv; intros G x cInv T T' h1.
simpl in h1; elim h1; clear h1; intro h1.
- discriminate h1.
- apply cInv; auto.
Qed.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

Lemma eq_ref :
  forall (i:nat) (T:uexp) (G:list atm),
  eq_a_context_inv G ->
  seq_ i (weaken G) (atom_ (is_tm T)) ->
  seq_ i (weaken G) (atom_ (eq_a T T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T:uexp) (G:list atm),
     eq_a_context_inv G ->
     seq_ i (weaken G) (atom_ (is_tm T)) ->
     seq_ i (weaken G) (atom_ (eq_a T T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T G cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (eq_a T1 T1)) (atom_ (eq_a T2 T2)));
      auto with hybrid.
    apply s_and; auto.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h1.
    generalize (H4 x h1); intro h2.
    inversion h2; subst; clear h2.
    apply s_imp; auto.
    generalize (ref_extended_cInv G x cInv); intro h2.
    assert (h3: i0<i0+1+1+1); try lia.
    assert (h4:(seq_ i0 (weaken (is_tm x :: G)) (atom_ (is_tm (T0 x))))).
    * simpl.
      apply seq_thin_exch with (is_tm x::weaken G); auto.
      intro a; simpl; tauto.
    * specialize h with (1:=h3) (2:=h2) (3:=h4).
      simpl in h.
      specialize eq_strengthen_lem with (1:=h); intro h5.
      simpl in h5.
      apply seq_thin_exch with (eq_a x x::eq_strengthen (weaken G)); auto.
      intro a; simpl; intros [h6 | h6].
      -- tauto.
      -- right; apply eq_strengthen_weaken; auto.
(* context case *)
- apply s_init; auto.
  rewrite -> H; rewrite -> H in H2.
  apply is_tm_eq_a_weaken; auto.
Qed.

Lemma eq_ref_cor :
  forall (T:uexp), seq0 (atom_ (is_tm T)) -> seq0 (atom_ (eq_a T T)).
Proof.
intros T [n h].
assert (cInv:eq_a_context_inv nil).
- unfold eq_a_context_inv; simpl; tauto.
- assert (h1:seq prog n (weaken nil) (atom_ (is_tm T))).
  { unfold weaken; auto. }
  specialize eq_ref with (1:=cInv) (2:=h1); intro h2.
  exists n; auto.
Qed.

End ref.

(****************************************************************
 3. Admissibility of Transivity
  ****************************************************************)

Section tr.

(************)
(* Contexts *)
(************)

Lemma tr_extended_cInv : forall (Psi:list atm) (x:uexp),
  eq_a_context_inv Psi -> eq_a_context_inv (eq_a x x::Psi).
Proof.
unfold eq_a_context_inv; intros Psi x cInv T T' h1.
simpl in h1; elim h1; clear h1; intro h1.
- injection h1; clear h1; intros; subst; subst; auto.
- specialize cInv with (1:=h1); auto.
Qed.

Lemma eq_tr :
  forall (i:nat) (T R U:uexp) (Psi:list atm), eq_a_context_inv Psi ->
  seq_ i Psi (atom_ (eq_a T R)) ->
  seq_ i Psi (atom_ (eq_a R U)) ->
  seq_ i Psi (atom_ (eq_a T U)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T R U:uexp) (Psi:list atm), eq_a_context_inv Psi ->
     seq_ i Psi (atom_ (eq_a T R)) ->
     seq_ i Psi (atom_ (eq_a R U)) ->
     seq_ i Psi (atom_ (eq_a T U)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T R U Psi cInv h1 h2.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    inversion h2; subst; clear h2.
    * inversion H1; subst; clear H1.
      specialize abstr_lbind_simp with (1:=H7) (2:=H5) (3:=H0); intro h1.
      rewrite H.
      unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T'0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h2.
      inversion H6; subst; clear H6.
      specialize H10 with (1:=h2).
      unfold ext_eq in h1; rewrite -> h1 in H10; auto; clear H0 H7 h1 T.
      assert (hi:i1=i); try lia; subst; clear H.
      specialize H4 with (1:=h2).
      inversion H10; subst; clear H10.
      inversion H4; subst; clear H4.
      apply s_imp; auto.
      assert (hi:i0=i); try lia; subst; clear H.
      apply h with (T' x); auto; try lia.
      apply tr_extended_cInv; auto.
    (* lam case: context subcase *)
    * unfold eq_a_context_inv in cInv.
      specialize cInv with (1:=H3); subst.
      unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T' x))))));
        auto with hybrid.
      apply s_all; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    inversion h2; subst; clear h2.
    * inversion H1; subst; clear H1.
      inversion H3; subst; clear H3.
      assert (hi:i1=i); try lia; subst; clear H.
      unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (eq_a T1 E0)) (atom_ (eq_a T2 E3)));
        auto with hybrid.
      apply s_and; auto.
      -- apply h with E1; try lia; auto.
      -- apply h with E2; try lia; auto.
    (* app case: context subcase *)
    * unfold eq_a_context_inv in cInv.
      specialize cInv with (1:=H2); subst.
      unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- unfold eq_a_context_inv in cInv.
  specialize cInv with (1:=H2); clear H2; subst; auto.
Qed.

Lemma eq_tr_cor : forall (T R U:uexp),
 seq0 (atom_ (eq_a T R)) -> seq0 (atom_ (eq_a R U)) ->
 seq0 (atom_ (eq_a T U)).
Proof.
intros T R U [i h1] [j h2].
assert (cInv:eq_a_context_inv nil).
- unfold eq_a_context_inv; simpl; tauto.
- exists (i+j); apply eq_tr with R; auto.
  * apply seq_mono_cor with i; auto; try lia.
  * apply seq_mono_cor with j; auto; try lia.
Qed.

End tr.

(****************************************************************
 4. Correctness
  ****************************************************************)

Section ceq.

(************)
(* Contexts *)
(************)

Lemma weaken_eq_cInv : forall (G:list atm),
  eq_a_context_inv G -> eq_a_context_inv (weaken G).
Proof.
induction G.
- simpl; tauto.
- case a.
  + unfold eq_a_context_inv; simpl.
    intros u cInv T T' [h1 | [h1 | h1]].
    * discriminate h1.
    * injection h1; intros; subst; auto.
    * unfold eq_a_context_inv in IHG.
      apply IHG; auto.
  + unfold eq_a_context_inv; simpl.
    intros u u0 cInv T T' [h1 | [h1 | h1]].
    * discriminate h1.
    * injection h1; intros; subst; auto.
    * unfold eq_a_context_inv in IHG.
      apply IHG; auto.
  + unfold eq_a_context_inv; simpl.
    intros u u0 cInv T T' [h1 | h1].
    * injection h1; intros; subst; auto.
    * unfold eq_a_context_inv in IHG.
      apply IHG; auto.
Qed.

Lemma weaken_equal_cInv : forall (G:list atm),
  equal_d_context_inv G -> equal_d_context_inv (weaken G).
Proof.
induction G.
- simpl; tauto.
- case a.
  + unfold equal_d_context_inv; simpl.
    intros u cInv T T' [h1 | [h1 | h1]].
    * discriminate h1.
    * discriminate h1.
    * unfold equal_d_context_inv in IHG.
      apply IHG; auto.
  + unfold equal_d_context_inv; simpl.
    intros u u0 cInv T T' [h1 | [h1 | h1]].
    * injection h1; intros; subst; auto.
    * discriminate h1.
    * unfold equal_d_context_inv in IHG.
      apply IHG; auto.
  + unfold equal_d_context_inv; simpl.
    intros u u0 cInv T T' [h1 | h1].
    discriminate h1.
    unfold equal_d_context_inv in IHG.
    apply IHG; auto.
Qed.

Lemma equal_eq_weaken : forall (G:list atm) (T:uexp),
  In (equal_d T T) (weaken G) -> In (eq_a T T) (weaken G).
Proof.
induction G.
- intro T; simpl; tauto.
- intro T; case a.
  + intros u; simpl; intros [h1 | [h1 | h1]].
    * discriminate h1.
    * discriminate h1.
    * right; right; apply IHG; auto.
  + intros u u0; simpl; intros [h1 | [h1 | h1]].
    * injection h1; intros; subst; auto.
    * discriminate h1.
    * right; right; apply IHG; auto.
  + intros u u0; simpl; intros [h1 | h1].
    * discriminate h1.
    * right; apply IHG; auto.
Qed.

Lemma ceq_extended_cInv1 : forall (G:list atm) (x:uexp),
  eq_a_context_inv G ->
  eq_a_context_inv (equal_d x x::is_tm x :: G).
Proof.
unfold eq_a_context_inv; intros G x cInv T T' h1.
simpl in h1; elim h1; clear h1; intro h1.
- discriminate h1.
- elim h1; clear h1; intro h1.
  + discriminate h1.
  + apply cInv; auto.
Qed.

Lemma ceq_extended_cInv2 : forall (G:list atm) (x:uexp),
  equal_d_context_inv G ->
  equal_d_context_inv (equal_d x x::is_tm x :: G).
Proof.
unfold eq_a_context_inv; intros G x cInv T T' h1.
simpl in h1; elim h1; clear h1; intro h1.
- injection h1; intros; subst; auto.
- elim h1; clear h1; intro h1.
  + discriminate h1.
  + apply cInv; auto.
Qed.

Lemma ceq_extended_cInv : forall (G:list atm) (x:uexp),
  ceq_context_inv G -> ceq_context_inv (equal_d x x::is_tm x :: G).
Proof.
unfold ceq_context_inv; intros G x [cInv1 cInv2]; split.
- apply ceq_extended_cInv1; auto.
- apply ceq_extended_cInv2; auto.
Qed.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

Lemma eq_ceq : forall (i:nat) (T R:uexp) (G:list atm),
  ceq_context_inv G ->
  seq_ i (weaken G) (atom_ (equal_d T R)) ->
  seq_ i (weaken G) (atom_ (eq_a T R)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T R:uexp) (G:list atm),
     ceq_context_inv G ->
     seq_ i (weaken G) (atom_ (equal_d T R)) ->
     seq_ i (weaken G) (atom_ (eq_a T R)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T R G cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T' x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h1.
    generalize (H4 x h1); intro h2.
    inversion h2; subst; clear h2.
    inversion H3; subst; clear H3.
    apply s_imp; auto.
    generalize (ceq_extended_cInv G x cInv); intro h2.
    assert (h3: i<i+1+1+1+1); try lia.
    assert (h4:(seq_ i (weaken (equal_d x x::is_tm x::G))
                     (atom_ (equal_d (T0 x) (T' x))))).
    { simpl.
      apply seq_thin_exch with (equal_d x x::is_tm x::weaken G); auto.
      intro a; simpl; tauto. }
    specialize h with (1:=h3) (2:=h2) (3:=h4).
    simpl in h.
    specialize eq_strengthen_lem with (1:=h); intro h5.
    simpl in h5.
    apply seq_thin_exch with
        (eq_a x x::eq_a x x::eq_strengthen (weaken G)); auto.
    * intro a; simpl; intros [h6 | [h6 | h6]]; try tauto.
      right; apply eq_strengthen_weaken; auto.
    * apply seq_mono with i; try lia; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2)));
      auto with hybrid.
    apply s_and; auto.
  (* refl case *)
  + elim cInv; clear cInv; intros cInv1 cInv2.
    apply seq_mono with i0; auto; try lia.
    apply eq_ref; auto.
  (* trans case *)
  + elim cInv; intros cInv1 cInv2.
    inversion H3; subst; clear H3.
    apply eq_tr with T'; auto.
    * apply weaken_eq_cInv; auto.
    * apply seq_mono with i; auto; try lia.
      apply h; auto; try lia.
    * apply seq_mono with i; auto; try lia.
      apply h; auto; try lia.
(* context case *)
- elim cInv; intros cInv1 cInv2.
  specialize weaken_equal_cInv with (1:=cInv2); intro h1.
  unfold equal_d_context_inv in h1.
  rewrite -> H in H2.
  specialize h1 with (1:=H2); subst.
  specialize equal_eq_weaken with (1:=H2); intro h1.
  apply s_init; auto.
  rewrite -> H; auto.
Qed.

Lemma eq_ceq_cor : forall (T R:uexp),
 seq0 (atom_ (equal_d T R)) -> seq0 (atom_ (eq_a T R)).
Proof.
intros T R [i h1].
assert (cInv:ceq_context_inv nil).
- unfold ceq_context_inv,eq_a_context_inv,equal_d_context_inv; simpl; tauto.
- assert (h2:seq prog i (weaken nil) (atom_ (equal_d T R))).
  { unfold weaken; auto. }
  specialize eq_ceq with (1:=cInv) (2:=h2); intro h3.
  exists i; auto.
Qed.

End ceq.

(****************************************************************
 5. Adequacy
  ****************************************************************)

(*********************)
(* "proper" Adequacy *)
(*********************)

Section proper_adeq.

Lemma is_tm_proper : forall T:uexp,
  seq0 (atom_ (is_tm T)) -> (proper T).
Proof.
intros T [n h1].
generalize T h1; clear h1 T.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T : uexp, seq_ n nil (atom_ (is_tm T)) -> proper T)).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* app case *)
- inversion H3; clear H3; subst.
  apply proper_app; auto.
  + apply h1 with i0; auto; try lia.
  + apply h1 with i0; auto; try lia.
(* lam case *)
- inversion H3; clear H3; subst.
  apply proper_lam; auto.
Qed.

Lemma equal_proper : forall T T':uexp,
  seq0 (atom_ (equal_d T T')) -> (proper T /\ proper T').
Proof.
intros T T' [n h1].
generalize T T' h1; clear h1 T T'.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T T' : uexp, seq_ n nil (atom_ (equal_d T T')) ->
        (proper T /\ proper T'))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T T' h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- split; apply proper_lam; auto.
(* app case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; apply proper_app; auto.
(* refl case *)
- split; apply is_tm_proper; unfold seq0,seq'_,seq'; auto.
  + exists i; auto.
  + exists i; auto.
(* trans case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; auto.
Qed.

Lemma eq_proper : forall T T':uexp,
  seq0 (atom_ (eq_a T T')) -> (proper T /\ proper T').
Proof.
intros T T' [n h1].
generalize T T' h1; clear h1 T T'.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T T' : uexp, seq_ n nil (atom_ (eq_a T T')) ->
        (proper T /\ proper T'))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T T' h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- split; apply proper_lam; auto.
(* app case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; apply proper_app; auto.
Qed.

End proper_adeq.

Section equal_adeq.

(************************)
(* Inversion Properties *)
(************************)
(* Specialized inversion properties of prog (could be automated) *)

Lemma equal_lam_inv :
forall (i:nat) (Phi:list atm) (T T':uexp->uexp),
(forall x : uexp,
       proper x ->
       seq_ i Phi (Imp (is_tm x) (Imp (equal_d x x)
                   (atom_ (equal_d (T x) (T' x)))))) ->
exists j:nat, (i=j+2 /\
 forall x : uexp,
       proper x ->
       seq_ j ((equal_d x x)::(is_tm x)::Phi) (atom_ (equal_d (T x) (T' x)))).
Proof.
induction i; auto.
intros Phi T T' H.
generalize (H (Var 0) (proper_Var 0)); intro H1.
inversion H1; clear H1; subst.
replace (i+1) with (S i) in H0; try lia.
generalize i; clear i IHi.
induction i; auto.
- intros Phi T T' H.
  generalize (H (Var 0) (proper_Var 0)); intro H1.
  inversion H1; clear H1; subst.
  inversion H4; clear H4; subst.
  replace (i0+1+1) with (S (S i0)) in H0; try lia.
- intros Phi T T' H.
  exists i; split; try lia.
  intros x H0.
  generalize (H x H0); intro H1.
  inversion H1; clear H1; subst.
  inversion H5; clear H5; subst.
  assert (i1 = i); try lia.
  subst; auto.
Qed.

(************)
(* Contexts *)
(************)

Definition equal_context_inv : list atm -> list atm -> Prop :=
  fun Phi:list atm => fun Psi:list atm =>
  ((forall (T T':uexp), (In (equal_d T T') Phi) ->
    (In (is_tm T) Psi /\ In (is_tm T') Psi)) /\
   (forall (T:uexp), In (is_tm T ) Phi ->  In (is_tm T) Psi)).

Lemma equal_extended_cInv :
  forall (Phi Psi:list atm) (x:uexp), equal_context_inv Phi Psi ->
   equal_context_inv (equal_d x x::is_tm x::Phi) (is_tm x::Psi).
Proof.
unfold equal_context_inv; intros Phi Psi x [cInv1 cInv2]; split.
- intros T T' h5; simpl in h5; elim h5; clear h5; [intro h5 | intros [h5 | h5]].
  + injection h5; clear h5; intros; subst; subst.
    simpl; tauto.
  + discriminate h5.
  + specialize cInv1 with (1:=h5).
    elim cInv1; simpl; tauto.
- simpl.
  intros T [h3 | [h3 | h3]].
  + discriminate h3.
  + injection h3; subst; tauto.
  + specialize cInv2 with (1:=h3); tauto.
Qed.

Lemma is_tm_related_contexts :
  forall (i:nat) (T:uexp) (Phi Psi:list atm),
  (forall (T:uexp), In (is_tm T) Phi ->  In (is_tm T) Psi) ->
  seq_ i Phi (atom_ (is_tm T)) ->
  seq_ i Psi (atom_ (is_tm T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T:uexp) (Phi Psi:list atm),
     (forall (T:uexp), In (is_tm T ) Phi ->  In (is_tm T) Psi) ->
     seq_ i Phi (atom_ (is_tm T)) ->
     seq_ i Psi (atom_ (is_tm T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T Phi Psi h1 h2.
inversion h2; subst; clear h2.
- inversion H0; subst; clear H0.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=h1) (3:=H4).
    specialize h' with (1:=hi) (2:=h1) (3:=H5).
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
      auto with hybrid.
    apply s_and; auto.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h5.
    generalize (H4 x h5); intro h6.
    inversion h6; subst; clear h6 H4.
    apply s_imp; auto.
    apply h with (is_tm x::Phi); auto; try lia.
    (* proof of extended context inv *)
    intro T; generalize (h1 T); simpl; tauto.
(* context case *)
- generalize (h1 T H2); clear h1 H2.
  case Psi.
  + simpl; tauto.
  + intros a Phi h1.
    apply s_init; auto with hybrid.
Qed.

(********************)
(* equal_d Adequacy *)
(********************)

Lemma equal_is_tm :
  forall (i:nat) (T T':uexp) (Phi Psi:list atm),
  equal_context_inv Phi Psi ->
  seq_ i Phi (atom_ (equal_d T T')) ->
  seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Phi Psi:list atm),
     equal_context_inv Phi Psi ->
     seq_ i Phi (atom_ (equal_d T T')) ->
     seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (equal_lam_inv i Phi T0 T'0 H4); clear H4; intros [j [h1 h2]];
      subst.
    assert (h':forall x:uexp, proper x ->
        (seq_ j (is_tm x:: Psi) (atom_ (is_tm (T0 x))) /\
         seq_ j (is_tm x:: Psi) (atom_ (is_tm (T'0 x))))).
    { intros x h1.
      apply h with (equal_d x x::is_tm x::Phi); auto; try lia.
      apply equal_extended_cInv; auto. }
    replace (j+2) with (j+1+1); try lia.
    split.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); intros [h6 h7].
      apply seq_mono with j; auto; try lia.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T'0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); intros [h6 h7].
      apply seq_mono with j; auto; try lia.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm E1)) (atom_ (is_tm E2)));
        auto with hybrid.
      apply s_and; auto.
  (* refl case *)
  + elim cInv; intros cInv1 cInv2.
    specialize is_tm_related_contexts with (1:=cInv2) (2:=H3); intro h1.
    split; apply seq_mono with i0; auto; try lia.
  (* trans case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split; apply seq_mono with i; auto; try lia.
(* context case *)
- elim cInv; intros cInv1 cInv2.
  specialize cInv1 with (1:=H2); clear H2.
  elim cInv1; clear cInv2; case Psi.
  + simpl; tauto.
  + intros a Phi h1 h2.
    split; apply s_init; auto with hybrid.
Qed.

Lemma equal_is_tm_cor : forall T T':uexp, seq0 (atom_ (equal_d T T')) ->
  (seq0 (atom_ (is_tm T)) /\ seq0 (atom_ (is_tm T'))).
Proof.
intros T T' [n h].
assert (cInv:equal_context_inv nil nil).
- unfold equal_context_inv; simpl; tauto.
- specialize equal_is_tm with (1:=cInv) (2:=h); intros [h2 h3].
  split; exists n; auto.
Qed.

End equal_adeq.

Section eq_adeq.

(************************)
(* Inversion Properties *)
(************************)
(* Specialized inversion properties of prog (could be automated) *)

Lemma eq_lam_inv :
forall (i:nat) (Psi:list atm) (T T':uexp->uexp),
(forall x : uexp,
       proper x ->
       seq_ i Psi (Imp (eq_a x x) (atom_ (eq_a (T x) (T' x))))) ->
exists j:nat, (i=j+1 /\
 forall x : uexp,
       proper x ->
       seq_ j (eq_a x x::Psi) (atom_ (eq_a (T x) (T' x)))).
Proof.
induction i; auto.
- intros Psi T T' H.
  generalize (H (Var 0) (proper_Var 0)); intro H1.
  inversion H1; clear H1; subst.
  replace (i+1) with (S i) in H0; try lia.
- intros Psi T T' H.
  exists i; split; try lia.
  intros x H0.
  generalize (H x H0); intro H1.
  inversion H1; clear H1; subst.
  assert (i0 = i); try lia.
  subst; auto.
Qed.

(************)
(* Contexts *)
(************)

Definition eq_context_inv : list atm -> list atm -> Prop :=
  fun Phi:list atm => fun Psi:list atm =>
  (forall (T T':uexp), (In (eq_a T T') Phi) ->
    (In (is_tm T) Psi /\ In (is_tm T') Psi)).

Lemma eq_extended_cInv :
  forall (Phi Psi:list atm) (x:uexp), eq_context_inv Phi Psi ->
   eq_context_inv (eq_a x x::Phi) (is_tm x::Psi).
Proof.
unfold eq_context_inv; intros Phi Psi x cInv T T' h1.
simpl in h1; elim h1; clear h1; intro h1.
- injection h1; clear h1; intros; subst; subst.
  simpl; tauto.
- specialize cInv with (1:=h1).
  elim cInv; simpl; tauto.
Qed.

(*****************)
(* eq_a Adequacy *)
(*****************)

Lemma eq_is_tm :
  forall (i:nat) (T T':uexp) (Phi Psi:list atm),
  eq_context_inv Phi Psi ->
  seq_ i Phi (atom_ (eq_a T T')) ->
  seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Phi Psi:list atm),
     eq_context_inv Phi Psi ->
     seq_ i Phi (atom_ (eq_a T T')) ->
     seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (eq_lam_inv i Phi T0 T'0 H4); clear H4; intros [j [h1 h2]];
      subst.
    assert (h':forall x:uexp, proper x ->
        (seq_ j (is_tm x:: Psi) (atom_ (is_tm (T0 x))) /\
         seq_ j (is_tm x:: Psi) (atom_ (is_tm (T'0 x))))).
    { intros x h1.
      apply h with (eq_a x x::Phi); auto; try lia.
      apply eq_extended_cInv; auto. }
    split.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); tauto.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T'0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); tauto.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm E1)) (atom_ (is_tm E2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- unfold eq_context_inv in cInv.
  specialize cInv with (1:=H2); clear H2.
  elim cInv; clear cInv; case Psi.
  + simpl; tauto.
  + intros a Phi h1 h2.
    split; apply s_init; auto with hybrid.
Qed.

Lemma eq_is_tm_cor : forall T T':uexp, seq0 (atom_ (eq_a T T')) ->
  (seq0 (atom_ (is_tm T)) /\ seq0 (atom_ (is_tm T'))).
Proof.
intros T T' [n h].
assert (cInv:eq_context_inv nil nil).
{ unfold eq_context_inv; simpl; tauto. }
specialize eq_is_tm with (1:=cInv) (2:=h); intros [h2 h3].
split; exists n; auto.
Qed.

End eq_adeq.