(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Lemmas from the Lambda JAR paper. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export TLC.LibFset.
Require Export Cyclone_LN_Tactics Cyclone_LN_Types Cyclone_LN_Terms Cyclone_LN_Types_In_Terms.
Require Export Cyclone_LN_Types_Lemmas Cyclone_LN_Terms_Lemmas.
Open Scope cyclone_scope.
Open Scope nat_scope.
Open Scope fset_scope.
Import TTM.
Import TMP.

(* This is the version just for the lemmas manipulating types in terms. *)
Module TTMP. (* T = Types TM = Term P = Proof. *)

(* ====================================================================== *)
(** ** Proofs *)

(* ********************************************************************** *)
(** Variable closing and variable opening are reciprocal of one another *)

(** Showing that [close_var] after [open_var] is the identity is easy *)

Lemma close_v_open_v :
  forall t alpha n,
  alpha \notin fv_v t ->
  close_rec_v n alpha (open_rec_v n (ftvar alpha) t) = t.
Proof.
  introv.
  induction t; simpl; introv Fr; fequals~.
Qed.

(* The application of a mutually defined induction principle in Coq is
 quite verbose. You must make N predicates for N way mutually recursively
 defined inductive types and then apply them. Each of the N must have
 it's own Lemma. To shorten this, I define functions and an Ltac to
 prevent the repeating of any text that I can. *)

Function close_st_open_st_pred (t : St) :=
  forall alpha n,
    alpha \notin fv_st t ->
    close_rec_st n alpha (open_rec_st n (ftvar alpha) t) = t.
Hint Unfold close_st_open_st_pred.

Function close_e_open_e_pred (t : E) :=
  forall alpha n,
    alpha \notin fv_e t ->
    close_rec_e n alpha (open_rec_e n (ftvar alpha) t) = t.
Hint Unfold close_e_open_e_pred.

Function close_f_open_f_pred (t : F) :=
  forall alpha n,
    alpha \notin fv_f t ->
    close_rec_f n alpha (open_rec_f n (ftvar alpha) t) = t.
Hint Unfold close_f_open_f_pred.

Function close_tau_open_tau_pred (t : Tau) :=
  forall alpha n,
    alpha \notin T.fv t ->
    T.close_rec n alpha (T.open_rec n (ftvar alpha) t) = t.
Hint Unfold close_tau_open_tau_pred.

Ltac close_X_open_X_proof :=
  autounfold in *;
  simpl;
  intros;
  fequals~;
  try applys* close_v_open_v;
  try case_nat~;
  simpl;
  try case_var~;
  try case_var~.

Ltac close_X_open_X_induction M :=
  apply(M
          close_st_open_st_pred
          close_e_open_e_pred
          close_f_open_f_pred
          close_tau_open_tau_pred).

Lemma close_st_open_st :
  forall t alpha n,
    alpha \notin fv_st t ->
    close_rec_st n alpha (open_rec_st n (ftvar alpha) t) = t.
Proof.
  close_X_open_X_induction Tau_St_ind_mutual;
  close_X_open_X_proof.
Qed.

Lemma close_e_open_e :
  forall t, close_e_open_e_pred t.
Proof.
  close_X_open_X_induction Tau_E_ind_mutual;
  close_X_open_X_proof.
Qed.

Lemma close_f_open_f :
  forall t, close_f_open_f_pred t.
Proof.
  close_X_open_X_induction Tau_F_ind_mutual;
  close_X_open_X_proof.
Qed.

Lemma close_tau_open_tau:
  forall t, close_tau_open_tau_pred t.
Proof.
  close_X_open_X_induction Tau_Tau_ind_mutual;
  close_X_open_X_proof.
Qed.

Lemma close_open :
  forall alpha t n,
  alpha \notin TTM.fv t ->
  close_rec n alpha (open_rec n (ftvar alpha) t) = t.
Proof.
  destruct t; simpl; intros; fequals~.
  applys~ close_st_open_st.
  applys~ close_e_open_e.
  applys~ close_f_open_f.
Qed.

(** The other direction is much harder; First, we first need
    to establish the injectivity of [open_var] *)

Lemma open_rec_st_inj :
  forall alpha n t1 t2,
    alpha \notin (fv_st t1) ->
    alpha \notin (fv_st t2) ->
    open_rec_st n (ftvar alpha) t1 = open_rec_st n (ftvar alpha) t2 ->
    (t1 = t2).
Proof.
  introv Fr1 Fr2 Eq.
  rewrite~ <- (@close_st_open_st t1 alpha n).
  rewrite~ <- (@close_st_open_st t2 alpha n).
  fequals~.
Qed.

Lemma open_rec_e_inj :
  forall alpha n t1 t2,
    alpha \notin (fv_e t1) ->
    alpha \notin (fv_e t2) ->
    open_rec_e n (ftvar alpha) t1 = open_rec_e n (ftvar alpha) t2 ->
    (t1 = t2).
Proof.
  introv Fr1 Fr2 Eq.
  rewrite~ <- (@close_e_open_e t1 alpha n).
  rewrite~ <- (@close_e_open_e t2 alpha n).
  fequals~.
Qed.

Lemma open_rec_f_inj :
  forall alpha n t1 t2,
    alpha \notin (fv_f t1) ->
    alpha \notin (fv_f t2) ->
    open_rec_f n (ftvar alpha) t1 = open_rec_f n (ftvar alpha) t2 ->
    (t1 = t2).
Proof.
  introv Fr1 Fr2 Eq.
  rewrite~ <- (@close_f_open_f t1 alpha n).
  rewrite~ <- (@close_f_open_f t2 alpha n).
  fequals~.
Qed.

Lemma open_rec_inj :
  forall alpha n t1 t2,
    alpha \notin (fv t1) ->
    alpha \notin (fv t2) ->
    open_rec n (ftvar alpha) t1 = open_rec n (ftvar alpha) t2 ->
    (t1 = t2).
Proof.
  introv Fr1 Fr2 Eq.
  rewrite~ <- (@close_open alpha t1 n).
  rewrite~ <- (@close_open alpha t2 n).
  fequals~.
Qed.

(** We also need one (tricky) auxiliary lemma to handle the binder case *)

Lemma open_rec_v_close_rec_v_on_open_rec_v:
  forall alpha beta gamma t i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv_v t) ->
    open_rec_v i (ftvar beta) (open_rec_v j (ftvar gamma) (close_rec_v j alpha t))
  = open_rec_v j (ftvar gamma) (close_rec_v j alpha (open_rec_v i (ftvar beta) t)).
Proof.
  induction t; try solve[simpl; intros; try solve [ fequals~ ]];
  intros;
  do 4 (simpl; try case_nat~; try case_nat~; try case_var~).
Qed.

Function open_rec_e_close_rec_e_on_open_rec_e_pred (t : E) :=
  forall alpha beta gamma i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv_e t) ->
    open_rec_e i (ftvar beta) (open_rec_e j (ftvar gamma) (close_rec_e j alpha t))
  = open_rec_e j (ftvar gamma) (close_rec_e j alpha (open_rec_e i (ftvar beta) t)).
Hint Unfold open_rec_e_close_rec_e_on_open_rec_e_pred.

Function open_rec_st_close_rec_st_on_open_rec_st_pred (t : St) :=
  forall alpha beta gamma i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv_st t) ->
    open_rec_st i (ftvar beta) (open_rec_st j (ftvar gamma) (close_rec_st j alpha t))
  = open_rec_st j (ftvar gamma) (close_rec_st j alpha (open_rec_st i (ftvar beta) t)).
Hint Unfold open_rec_st_close_rec_st_on_open_rec_st_pred.

Function open_rec_f_close_rec_f_on_open_rec_f_pred (t : F) :=
  forall alpha beta gamma i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv_f t) ->
    open_rec_f i (ftvar beta) (open_rec_f j (ftvar gamma) (close_rec_f j alpha t))
  = open_rec_f j (ftvar gamma) (close_rec_f j alpha (open_rec_f i (ftvar beta) t)).
Hint Unfold open_rec_f_close_rec_f_on_open_rec_f_pred.

Ltac open_rec_X_close_rec_X_on_open_rec_X_induction MIS :=
  apply (MIS
           open_rec_st_close_rec_st_on_open_rec_st_pred
           open_rec_e_close_rec_e_on_open_rec_e_pred
           open_rec_f_close_rec_f_on_open_rec_f_pred).

Ltac open_rec_X_close_rec_X_on_open_rec_X_proof :=
  autounfold in *;
  try solve[simpl; intros; try solve [ fequals~ ]];
  simpl;
  intros;
  fequals~;
  lets M: TP.open_close_var_on_open_var;
  auto.

Lemma open_rec_st_close_rec_st_on_open_rec_st:
  forall t, open_rec_st_close_rec_st_on_open_rec_st_pred t.
Proof.
  open_rec_X_close_rec_X_on_open_rec_X_induction St_ind_mutual;
  open_rec_X_close_rec_X_on_open_rec_X_proof.
Qed.

Lemma open_rec_e_close_rec_e_on_open_rec_e:
  forall t, open_rec_e_close_rec_e_on_open_rec_e_pred t.
Proof.
  open_rec_X_close_rec_X_on_open_rec_X_induction E_ind_mutual;
  open_rec_X_close_rec_X_on_open_rec_X_proof.
Qed.

Lemma open_rec_f_close_rec_f_on_open_rec_f:
  forall t, open_rec_f_close_rec_f_on_open_rec_f_pred t.
Proof.
  open_rec_X_close_rec_X_on_open_rec_X_induction F_ind_mutual;
  open_rec_X_close_rec_X_on_open_rec_X_proof.
Qed.

Lemma open_rec_close_rec_on_open_rec:
  forall alpha beta gamma t i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv t) ->
    open_rec i (ftvar beta) (open_rec j (ftvar gamma) (close_rec j alpha t))
  = open_rec j (ftvar gamma) (close_rec j alpha (open_rec i (ftvar beta) t)).
Proof.
  destruct t; simpl; intros; fequals~.
  applys~ open_rec_st_close_rec_st_on_open_rec_st.
  applys~ open_rec_e_close_rec_e_on_open_rec_e.
  applys~ open_rec_f_close_rec_f_on_open_rec_f.
Qed.

(** Now we can prove that [open_var] after [close_var] is the identity *)

Lemma open_rec_v_close_rec_v:
  forall alpha t n,
    lc_v t ->
    open_rec_v n (ftvar alpha) (close_rec_v n alpha t)  = t.
Proof.
  introv T.
  induction T.
  auto.
Qed.

(* Mutual induction again. *)

Function open_rec_st_close_rec_st_pred (t : St) (_ : lc_st t):=
  forall alpha n,
    open_rec_st n (ftvar alpha) (close_rec_st n alpha t)  = t.
Hint Unfold open_rec_st_close_rec_st_pred.

Function open_rec_e_close_rec_e_pred (t : E) (_ : lc_e t):=
  forall alpha n,
    open_rec_e n (ftvar alpha) (close_rec_e n alpha t)  = t.
Hint Unfold open_rec_e_close_rec_e_pred.

Function open_rec_f_close_rec_f_pred (t : F) (_ : lc_f t) :=
  forall alpha n,
    open_rec_f n (ftvar alpha) (close_rec_f n alpha t)  = t.
Hint Unfold open_rec_f_close_rec_f_pred.

Ltac open_rec_X_close_rec_X_induction MIS :=
  apply (MIS
           open_rec_st_close_rec_st_pred
           open_rec_e_close_rec_e_pred
           open_rec_f_close_rec_f_pred).

(* This interesting in that I'm hinting some very general proof tactics.
  It could be dangerous. *)

Ltac invert_lc_btvar :=
  match goal with
    | H : T.lc (btvar _) |- _  => inversion H
  end.

Hint Extern 1 (T.lc (btvar _)) => invert_lc_btvar.

Ltac inversion_on_lc :=
  match goal with
    | H : T.lc (_ _)    |- _ => inversions~ H
    | H : T.lc (_ _ _)    |- _ => inversions~ H
    | H : TTM.lc (_ _)    |- _ => inversions~ H
    | H : TTM.lc (_ _ _)    |- _ => inversions~ H
end.

Hint Extern 1 (T.lc (_ _)) => inversion_on_lc.
Hint Extern 1 (T.lc (_ _ _)) => inversion_on_lc.

Ltac open_rec_X_close_rec_X_proof t :=
  autounfold in *;
  lets: open_rec_v_close_rec_v;
  lets~ M: TP.open_close_var;
  try solve[simpl; intros; fequals~];
  simpl;
  intros;
  fequals~;
  try induction t; simpl; intros; fequals~;
  try solve[case_var~; simpl; case_nat~].

Lemma open_rec_st_close_rec_st:
  forall t,
     lc_st t ->
     forall alpha,
       forall n,
         open_rec_st n (ftvar alpha) (close_rec_st n alpha t)  = t.
Proof.
  open_rec_X_close_rec_X_induction lc_st_ind_mutual;
  open_rec_X_close_rec_X_proof t.
Qed.

Lemma open_rec_e_close_rec_e:
  forall t,
     lc_e t ->
     forall alpha,
       forall n,
         open_rec_e n (ftvar alpha) (close_rec_e n alpha t)  = t.
Proof.
  open_rec_X_close_rec_X_induction lc_e_ind_mutual;
  open_rec_X_close_rec_X_proof t.
Qed.

Lemma open_rec_f_close_rec_f:
  forall t,
     lc_f t ->
     forall alpha,
       forall n,
         open_rec_f n (ftvar alpha) (close_rec_f n alpha t)  = t.
Proof.
  open_rec_X_close_rec_X_induction lc_f_ind_mutual;
  open_rec_X_close_rec_X_proof t.
Qed.

Lemma open_rec_close_rec:
  forall t,
     lc t ->
     forall alpha,
       forall n,
         open_rec n (ftvar alpha) (close_rec n alpha t)  = t.
Proof.
  destruct t; intros; simpl; fequals~; inversions H.
  apply~ open_rec_st_close_rec_st.
  apply~ open_rec_e_close_rec_e.
  apply~ open_rec_f_close_rec_f.
Qed.

(** As a bonus, we get the injectivity of [close_var] *)

Lemma close_on_var_inj :
  forall alpha t1 t2,
    lc t1 ->
    lc t2 ->
    close alpha t1 = close alpha t2 ->
    (t1 = t2).
Proof.
  unfold close.
  introv T1 T2 Eq.
  rewrite~ <- (@open_rec_close_rec t1 T1 alpha 0).
  rewrite~ <- (@open_rec_close_rec t2 T2 alpha 0).
  fequals~.
Qed.

(* ********************************************************************** *)
(** Interaction of [fv] with [open_var] and [close_var] *)

(** Opening with [u] adds [fv u] to the set of free variables *)

Lemma fv_v_open :
  forall (t : V) (u : var) (n: nat),
    fv_v (open_rec_v n (ftvar u) t) \c  fv_v t \u \{u}.
Proof.
  intros.
  destruct t; simpl; try case_nat; simpl; fset.
Qed.

Function fv_st_open_pred (t : St) :=
  forall (u : var) (n : nat),
    fv_st (open_rec_st n (ftvar u) t) \c fv_st t \u \{u}.
Hint Unfold fv_st_open_pred.

Function fv_e_open_pred (t : E) :=
  forall (u : var) (n : nat),
    fv_e (open_rec_e n (ftvar u) t) \c fv_e t \u \{u}.
Hint Unfold fv_e_open_pred.

Function fv_f_open_pred (t : F) :=
  forall (u : var) (n : nat),
    fv_f (open_rec_f n (ftvar u) t) \c fv_f t \u \{u}.
Hint Unfold fv_f_open_pred.

Ltac fv_X_open_proof t t0 u:=
  autounfold in *;
  lets I: fv_v_open;
  try solve[intros l; simpl; try case_nat; try fset];
  simpl;
  intros;
  lets: (TP.fv_open t (ftvar u));
  try lets: (TP.fv_open t0 (ftvar u));
  lets: (TP.fv_open t (ftvar u));
  fset.

Ltac fv_X_open_induction T :=
  apply (T
           fv_st_open_pred
           fv_e_open_pred
           fv_f_open_pred).

Lemma fv_st_open:
  forall t u n,
    fv_st (open_rec_st n (ftvar u) t) \c fv_st t \u \{u}.
Proof.
  fv_X_open_induction St_ind_mutual;
  fv_X_open_proof t t0 u.
Qed.

Lemma fv_e_open :
  forall t u n,
    fv_e (open_rec_e n (ftvar u) t) \c fv_e t \u \{u}.
Proof.
  fv_X_open_induction E_ind_mutual;
  fv_X_open_proof t t0 u.
Qed.

Lemma fv_f_open :
  forall t u n,
    fv_f (open_rec_f n (ftvar u) t) \c fv_f t \u \{u}.
Proof.
  fv_X_open_induction F_ind_mutual;
  fv_X_open_proof t t0 u.
Qed.

Lemma fv_open : forall t u,
  fv (open (ftvar u) t) \c fv t \u \{u}.
Proof.
  destruct t; intros.
  apply fv_st_open.
  apply fv_e_open.
  apply fv_f_open.
Qed.

(** In particular, opening with variable [x] adds [x] to the set
    of free variables *)

Lemma open_var_fv : forall alpha t,
  fv (open_rec 0 (ftvar alpha) t) \c (fv t \u \{alpha}).
Proof.
  intros.
  apply fv_open.
Qed.

(** Closing w.r.t variable [x] removes [x] from the set of free variables *)

Lemma close_tv_v_fv : forall alpha t n,
  fv_v (close_rec_v n alpha t) \c (fv_v t \- \{alpha}).
Proof.
  intros.
  destruct t; simpl; fset.
Qed.

Function close_tv_st_fv_pred (t : St) :=
  forall alpha n,
    fv_st (close_rec_st n alpha t) \c (fv_st t \- \{alpha}).
Hint Unfold close_tv_st_fv_pred.

Function close_tv_e_fv_pred (t : E) :=
  forall alpha n,
    fv_e (close_rec_e n alpha t) \c (fv_e t \- \{alpha}).
Hint Unfold close_tv_e_fv_pred.

Function close_tv_f_fv_pred (t : F) :=
  forall alpha n,
    fv_f (close_rec_f n alpha t) \c (fv_f t \- \{alpha}).
Hint Unfold close_tv_f_fv_pred.

Ltac close_tv_X_fv_induction T :=
  apply (T
           close_tv_st_fv_pred
           close_tv_e_fv_pred
           close_tv_f_fv_pred).

Ltac close_tv_X_fv_proof :=
  lets: close_tv_v_fv;
  lets: TP.close_fv;
  autounfold in *; simpl; intros; fset.

Lemma close_tv_st_fv :
  forall t alpha n,
    fv_st (close_rec_st n alpha t) \c (fv_st t \- \{alpha}).
Proof.
  close_tv_X_fv_induction St_ind_mutual;
  close_tv_X_fv_proof.
Qed.

Lemma close_tv_e_fv :
  forall t alpha n,
    fv_e (close_rec_e n alpha t) \c (fv_e t \- \{alpha}).
Proof.
  close_tv_X_fv_induction E_ind_mutual;
  close_tv_X_fv_proof.
Qed.

Lemma close_tv_f_fv :
  forall t alpha n,
    fv_f (close_rec_f n alpha t) \c (fv_f t \- \{alpha}).
Proof.
  close_tv_X_fv_induction F_ind_mutual;
  close_tv_X_fv_proof.
Qed.

Lemma close_tv_fv : forall alpha t,
  fv (close_rec 0 alpha t) \c (fv t \- \{alpha}).
Proof.
  destruct t; intros.
  apply close_tv_st_fv.
  apply close_tv_e_fv.
  apply close_tv_f_fv.
Qed.

(* ********************************************************************** *)
(** Properties of substitution *)

(** Distributivity of [subst] on [open].
    Two (tricky) intermediate lemmas are required *)

Lemma open_rec_v_lc_ind:
  forall t j v i u,
    i <> j ->
    open_rec_v i u (open_rec_v j v t) = open_rec_v j v t ->
    open_rec_v i u t = t.
Proof.
  induction t; introv Nq Eq;
  simpls; inversions~ Eq; fequals*.
Qed.

Function open_rec_st_lc_ind_pred (t : St) :=
  forall j v i u,
    i <> j ->
    open_rec_st i u (open_rec_st j v t) = open_rec_st j v t ->
    open_rec_st i u t = t.
Hint Unfold open_rec_st_lc_ind_pred.

Function open_rec_e_lc_ind_pred (t : E) :=
  forall j v i u,
    i <> j ->
    open_rec_e i u (open_rec_e j v t) = open_rec_e j v t ->
    open_rec_e i u t = t.
Hint Unfold open_rec_e_lc_ind_pred.

Function open_rec_f_lc_ind_pred (t : F) :=
  forall j v i u,
    i <> j ->
    open_rec_f i u (open_rec_f j v t) = open_rec_f j v t ->
    open_rec_f i u t = t.
Hint Unfold open_rec_f_lc_ind_pred.

Ltac open_rec_f_lc_ind_induction T :=
  apply (T
           open_rec_st_lc_ind_pred
           open_rec_e_lc_ind_pred
           open_rec_f_lc_ind_pred).

Ltac open_rec_f_lc_ind_proof :=
  autounfold in *;
  lets: open_rec_v_lc_ind;
  lets: TP.open_rec_lc_ind;
  intros;
  simpls;
  try inversion_on_equated_constructors;
  fequals;
  intuition eauto.

Lemma open_rec_st_lc_ind:
  forall t j v i u,
    i <> j ->
    open_rec_st i u (open_rec_st j v t) = open_rec_st j v t ->
    open_rec_st i u t = t.
Proof.
  open_rec_f_lc_ind_induction St_ind_mutual;
  open_rec_f_lc_ind_proof.
Qed.

Lemma open_rec_e_lc_ind :
  forall t j v i u,
    i <> j ->
    open_rec_e i u (open_rec_e j v t) = open_rec_e j v t ->
    open_rec_e i u t = t.
Proof.
  open_rec_f_lc_ind_induction E_ind_mutual;
  open_rec_f_lc_ind_proof.
Qed.

Lemma open_rec_f_lc_ind :
  forall t j v i u,
    i <> j ->
    open_rec_f i u (open_rec_f j v t) = open_rec_f j v t ->
    open_rec_f i u t = t.
Proof.
  open_rec_f_lc_ind_induction F_ind_mutual;
  open_rec_f_lc_ind_proof.
Qed.

Lemma open_rec_lc_ind:
  forall t j v i u,
    i <> j ->
    open_rec i u (open_rec j v t) = open_rec j v t ->
    open_rec i u t = t.
Proof.
  intros.
  lets: open_rec_st_lc_ind.
  lets: open_rec_e_lc_ind.
  lets: open_rec_f_lc_ind.
  destruct t; simpls; fequals~;
  inversion_on_equated_constructors;
  intuition eauto.
Qed.

Lemma open_rec_v_lc_t : forall u t k,
  lc_v t -> open_rec_v k u t = t.
Proof.
  destruct t; intros; simpls~.
Qed.

Function open_rec_st_lc_t_st_pred (t : St) (_ : lc_st t) :=
  forall u, forall n, open_rec_st n u t = t.
Hint Unfold open_rec_st_lc_t_st_pred.

Function open_rec_e_lc_t_e_pred (t : E) (_ : lc_e t) :=
  forall u, forall n, open_rec_e n u t = t.
Hint Unfold open_rec_e_lc_t_e_pred.

Function open_rec_f_lc_t_f_pred (t : F) (_ : lc_f t):=
  forall u, forall n, open_rec_f n u t = t.
Hint Unfold open_rec_f_lc_t_f_pred.

Ltac open_rec_X_lc_t_X_induction T :=
  apply (T
           open_rec_st_lc_t_st_pred
           open_rec_e_lc_t_e_pred
           open_rec_f_lc_t_f_pred).

Ltac open_rec_X_lc_t_X_proof alpha :=
  lets: open_rec_v_lc_t;
  lets: TP.open_rec_lc;
  autounfold in *;
  intros; simpl; fequals~.

Lemma open_rec_st_lc_t:
  forall t,
    lc_st t ->
    forall u,
     forall n,
       open_rec_st n u t = t.
Proof.
  open_rec_X_lc_t_X_induction lc_st_ind_mutual;
  open_rec_X_lc_t_X_proof alpha.
Qed.

Lemma open_rec_e_lc_t :
  forall t,
    lc_e t ->
    forall u,
     forall n,
       open_rec_e n u t = t.
Proof.
  open_rec_X_lc_t_X_induction lc_e_ind_mutual;
  open_rec_X_lc_t_X_proof alpha.
Qed.

Lemma open_rec_f_lc_t :
  forall t,
    lc_f t ->
    forall u,
     forall n,
       open_rec_f n u t = t.
Proof.
  open_rec_X_lc_t_X_induction lc_f_ind_mutual;
  open_rec_X_lc_t_X_proof alpha.
Qed.

Lemma open_rec_lc_t :
  forall t,
    lc t ->
    forall u,
     forall n,
       open_rec n u t = t.
Proof.
  lets L1: open_rec_st_lc_t.
  lets L2: open_rec_e_lc_t.
  lets L3: open_rec_f_lc_t.
  destruct t; intros; simpl; fequals~; inversions~ H.
Qed.

(* Restart here. *)

Function subst_st_open_pred (t : St) :=
  forall alpha u v n,
    T.lc u ->
    subst_st u alpha (open_rec_st n v t) =
    open_rec_st n (T.subst u alpha v) (subst_st u alpha t).
Hint Unfold subst_st_open_pred.

Function subst_e_open_pred (t : E) :=
  forall alpha u v n,
    T.lc u ->
    subst_e u alpha (open_rec_e n v t) =
    open_rec_e n (T.subst u alpha v) (subst_e u alpha t).
Hint Unfold subst_e_open_pred.

Function subst_f_open_pred (t : F) :=
  forall alpha u v n,
    T.lc u ->
    subst_f u alpha (open_rec_f n v t) =
    open_rec_f n (T.subst u alpha v) (subst_f u alpha t).
Hint Unfold subst_f_open_pred.

Ltac subst_X_open_induction T :=
  apply (T
           subst_st_open_pred
           subst_e_open_pred
           subst_f_open_pred).

Ltac subst_X_open_proof :=
  autounfold in *;
  lets: TP.subst_open_rec;
  intros; simpl; fequals~.

Lemma subst_st_open:
  forall t, subst_st_open_pred t.
Proof.
  subst_X_open_induction St_ind_mutual;
  subst_X_open_proof.
Qed.

Lemma subst_e_open:
  forall t, subst_e_open_pred t.
Proof.
  subst_X_open_induction E_ind_mutual;
  subst_X_open_proof.
Qed.

Lemma subst_f_open:
  forall t, subst_f_open_pred t.
Proof.
  subst_X_open_induction F_ind_mutual;
  subst_X_open_proof.
Qed.

Lemma subst_open:
  forall (t: Term) (alpha : var) (u : Tau) (v : Tau)  n,
    T.lc u ->
    subst u alpha (open_rec n v t) =
    open_rec n (T.subst u alpha v) (subst u alpha t).
Proof.
  lets: subst_st_open;
  lets: subst_e_open;
  lets: subst_f_open;
  autounfold in *;
  destruct t;
  simpl;
  intros;
  fequals~.
Qed.

(** In particular, we can distribute [subst] on [open_var] *)

Lemma subst_open_var:
  forall alpha beta u t,
    alpha <> beta ->
    T.lc u ->
    subst u alpha (open_rec 0 (ftvar beta) t) =
    open_rec 0 (ftvar beta) (subst u alpha t).
Proof.
  introv N U.
  rewrite~ subst_open.
  fequals.
  simpl.
  case_var~.
Qed.

(** For the distributivity of [subst] on [close_var],
    one simple intermediate lemmas is required to
    say that closing on a fresh name is the identity *)

Lemma close_rec_v_fresh :
  forall alpha t k,
  alpha \notin fv_v t -> close_rec_v k alpha t = t.
Proof.
  destruct t; intros; simpls*.
Qed.

Function close_rec_st_fresh_pred (t : St) :=
  forall alpha k,
    alpha \notin fv_st t -> close_rec_st k alpha t = t.
Hint Unfold close_rec_st_fresh_pred.

Function close_rec_e_fresh_pred (t : E) :=
  forall alpha k,
    alpha \notin fv_e t -> close_rec_e k alpha t = t.
Hint Unfold close_rec_e_fresh_pred.

Function close_rec_f_fresh_pred (t : F) :=
  forall alpha k,
    alpha \notin fv_f t -> close_rec_f k alpha t = t.
Hint Unfold close_rec_f_fresh_pred.

Ltac close_rec_X_fresh_induction T :=
  apply (T
           close_rec_st_fresh_pred
           close_rec_e_fresh_pred
           close_rec_f_fresh_pred).

Ltac close_rec_X_fresh_proof :=
  lets: close_rec_v_fresh;
  lets: TP.close_rec_fresh;
  autounfold in *;
  simpl;
  intros;
  fequals~.

Lemma close_rec_st_fresh :
  forall t alpha k,
    alpha \notin fv_st t -> close_rec_st k alpha t = t.
Proof.
  close_rec_X_fresh_induction St_ind_mutual;
  close_rec_X_fresh_proof.
Qed.

Lemma close_rec_e_fresh :
  forall t alpha k,
    alpha \notin fv_e t -> close_rec_e k alpha t = t.
Proof.
  close_rec_X_fresh_induction E_ind_mutual;
  close_rec_X_fresh_proof.
Qed.

Lemma close_rec_f_fresh :
  forall t alpha k,
    alpha \notin fv_f t -> close_rec_f k alpha t = t.
Proof.
  close_rec_X_fresh_induction F_ind_mutual;
  close_rec_X_fresh_proof.
Qed.

Lemma close_rec_fresh:
  forall alpha t k,
    alpha \notin fv t -> close_rec k alpha t = t.
Proof.
  lets: close_rec_st_fresh.
  lets: close_rec_e_fresh.
  lets: close_rec_f_fresh.
  destruct t; simpl; intros; fequals~.
Qed.

(** Distributivity of [subst] on [close_var] *)

Function subst_st_close_rec_st_pred (t : St) :=
  forall (alpha beta : var) (u : Tau),
    alpha <> beta ->
    beta \notin T.fv u ->
    forall n,
      subst_st u alpha (close_rec_st n beta t) =
      close_rec_st n beta (subst_st u alpha t).
Hint Unfold subst_st_close_rec_st_pred.

Function subst_e_close_rec_e_pred (t : E) :=
  forall alpha beta u,
    alpha <> beta ->
    beta \notin T.fv u ->
    forall n,
      subst_e u alpha (close_rec_e n beta t) =
      close_rec_e n beta (subst_e u alpha t).
Hint Unfold subst_e_close_rec_e_pred.

Function subst_f_close_rec_f_pred (t : F) :=
  forall alpha beta u,
    alpha <> beta ->
    beta \notin T.fv u ->
    forall n,
      subst_f u alpha (close_rec_f n beta t) =
      close_rec_f n beta (subst_f u alpha t).
Hint Unfold subst_f_close_rec_f_pred.

Ltac subst_X_close_rec_X_induction T :=
  apply (T
           subst_st_close_rec_st_pred
           subst_e_close_rec_e_pred
           subst_f_close_rec_f_pred).

Ltac subst_X_close_rec_X_proof :=
  lets: TP.subst_close_rec;
  autounfold in *;
  simpl;
  intros;
  fequals~.

Lemma subst_st_close_rec_st:
  forall t, subst_st_close_rec_st_pred t.
Proof.
  subst_X_close_rec_X_induction St_ind_mutual;
  subst_X_close_rec_X_proof.
Qed.

Lemma subst_e_close_rec_e:
  forall t, subst_e_close_rec_e_pred t.
Proof.
  subst_X_close_rec_X_induction E_ind_mutual;
  subst_X_close_rec_X_proof.
Qed.

Lemma subst_f_close_rec_f:
  forall t, subst_f_close_rec_f_pred t.
Proof.
  subst_X_close_rec_X_induction F_ind_mutual;
  subst_X_close_rec_X_proof.
Qed.

Lemma subst_v_close_rec:
  forall t alpha beta u,
    alpha <> beta ->
    beta \notin T.fv u ->
    forall n,
      subst u alpha (close_rec n beta t) = close_rec n beta (subst u alpha t).
Proof.
  lets: subst_st_close_rec_st;
  lets: subst_e_close_rec_e;
  lets: subst_f_close_rec_f;
  autounfold in *;
  destruct t; simpl; intros; fequals~.
Qed.

(** Substitution for a fresh name is the identity *)

Function subst_st_fresh_pred (t : St) :=
  forall alpha u,
    alpha \notin fv_st t -> subst_st u alpha t = t.
Hint Unfold subst_st_fresh_pred.

Function subst_e_fresh_pred (t : E) :=
  forall alpha u,
    alpha \notin fv_e t -> subst_e u alpha t = t.
Hint Unfold subst_e_fresh_pred.

Function subst_f_fresh_pred (t : F) :=
forall alpha u,
  alpha \notin fv_f t -> subst_f u alpha t = t.
Hint Unfold subst_f_fresh_pred.

Ltac subst_X_fresh_induction T :=
  apply(T
          subst_st_fresh_pred
          subst_e_fresh_pred
          subst_f_fresh_pred).

Ltac subst_X_fresh_proof :=
  lets: subst_fresh;
  lets: TP.subst_fresh;
  autounfold in *;
  simpl;
  intros;
  fequals~.

Lemma subst_st_fresh:
  forall t alpha u,
  alpha \notin fv_st t -> subst_st u alpha t = t.
Proof.
  subst_X_fresh_induction St_ind_mutual;
  subst_X_fresh_proof.
Qed.

Lemma subst_e_fresh:
forall t alpha u,
  alpha \notin fv_e t -> subst_e u alpha t = t.
Proof.
  subst_X_fresh_induction E_ind_mutual;
  subst_X_fresh_proof.
Qed.

Lemma subst_f_fresh:
  forall t alpha u,
  alpha \notin fv_f t -> subst_f u alpha t = t.
Proof.
  subst_X_fresh_induction F_ind_mutual;
  subst_X_fresh_proof.
Qed.

Lemma subst_v_fresh : forall alpha t u,
  alpha \notin fv t -> subst u alpha t = t.
Proof.
  lets: subst_st_fresh.
  lets: subst_e_fresh.
  lets: subst_f_fresh.
  destruct t; simpl; intros; fequals~.
Qed.

(** Substitution can be introduced to decompose an opening *)

(** An alternative, longer proof, but with fewer hypotheses *)

Function subst_st_intro_alternative_pred (t : St) :=
 forall alpha  u n,
  alpha \notin (fv_st t) ->
  open_rec_st n u t = subst_st u alpha (open_rec_st n (ftvar alpha) t).
Hint Unfold subst_st_intro_alternative_pred.

Function subst_e_intro_alternative_pred (t : E) :=
 forall alpha  u n,
  alpha \notin (fv_e t) ->
  open_rec_e n u t = subst_e u alpha (open_rec_e n (ftvar alpha) t).
Hint Unfold subst_e_intro_alternative_pred.

Function subst_f_intro_alternative_pred (t : F) :=
 forall alpha  u n,
  alpha \notin (fv_f t) ->
  open_rec_f n u t = subst_f u alpha (open_rec_f n (ftvar alpha) t).
Hint Unfold subst_f_intro_alternative_pred.

Ltac subst_X_intro_alternative_induction T :=
  apply (T
           subst_st_intro_alternative_pred
           subst_e_intro_alternative_pred
           subst_f_intro_alternative_pred).

Ltac subst_X_intro_alternative_proof :=
  autounfold in *;
  lets: TP.subst_intro_alternative;
  simpl;
  intros;
  fequals~.

Lemma subst_st_intro_alternative:
  forall t, subst_st_intro_alternative_pred t.
Proof.
  subst_X_intro_alternative_induction St_ind_mutual;
  subst_X_intro_alternative_proof.
Qed.

Lemma subst_e_intro_alternative:
  forall t, subst_e_intro_alternative_pred t.
Proof.
  subst_X_intro_alternative_induction E_ind_mutual;
  subst_X_intro_alternative_proof.
Qed.

Lemma subst_f_intro_alternative:
  forall t, subst_f_intro_alternative_pred t.
Proof.
  subst_X_intro_alternative_induction F_ind_mutual;
  subst_X_intro_alternative_proof.
Qed.

Lemma subst_intro_alternative : forall alpha t u n,
  alpha \notin (fv t) ->
  open_rec n u t = subst u alpha (open_rec n (ftvar alpha) t).
Proof.
  destruct t;
  lets: subst_st_intro_alternative;
  lets: subst_e_intro_alternative;
  lets: subst_f_intro_alternative;
  autounfold in *;
  simpl; intros; fequals~.
Qed.

(** Substitution can be introduced to decompose a variable
    closing in terms of another one using a different name *)

Function close_st_rename_pred (t : St) :=
  forall alpha beta n,
  alpha \notin fv_st t ->
  close_rec_st n beta t =
  close_rec_st n alpha (subst_st (ftvar alpha) beta t).
Hint Unfold close_st_rename_pred.

Function close_e_rename_pred (t : E) :=
  forall alpha beta n,
  alpha \notin fv_e t ->
  close_rec_e n beta t =
  close_rec_e n alpha (subst_e (ftvar alpha) beta t).
Hint Unfold close_e_rename_pred.

Function close_f_rename_pred (t : F) :=
  forall alpha beta n,
  alpha \notin fv_f t ->
  close_rec_f n beta t =
  close_rec_f n alpha (subst_f (ftvar alpha) beta t).
Hint Unfold close_f_rename_pred.

Ltac close_X_rename_induction T :=
  apply (T
           close_st_rename_pred
           close_e_rename_pred
           close_f_rename_pred).

Ltac close_X_rename_proof :=
  lets M: TP.close_rename;
  autounfold in *;
  simpl;
  intros;
  fequals~.

Lemma close_st_rename:
  forall t,  close_st_rename_pred t.
Proof.
  close_X_rename_induction St_ind_mutual;
  close_X_rename_proof.
Qed.

Lemma close_e_rename:
  forall t,  close_e_rename_pred t.
Proof.
  close_X_rename_induction E_ind_mutual;
  close_X_rename_proof.
Qed.

Lemma close_f_rename:
  forall t,  close_f_rename_pred t.
Proof.
  close_X_rename_induction F_ind_mutual;
  close_X_rename_proof.
Qed.

Lemma close_rename : forall t alpha beta n,
  alpha \notin fv t ->
  close_rec n beta t =
  close_rec n alpha (subst (ftvar alpha) beta t).
Proof.
  lets: close_st_rename;
  lets: close_e_rename;
  lets: close_f_rename;
  autounfold in *;
  destruct t; simpl; intros; fequals~.
Qed.

(* ********************************************************************** *)
(** Preservation of local closure through substitution and opening *)

(** Substitution of a locally closed terms into another one produces
    a locally closed term *)

Function subst_st_lc_pred (t : St) (_ : lc_st t) :=
  forall alpha u,
    T.lc u -> lc_st (subst_st u alpha t).
Hint Unfold subst_st_lc_pred.

Function subst_e_lc_pred (t : E) (_ : lc_e t) :=
  forall alpha u,
    T.lc u -> lc_e (subst_e u alpha t).
Hint Unfold subst_e_lc_pred.

Function subst_f_lc_pred (t : F) (_ : lc_f t) :=
  forall alpha u,
    T.lc u -> lc_f (subst_f u alpha t).
Hint Unfold subst_f_lc_pred.

Ltac subst_X_lc_induction T :=
  apply (T
           subst_st_lc_pred
           subst_e_lc_pred
           subst_f_lc_pred).

Ltac subst_X_lc_proof :=
  autounfold in *;
  simpl;
  intros;
  fequals~;
  lets: TP.subst_lc;
  constructor~.

Lemma subst_st_lc :
  forall t,
    lc_st t ->
    forall alpha u,
    T.lc u -> lc_st (subst_st u alpha t).
Proof.
  subst_X_lc_induction lc_st_ind_mutual;
  subst_X_lc_proof.
Qed.

Lemma subst_e_lc :
  forall t,
    lc_e t ->
    forall alpha u,
    T.lc u -> lc_e (subst_e u alpha t).
Proof.
  subst_X_lc_induction lc_e_ind_mutual;
  subst_X_lc_proof.
Qed.

Lemma subst_f_lc :
  forall t,
    lc_f t ->
    forall alpha u,
    T.lc u -> lc_f (subst_f u alpha t).
Proof.
  subst_X_lc_induction lc_f_ind_mutual;
  subst_X_lc_proof.
Qed.

Lemma subst_lc :
  forall alpha u t,
    T.lc u -> lc t -> lc (subst u alpha t).
Proof.
  lets: subst_st_lc;
  lets: subst_e_lc;
  lets: subst_f_lc;
  simpl;
  intros;
  destruct t;
  inversion_on_lc;
  constructor~.
Qed.

(** Substitution of a locally closed terms into a body one produces
    another body *)

(* We need a lemma that Arthur only proved for his alternate inductive lc. *)
Lemma lc_open_var_rec_v:
  forall t alpha,
    lc_v t -> lc_v (open_rec_v 0 (ftvar alpha) t).
Proof.
  induction t; auto.
Qed.

Function lc_open_var_rec_st_pred (t : St) :=
  forall alpha,
    lc_st t -> lc_st (open_rec_st 0 (ftvar alpha) t).
Hint Unfold lc_open_var_rec_st_pred.

Function lc_open_var_rec_e_pred (t : E) :=
  forall alpha,
    lc_e t -> lc_e (open_rec_e 0 (ftvar alpha) t).
Hint Unfold lc_open_var_rec_e_pred.

Function lc_open_var_rec_f_pred (t : F) :=
  forall alpha,
    lc_f t -> lc_f (open_rec_f 0 (ftvar alpha) t).
Hint Unfold lc_open_var_rec_f_pred.

Ltac lc_open_var_rec_X_induction T :=
  apply (T
           lc_open_var_rec_st_pred
           lc_open_var_rec_e_pred
           lc_open_var_rec_f_pred).

Ltac inversion_on_lc_term :=
  match goal with
    | H : TTM.lc_st (_ _)    |- _ => inversions~ H
    | H : TTM.lc_st (_ _ _)    |- _ => inversions~ H
    | H : TTM.lc_e (_ _)    |- _ => inversions~ H
    | H : TTM.lc_e (_ _ _)    |- _ => inversions~ H
    | H : TTM.lc_f (_ _)    |- _ => inversions~ H
    | H : TTM.lc_f (_ _ _)    |- _ => inversions~ H
end.

Ltac lc_open_var_rec_X_proof :=
  lets: lc_open_var_rec_v;
  autounfold in *;
  simpl;
  intros;
  inversion_on_lc_term;
  constructor~;
  applys~ TP.lc_open_var_rec.

Lemma lc_open_var_rec_st:
  forall t, lc_open_var_rec_st_pred t.
Proof.
  lc_open_var_rec_X_induction St_ind_mutual;
  lc_open_var_rec_X_proof.
Qed.

Lemma lc_open_var_rec_e:
  forall t, lc_open_var_rec_e_pred t.
Proof.
  lc_open_var_rec_X_induction E_ind_mutual;
  lc_open_var_rec_X_proof.
Qed.

Lemma lc_open_var_rec_f:
  forall t, lc_open_var_rec_f_pred t.
Proof.
  lc_open_var_rec_X_induction F_ind_mutual;
  lc_open_var_rec_X_proof.
Qed.

Lemma lc_open_var_rec:
  forall alpha t,
    lc t -> lc (open_rec 0 (ftvar alpha) t).
Proof.
  intros.
  lets: lc_open_var_rec_st;
  lets: lc_open_var_rec_e;
  lets: lc_open_var_rec_f;
  destruct t;
  autounfold in *;
  inversions~ H;
  constructor~.
Qed.

Lemma subst_body :
  forall alpha t u,
    T.lc u -> body t -> body (subst u alpha t).
Proof.
  introv U [L H].
  exists_fresh.
  rewrite~ <- subst_open_var.
  apply~ subst_lc.
Qed.

(** Opening of a body with a locally closed terms produces a
    locally closed term *)

Lemma open_rec_preserves_lc : forall t u,
  body t -> T.lc u -> lc (open_rec 0 u t).
Proof.
  introv [L H] U.
  pick_fresh alpha.
  rewrite~ (@subst_intro_alternative alpha).
  apply~ subst_lc.
Qed.

(* ********************************************************************** *)
(** Properties of [body] *)

(** An abstraction is locally closed iff it satifies the predicate [body] *)

(* This is a weakened version as body does not imply lc t0 and lc t1. *)
Lemma lc_dfun_iff_body :
  forall t0 t1 s,
    T.lc t0 ->
    T.lc t1 ->
    lc_st s ->
    lc (term_f (dfun t0 t1 s)) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  inversions~ H3.
  unfold body.
  exists ((T.fv t0 \u T.fv t1) \u TM.fv_st s \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_rec_st.

  unfold body in A.
  simpl in A.
  constructor.
  constructor~.
Qed.

Lemma lc_open_iff_body:
  forall e s,
    lc_e e ->
    lc_st s ->
    lc_st (openx e s) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  unfold body.
  exists ((fv_e e) \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_rec_st.

  unfold body in A.
  simpl in A.
  constructor.
  assumption.
  assumption.
Qed.

Lemma lc_openstar_iff_body :
  forall e s,
    lc_e e ->
    lc_st s ->
    lc_st (openstar e s) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  unfold body.
  exists ((fv_e e) \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_rec_st.

  unfold body in A.
  simpl in A.
  constructor.
  assumption.
  assumption.
Qed.

Lemma lc_letx_iff_body :
  forall e s,
    lc_e e ->
    lc_st s ->
    lc_st (letx e s) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  unfold body.
  exists ((fv_e e) \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_rec_st.

  unfold body in A.
  simpl in A.
  constructor.
  assumption.
  assumption.
Qed.

(* ====================================================================== *)
(** ** An induction principle for locally closed terms *)

(** Interaction of [size] with [open_var] *)

Lemma size_open_rec_v:
  forall t alpha n,
    TM.size_v (open_rec_v n (ftvar alpha) t) = TM.size_v t.
Proof.
  intros.
  induction t; auto.
Qed.

Function size_open_rec_st_pred (t : St) :=
  forall alpha n,
    TM.size_st (open_rec_st n (ftvar alpha) t) = TM.size_st t.
Hint Unfold size_open_rec_st_pred.

Function size_open_rec_e_pred (t : E) :=
  forall alpha n,
    TM.size_e (open_rec_e n (ftvar alpha) t) = TM.size_e t.
Hint Unfold size_open_rec_e_pred.

Function size_open_rec_f_pred (t : F) :=
  forall alpha n,
    TM.size_f (open_rec_f n (ftvar alpha) t) = TM.size_f t.
Hint Unfold size_open_rec_f_pred.

Ltac size_open_rec_X_induction T :=
  apply (T
           size_open_rec_st_pred
           size_open_rec_e_pred
           size_open_rec_f_pred).

Ltac size_open_rec_X_proof :=
  autounfold in *;
  lets: TP.size_open_var;
  lets: TMP.size_open_rec;
  simpl;
  intros;
  fequals~;
  auto.

Lemma size_open_rec_st:
  forall t, size_open_rec_st_pred t.
Proof.
  size_open_rec_X_induction St_ind_mutual;
  size_open_rec_X_proof.
Qed.

Lemma size_open_rec_e:
  forall t, size_open_rec_e_pred t.
Proof.
  size_open_rec_X_induction E_ind_mutual;
  size_open_rec_X_proof.
Qed.

Lemma size_open_rec_f:
  forall t, size_open_rec_f_pred t.
Proof.
  size_open_rec_X_induction F_ind_mutual;
  size_open_rec_X_proof.
Qed.

Lemma size_open_rec:
  forall t alpha n,
    TM.size (open_rec n (ftvar alpha) t) = TM.size t.
Proof.
  destruct t;
  lets: size_open_rec_st;
  lets: size_open_rec_e;
  lets: size_open_rec_f;
  simpl;
  intros;
  fequals~.
Qed.

(** Interaction of [size] with [close_var] *)

Lemma size_close_var_v:
  forall t alpha n,
  TM.size_v (close_rec_v n alpha t) = TM.size_v t.
Proof.
  induction t; auto.
Qed.

Function size_close_var_st_pred (t : St) :=
  forall alpha n,
  TM.size_st (close_rec_st n alpha t) = TM.size_st t.
Hint Unfold size_close_var_st_pred.

Function size_close_var_e_pred (t : E) :=
  forall alpha n,
    TM.size_e (close_rec_e n alpha t) = TM.size_e t.
Hint Unfold size_close_var_e_pred.

Function size_close_var_f_pred (t : F) :=
  forall alpha n,
    TM.size_f (close_rec_f n alpha t) = TM.size_f t.
Hint Unfold size_close_var_f_pred.

Ltac size_close_var_X_induction T :=
  apply (T
           size_close_var_st_pred
           size_close_var_e_pred
           size_close_var_f_pred).

Ltac size_close_var_X_proof :=
  autounfold in *;
  lets: TP.size_close_var;
  lets: TMP.size_close_var;
  simpl;
  intros;
  fequals~.

Lemma size_close_var_st:
  forall t, size_close_var_st_pred t.
Proof.
  size_close_var_X_induction St_ind_mutual;
  size_close_var_X_proof.
Qed.

Lemma size_close_var_e:
  forall t, size_close_var_e_pred t.
Proof.
  size_close_var_X_induction E_ind_mutual;
  size_close_var_X_proof.
Qed.

Lemma size_close_var_f:
  forall t, size_close_var_f_pred t.
Proof.
  size_close_var_X_induction F_ind_mutual;
  size_close_var_X_proof.
Qed.

Lemma size_close_var:
  forall t alpha n,
    TM.size (close_rec n alpha t) = TM.size t.
Proof.
  lets: size_close_var_st;
  lets: size_close_var_e;
  lets: size_close_var_f;
  destruct t;
  simpl;
  intros;
  fequals~.
Qed.

(** The induction principle *)
(* This would be very large, three induction principles. *)
(* And the only thing Dan seems to induct on is the length of a context,
  not its full size. So unless I need this I won't make it. *)

End TTMP.


Require Import Coq.Strings.String
        Coq.omega.Omega
        Coq.Lists.List
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.SetEq
        Fiat.Common.ilist2
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.Computation
        Fiat.ADT
        Fiat.Common.Ensembles.EnsembleListEquivalence
        Fiat.ADTRefinement
        Fiat.ADTNotation
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.QueryStructure.Specification.Operations.Empty
        Fiat.QueryStructure.Specification.Representation.QueryStructure.

Lemma EnsembleIndexedListEquivalence_lift_property {heading}
      {P: @RawTuple heading -> Prop} :
  forall (sequence: list (@RawTuple heading))
         (ensemble: IndexedEnsemble ),
    EnsembleIndexedListEquivalence ensemble sequence ->
    ((forall item,
        List.In item sequence -> P item) <->
     (forall item,
        Ensembles.In _ ensemble item -> P (indexedRawTuple item))).
Proof.
  intros * equiv;
  destruct equiv as [? [ l' (is_map & equiv & ?) ] ];
  setoid_rewrite equiv.
  unfold IndexedRawTuple, indexedRawTuple in *.
  split; intros; firstorder; subst; intuition.
  eapply H1; eapply in_map_iff; eauto.
  rewrite in_map_iff in H2; destruct_ex; intuition.
  subst; eauto.
Qed.

Lemma EnsembleIndexedListEquivalence_pick_new_index {heading} :
  forall (ens : Ensemble (@IndexedRawTuple heading)) seq,
    EnsembleIndexedListEquivalence ens seq ->
    exists bound,
      UnConstrFreshIdx ens bound.
Proof.
  intros * (indexes & equiv) ** .
  destruct_ex; eexists x; eauto.
Qed.

Lemma EnsembleListEquivalence_Empty :
  forall qsSchema Ridx,
    EnsembleListEquivalence
      (GetUnConstrRelation (imap2 rawRel (Build_EmptyRelations (qschemaSchemas qsSchema)))
                           Ridx) [].
Proof.
  intros; simpl; split; simpl; intros;
  unfold GetRelation, In in *.
  + econstructor.
  + unfold GetUnConstrRelation; rewrite <- ith_imap2;
    rewrite Build_EmptyRelation_IsEmpty; simpl in *; intuition.
Qed.

Lemma EnsembleIndexedListEquivalence_Empty :
  forall qsSchema Ridx,
    EnsembleIndexedListEquivalence
      (GetUnConstrRelation (imap2 rawRel (Build_EmptyRelations (qschemaSchemas qsSchema)))
                           Ridx) [].
Proof.
  intros; simpl; split; simpl; intros;
  unfold GetRelation, In in *.
  + unfold GetUnConstrRelation; rewrite <- ith_imap2;
    rewrite Build_EmptyRelation_IsEmpty in *; simpl in *; intuition.
    exists 0; unfold UnConstrFreshIdx; intros; intuition.
  + eexists []; intuition.
  - unfold In in *; intuition.
    unfold GetUnConstrRelation in *; rewrite <- ith_imap2 in *;
    rewrite Build_EmptyRelation_IsEmpty in *; simpl in *; intuition.
  - econstructor.
Qed.

Lemma ith_Bounded_BuildEmptyRelations {n}
: forall ns idx, ith2 (Build_EmptyRelations (n := n) ns) idx = EmptyRelation _.
Proof.
  induction ns; intros.
  - inversion idx; subst.
  - revert ns IHns. pattern n, idx.
    apply Fin.caseS; simpl; intros; eauto.
Qed.


Require Export RelDefinitions.

(** * The [RDestruct] class *)

(** ** Introducing the hypothesis to be destructed *)

(** The goal of [rdestruct] is usually to make progress on a goal
  relating two [match] constructions, by breaking down the terms being
  matched. The instances below will attempt to prove automatically
  that these terms are related, then destruct the resulting hypothesis
  in order to break them down and reduce the [match]es.

  If proving the destructed hypothesis automatically is not possible,
  the user can use the following tactic to introduce it manually. *)

Ltac rdestruct_assert :=
  lazymatch goal with
    | |- _ (match ?m with _ => _ end) (match ?n with _ => _ end) =>
      let Tm := type of m in
      let Tn := type of n in
      let R := fresh "R" in
      evar (R: rel Tm Tn);
      assert (R m n); subst R
  end.

(** ** [RDestruct] steps *)

(** Sometimes we want to remember what the destructed terms were.
  To make this possible, we use the following relation to wrap the
  subgoals generated by the [RDestruct] instance. *)

Definition rdestruct_result {A B} m n (Q: rel A B): rel A B :=
  fun x y => m = x /\ n = y -> Q x y.

(** To use [RDestruct] instances to reduce a goal involving pattern
  matching [G] := [_ (match m with _ end) (match n with _ end)], we
  need to establish that [m] and [n] are related by some relation [R],
  then locate an instance of [RDestruct] that corresponds to [R]. It
  is essential that this happens in one step. At some point, I tried
  to split the process in two different [RStep]s, so that the user
  could control the resolution of the [?R m n] subgoal. However, in
  situation where [RDestruct] is not the right strategy, this may
  push a [delayed rauto] into a dead end. Thankfully, now we can use
  the [RAuto] typeclass to solve the [?R m n] subgoal in one swoop. *)

Lemma rdestruct_rstep {A B} m n (R: rel A B) P (Q: rel _ _):
  RAuto (R m n) ->
  RDestruct R P ->
  P (rdestruct_result m n Q) ->
  Q m n.
Proof.
  intros Hmn HR H.
  firstorder.
Qed.

Ltac use_rdestruct_rstep m n :=
  let H := fresh in
  intro H;
  pattern m, n;
  eapply (rdestruct_rstep m n);
  [ .. | eexact H].

Hint Extern 40 (RStep _ (_ (match ?m with _=>_ end) (match ?n with _=>_ end))) =>
  use_rdestruct_rstep m n : typeclass_instances.

(** ** Choosing to discard or keep equations *)

(** The [RStep] above will leave us with a bunch of [rdestruct_result]
  subgoals. The next [RStep] will unpack them, and either discard or
  keep equations.

  By default, we discard equations. This is to prevent them from
  cluttering the context, possibly interfering with further steps, and
  introducing unwanted dependencies. However, the user can use the
  [rdestruct_remember] and [rdestruct_forget] tactics below to control
  this behavior. *)

CoInductive rdestruct_remember := rdestruct_remember_intro.

Ltac rdestruct_remember :=
  lazymatch goal with
    | _ : rdestruct_remember |- _ =>
      idtac
    | _ =>
      let H := fresh "Hrdestruct" in
      pose proof rdestruct_remember_intro as H
  end.

Ltac rdestruct_forget :=
  lazymatch goal with
    | H : rdestruct_remember |- _ =>
      clear H
    | _ =>
      idtac
  end.

(** The following [RStep] instance will keep or discard the equations
  in [rdestruct_result] based on the user's choice. *)

Lemma rdestruct_forget_rintro {A B} m n (Q: rel A B) x y:
  RIntro (Q x y) (rdestruct_result m n Q) x y.
Proof.
  firstorder.
Qed.

Lemma rdestruct_remember_rintro {A B} m n (Q: rel A B) x y:
  RIntro (m = x -> n = y -> Q x y) (rdestruct_result m n Q) x y.
Proof.
  firstorder.
Qed.

Ltac rdestruct_result_rintro :=
  lazymatch goal with
    | _ : rdestruct_remember |- _ =>
      eapply rdestruct_remember_rintro
    | _ =>
      eapply rdestruct_forget_rintro
  end.

Hint Extern 100 (RIntro _ (rdestruct_result _ _ _) _ _) =>
  rdestruct_result_rintro : typeclass_instances.

(** ** Default instance *)

(** We provide a default instance of [RDestruct] by reifying the
  behavior of the [destruct] tactic on the relational hypothesis that
  we're trying to destruct. *)

Ltac default_rdestruct :=
  let m := fresh "m" in
  let n := fresh "n" in
  let Hmn := fresh "H" m n in
  let P := fresh "P" in
  let H := fresh in
  intros m n Hmn P H;
  revert m n Hmn;
  delayed_conjunction (intros m n Hmn; destruct Hmn; delay);
  pattern P;
  eexact H.

Hint Extern 100 (RDestruct _ _) =>
  default_rdestruct : typeclass_instances.

(** In the special case where the terms matched on the left- and
  right-hand sides are identical, we want to destruct that term
  instead. We accomplish this by introducing a special instance of
  [RDestruct] for the relation [eq]. *)

Ltac eq_rdestruct :=
  let m := fresh "m" in
  let n := fresh "n" in
  let Hmn := fresh "H" m n in
  let P := fresh "P" in
  let H := fresh in
  intros m n Hmn P H;
  revert m n Hmn;
  delayed_conjunction (intros m n Hmn; destruct Hmn; destruct m; delay);
  pattern P;
  eexact H.

Hint Extern 99 (RDestruct eq _) =>
  eq_rdestruct : typeclass_instances.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_float_prop.

Section Fcore_ulp.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.

Definition ulp x := bpow (canonic_exp beta fexp x).

Notation F := (generic_format beta fexp).

Theorem ulp_opp :
  forall x, ulp (- x) = ulp x.
Proof.
intros x.
unfold ulp.
now rewrite canonic_exp_opp.
Qed.

Theorem ulp_abs :
  forall x, ulp (Rabs x) = ulp x.
Proof.
intros x.
unfold ulp.
now rewrite canonic_exp_abs.
Qed.

Theorem ulp_le_id:
  forall x,
    (0 < x)%R ->
    F x ->
    (ulp x <= x)%R.
Proof.
intros x Zx Fx.
rewrite <- (Rmult_1_l (ulp x)).
pattern x at 2; rewrite Fx.
unfold F2R, ulp; simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
replace 1%R with (Z2R (Zsucc 0)) by reflexivity.
apply Z2R_le.
apply Zlt_le_succ.
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
now rewrite <- Fx.
Qed.

Theorem ulp_le_abs:
  forall x,
    (x <> 0)%R ->
    F x ->
    (ulp x <= Rabs x)%R.
Proof.
intros x Zx Fx.
rewrite <- ulp_abs.
apply ulp_le_id.
now apply Rabs_pos_lt.
now apply generic_format_abs.
Qed.

Theorem ulp_DN_UP :
  forall x, ~ F x ->
  round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R.
Proof.
intros x Fx.
unfold round, ulp. simpl.
unfold F2R. simpl.
rewrite Zceil_floor_neq.
rewrite Z2R_plus. simpl.
ring.
intros H.
apply Fx.
unfold generic_format, F2R. simpl.
rewrite <- H.
rewrite Ztrunc_Z2R.
rewrite H.
now rewrite scaled_mantissa_mult_bpow.
Qed.

(** The successor of x is x + ulp x *)
Theorem succ_le_bpow :
  forall x e, (0 < x)%R -> F x ->
  (x < bpow e)%R ->
  (x + ulp x <= bpow e)%R.
Proof.
intros x e Zx Fx Hx.
pattern x at 1 ; rewrite Fx.
unfold ulp, F2R. simpl.
pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
rewrite <- Rmult_plus_distr_r.
change 1%R with (Z2R 1).
rewrite <- Z2R_plus.
change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R.
apply F2R_p1_le_bpow.
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
now rewrite <- Fx.
now rewrite <- Fx.
Qed.

Theorem ln_beta_succ :
  forall x, (0 < x)%R -> F x ->
  forall eps, (0 <= eps < ulp x)%R ->
  ln_beta beta (x + eps) = ln_beta beta x :> Z.
Proof.
intros x Zx Fx eps Heps.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He (Rgt_not_eq _ _ Zx)).
apply ln_beta_unique.
rewrite Rabs_pos_eq.
rewrite Rabs_pos_eq in He.
split.
apply Rle_trans with (1 := proj1 He).
pattern x at 1 ; rewrite <- Rplus_0_r.
now apply Rplus_le_compat_l.
apply Rlt_le_trans with (x + ulp x)%R.
now apply Rplus_lt_compat_l.
pattern x at 1 ; rewrite Fx.
unfold ulp, F2R. simpl.
pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
rewrite <- Rmult_plus_distr_r.
change 1%R with (Z2R 1).
rewrite <- Z2R_plus.
change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R.
apply F2R_p1_le_bpow.
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
now rewrite <- Fx.
now rewrite <- Fx.
now apply Rlt_le.
apply Rplus_le_le_0_compat.
now apply Rlt_le.
apply Heps.
Qed.

Theorem round_DN_succ :
  forall x, (0 < x)%R -> F x ->
  forall eps, (0 <= eps < ulp x)%R ->
  round beta fexp Zfloor (x + eps) = x.
Proof.
intros x Zx Fx eps Heps.
pattern x at 2 ; rewrite Fx.
unfold round.
unfold scaled_mantissa. simpl.
unfold canonic_exp at 1 2.
rewrite ln_beta_succ ; trivial.
apply (f_equal (fun m => F2R (Float beta m _))).
rewrite Ztrunc_floor.
apply Zfloor_imp.
split.
apply (Rle_trans _ _ _ (Zfloor_lb _)).
apply Rmult_le_compat_r.
apply bpow_ge_0.
pattern x at 1 ; rewrite <- Rplus_0_r.
now apply Rplus_le_compat_l.
apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply Rplus_lt_compat_l.
rewrite Rmult_plus_distr_r.
rewrite Z2R_plus.
apply Rplus_le_compat.
pattern x at 1 3 ; rewrite Fx.
unfold F2R. simpl.
rewrite Rmult_assoc.
rewrite <- bpow_plus.
rewrite Zplus_opp_r.
rewrite Rmult_1_r.
rewrite Zfloor_Z2R.
apply Rle_refl.
unfold ulp.
rewrite <- bpow_plus.
rewrite Zplus_opp_r.
apply Rle_refl.
apply Rmult_le_pos.
now apply Rlt_le.
apply bpow_ge_0.
Qed.

Theorem generic_format_succ :
  forall x, (0 < x)%R -> F x ->
  F (x + ulp x).
Proof.
intros x Zx Fx.
destruct (ln_beta beta x) as (ex, Ex).
specialize (Ex (Rgt_not_eq _ _ Zx)).
assert (Ex' := Ex).
rewrite Rabs_pos_eq in Ex'.
destruct (succ_le_bpow x ex) ; try easy.
unfold generic_format, scaled_mantissa, canonic_exp.
rewrite ln_beta_unique with beta (x + ulp x)%R ex.
pattern x at 1 3 ; rewrite Fx.
unfold ulp, scaled_mantissa.
rewrite canonic_exp_fexp with (1 := Ex).
unfold F2R. simpl.
rewrite Rmult_plus_distr_r.
rewrite Rmult_assoc.
rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
change (bpow 0) with (Z2R 1).
rewrite <- Z2R_plus.
rewrite Ztrunc_Z2R.
rewrite Z2R_plus.
rewrite Rmult_plus_distr_r.
now rewrite Rmult_1_l.
rewrite Rabs_pos_eq.
split.
apply Rle_trans with (1 := proj1 Ex').
pattern x at 1 ; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
apply bpow_ge_0.
exact H.
apply Rplus_le_le_0_compat.
now apply Rlt_le.
apply bpow_ge_0.
rewrite H.
apply generic_format_bpow.
apply valid_exp.
destruct (Zle_or_lt ex (fexp ex)) ; trivial.
elim Rlt_not_le with (1 := Zx).
rewrite Fx.
replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0.
rewrite F2R_0.
apply Rle_refl.
unfold scaled_mantissa.
rewrite canonic_exp_fexp with (1 := Ex).
destruct (mantissa_small_pos beta fexp x ex) ; trivial.
rewrite Ztrunc_floor.
apply sym_eq.
apply Zfloor_imp.
split.
now apply Rlt_le.
exact H2.
now apply Rlt_le.
now apply Rlt_le.
Qed.

Theorem round_UP_succ :
  forall x, (0 < x)%R -> F x ->
  forall eps, (0 < eps <= ulp x)%R ->
  round beta fexp Zceil (x + eps) = (x + ulp x)%R.
Proof with auto with typeclass_instances.
intros x Zx Fx eps (Heps1,[Heps2|Heps2]).
assert (Heps: (0 <= eps < ulp x)%R).
split.
now apply Rlt_le.
exact Heps2.
assert (Hd := round_DN_succ x Zx Fx eps Heps).
rewrite ulp_DN_UP.
rewrite Hd.
unfold ulp, canonic_exp.
now rewrite ln_beta_succ.
intros Fs.
rewrite round_generic in Hd...
apply Rgt_not_eq with (2 := Hd).
pattern x at 2 ; rewrite <- Rplus_0_r.
now apply Rplus_lt_compat_l.
rewrite Heps2.
apply round_generic...
now apply generic_format_succ.
Qed.

Theorem succ_le_lt:
  forall x y,
  F x -> F y ->
  (0 < x < y)%R ->
  (x + ulp x <= y)%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy H.
case (Rle_or_lt (ulp x) (y-x)); intros H1.
apply Rplus_le_reg_r with (-x)%R.
now ring_simplify (x+ulp x + -x)%R.
replace y with (x+(y-x))%R by ring.
absurd (x < y)%R.
2: apply H.
apply Rle_not_lt; apply Req_le.
rewrite <- round_DN_succ with (eps:=(y-x)%R); try easy.
ring_simplify (x+(y-x))%R.
apply sym_eq.
apply round_generic...
split; trivial.
apply Rlt_le; now apply Rlt_Rminus.
Qed.

(** Error of a rounding, expressed in number of ulps *)
Theorem ulp_error :
  forall rnd { Zrnd : Valid_rnd rnd } x,
  (Rabs (round beta fexp rnd x - x) < ulp x)%R.
Proof with auto with typeclass_instances.
intros rnd Zrnd x.
destruct (generic_format_EM beta fexp x) as [Hx|Hx].
(* x = rnd x *)
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply bpow_gt_0.
(* x <> rnd x *)
destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H.
(* . *)
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rplus_lt_reg_r with (round beta fexp Zfloor x).
rewrite <- ulp_DN_UP with (1 := Hx).
ring_simplify.
assert (Hu: (x <= round beta fexp Zceil x)%R).
apply round_UP_pt...
destruct Hu as [Hu|Hu].
exact Hu.
elim Hx.
rewrite Hu.
apply generic_format_round...
apply Rle_minus.
apply round_DN_pt...
(* . *)
rewrite Rabs_pos_eq.
rewrite ulp_DN_UP with (1 := Hx).
apply Rplus_lt_reg_r with (x - ulp x)%R.
ring_simplify.
assert (Hd: (round beta fexp Zfloor x <= x)%R).
apply round_DN_pt...
destruct Hd as [Hd|Hd].
exact Hd.
elim Hx.
rewrite <- Hd.
apply generic_format_round...
apply Rle_0_minus.
apply round_UP_pt...
Qed.

Theorem ulp_half_error :
  forall choice x,
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R.
Proof with auto with typeclass_instances.
intros choice x.
destruct (generic_format_EM beta fexp x) as [Hx|Hx].
(* x = rnd x *)
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_ge_0.
(* x <> rnd x *)
set (d := round beta fexp Zfloor x).
destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2).
destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H].
(* . rnd(x) = rndd(x) *)
apply Rle_trans with (Rabs (d - x)).
apply Hr2.
apply (round_DN_pt beta fexp x).
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rmult_le_reg_r with 2%R.
now apply (Z2R_lt 0 2).
apply Rplus_le_reg_r with (d - x)%R.
ring_simplify.
apply Rle_trans with (1 := H).
right. field.
apply Rle_minus.
apply (round_DN_pt beta fexp x).
(* . rnd(x) = rndu(x) *)
assert (Hu: (d + ulp x)%R = round beta fexp Zceil x).
unfold d.
now rewrite <- ulp_DN_UP.
apply Rle_trans with (Rabs (d + ulp x - x)).
apply Hr2.
rewrite Hu.
apply (round_UP_pt beta fexp x).
rewrite Rabs_pos_eq.
apply Rmult_le_reg_r with 2%R.
now apply (Z2R_lt 0 2).
apply Rplus_le_reg_r with (- (d + ulp x - x))%R.
ring_simplify.
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
right. field.
apply Rle_0_minus.
rewrite Hu.
apply (round_UP_pt beta fexp x).
Qed.

Theorem ulp_le :
  forall { Hm : Monotone_exp fexp },
  forall x y: R,
  (0 < x)%R -> (x <= y)%R ->
  (ulp x <= ulp y)%R.
Proof.
intros Hm x y Hx Hxy.
apply bpow_le.
apply Hm.
now apply ln_beta_le.
Qed.

Theorem ulp_bpow :
  forall e, ulp (bpow e) = bpow (fexp (e + 1)).
intros e.
unfold ulp.
apply f_equal.
apply canonic_exp_fexp.
rewrite Rabs_pos_eq.
split.
ring_simplify (e + 1 - 1)%Z.
apply Rle_refl.
apply bpow_lt.
apply Zlt_succ.
apply bpow_ge_0.
Qed.

Theorem ulp_DN :
  forall x,
  (0 < round beta fexp Zfloor x)%R ->
  ulp (round beta fexp Zfloor x) = ulp x.
Proof.
intros x Hd.
unfold ulp.
now rewrite canonic_exp_DN with (2 := Hd).
Qed.

Theorem ulp_error_f :
  forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x,
  (round beta fexp rnd x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros Hm rnd Zrnd x Hfx.
case (round_DN_or_UP beta fexp rnd x); intros Hx.
(* *)
case (Rle_or_lt 0 (round beta fexp Zfloor x)).
intros H; destruct H.
rewrite Hx at 2.
rewrite ulp_DN; trivial.
apply ulp_error...
rewrite Hx in Hfx; contradict Hfx; auto with real.
intros H.
apply Rlt_le_trans with (1:=ulp_error _ _).
rewrite <- (ulp_opp x), <- (ulp_opp (round beta fexp rnd x)).
apply ulp_le; trivial.
apply Ropp_0_gt_lt_contravar; apply Rlt_gt.
case (Rle_or_lt 0 x); trivial.
intros H1; contradict H.
apply Rle_not_lt.
apply round_ge_generic...
apply generic_format_0.
apply Ropp_le_contravar; rewrite Hx.
apply (round_DN_pt beta fexp x).
(* *)
rewrite Hx; case (Rle_or_lt 0 (round beta fexp Zceil x)).
intros H; destruct H.
apply Rlt_le_trans with (1:=ulp_error _ _).
apply ulp_le; trivial.
case (Rle_or_lt x 0); trivial.
intros H1; contradict H.
apply Rle_not_lt.
apply round_le_generic...
apply generic_format_0.
apply round_UP_pt...
rewrite Hx in Hfx; contradict Hfx; auto with real.
intros H.
rewrite <- (ulp_opp (round beta fexp Zceil x)).
rewrite <- round_DN_opp.
rewrite ulp_DN; trivial.
replace (round beta fexp Zceil x - x)%R with (-((round beta fexp Zfloor (-x) - (-x))))%R.
rewrite Rabs_Ropp.
apply ulp_error...
rewrite round_DN_opp; ring.
rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption.
Qed.

Theorem ulp_half_error_f :
  forall { Hm : Monotone_exp fexp },
  forall choice x,
  (round beta fexp (Znearest choice) x <> 0)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hm choice x Hfx.
case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx.
(* *)
case (Rle_or_lt 0 (round beta fexp Zfloor x)).
intros H; destruct H.
rewrite Hx at 2.
rewrite ulp_DN; trivial.
apply ulp_half_error.
rewrite Hx in Hfx; contradict Hfx; auto with real.
intros H.
apply Rle_trans with (1:=ulp_half_error _ _).
apply Rmult_le_compat_l.
auto with real.
rewrite <- (ulp_opp x), <- (ulp_opp (round beta fexp (Znearest choice) x)).
apply ulp_le; trivial.
apply Ropp_0_gt_lt_contravar; apply Rlt_gt.
case (Rle_or_lt 0 x); trivial.
intros H1; contradict H.
apply Rle_not_lt.
apply round_ge_generic...
apply generic_format_0.
apply Ropp_le_contravar; rewrite Hx.
apply (round_DN_pt beta fexp x).
(* *)
case (Rle_or_lt 0 (round beta fexp Zceil x)).
intros H; destruct H.
apply Rle_trans with (1:=ulp_half_error _ _).
apply Rmult_le_compat_l.
auto with real.
apply ulp_le; trivial.
case (Rle_or_lt x 0); trivial.
intros H1; contradict H.
apply Rle_not_lt.
apply round_le_generic...
apply generic_format_0.
rewrite Hx; apply (round_UP_pt beta fexp x).
rewrite Hx in Hfx; contradict Hfx; auto with real.
intros H.
rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)).
rewrite <- round_DN_opp.
rewrite ulp_DN; trivial.
pattern x at 1 2; rewrite <- Ropp_involutive.
rewrite round_N_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr, Rabs_Ropp.
apply ulp_half_error.
rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption.
Qed.

(** Predecessor *)
Definition pred x :=
  if Req_bool x (bpow (ln_beta beta x - 1)) then
    (x - bpow (fexp (ln_beta beta x - 1)))%R
  else
    (x - ulp x)%R.

Theorem pred_ge_bpow :
  forall x e,  F x ->
  x <> ulp x ->
  (bpow e < x)%R ->
  (bpow e <= x - ulp x)%R.
Proof.
intros x e Fx Hx' Hx.
(* *)
assert (1 <= Ztrunc (scaled_mantissa beta fexp x))%Z.
assert (0 <  Ztrunc (scaled_mantissa beta fexp x))%Z.
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
rewrite <- Fx.
apply Rle_lt_trans with (2:=Hx).
apply bpow_ge_0.
omega.
case (Zle_lt_or_eq _ _ H); intros Hm.
(* *)
pattern x at 1 ; rewrite Fx.
unfold ulp, F2R. simpl.
pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
rewrite <- Rmult_minus_distr_r.
change 1%R with (Z2R 1).
rewrite <- Z2R_minus.
change (bpow e <= F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) - 1) (canonic_exp beta fexp x)))%R.
apply bpow_le_F2R_m1; trivial.
now rewrite <- Fx.
(* *)
contradict Hx'.
pattern x at 1; rewrite Fx.
rewrite  <- Hm.
unfold ulp, F2R; simpl.
now rewrite Rmult_1_l.
Qed.

Lemma generic_format_pred_1:
  forall x, (0 < x)%R -> F x ->
  x <> bpow (ln_beta beta x - 1) ->
  F (x - ulp x).
Proof.
intros x Zx Fx Hx.
destruct (ln_beta beta x) as (ex, Ex).
simpl in Hx.
specialize (Ex (Rgt_not_eq _ _ Zx)).
assert (Ex' : (bpow (ex - 1) < x < bpow ex)%R).
rewrite Rabs_pos_eq in Ex.
destruct Ex as (H,H'); destruct H; split; trivial.
contradict Hx; easy.
now apply Rlt_le.
unfold generic_format, scaled_mantissa, canonic_exp.
rewrite ln_beta_unique with beta (x - ulp x)%R ex.
pattern x at 1 3 ; rewrite Fx.
unfold ulp, scaled_mantissa.
rewrite canonic_exp_fexp with (1 := Ex).
unfold F2R. simpl.
rewrite Rmult_minus_distr_r.
rewrite Rmult_assoc.
rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
change (bpow 0) with (Z2R 1).
rewrite <- Z2R_minus.
rewrite Ztrunc_Z2R.
rewrite Z2R_minus.
rewrite Rmult_minus_distr_r.
now rewrite Rmult_1_l.
rewrite Rabs_pos_eq.
split.
apply pred_ge_bpow; trivial.
unfold ulp; intro H.
assert (ex-1 < canonic_exp beta fexp x  < ex)%Z.
split ; apply (lt_bpow beta) ; rewrite <- H ; easy.
clear -H0. omega.
apply Ex'.
apply Rle_lt_trans with (2 := proj2 Ex').
pattern x at 3 ; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
rewrite <-Ropp_0.
apply Ropp_le_contravar.
apply bpow_ge_0.
apply Rle_0_minus.
pattern x at 2; rewrite Fx.
unfold ulp, F2R; simpl.
pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l.
apply Rmult_le_compat_r.
apply bpow_ge_0.
replace 1%R with (Z2R 1) by reflexivity.
apply Z2R_le.
assert (0 <  Ztrunc (scaled_mantissa beta fexp x))%Z.
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
rewrite <- Fx.
apply Rle_lt_trans with (2:=proj1 Ex').
apply bpow_ge_0.
omega.
Qed.

Lemma generic_format_pred_2 :
  forall x, (0 < x)%R -> F x ->
  let e := ln_beta_val beta x (ln_beta beta x) in
  x =  bpow (e - 1) ->
  F (x - bpow (fexp (e - 1))).
Proof.
intros x Zx Fx e Hx.
pose (f:=(x - bpow (fexp (e - 1)))%R).
fold f.
assert (He:(fexp (e-1) <= e-1)%Z).
apply generic_format_bpow_inv with beta; trivial.
rewrite <- Hx; assumption.
case (Zle_lt_or_eq _ _ He); clear He; intros He.
assert (f = F2R (Float beta (Zpower beta (e-1-(fexp (e-1))) -1) (fexp (e-1))))%R.
unfold f; rewrite Hx.
unfold F2R; simpl.
rewrite Z2R_minus, Z2R_Zpower.
rewrite Rmult_minus_distr_r, Rmult_1_l.
rewrite <- bpow_plus.
now replace (e - 1 - fexp (e - 1) + fexp (e - 1))%Z with (e-1)%Z by ring.
omega.
rewrite H.
apply generic_format_F2R.
intros _.
apply Zeq_le.
apply canonic_exp_fexp.
rewrite <- H.
unfold f; rewrite Hx.
rewrite Rabs_right.
split.
apply Rplus_le_reg_l with (bpow (fexp (e-1))).
ring_simplify.
apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R.
apply Rplus_le_compat ; apply bpow_le ; omega.
apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac].
apply Rle_trans with (bpow 1*bpow (e - 2))%R.
apply Rmult_le_compat_r.
apply bpow_ge_0.
replace 2%R with (Z2R 2) by reflexivity.
replace (bpow 1) with (Z2R beta).
apply Z2R_le.
apply <- Zle_is_le_bool.
now destruct beta.
simpl.
unfold Zpower_pos; simpl.
now rewrite Zmult_1_r.
rewrite <- bpow_plus.
replace (1+(e-2))%Z with (e-1)%Z by ring.
now right.
rewrite <- Rplus_0_r.
apply Rplus_lt_compat_l.
rewrite <- Ropp_0.
apply Ropp_lt_contravar.
apply bpow_gt_0.
apply Rle_ge; apply Rle_0_minus.
apply bpow_le.
omega.
replace f with 0%R.
apply generic_format_0.
unfold f.
rewrite Hx, He.
ring.
Qed.

Theorem generic_format_pred :
  forall x, (0 < x)%R -> F x ->
  F (pred x).
Proof.
intros x Zx Fx.
unfold pred.
case Req_bool_spec; intros H.
now apply generic_format_pred_2.
now apply generic_format_pred_1.
Qed.

Theorem generic_format_plus_ulp :
  forall { monotone_exp : Monotone_exp fexp },
  forall x, (x <> 0)%R ->
  F x -> F (x + ulp x).
Proof with auto with typeclass_instances.
intros monotone_exp x Zx Fx.
destruct (Rtotal_order x 0) as [Hx|[Hx|Hx]].
rewrite <- Ropp_involutive.
apply generic_format_opp.
rewrite Ropp_plus_distr, <- ulp_opp.
apply generic_format_opp in Fx.
destruct (Req_dec (-x) (bpow (ln_beta beta (-x) - 1))) as [Hx'|Hx'].
rewrite Hx' in Fx |- *.
apply generic_format_bpow_inv' in Fx...
unfold ulp, canonic_exp.
rewrite ln_beta_bpow.
revert Fx.
generalize (ln_beta_val _ _ (ln_beta beta (-x)) - 1)%Z.
clear -monotone_exp valid_exp.
intros e He.
destruct (Zle_lt_or_eq _ _ He) as [He1|He1].
assert (He2 : e = (e - fexp (e + 1) + fexp (e + 1))%Z) by ring.
rewrite He2 at 1.
rewrite bpow_plus.
assert (Hb := Z2R_Zpower beta _ (Zle_minus_le_0 _ _ He)).
match goal with |- F (?a * ?b + - ?b) =>
  replace (a * b + -b)%R with ((a - 1) * b)%R by ring end.
rewrite <- Hb.
rewrite <- (Z2R_minus _ 1).
change (F (F2R (Float beta (Zpower beta (e - fexp (e + 1)) - 1) (fexp (e + 1))))).
apply generic_format_F2R.
intros Zb.
unfold canonic_exp.
rewrite ln_beta_F2R with (1 := Zb).
rewrite (ln_beta_unique beta _ (e - fexp (e + 1))).
apply monotone_exp.
rewrite <- He2.
apply Zle_succ.
rewrite Rabs_pos_eq.
rewrite Z2R_minus, Hb.
split.
apply Rplus_le_reg_r with (- bpow (e - fexp (e + 1) - 1) + Z2R 1)%R.
apply Rmult_le_reg_r with (bpow (-(e - fexp (e+1) - 1))).
apply bpow_gt_0.
ring_simplify.
apply Rle_trans with R1.
rewrite Rmult_1_l.
apply (bpow_le _ _ 0).
clear -He1 ; omega.
rewrite Ropp_mult_distr_l_reverse.
rewrite <- 2!bpow_plus.
ring_simplify (e - fexp (e + 1) - 1 + - (e - fexp (e + 1) - 1))%Z.
ring_simplify (- (e - fexp (e + 1) - 1) + (e - fexp (e + 1)))%Z.
rewrite bpow_1.
rewrite <- (Z2R_plus (-1) _).
apply (Z2R_le 1).
generalize (Zle_bool_imp_le _ _ (radix_prop beta)).
clear ; omega.
rewrite <- (Rplus_0_r (bpow (e - fexp (e + 1)))) at 2.
apply Rplus_lt_compat_l.
now apply (Z2R_lt (-1) 0).
rewrite Z2R_minus.
apply Rle_0_minus.
rewrite Hb.
apply (bpow_le _ 0).
now apply Zle_minus_le_0.
rewrite He1, Rplus_opp_r.
apply generic_format_0.
apply generic_format_pred_1 ; try easy.
rewrite <- Ropp_0.
now apply Ropp_lt_contravar.
now elim Zx.
now apply generic_format_succ.
Qed.

Theorem generic_format_minus_ulp :
  forall { monotone_exp : Monotone_exp fexp },
  forall x, (x <> 0)%R ->
  F x -> F (x - ulp x).
Proof.
intros monotone_exp x Zx Fx.
replace (x - ulp x)%R with (-(-x + ulp x))%R by ring.
apply generic_format_opp.
rewrite <- ulp_opp.
apply generic_format_plus_ulp.
contradict Zx.
rewrite <- (Ropp_involutive x), Zx.
apply Ropp_0.
now apply generic_format_opp.
Qed.

Lemma pred_plus_ulp_1 :
  forall x, (0 < x)%R -> F x ->
  x <> bpow (ln_beta beta x - 1) ->
  ((x - ulp x) + ulp (x-ulp x) = x)%R.
Proof.
intros x Zx Fx Hx.
replace (ulp (x - ulp x)) with (ulp x).
ring.
unfold ulp at 1 2; apply f_equal.
unfold canonic_exp; apply f_equal.
destruct (ln_beta beta x) as (ex, Hex).
simpl in *.
assert (x <> 0)%R by auto with real.
specialize (Hex H).
apply sym_eq.
apply ln_beta_unique.
rewrite Rabs_right.
rewrite Rabs_right in Hex.
2: apply Rle_ge; apply Rlt_le; easy.
split.
destruct Hex as ([H1|H1],H2).
apply pred_ge_bpow; trivial.
unfold ulp; intros H3.
assert (ex-1 < canonic_exp beta fexp x  < ex)%Z.
split ; apply (lt_bpow beta) ; rewrite <- H3 ; easy.
omega.
contradict Hx; auto with real.
apply Rle_lt_trans with (2:=proj2 Hex).
rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
apply bpow_ge_0.
apply Rle_ge.
apply Rle_0_minus.
pattern x at 2; rewrite Fx.
unfold ulp, F2R; simpl.
pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l.
apply Rmult_le_compat_r.
apply bpow_ge_0.
replace 1%R with (Z2R (Zsucc 0)) by reflexivity.
apply Z2R_le.
apply Zlt_le_succ.
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
now rewrite <- Fx.
Qed.

Lemma pred_plus_ulp_2 :
  forall x, (0 < x)%R -> F x ->
  let e := ln_beta_val beta x (ln_beta beta x) in
  x =  bpow (e - 1) ->
  (x - bpow (fexp (e-1)) <> 0)%R ->
  ((x - bpow (fexp (e-1))) + ulp (x - bpow (fexp (e-1))) = x)%R.
Proof.
intros x Zx Fx e Hxe Zp.
replace (ulp (x - bpow (fexp (e - 1)))) with (bpow (fexp (e - 1))).
ring.
assert (He:(fexp (e-1) <= e-1)%Z).
apply generic_format_bpow_inv with beta; trivial.
rewrite <- Hxe; assumption.
case (Zle_lt_or_eq _ _ He); clear He; intros He.
(* *)
unfold ulp; apply f_equal.
unfold canonic_exp; apply f_equal.
apply sym_eq.
apply ln_beta_unique.
rewrite Rabs_right.
split.
apply Rplus_le_reg_l with (bpow (fexp (e-1))).
ring_simplify.
apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R.
apply Rplus_le_compat; apply bpow_le; omega.
apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac].
apply Rle_trans with (bpow 1*bpow (e - 2))%R.
apply Rmult_le_compat_r.
apply bpow_ge_0.
replace 2%R with (Z2R 2) by reflexivity.
replace (bpow 1) with (Z2R beta).
apply Z2R_le.
apply <- Zle_is_le_bool.
now destruct beta.
simpl.
unfold Zpower_pos; simpl.
now rewrite Zmult_1_r.
rewrite <- bpow_plus.
replace (1+(e-2))%Z with (e-1)%Z by ring.
now right.
rewrite <- Rplus_0_r, Hxe.
apply Rplus_lt_compat_l.
rewrite <- Ropp_0.
apply Ropp_lt_contravar.
apply bpow_gt_0.
apply Rle_ge; apply Rle_0_minus.
rewrite Hxe.
apply bpow_le.
omega.
(* *)
contradict Zp.
rewrite Hxe, He; ring.
Qed.

Theorem pred_plus_ulp :
  forall x, (0 < x)%R -> F x ->
  (pred x <> 0)%R ->
  (pred x + ulp (pred x) = x)%R.
Proof.
intros x Zx Fx.
unfold pred.
case Req_bool_spec; intros H Zp.
now apply pred_plus_ulp_2.
now apply pred_plus_ulp_1.
Qed.

Theorem pred_lt_id :
  forall x,
  (pred x < x)%R.
Proof.
intros.
unfold pred.
case Req_bool_spec; intros H.
(* *)
rewrite <- Rplus_0_r.
apply Rplus_lt_compat_l.
rewrite <- Ropp_0.
apply Ropp_lt_contravar.
apply bpow_gt_0.
(* *)
rewrite <- Rplus_0_r.
apply Rplus_lt_compat_l.
rewrite <- Ropp_0.
apply Ropp_lt_contravar.
apply bpow_gt_0.
Qed.

Theorem pred_ge_0 :
  forall x,
  (0 < x)%R -> F x -> (0 <= pred x)%R.
intros x Zx Fx.
unfold pred.
case Req_bool_spec; intros H.
(* *)
apply Rle_0_minus.
rewrite H.
apply bpow_le.
destruct (ln_beta beta x) as (ex,Ex) ; simpl.
rewrite ln_beta_bpow.
ring_simplify (ex - 1 + 1 - 1)%Z.
apply generic_format_bpow_inv with beta; trivial.
simpl in H.
rewrite <- H; assumption.
apply Rle_0_minus.
now apply ulp_le_id.
Qed.

Theorem round_UP_pred :
  forall x, (0 < pred x)%R -> F x ->
  forall eps, (0 < eps <= ulp (pred x) )%R ->
  round beta fexp Zceil (pred x + eps) = x.
Proof.
intros x Hx Fx eps Heps.
rewrite round_UP_succ; trivial.
apply pred_plus_ulp; trivial.
apply Rlt_trans with (1:=Hx).
apply pred_lt_id.
now apply Rgt_not_eq.
apply generic_format_pred; trivial.
apply Rlt_trans with (1:=Hx).
apply pred_lt_id.
Qed.

Theorem round_DN_pred :
  forall x, (0 < pred x)%R -> F x ->
  forall eps, (0 < eps <= ulp (pred x))%R ->
  round beta fexp Zfloor (x - eps) = pred x.
Proof.
intros x Hpx Fx eps Heps.
assert (Hx:(0 < x)%R).
apply Rlt_trans with (1:=Hpx).
apply pred_lt_id.
replace (x-eps)%R with (pred x + (ulp (pred x)-eps))%R.
2: pattern x at 3; rewrite <- (pred_plus_ulp x); trivial.
2: ring.
2: now apply Rgt_not_eq.
rewrite round_DN_succ; trivial.
now apply generic_format_pred.
split.
apply Rle_0_minus.
now apply Heps.
rewrite <- Rplus_0_r.
apply Rplus_lt_compat_l.
rewrite <- Ropp_0.
apply Ropp_lt_contravar.
now apply Heps.
Qed.

Lemma le_pred_lt_aux :
  forall x y,
  F x -> F y ->
  (0 < x < y)%R ->
  (x <= pred y)%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy H.
assert (Zy:(0 < y)%R).
apply Rlt_trans with (1:=proj1 H).
apply H.
(* *)
assert (Zp: (0 < pred y)%R).
assert (Zp:(0 <= pred y)%R).
apply pred_ge_0 ; trivial.
destruct Zp; trivial.
generalize H0.
unfold pred.
destruct (ln_beta beta y) as (ey,Hey); simpl.
case Req_bool_spec; intros Hy2.
(* . *)
intros Hy3.
assert (ey-1 = fexp (ey -1))%Z.
apply bpow_inj with beta.
rewrite <- Hy2, <- Rplus_0_l, Hy3.
ring.
assert (Zx: (x <> 0)%R).
now apply Rgt_not_eq.
destruct (ln_beta beta x) as (ex,Hex).
specialize (Hex Zx).
assert (ex <= ey)%Z.
apply bpow_lt_bpow with beta.
apply Rle_lt_trans with (1:=proj1 Hex).
apply Rlt_trans with (Rabs y).
rewrite 2!Rabs_right.
apply H.
now apply Rgt_ge.
now apply Rgt_ge.
apply Hey.
now apply Rgt_not_eq.
case (Zle_lt_or_eq _ _ H2); intros Hexy.
assert (fexp ex = fexp (ey-1))%Z.
apply valid_exp.
omega.
rewrite <- H1.
omega.
absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z.
omega.
split.
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
now rewrite <- Hx.
apply lt_Z2R.
apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)).
apply bpow_gt_0.
replace (Z2R (Ztrunc (scaled_mantissa beta fexp x)) *
 bpow (canonic_exp beta fexp x))%R with x.
rewrite Rmult_1_l.
unfold canonic_exp.
rewrite ln_beta_unique with beta x ex.
rewrite H3,<-H1, <- Hy2.
apply H.
exact Hex.
absurd (y <= x)%R.
now apply Rlt_not_le.
rewrite Rabs_right in Hex.
apply Rle_trans with (2:=proj1 Hex).
rewrite Hexy, Hy2.
now apply Rle_refl.
now apply Rgt_ge.
(* . *)
intros Hy3.
assert (y = bpow (fexp ey))%R.
apply Rminus_diag_uniq.
rewrite Hy3.
unfold ulp, canonic_exp.
rewrite (ln_beta_unique beta y ey); trivial.
apply Hey.
now apply Rgt_not_eq.
contradict Hy2.
rewrite H1.
apply f_equal.
apply Zplus_reg_l with 1%Z.
ring_simplify.
apply trans_eq with (ln_beta beta y).
apply sym_eq; apply ln_beta_unique.
rewrite H1, Rabs_right.
split.
apply bpow_le.
omega.
apply bpow_lt.
omega.
apply Rle_ge; apply bpow_ge_0.
apply ln_beta_unique.
apply Hey.
now apply Rgt_not_eq.
(* *)
case (Rle_or_lt (ulp (pred y)) (y-x)); intros H1.
(* . *)
apply Rplus_le_reg_r with (-x + ulp (pred y))%R.
ring_simplify (x+(-x+ulp (pred y)))%R.
apply Rle_trans with (1:=H1).
rewrite <- (pred_plus_ulp y) at 1; trivial.
apply Req_le; ring.
now apply Rgt_not_eq.
(* . *)
replace x with (y-(y-x))%R by ring.
rewrite <- round_DN_pred with (eps:=(y-x)%R); try easy.
ring_simplify (y-(y-x))%R.
apply Req_le.
apply sym_eq.
apply round_generic...
split; trivial.
now apply Rlt_Rminus.
now apply Rlt_le.
Qed.

Theorem le_pred_lt :
  forall x y,
  F x -> F y ->
  (0 < y)%R ->
  (x < y)%R ->
  (x <= pred y)%R.
Proof.
intros x y Fx Fy Hy Hxy.
destruct (Rle_or_lt x 0) as [Hx|Hx].
apply Rle_trans with (1 := Hx).
now apply pred_ge_0.
apply le_pred_lt_aux ; try easy.
now split.
Qed.

End Fcore_ulp.


(*Check basic properties of shares*)
Add LoadPath "..".
Require Import msl.msl_standard.
Require Import share_dec_base.
Require Import share_equation_system.
Require Import share_simplifier.
Require Import share_solver.
Require Import fbool_solver.
Require Import share_solver_with_partition.

Module Tester.

 Module es := Equation_system sv_nat Share_Domain.
 Module esf := System_Features sv_nat es.
 Module bf := Bool_formula sv_nat.
 Module bsf := BF_solver sv_nat bf.
 Import es.
 Module solver := Solver_with_partition sv_nat es bf bsf.
 Import solver.

 Definition a : var := 1.
 Definition b : var := 2.
 Definition c : var := 3.
 Definition c' : var := 4.
 Definition d : var := 5.
 Definition e : var := 6.
 Definition f : var := 7.
 Definition e' : var := 8.
 Definition a' : var := 9.
 Definition v1 : var := 10.
 Definition v2 : var := 11.
 Definition v3 : var := 12.
 Definition v4 : var := 13.
 Definition eqn0 : equation := (Vobject b, Vobject a, Vobject c).
 Definition eqn1 : equation := (Vobject a, Vobject b, Vobject c).
 Definition eqn2 : equation := (Vobject a, Vobject b, Vobject c').
 Definition eqn3 : equation := (Vobject c, Vobject d, Vobject e).
 Definition eqn4 : equation := (Vobject b, Vobject d, Vobject f).
 Definition eqn5 : equation := (Vobject a, Vobject f, Vobject e).
 Definition eqn6 : equation := (Vobject a', Vobject b, Vobject c).
 Definition eqn7 : equation := (Vobject a, Vobject a, Vobject b).
 Definition eqn8 : equation := (Vobject a, Vobject b, Vobject a).
 Definition eqn9 : equation := (Vobject d, Vobject f, Vobject c).
 Definition eqn10 : equation := (Vobject v1, Vobject v2, Vobject a).
 Definition eqn11 : equation := (Vobject v3, Vobject v4, Vobject b).
 Definition eqn12 : equation := (Vobject v1, Vobject v3, Vobject d).
 Definition eqn13 : equation := (Vobject v2, Vobject v4, Vobject f).
 Definition eqn14 : equation := (Vobject a, Cobject Share.bot, Vobject a).

 Definition eql1 : equality := (Vobject c, Vobject c').
 Definition eql2 : equality := (Vobject e, Vobject e').
 Definition eql3 : equality := (Vobject a, Vobject a').
 Definition eql4 : equality := (Vobject a, Vobject b).

 Definition comm : impl_system := (Impl_equation_system nil nil nil (eqn1::nil),Impl_equation_system nil nil nil (eqn0::nil)).
 Definition assoc : impl_system := (Impl_equation_system nil nil nil (eqn1::eqn3::nil),Impl_equation_system (f::nil) nil nil (eqn4::eqn5::nil)).
 Definition func : impl_system := (Impl_equation_system nil nil nil (eqn1::eqn2::nil),Impl_equation_system nil nil (eql1::nil) nil).
 Definition canc : impl_system := (Impl_equation_system nil nil nil (eqn1::eqn6::nil),Impl_equation_system nil nil (eql3::nil) nil).
 Definition dis : impl_system := (Impl_equation_system nil nil nil (eqn7::nil),Impl_equation_system nil nil (eql4::nil) nil).
 Definition unit : impl_system := (Impl_equation_system nil nil nil nil,Impl_equation_system (b::nil) nil nil (eqn8::nil)).
 Definition infi : impl_system := (Impl_equation_system nil (c::nil) nil nil,Impl_equation_system (a::b::nil) (a::b::nil) nil (eqn1::nil)).
 Definition cross : impl_system := (Impl_equation_system nil nil nil (eqn1::eqn9::nil),Impl_equation_system (v1::v2::v3::v4::nil) nil nil (eqn10::eqn11::eqn12::eqn13::nil)).
 Definition crossnz : impl_system := (Impl_equation_system nil (a::b::d::f::nil) nil (eqn1::eqn9::nil),Impl_equation_system (v1::v2::v3::v4::nil) (v1::v2::v3::v4::nil) nil (eqn10::eqn11::eqn12::eqn13::nil)).
 Definition unit' : impl_system := (Impl_equation_system nil nil nil nil,Impl_equation_system nil nil nil (eqn14::nil)).

 Definition properties := comm :: assoc :: func :: canc :: dis :: unit :: infi :: cross :: nil.

 Time Eval compute in (map IMPLsolver properties).

End Tester.


(******************************************************************************)
(*       Copyright (C) 2014 Florent Hivert <florent.hivert@lri.fr>            *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
Add Rec LoadPath "ALEA/src" as ALEA.
Add Rec LoadPath "../Combi/LRrule".

Require Import Misc Ccpo Qmeasure.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import ssreflect ssrfun ssrbool eqtype choice ssrnat seq ssrint rat
               fintype bigop path ssralg ssrnum.
(* Import bigop before ssralg/ssrnum to get correct printing of \sum \prod*)

Require Import tools subseq partition.
Require Import rat_coerce.

Import GRing.Theory.
Import Num.Theory.

(* TODO : Move in Qmeasure *)
Section DistrSum.

Local Open Scope ring_scope.

Lemma mu_bool_0le A (m:distr A) (f:A->bool) : 0 <= mu m (fun x => (f x)%:Q).
Proof.
  apply mu_stable_pos => x /=.
  by case (f x).
Qed.
Hint Resolve mu_bool_0le.

Lemma mu_stable_sum (A : Type) (m : distr A) (I : Type) (s : seq I) (f : I -> A -> rat) :
  mu m (fun a => \sum_(i <- s) f i a) = \sum_(i <- s) (mu m (f i)).
Proof.
  elim: s => [| s0 s IHs] /=.
    rewrite big_nil; apply mu_zero_eq => x; by rewrite big_nil.
  rewrite big_cons -IHs -mu_stable_add.
  apply Mstable_eq => x /=; by rewrite big_cons.
Qed.

Lemma in_seq_sum (A : eqType) (s : seq A) x :
  uniq s -> (x \in s)%:Q = \sum_(i <- s) (x == i)%:Q.
Proof.
  elim: s => [| s0 s IHs] /=; first by rewrite big_nil.
  rewrite inE big_cons => /andP [] /negbTE Hs0 /IHs <- {IHs}.
  case: (boolP (x == s0)) => [/= /eqP -> | _ ]; last by rewrite /= add0r.
  by rewrite Hs0 addr0.
Qed.

Lemma mu_in_seq (A : eqType) (m : distr A) (s : seq A) :
  uniq s ->
  mu m (fun x => (x \in s)) = \sum_(a <- s) mu m (fun x => (x == a)).
Proof.
  rewrite -mu_stable_sum => Hs.
  apply Mstable_eq => x /=.
  exact: in_seq_sum.
Qed.

Lemma mu_bool_cond (A : Type) (m : distr A) (f g : A -> bool) :
  mu m (fun x => (f x)) = 1 ->
  mu m (fun x => (g x)) = mu m (fun x => (f x && g x)).
Proof.
  move=> H; apply ler_asym; apply/andP; split.
  - rewrite -[X in (_ <= X)]addr0.
    have <- : (mu m) (fun x : A => (~~ f x && g x)) = 0.
      move: H; apply mu_bool_negb0 => x; by case: (f x).
    rewrite -Mstable_add //.
    apply mu_monotonic => x /=.
    case: (f x); by rewrite ?addr0 ?add0r.
  - by apply mu_bool_impl => x; apply/implyP => /andP [].
Qed.

Lemma mu_pos_cond (A : Type) (m : distr A) (f : A -> bool) (g : A -> rat) :
  (forall x, 0 <= g x <= 1) ->
  mu m (fun x => (f x)) = 1 ->
  mu m (fun x => (g x)) = mu m (fun x => ((f x)%:Q * g x)).
Proof.
  move=> Hg H.
  have H0g x : 0 <= g x by have := Hg x => /andP [].
  have Hg1 x : g x <= 1 by have := Hg x => /andP [].
  apply ler_asym; apply/andP; split.
  - rewrite -[X in (_ <= X)]addr0.
    have <- : (mu m) (fun x : A => ((~~ f x)%:Q * g x)) = 0.
      apply ler_asym; apply/andP; split.
      + rewrite -(subrr 1) -{3}H -mu_bool_negb.
        apply mu_monotonic => x /=.
        case: (f x) => /=; by rewrite ?mul0r ?mul1r.
      + apply mu_stable_pos => x /=.
        case: (f x) => /=; by rewrite ?mul0r ?mul1r.
    rewrite -Mstable_add //.
    apply mu_monotonic => x /=.
    case: (f x); by rewrite /= ?mul0r ?mul1r ?addr0 ?add0r.
  - apply mu_monotonic => x /=.
    case: (f x) => /=; by rewrite ?mul0r ?mul1r.
Qed.

End DistrSum.


Require Import List String.
Import ListNotations.
Require Import Coq.Numbers.DecimalString.
Local Open Scope string_scope.

Record Field := {
  field_name : option string;
  field_type : Set
}.

Record Constructor := {
  con_name : string;
  fields : list Field
}.

Record Shape := {
  type_name : string;
  constructors : list Constructor
}.

Inductive empty : Set :=.

Fixpoint Product (ts : list Set) : Set :=
  match ts with
  | [] => unit
  | x :: xs => x * Product xs
  end.

Fixpoint Sum (ts : list Set) : Set :=
  match ts with
  | [] => empty
  | x :: xs => sum x (Sum xs)
  end.

Definition SOP tts := Sum (map Product tts).
Definition to_sop (s : list Constructor) := map (fun x => map field_type (fields x)) s.

Definition Rep_F xs := Product (map field_type xs).
Definition Rep_C xs := Sum (map (fun x => Rep_F (fields x)) xs).
Definition Rep (s : Shape) : Set := Rep_C s.(constructors).

Example rep_test1 :
  Rep (Build_Shape "test"
    [ Build_Constructor "C1" []
    ; Build_Constructor "C2" [Build_Field (Some "F1") nat]
    ; Build_Constructor "C3" [Build_Field None nat; Build_Field None bool]]) =
  (unit +
   (nat * unit +
    (nat * (bool * unit) +
     empty)))%type
  := eq_refl.

Class Show (A : Set) := {
  show : A -> string
}.

Class Generic (A : Set) := {
  shape : Shape;
  to : A -> Rep shape
}.

Instance Generic_empty : Generic empty := {
  shape := Build_Shape "empty" [];
  to := empty_rec _
}.

Instance Generic_unit : Generic unit := {
  shape := Build_Shape "unit" [Build_Constructor "tt" []];
  to := fun _ => inl tt
}.

Arguments shape A [_].

Instance Show_empty : Show empty := { show := empty_rec _ }.
Instance Show_unit : Show unit := { show := fun _ => "tt" }.

Class Both P Q := { both1 : P; both2: Q }.
Instance Both_PQ {P Q} {p : P} {q : Q} : Both P Q := {
  both1 := p; both2 := q
}.

Class Always := {}.
Instance Always_instance : Always := {}.

Fixpoint All {A} (P : A -> Set) (xs : list A) : Set :=
  match xs with
  | [] => Always
  | x :: xs' => Both (P x) (All P xs')
  end.

Definition compose {A B C} (f : B -> C) (g : A -> B) (x : A) : C := f (g x).
Notation "f ... g" := (compose f g) (at level 90).

Fixpoint shows_fields (ts : list Field) :
    forall {_ : All (fun x => Show (field_type x)) ts},
    Product (map field_type ts) -> list (option string * string) :=
  match ts with
  | [] => fun _ _ => []
  | Build_Field name _ :: ts => fun allshow v =>
    let (x, xs) := v in
    let (show_t, show_ts) := allshow in
    (name, show x) :: @shows_fields ts show_ts xs
  end.

Fixpoint elim_fields
    (P : Field -> Set)
    R
    (f : forall field, P field -> field_type field -> R)
    (ts : list Field) :
    All P ts -> Rep_F ts -> list R :=
  match ts with
  | [] => fun _ _ => []
  | field :: ts => fun all_p v =>
    let (x, xs) := v in
    let (P_t, P_ts) := all_p in
    f field P_t x :: @elim_fields P R f ts P_ts xs
  end.

Definition shows_fields2 :=
  elim_fields
    (fun x => Show (field_type x))
    (option string * string)
    (fun field Show_x x => (field_name field, @show _ Show_x x)).

Definition RepC_nil_elim {A} : Rep_C [] -> A.
compute. apply empty_rect. Defined.

Fixpoint elim_sum
    (P : Constructor -> Set)
    R
    (f : forall c, P c -> Rep_F (fields c) -> R)
    (ts : list Constructor) :
    All P ts -> Rep_C ts -> R :=
  match ts with
  | [] => fun _ => RepC_nil_elim
  | con :: ts => fun all_p v =>
    let (P_t, P_ts) := all_p in
    match v with
    | inl x => f con P_t x
    | inr xs => @elim_sum P R f ts P_ts xs
    end
  end.

Fixpoint intercalate (sep : string) (l : list string) : string :=
  match l with
  | [] => ""
  | [x] => x
  | x :: xs => x ++ sep ++ intercalate sep xs
  end.

Definition All_C P := All (fun c => All (fun x => P (field_type x)) c.(fields)).

Fixpoint genericShow (cs : list Constructor)
  {allShow : All_C Show cs}
  (x : Rep_C cs) : string :=
  elim_sum _ _
    (fun c Pc flds =>
      c.(con_name) ++ " (" ++
      intercalate ", "
       (map (@snd (option string) string)
         (shows_fields2
          c.(fields) Pc flds)) ++ ")")
    cs allShow x.

Notation solve_constraint := (ltac:(compute; typeclasses eauto)) (only parsing).

Definition test_shape :=
  Build_Shape "test"
    [ Build_Constructor "C1" []
    ; Build_Constructor "C2" [Build_Field (Some "F1") nat]
    ; Build_Constructor "C3" [Build_Field None nat; Build_Field None bool]].

Instance Show_bool : Show bool := {
  show x :=
    match x with
    | true => "true"
    | false => "false"
    end
}.

Definition string_of_nat x := NilZero.string_of_int (Nat.to_int x).

Instance Show_nat : Show nat := {
  show := string_of_nat
}.

Example test_genericShow :
  @genericShow test_shape.(constructors) solve_constraint
    (inr (inr (inl (179, (true, tt)))))
    = "C3 (179, true)"
    := eq_refl.