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.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive bool : Set :=
| True : bool
| False : bool.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Fixpoint eqb (n : natural) (m : natural) {struct n} : bool :=
  match n with
  | Succ n' =>
    match m with
    | Succ m' => eqb n' m'
    | Zero => False
    end
  | Zero =>
    match m with
    | Succ _ => False
    | Zero => True
    end
  end.

Definition synth (lf1 : natural) : natural := Succ lf1.


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.


Require Coq.ZArith.Zpower Coq.ZArith.Znumtheory Coq.ZArith.ZArith Coq.ZArith.Zdiv.
Require Coq.micromega.Lia Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith.
Require Crypto.Util.ZUtil.AddGetCarry.
Require Crypto.Util.ZUtil.AddModulo.
Require Crypto.Util.ZUtil.CC.
Require Crypto.Util.ZUtil.CPS.
Require Crypto.Util.ZUtil.Definitions.
Require Crypto.Util.ZUtil.DistrIf.
Require Crypto.Util.ZUtil.Div.
Require Crypto.Util.ZUtil.Div.Bootstrap.
Require Crypto.Util.ZUtil.Divide.
Require Crypto.Util.ZUtil.Divide.Bool.
Require Crypto.Util.ZUtil.EquivModulo.
Require Crypto.Util.ZUtil.Ge.
Require Crypto.Util.ZUtil.Hints.
Require Crypto.Util.ZUtil.Hints.Core.
Require Crypto.Util.ZUtil.Hints.PullPush.
Require Crypto.Util.ZUtil.Hints.ZArith.
Require Crypto.Util.ZUtil.Hints.Ztestbit.
Require Crypto.Util.ZUtil.Land.
Require Crypto.Util.ZUtil.Land.Fold.
Require Crypto.Util.ZUtil.LandLorBounds.
Require Crypto.Util.ZUtil.LandLorShiftBounds.
Require Crypto.Util.ZUtil.Lor.
Require Crypto.Util.ZUtil.Le.
Require Crypto.Util.ZUtil.Lnot.
Require Crypto.Util.ZUtil.Log2.
Require Crypto.Util.ZUtil.ModInv.
Require Crypto.Util.ZUtil.Modulo.
Require Crypto.Util.ZUtil.Modulo.Bootstrap.
Require Crypto.Util.ZUtil.Modulo.PullPush.
Require Crypto.Util.ZUtil.Morphisms.
Require Crypto.Util.ZUtil.Mul.
Require Crypto.Util.ZUtil.MulSplit.
Require Crypto.Util.ZUtil.N2Z.
Require Crypto.Util.ZUtil.Notations.
Require Crypto.Util.ZUtil.Odd.
Require Crypto.Util.ZUtil.Ones.
Require Crypto.Util.ZUtil.Opp.
Require Crypto.Util.ZUtil.Peano.
Require Crypto.Util.ZUtil.Pow.
Require Crypto.Util.ZUtil.Pow2.
Require Crypto.Util.ZUtil.Pow2Mod.
Require Crypto.Util.ZUtil.Quot.
Require Crypto.Util.ZUtil.Rshi.
Require Crypto.Util.ZUtil.Sgn.
Require Crypto.Util.ZUtil.Shift.
Require Crypto.Util.ZUtil.Sorting.
Require Crypto.Util.ZUtil.Stabilization.
Require Crypto.Util.ZUtil.Tactics.
Require Crypto.Util.ZUtil.Tactics.CompareToSgn.
Require Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Crypto.Util.ZUtil.Tactics.DivideExistsMul.
Require Crypto.Util.ZUtil.Tactics.LinearSubstitute.
Require Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Crypto.Util.ZUtil.Tactics.PeelLe.
Require Crypto.Util.ZUtil.Tactics.PrimeBound.
Require Crypto.Util.ZUtil.Tactics.PullPush.
Require Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Crypto.Util.ZUtil.Tactics.RewriteModDivide.
Require Crypto.Util.ZUtil.Tactics.SimplifyFractionsLe.
Require Crypto.Util.ZUtil.Tactics.SplitMinMax.
Require Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Crypto.Util.ZUtil.Tactics.Ztestbit.
Require Crypto.Util.ZUtil.Testbit.
Require Crypto.Util.ZUtil.Z2Nat.
Require Crypto.Util.ZUtil.ZSimplify.
Require Crypto.Util.ZUtil.ZSimplify.Autogenerated.
Require Crypto.Util.ZUtil.ZSimplify.Core.
Require Crypto.Util.ZUtil.ZSimplify.Simple.
Require Crypto.Util.ZUtil.Zselect.