Add LoadPath "..".
Add LoadPath "../LabelFree/NoDiamond".
Require Import LabelFreeNoDia.

Open Scope is5_scope.
Open Scope permut_scope.

Inductive WHT: te_LF -> Type :=
| val_WHT: forall M, value_LF M -> WHT M
| step_WHT: forall M,
              sigT (fun V => prod (value_LF V) (steps_LF M V)) -> WHT M.

Fixpoint Red (M: te_LF) (A: ty) : Type :=
match A with
| tvar => WHT M
| tarrow A1 A2 =>
    prod (WHT M)
    (forall N,
       lc_t_LF N ->
       Red N A1 ->
      Red (appl_LF M N) A2)
| tbox A1 => prod (WHT M) (Red (unbox_LF M) A1)
end.

Lemma step_LF_unique:
forall M N N',
  M |-> N -> M |->N' -> N = N'.
intros; generalize dependent N'; induction H; intros; inversion H0; subst;
auto. inversion H5. inversion H2. inversion H.
rewrite IHstep_LF with M'0; auto.
inversion H. rewrite IHstep_LF with M'0; auto.
Qed.

Lemma WHT_step:
forall M M',
  WHT M ->
  M |-> M' ->
  WHT M'.
intros; inversion H; subst.
apply value_no_step with (N:=M') in H1; auto; contradiction.
destruct H1 as (V, (H1, H2)).
inversion H2; subst.
apply step_LF_unique with (N':=V) in H0; subst; auto. constructor; auto.
apply step_WHT; exists V; split; auto.
apply step_LF_unique with (N':=M'0) in H0; subst; auto.
Qed.

Lemma WHT_step_back:
forall M M',
  M |-> M' ->
WHT M' -> WHT M.
intros; apply step_WHT.
inversion H0; subst.
exists M'; split; auto; constructor; auto.
destruct H1; destruct p.
exists x; split; auto; apply multi_step_LF with (M':=M'); auto.
Qed.

Hint Resolve WHT_step WHT_step_back.

(* CR 2 *)
Theorem property_2:
forall A M M'
  (HRed: Red M A)
  (H_lc_t: lc_t_LF M)
  (HStep: M |-> M'),
  Red M' A.
induction A; intros; simpl in *; intros.
(* base type *)
eauto.
(* arrow type *)
destruct HRed; split; eauto; intros.
apply IHA2 with (M:=appl_LF M N); auto.
constructor; auto.
constructor; auto.
(* box type *)
destruct HRed; split; eauto; intros.
apply IHA with (M:=unbox_LF M); auto; constructor; eauto.
Qed.

(* CR 1 *)
Theorem property_1:
forall A M
  (H_lc_t: lc_t_LF M),
  Red M A -> WHT M.
induction A; intros; simpl in *; auto;
destruct X; auto.
Qed.

(* CR 3 *)
Theorem property_3:
forall A M M'
  (H_lc: lc_t_LF M),
  M |-> M' ->   Red M' A ->
  Red M A.
induction A; intros; simpl in *.
(* base type *)
eauto.
(* arrow type *)
destruct X; split; eauto; intros.
apply IHA2 with (appl_LF M' N); try constructor; auto; intros; simpl in *.
(* box type *)
destruct X; split; eauto; intros.
intros; apply IHA with (unbox_LF M'); try constructor; auto.
Qed.

Fixpoint find_var (L: list (var * ty * te_LF)) (x:var) :
                     option (var * ty * te_LF) :=
match L with
| nil => None
| (v, A, M) :: L' =>
  if (eq_var_dec x v) then Some (v, A, M) else find_var L' x
end.

Lemma Mem_find_var:
  forall L v,
    Mem v (map fst_ (map fst_ L)) ->
    exists A M, find_var L v = Some (v, A, M).
induction L; intros; [ rewrite Mem_nil_eq in *; contradiction | ];
destruct a; destruct p; rew_map in *; simpl in *.
subst; rewrite Mem_cons_eq in H.
destruct (eq_var_dec v v0).
subst; simpl; exists t0 t; auto.
destruct H; try contradiction; apply IHL; auto.
Qed.

Lemma NotMem_find_var:
  forall L v,
    ~Mem v (map fst_ (map fst_ L)) ->
    find_var L v = None.
induction L; intros; simpl in *; auto;
destruct a; destruct p; rew_map in *; simpl in *;
case_if.
elim H; apply Mem_here.
apply IHL; intro; elim H;
rewrite Mem_cons_eq; right; auto.
Qed.

Lemma find_var_Mem:
forall L v A M,
  find_var L v = Some (v, A, M) -> Mem (v, A, M) L.
induction L; intros; [inversion H; subst | ].
destruct a; destruct p; simpl in *; case_if.
inversion H; subst; apply Mem_here.
rewrite Mem_cons_eq; right; apply IHL; auto.
Qed.

Fixpoint OkL (L: list (var * ty * te_LF)) U :=
match L with
| nil => True
| (v, A, M) :: L' => ~ Mem v U /\ OkL L' (v::U)
end.

Lemma OkL_permut:
forall L U1 U2,
  U1 *=* U2 ->
  OkL L U1 -> OkL L U2.
induction L; intros; [constructor | destruct a; destruct p];
inversion H0; subst; constructor.
intro; elim H1; apply Mem_permut with (l:=U2); [symmetry | ]; auto.
apply IHL with (U1:=v::U1); auto.
Qed.

Lemma OkL_weaken:
forall L U w,
  OkL L (w::U) -> OkL L U.
induction L; intros; simpl in *; auto; destruct a; destruct p; destruct H;
split.
intro; elim H; rewrite Mem_cons_eq; right; auto.
apply IHL with w. apply OkL_permut with (U1:=v::w::U); auto; permut_simpl.
Qed.

Lemma OkL_used_notin:
forall L U x A M,
  OkL L U ->
  Mem x U ->
  ~ Mem (x, A, M) L.
induction L; intros.
rewrite Mem_nil_eq; tauto.
intro; destruct a; destruct p; rewrite Mem_cons_eq in *; inversion H; subst;
destruct H1.
inversion H1; subst; contradiction.
specialize IHL with U x A M.
apply OkL_weaken in H3; apply IHL in H3; auto.
Qed.

Lemma OkL_fresh:
forall L x U,
  OkL L U->
  x \notin from_list (map fst_ (map fst_ L)) \u from_list U ->
  OkL L (x::U).
induction L; intros; [constructor | destruct a; destruct p];
simpl in *; destruct H; split.
intro; elim H; rewrite Mem_cons_eq in *; destruct H2; subst; auto;
repeat rewrite notin_union in *; destruct H0; destruct H0;
rew_map; simpl; rewrite from_list_cons; rewrite in_union; left;
rewrite in_singleton; auto.
apply OkL_permut with (U1:=x::v::U); [permut_simpl | apply IHL]; auto.
rew_map in *; simpl in *;
repeat rewrite from_list_cons in *; repeat rewrite notin_union in *;
simpl in *; destruct H0; destruct H0; split; auto.
Qed.

Lemma Mem_find_var_type:
  forall L v A,
    OkL L nil ->
    Mem (v, A) (map fst_ L) ->
    {M | find_var L v = Some (v, A, M)}.
induction L; intros; [ rewrite Mem_nil_eq in *; contradiction | ];
destruct a; destruct p; rew_map in *; simpl in *; destruct H.
subst; apply Mem_cons_spec in H0.
case_if.
destruct H0.
inversion e; subst; exists t; auto.
destruct IHL with v0 A; auto.
apply OkL_weaken in H1; auto.
apply find_var_Mem in e.
apply OkL_used_notin with (x:=v0) (A:=A) (M:=x) in H1; [ | apply Mem_here];
contradiction.
destruct H0; [inversion e; subst; elim H2; auto | ].
apply IHL; auto; apply OkL_weaken in H1; auto.
intros; decide equality. apply eq_ty_dec. apply eq_var_dec.
Qed.

Fixpoint SL (L: list (var * ty * te_LF)) (M: te_LF) : te_LF :=
match M with
| hyp_LF (bte v) => M
| hyp_LF (fte v) =>
  let x := find_var L v in
  match x with
    | Some (v, A, M) => M
    | None => hyp_LF (fte v)
  end
| lam_LF A M => lam_LF A (SL L M)
| appl_LF M N => appl_LF (SL L M) (SL L N)
| box_LF M => box_LF (SL L M)
| unbox_LF M => unbox_LF (SL L M)
end.

Lemma SL_nil:
forall M,
  SL nil M = M.
induction M; intros; simpl in *;
try erewrite IHM || (erewrite IHM1; erewrite IHM2); eauto.
destruct v; auto.
Qed.

Lemma lc_SL:
forall M L n,
  lc_t_n_LF n M ->
  (forall a b c, Mem (a,b,c) L -> lc_t_LF c) ->
  lc_t_n_LF n (SL L M).
induction M; intros; simpl in *;
try (inversion H; subst; constructor; eapply IHM; eauto).
destruct v; inversion H; subst.
constructor; auto.
destruct (Mem_dec var (map fst_ (map fst_ L)) v). apply eq_var_dec.
apply Mem_find_var in m; destruct m; destruct H1.
rewrite H1. replace n with (0+n) by omega.
apply closed_t_addition_LF; apply H0 with v x. apply find_var_Mem; auto.
rewrite NotMem_find_var; auto.
inversion H; subst; constructor; [apply IHM1 | apply IHM2]; auto.
Qed.

Fixpoint FV_L (L: list (var * ty * te_LF)) :=
match L with
| nil => \{}
| (v, A, M) :: L' => used_vars_te_LF M \u FV_L L'
end.

Lemma notin_FV_notin_elem:
forall x L,
  x \notin FV_L L ->
  forall a b c, Mem (a,b,c) L -> x \notin used_vars_te_LF c.
induction L; intros; simpl in *.
rewrite Mem_nil_eq in *; contradiction.
rewrite Mem_cons_eq in H0; destruct H0; [inversion H0; subst | ].
rewrite notin_union in H; destruct H; auto.
destruct a; destruct p; rewrite notin_union in H; destruct H;
apply IHL with (a:=a0) (b:=b); auto.
Qed.

Lemma SL_hyp:
forall L G Gamma v A,
  OkL L nil ->
  concat (Gamma::G) *=* map fst_ L ->
  (forall a b c, Mem (a, b, c) L -> Red c b) ->
  G |= Gamma |- hyp_LF (fte v) ::: A ->
  Red (SL L (hyp_LF (fte v))) A.
intros.
inversion X0; subst.
assert (Mem (v, A) (map fst_ L)).
  apply Mem_permut with (l:=concat (Gamma::G)); auto.
  rew_concat; rewrite Mem_app_or_eq; left; auto.
apply Mem_find_var_type in H1; auto. destruct H1.
simpl; rewrite e; apply X with v.
apply find_var_Mem; auto.
Qed.

Lemma SL_bte_subst:
forall L0 M x k,
  ~ Mem x (map fst_ (map fst_ L0)) ->
  (forall v a m, Mem (v, a, m) L0 -> lc_t_LF m) ->
  [hyp_LF (fte x) // bte k](SL L0 M) =
  SL L0 [hyp_LF (fte x) // bte k]M.
induction M; intros; simpl in *;
try rewrite IHM || (rewrite IHM1; try rewrite IHM2); auto.
case_if; simpl.
case_if. rewrite NotMem_find_var; auto.
destruct v; simpl; repeat case_if; auto.
destruct (Mem_dec var (map fst_ (map fst_ L0)) v);
try apply eq_var_dec; [ | rewrite NotMem_find_var]; auto;
simpl; repeat case_if; auto.
apply Mem_find_var in m; destruct m as (a, (b, m)); rewrite m; simpl.
rewrite closed_subst_t_bound_LF with (n:=0); auto; try omega;
apply H0 with v a; apply find_var_Mem; auto.
Qed.

Lemma SL_extend:
forall M L0 x A N,
  x \notin FV_L L0 ->
  ~Mem x (map fst_ (map fst_ L0)) ->
  SL ((x, A, N) :: L0) M =
  [N // fte x](SL L0 M).
induction M; intros; simpl in *;
try rewrite IHM || (rewrite IHM1; try rewrite IHM2); auto.
destruct v; simpl; repeat case_if; auto.
rewrite NotMem_find_var; auto; simpl; case_if; auto.
destruct (Mem_dec var (map fst_ (map fst_ L0)) v);
try apply eq_var_dec; [ | rewrite NotMem_find_var]; auto;
simpl; repeat case_if; auto.
apply Mem_find_var in m; destruct m as (a, (b, m)); rewrite m; simpl.
rewrite closed_subst_t_free_LF; auto.
apply notin_FV_notin_elem with L0 v a; eauto.
apply find_var_Mem; eauto.
Qed.

Theorem main_theorem:
forall G Gamma M A,
  lc_t_LF M ->
  G |= Gamma |- M ::: A ->
  forall L,
    OkL L nil ->
    concat(Gamma::G) *=* map fst_ L ->
    (forall a b c, Mem (a,b,c) L -> lc_t_LF c) ->
    (forall a b c, Mem (a,b,c) L -> Red c b) ->
    Red (SL L M) A.
intros G Gamma M A LC HT; induction HT; intros.
(* hyp *)
apply SL_hyp with G Gamma; auto; constructor; auto.
(* lam *)
unfold open_LF in *;
assert {x | x \notin L \u used_vars_te_LF (SL L0 M) \u
       from_list (map fst_ (map fst_ L0)) \u FV_L L0} by apply Fresh.
destruct H3.
assert (forall V, Red V A -> lc_t_LF V ->
           Red (SL ((x, A, V) :: L0) [hyp_LF (fte x) // bte 0]M) B).
intros; apply X; auto.
apply lc_t_subst_t_LF_bound; [ constructor | inversion LC]; auto.
constructor. rewrite Mem_nil_eq; tauto.
apply OkL_fresh; auto; rewrite notin_union; split; auto;
rewrite from_list_nil; auto.
rew_map in *; simpl; rewrite <-  H1; rew_concat; auto.
intros; rewrite Mem_cons_eq in *; destruct H4.
inversion H4; subst; auto.
apply H2 with a b; auto.
intros; apply Mem_cons_spec in H4. destruct H4.
inversion e; subst; auto.
apply X0 with a ; auto.
intros; destruct k; destruct p; destruct k'; destruct p; decide equality.
apply eq_te_LF_dec. destruct p; destruct a0; decide equality.
apply eq_ty_dec. apply eq_var_dec.
simpl in *; split; intros. repeat constructor.
apply property_3 with (M':=(SL L0 M) ^t^ N).
constructor; auto; constructor; apply lc_SL; auto; inversion LC; auto.
constructor.
apply lc_SL; auto; inversion LC; auto. auto.
unfold open_LF in *.
rewrite subst_t_neutral_free_LF with (v:=x); auto.
replace ([N // fte x]([hyp_LF (fte x) // bte 0](SL L0 M))) with
  (SL ((x, A, N)::L0) [hyp_LF (fte x) // bte 0]M).
apply X1; auto.
rewrite SL_bte_subst; auto; [ | apply notin_Mem; auto].
rewrite SL_extend; auto; apply notin_Mem; auto.
(* appl *)
simpl in *; apply IHHT1; auto. inversion LC; auto.
apply lc_SL; inversion LC; auto.
apply IHHT2; auto; inversion LC; subst; auto.
(* box *)
simpl in *; split. repeat constructor.
apply property_3 with (SL L M).
constructor; constructor; apply lc_SL; inversion LC; auto.
constructor.
inversion LC; subst; apply lc_SL; auto.
apply IHHT; auto; rew_concat in *. inversion LC; auto.
rewrite <- H0; permut_simpl.
(* unbox *)
simpl in *; apply IHHT; auto.
inversion LC; auto.
(* unbox-fetch *)
simpl in *;apply IHHT; auto.
inversion LC; auto.
rewrite <- H0; apply PPermut_concat_permut.
transitivityP (Gamma' :: G & Gamma); PPermut_LF_simpl.
Qed.

Theorem termination_language:
forall G M A,
  emptyEquiv_LF G |= nil |- M ::: A ->
  WHT M.
intros; apply property_1 with A.
apply types_LF_lc_t_LF in X; auto.
apply main_theorem with (L:=nil) in X.
rewrite SL_nil in X; auto.
apply types_LF_lc_t_LF in X; auto.
simpl; auto.
rew_concat; rew_map; clear X M A.
induction G; simpl; rew_concat; auto.
intros; rewrite Mem_nil_eq in *; contradiction.
intros; rewrite Mem_nil_eq in *; contradiction.
Qed.

(*
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive sumbool => "bool" [ "true" "false" ].

Extract Inductive nat => "int"
  [ "0" "(fun x → x + 1)" ]
  "(fun zero succ n →
      if n=0 then zero () else succ (n-1))".
Extract Constant plus => "( + )".

Extract Constant eq_var_dec => "( = )".

Extraction "termination_LF_nodia" termination_language.
*)


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   lemmas.
   Some nice lemmas, mostly about le, lt, and mult.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision$
*)

Global Set Asymmetric Patterns.

Require Import ZArith.
Require Import EqNat.

Lemma predminus1 : forall n : nat, pred n = n - 1.
Proof.
   intro n. case n.
   simpl in |- *. reflexivity.
   simpl in |- *. intro m. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma le_mult_l : forall p q : nat, p <= q -> forall r : nat, r * p <= r * q.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   apply le_n.
   intros r1 IHr1.
   simpl in |- *.
   apply plus_le_compat.
   assumption.
   assumption.
Qed.

Lemma lt_plus_plus : forall n m p q : nat, n < m -> p < q -> n + p < m + q.
Proof.
   intros n m p q H H0.
   elim H; simpl in |- *; auto with arith.
Qed.

Lemma lt_mult_l :
 forall p q : nat, p < q -> forall r : nat, S r * p < S r * q.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   rewrite <- plus_n_O.
   rewrite <- plus_n_O.
   assumption.
   intros r1 IHr1.
   simpl in |- *.
   apply lt_plus_plus.
   assumption.
   assumption.
Qed.

Lemma le_mult_r : forall p q : nat, p <= q -> forall r : nat, p * r <= q * r.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   rewrite <- (mult_n_O p).
   rewrite <- (mult_n_O q).
   apply le_n.
   intros r1 IHr1.
   rewrite <- (mult_n_Sm p r1).
   rewrite <- (mult_n_Sm q r1).
   apply plus_le_compat.
   assumption.
   assumption.
Qed.

Lemma sqrbound : forall p q : nat, p * p <= p * q \/ q * q <= p * q.
Proof.
   intros.
   elim (le_or_lt p q).
   left.
   apply le_mult_l.
   assumption.
   right.
   apply le_mult_r.
   apply lt_le_weak.
   assumption.
Qed.

Lemma le_n_nm : forall n m : nat, n <= n * S m.
Proof.
   simple induction n.
   simpl in |- *.
   intros.
   apply le_n.
   intros n1 IHn1.
   simpl in |- *.
   intros.
   apply le_n_S.
   rewrite (plus_comm m (n1 * S m)).
   apply le_plus_trans.
   apply IHn1.
Qed.

Lemma le_n_mn : forall n m : nat, n <= S m * n.
Proof.
   intros.
   rewrite (mult_comm (S m) n).
   apply le_n_nm.
Qed.

Lemma le_n_nn : forall n : nat, n <= n * n.
Proof.
   intro n. case n.
   simpl in |- *. apply le_n.
   simpl in |- *. intros. apply le_n_S. apply le_plus_trans. apply le_n.
Qed.

Lemma lt_n_nm : forall n m : nat, 0 < n -> 1 < m -> n < n * m.
Proof.
   intros n m.
   case n. intros. elim (lt_n_O 0). assumption.
   intro n1. case m. intros. elim (lt_n_O 1). assumption.
   intro m1. case m1. intros. elim (lt_irrefl 1). assumption.
   intro m2. elim n1.
   simpl in |- *. intros. apply lt_n_S. apply lt_O_Sn.
   simpl in |- *. intros n2 IH. intros.
   apply lt_n_S.
   apply lt_trans with (S (S (m2 + n2 * S (S m2)))).
   apply IH.
   apply lt_O_Sn.
   apply lt_n_S.
   apply lt_O_Sn.
   apply lt_n_S.
   rewrite (plus_comm m2).
   rewrite (plus_comm m2).
   simpl in |- *.
   apply lt_n_S.
   apply lt_le_trans with (S (n2 * S (S m2) + m2)).
   apply lt_n_Sn.
   apply le_n_S.
   apply le_plus_trans.
   apply le_n.
Qed.

Lemma sqr_ascend : forall n : nat, n > 1 -> n < n * n.
Proof.
   simple induction n.
   intros.
   elim (lt_n_O 1).
   assumption.
   intros m IHm.
   intro.
   unfold gt in H.
   unfold lt in H.
   elim (le_lt_or_eq 1 m).
   intros.
   simpl in |- *.
   apply lt_n_S.
   rewrite <- (mult_n_Sm m m).
   rewrite plus_comm.
   apply lt_plus_trans.
   apply lt_plus_trans.
   apply IHm.
   assumption.
   intros.
   rewrite <- H0.
   simpl in |- *.
   unfold lt in |- *.
   apply le_S.
   apply le_n.
   apply le_S_n.
   assumption.
Qed.

Lemma witness_le : forall x y : nat, (exists q : nat, x + q = y) -> x <= y.
Proof.
   intros. elim H. intro q. intros.
   rewrite <- H0.
   elim q.
   rewrite <- plus_n_O. apply le_n.
   intros. rewrite <- plus_n_Sm. apply le_S. assumption.
Qed.

Lemma le_witness : forall x y : nat, x <= y -> exists q : nat, x + q = y.
Proof.
   intros x y.
   intro.
   elim H.
   split with 0.
   simpl in |- *.
   symmetry  in |- *.
   apply plus_n_O.
   intros.
   case H1.
   intros.
   split with (S x0).
   replace (x + S x0) with (S (x + x0)).
   simpl in |- *.
   rewrite H2.
   reflexivity.
   apply plus_n_Sm.
Qed.

Lemma lt_witness :
 forall x y : nat, x < y -> exists q : nat, x + q = y /\ 0 < q.
Proof.
   unfold lt in |- *.
   intros.
   elim (le_witness (S x) y).
   intros.
   split with (S x0).
   split.
   rewrite <- plus_n_Sm.
   assumption.
   apply le_n_S.
   apply le_O_n.
   assumption.
Qed.

Lemma le_le_mult : forall b a c d : nat, a <= b -> c <= d -> a * c <= b * d.
Proof.
   simple induction b.
   intros.
   replace a with 0.
   simpl in |- *.
   apply le_n.
   apply le_n_O_eq.
   assumption.
   intros b1 IHb1.
   simpl in |- *.
   intros.
   elim (le_lt_or_eq a (S b1)).
   unfold lt in |- *.
   intros.
   rewrite (plus_comm d (b1 * d)).
   apply le_plus_trans.
   apply IHb1.
   apply le_S_n.
   assumption.
   assumption.
   intro.
   rewrite H1.
   replace (d + b1 * d) with (S b1 * d).
   apply le_mult_l.
   assumption.
   reflexivity.
   assumption.
Qed.

Lemma lt_lt_mult : forall a b c d : nat, a < b -> c < d -> a * c < b * d.
Proof.
   unfold lt in |- *.
   intros.
   apply le_trans with (S a * S c).
   simpl in |- *.
   apply le_n_S.
   rewrite <- (mult_n_Sm a c).
   rewrite (plus_comm c (a * c + a)).
   apply le_plus_trans.
   apply le_plus_trans.
   apply le_n.
   apply le_le_mult.
   assumption.
   assumption.
Qed.

Lemma lt_n_nm_m_gt_1 : forall a b : nat, a < a * b -> b > 1.
Proof.
   intros a b. case b.
   rewrite <- (mult_n_O a). intro. elim (lt_n_O a). assumption.
   intro b1. case b1.
   rewrite <- (mult_n_Sm a 0).
   rewrite <- (mult_n_O a). simpl in |- *. intro.
   elim (lt_irrefl a). assumption.
   intros. apply gt_n_S. apply gt_Sn_O.
Qed.

Lemma n0n1_or_gt : forall n : nat, n = 0 \/ n = 1 \/ n > 1.
Proof.
   intro n. case n.
   left. reflexivity.
   intro n1. case n1.
   right. left. reflexivity.
   intro n2.
   right. right. apply gt_n_S. apply gt_Sn_O.
Qed.

Lemma lt_multpred_pp : forall p : nat, p > 1 -> pred p * pred p < p * p.
Proof.
   intro.
   case p.
   intro.
   elim (lt_n_O 1).
   assumption.
   intro p1.
   case p1.
   intro.
   elim (lt_irrefl 1).
   assumption.
   intro p2.
   intros.
   apply lt_lt_mult.
   simpl in |- *. apply lt_n_Sn.
   simpl in |- *. apply lt_n_Sn.
Qed.

Lemma le_diff0 : forall b a c : nat, a <= b -> a = b + c -> c = 0.
Proof.
   simple induction b.
   simpl in |- *. intro.
   case a.
   intros.
   rewrite H0.
   reflexivity.
   intros.
   elim (lt_n_O n).
   assumption.
   intros b1 IH.
   simpl in |- *.
   intros.
   rewrite H0 in H.
   apply (IH (b1 + c) c).
   apply le_S_n.
   assumption.
   reflexivity.
Qed.

Lemma simpl_lt_mult_l : forall a b c : nat, a * b < a * c -> b < c.
Proof.
   simple induction a.
   simpl in |- *.
   intros.
   elim (lt_irrefl 0).
   assumption.
   intros a1 IH.
   intros.
   elim (le_or_lt b c).
   intro.
   elim (le_lt_or_eq b c).
   intro.
   assumption.
   intros.
   rewrite H1 in H.
   elim (lt_irrefl (S a1 * c)).
   assumption.
   assumption.
   intros.
   cut (S a1 * c <= S a1 * b).
   intros.
   elim (le_not_lt (S a1 * c) (S a1 * b)).
   assumption.
   assumption.
   apply lt_le_weak.
   apply lt_mult_l.
   assumption.
Qed.

Lemma simpl_le_mult_l : forall a b c : nat, 0 < a -> a * b <= a * c -> b <= c.
Proof.
   simple induction a.
   intros.
   elim (lt_n_O 0).
   assumption.
   intros a1 IH.
   intros.
   simpl in H0.
   elim (le_or_lt b c).
   intro.
   assumption.
   intro.
   elim (lt_not_le (S a1 * c) (S a1 * b)).
   apply lt_mult_l.
   assumption.
   assumption.
Qed.

Lemma simpl_eq_mult_l : forall a b c : nat, 0 < a -> a * b = a * c -> b = c.
Proof.
   intros. apply le_antisym.
   apply simpl_le_mult_l with a. assumption. rewrite H0. apply le_n.
   apply simpl_le_mult_l with a. assumption. rewrite H0. apply le_n.
Qed.

Lemma mult_ppq_p0q1 : forall p q : nat, p = p * q -> p = 0 \/ q = 1.
Proof.
   intro p. case p. left. reflexivity.
   intro p1. right.
   apply simpl_eq_mult_l with (S p1). apply lt_O_Sn.
   rewrite <- H.
   rewrite <- mult_n_Sm. rewrite <- mult_n_O.
   simpl in |- *. reflexivity.
Qed.

Lemma mult_pq1_p1q1 : forall p q : nat, p * q = 1 -> p = 1 /\ q = 1.
Proof.
   intro p. case p. simpl in |- *. intros. discriminate H.
   intro p1. case p1. simpl in |- *.
   intro q. rewrite <- plus_n_O. split. reflexivity. assumption.
   intro p2.
   intro q. case q. rewrite <- mult_n_O. intro. discriminate H.
   intro q1. case q1.
   rewrite <- mult_n_Sm.
   rewrite <- mult_n_O.
   simpl in |- *. intro. discriminate H.
   intro q2. simpl in |- *. intro. discriminate H.
Qed.

Lemma Zmult_ab0a0b0 : forall a b : Z, (a * b)%Z = 0%Z -> a = 0%Z \/ b = 0%Z.
Proof.
   simple induction a.
   simpl in |- *. left. reflexivity.
   intro p. simple induction b.
   simpl in |- *. right. reflexivity.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros. discriminate H.
   intro. simple induction b.
   simpl in |- *. right. reflexivity.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros. discriminate H.
Qed.

Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z.
Proof.
   intros a b. intros.
   apply Zplus_le_reg_l with b.
   unfold Zminus in |- *. rewrite (Zplus_comm a).
   rewrite (Zplus_assoc b (- b)). rewrite Zplus_opp_r.
   simpl in |- *. rewrite <- Zplus_0_r_reverse. assumption.
Qed.

Lemma Zopp_lt_gt_0 : forall x : Z, (x < 0)%Z -> (- x > 0)%Z.
Proof.
   simple induction x.
   intro. unfold Z.lt in H. simpl in H. discriminate H.
   intros. unfold Z.lt in H. simpl in H. discriminate H.
   intros. simpl in |- *. unfold Z.gt in |- *. simpl in |- *. reflexivity.
Qed.

Lemma Zlt_neq : forall x y : Z, (x < y)%Z -> x <> y.
Proof.
   intros. intro.
   rewrite H0 in H.
   elim (Z.lt_irrefl y).
   assumption.
Qed.

Lemma Zgt_neq : forall x y : Z, (x > y)%Z -> x <> y.
Proof.
   intros. intro.
   rewrite H0 in H.
   elim (Z.lt_irrefl y).
   apply Z.gt_lt. assumption.
Qed.

Lemma S_inj : forall n m : nat, S n = S m -> n = m.
  intros n m H; injection H; trivial.
Qed.

Lemma Zlt_mult_l :
 forall p q r : Z, (0 < r)%Z -> (p < q)%Z -> (r * p < r * q)%Z.
Proof.
   simple induction r.
   intros. elim (Z.lt_irrefl 0). assumption.
   intros. unfold Z.lt in |- *.
   rewrite (Zcompare_mult_compat p0 p q).
   assumption.
   intros. unfold Z.lt in H. simpl in H. discriminate H.
Qed.

Lemma Zle_mult_l :
 forall p q r : Z, (0 < r)%Z -> (p <= q)%Z -> (r * p <= r * q)%Z.
Proof.
   simple induction r.
   intros. simpl in |- *. apply Zeq_le. reflexivity.
   intros. unfold Z.le in |- *.
   rewrite (Zcompare_mult_compat p0 p q).
   assumption.
   intros. unfold Z.lt in H. simpl in H. discriminate H.
Qed.


From iris_logrel.F_mu_ref Require Export fundamental_binary.

Inductive ctx_item :=
  | CTX_Lam
  | CTX_AppL (e2 : expr)
  | CTX_AppR (e1 : expr)
  (* Products *)
  | CTX_PairL (e2 : expr)
  | CTX_PairR (e1 : expr)
  | CTX_Fst
  | CTX_Snd
  (* Sums *)
  | CTX_InjL
  | CTX_InjR
  | CTX_CaseL (e1 : expr) (e2 : expr)
  | CTX_CaseM (e0 : expr) (e2 : expr)
  | CTX_CaseR (e0 : expr) (e1 : expr)
  (* Recursive Types *)
  | CTX_Fold
  | CTX_Unfold
  (* Polymorphic Types *)
  | CTX_TLam
  | CTX_TApp
  (* Reference Types *)
  | CTX_Alloc
  | CTX_Load
  | CTX_StoreL (e2 : expr)
  | CTX_StoreR (e1 : expr).

Fixpoint fill_ctx_item (ctx : ctx_item) (e : expr) : expr :=
  match ctx with
  | CTX_Lam => Lam e
  | CTX_AppL e2 => App e e2
  | CTX_AppR e1 => App e1 e
  | CTX_PairL e2 => Pair e e2
  | CTX_PairR e1 => Pair e1 e
  | CTX_Fst => Fst e
  | CTX_Snd => Snd e
  | CTX_InjL => InjL e
  | CTX_InjR => InjR e
  | CTX_CaseL e1 e2 => Case e e1 e2
  | CTX_CaseM e0 e2 => Case e0 e e2
  | CTX_CaseR e0 e1 => Case e0 e1 e
  | CTX_Fold => Fold e
  | CTX_Unfold => Unfold e
  | CTX_TLam => TLam e
  | CTX_TApp => TApp e
  | CTX_Alloc => Alloc e
  | CTX_Load => Load e
  | CTX_StoreL e2 => Store e e2
  | CTX_StoreR e1 => Store e1 e
  end.

Definition ctx := list ctx_item.

Definition fill_ctx (K : ctx) (e : expr) : expr := foldr fill_ctx_item e K.

(** typed ctx *)
Inductive typed_ctx_item :
    ctx_item → list type → type → list type → type → Prop :=
  | TP_CTX_Lam Γ τ τ' :
     typed_ctx_item CTX_Lam (τ :: Γ) τ' Γ (TArrow τ τ')
  | TP_CTX_AppL Γ e2 τ τ' :
     typed Γ e2 τ →
     typed_ctx_item (CTX_AppL e2) Γ (TArrow τ τ') Γ τ'
  | TP_CTX_AppR Γ e1 τ τ' :
     typed Γ e1 (TArrow τ τ') →
     typed_ctx_item (CTX_AppR e1) Γ τ Γ τ'
  | TP_CTX_PairL Γ e2 τ τ' :
     typed Γ e2 τ' →
     typed_ctx_item (CTX_PairL e2) Γ τ Γ (TProd τ τ')
  | TP_CTX_PairR Γ e1 τ τ' :
     typed Γ e1 τ →
     typed_ctx_item (CTX_PairR e1) Γ τ' Γ (TProd τ τ')
  | TP_CTX_Fst Γ τ τ' :
     typed_ctx_item CTX_Fst Γ (TProd τ τ') Γ τ
  | TP_CTX_Snd Γ τ τ' :
     typed_ctx_item CTX_Snd Γ (TProd τ τ') Γ τ'
  | TP_CTX_InjL Γ τ τ' :
     typed_ctx_item CTX_InjL Γ τ Γ (TSum τ τ')
  | TP_CTX_InjR Γ τ τ' :
     typed_ctx_item CTX_InjR Γ τ' Γ (TSum τ τ')
  | TP_CTX_CaseL Γ e1 e2 τ1 τ2 τ' :
     typed (τ1 :: Γ) e1 τ' → typed (τ2 :: Γ) e2 τ' →
     typed_ctx_item (CTX_CaseL e1 e2) Γ (TSum τ1 τ2) Γ τ'
  | TP_CTX_CaseM Γ e0 e2 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed (τ2 :: Γ) e2 τ' →
     typed_ctx_item (CTX_CaseM e0 e2) (τ1 :: Γ) τ' Γ τ'
  | TP_CTX_CaseR Γ e0 e1 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed (τ1 :: Γ) e1 τ' →
     typed_ctx_item (CTX_CaseR e0 e1) (τ2 :: Γ) τ' Γ τ'
  | TP_CTX_Fold Γ τ :
     typed_ctx_item CTX_Fold Γ τ.[(TRec τ)/] Γ (TRec τ)
  | TP_CTX_Unfold Γ τ :
     typed_ctx_item CTX_Unfold Γ (TRec τ) Γ τ.[(TRec τ)/]
  | TP_CTX_TLam Γ τ :
     typed_ctx_item CTX_TLam (subst (ren (+1)) <$> Γ) τ Γ (TForall τ)
  | TP_CTX_TApp Γ τ τ' :
     typed_ctx_item CTX_TApp Γ (TForall τ) Γ τ.[τ'/]
  | TPCTX_Alloc Γ τ :
     typed_ctx_item CTX_Alloc Γ τ Γ (Tref τ)
  | TP_CTX_Load Γ τ :
     typed_ctx_item CTX_Load Γ (Tref τ) Γ τ
  | TP_CTX_StoreL Γ e2 τ :
     typed Γ e2 τ → typed_ctx_item (CTX_StoreL e2) Γ (Tref τ) Γ TUnit
  | TP_CTX_StoreR Γ e1 τ :
     typed Γ e1 (Tref τ) →
     typed_ctx_item (CTX_StoreR e1) Γ τ Γ TUnit.

Lemma typed_ctx_item_typed k Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx_item k Γ τ Γ' τ' →
  typed Γ' (fill_ctx_item k e) τ'.
Proof. induction 2; simpl; eauto using typed. Qed.

Inductive typed_ctx: ctx → list type → type → list type → type → Prop :=
  | TPCTX_nil Γ τ :
     typed_ctx nil Γ τ Γ τ
  | TPCTX_cons Γ1 τ1 Γ2 τ2 Γ3 τ3 k K :
     typed_ctx_item k Γ2 τ2 Γ3 τ3 →
     typed_ctx K Γ1 τ1 Γ2 τ2 →
     typed_ctx (k :: K) Γ1 τ1 Γ3 τ3.

Lemma typed_ctx_typed K Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx K Γ τ Γ' τ' → typed Γ' (fill_ctx K e) τ'.
Proof. induction 2; simpl; eauto using typed_ctx_item_typed. Qed.

Lemma typed_ctx_n_closed K Γ τ Γ' τ' e :
  (∀ f, e.[upn (length Γ) f] = e) → typed_ctx K Γ τ Γ' τ' →
  ∀ f, (fill_ctx K e).[upn (length Γ') f] = (fill_ctx K e).
Proof.
  intros H1 H2; induction H2; simpl; auto.
  induction H => f; asimpl; simpl in *;
    repeat match goal with H : _ |- _ => rewrite fmap_length in H end;
    try f_equal;
    eauto using typed_n_closed;
    try match goal with H : _ |- _ => eapply (typed_n_closed _ _ _ H) end.
Qed.

Definition ctx_refines (Γ : list type)
    (e e' : expr) (τ : type) := ∀ K thp σ v,
  typed_ctx K Γ τ [] TUnit →
  rtc step ([fill_ctx K e], ∅) (of_val v :: thp, σ) →
  ∃ thp' σ' v', rtc step ([fill_ctx K e'], ∅) (of_val v' :: thp', σ').
Notation "Γ ⊨ e '≤ctx≤' e' : τ" :=
  (ctx_refines Γ e e' τ) (at level 74, e, e', τ at next level).

Ltac fold_interp :=
  match goal with
  | |- context [ interp_expr (interp_arrow (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_arrow (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TArrow A A')) B (C, D))
  | |- context [ interp_expr (interp_prod (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_prod (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TProd A A')) B (C, D))
  | |- context [ interp_expr (interp_prod (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_prod (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TProd A A')) B (C, D))
  | |- context [ interp_expr (interp_sum (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_sum (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TSum A A')) B (C, D))
  | |- context [ interp_expr (interp_rec (interp ?A)) ?B (?C, ?D) ] =>
    change (interp_expr (interp_rec (interp A)) B (C, D)) with
    (interp_expr (interp (TRec A)) B (C, D))
  | |- context [ interp_expr (interp_forall (interp ?A))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_forall (interp A)) B (C, D)) with
    (interp_expr (interp (TForall A)) B (C, D))
  | |- context [ interp_expr (interp_ref (interp ?A))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_ref (interp A)) B (C, D)) with
    (interp_expr (interp (Tref A)) B (C, D))
  end.

Section bin_log_related_under_typed_ctx.
  Context `{heapG Σ, cfgSG Σ}.

  Lemma bin_log_related_under_typed_ctx Γ e e' τ Γ' τ' K :
    (∀ f, e.[upn (length Γ) f] = e) →
    (∀ f, e'.[upn (length Γ) f] = e') →
    typed_ctx K Γ τ Γ' τ' →
    Γ ⊨ e ≤log≤ e' : τ → Γ' ⊨ fill_ctx K e ≤log≤ fill_ctx K e' : τ'.
  Proof.
    revert Γ τ Γ' τ' e e'.
    induction K as [|k K]=> Γ τ Γ' τ' e e' H1 H2; simpl.
    - inversion_clear 1; trivial.
    - inversion_clear 1 as [|? ? ? ? ? ? ? ? Hx1 Hx2]. intros H3.
      specialize (IHK _ _ _ _ e e' H1 H2 Hx2 H3).
      inversion Hx1; subst; simpl; try fold_interp.
      + eapply bin_log_related_lam; eauto;
          match goal with
            H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
          end.
      + eapply bin_log_related_app; eauto using binary_fundamental.
      + eapply bin_log_related_app; eauto using binary_fundamental.
      + eapply bin_log_related_pair; eauto using binary_fundamental.
      + eapply bin_log_related_pair; eauto using binary_fundamental.
      + eapply bin_log_related_fst; eauto.
      + eapply bin_log_related_snd; eauto.
      + eapply bin_log_related_injl; eauto.
      + eapply bin_log_related_injr; eauto.
      + match goal with
          H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
        end.
        eapply bin_log_related_case;
          eauto using binary_fundamental;
          match goal with
            H : _ |- _ => eapply (typed_n_closed _ _ _ H)
          end.
      + match goal with
          H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
        end.
        eapply bin_log_related_case;
          eauto using binary_fundamental;
          try match goal with
                H : _ |- _ => eapply (typed_n_closed _ _ _ H)
              end;
          match goal with
            H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
          end.
      + match goal with
          H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
        end.
        eapply bin_log_related_case;
          eauto using binary_fundamental;
          try match goal with
                H : _ |- _ => eapply (typed_n_closed _ _ _ H)
              end;
          match goal with
            H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
          end.
      + eapply bin_log_related_fold; eauto.
      + eapply bin_log_related_unfold; eauto.
      + eapply bin_log_related_tlam; eauto with typeclass_instances.
      + eapply bin_log_related_tapp; eauto.
      + eapply bin_log_related_alloc; eauto.
      + eapply bin_log_related_load; eauto.
      + eapply bin_log_related_store; eauto using binary_fundamental.
      + eapply bin_log_related_store; eauto using binary_fundamental.
        Unshelve. all: trivial.
  Qed.
End bin_log_related_under_typed_ctx.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
Require Import Cos_rel.
Require Import Max.
Open Local Scope nat_scope.
Open Local Scope R_scope.

Definition Majxy (x y:R) (n:nat) : R :=
  Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S n) / INR (fact n).

Lemma Majxy_cv_R0 : forall x y:R, Un_cv (Majxy x y) 0.
Proof.
  intros.
  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  set (C0 := C ^ 4).
  cut (0 < C).
  intro.
  cut (0 < C0).
  intro.
  assert (H1 := cv_speed_pow_fact C0).
  unfold Un_cv in H1; unfold R_dist in H1.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  cut (0 < eps / C0);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
	[ assumption | apply Rinv_0_lt_compat; assumption ] ].
  elim (H1 (eps / C0) H3); intros N0 H4.
  exists N0; intros.
  replace (Majxy x y n) with (C0 ^ S n / INR (fact n)).
  simpl in |- *.
  apply Rmult_lt_reg_l with (Rabs (/ C0)).
  apply Rabs_pos_lt.
  apply Rinv_neq_0_compat.
  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
  rewrite <- Rabs_mult.
  unfold Rminus in |- *; rewrite Rmult_plus_distr_l.
  rewrite Ropp_0; rewrite Rmult_0_r.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  rewrite (Rabs_right (/ C0)).
  rewrite <- (Rmult_comm eps).
  replace (C0 ^ n * / INR (fact n) + 0) with (C0 ^ n * / INR (fact n) - 0);
    [ idtac | ring ].
  unfold Rdiv in H4; apply H4; assumption.
  apply Rle_ge; left; apply Rinv_0_lt_compat; assumption.
  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
  unfold Majxy in |- *.
  unfold C0 in |- *.
  rewrite pow_mult.
  unfold C in |- *; reflexivity.
  unfold C0 in |- *; apply pow_lt; assumption.
  apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *.
  apply RmaxLess1.
Qed.

Lemma reste1_maj :
  forall (x y:R) (N:nat),
    (0 < N)%nat -> Rabs (Reste1 x y N) <= Majxy x y (pred N).
Proof.
  intros.
  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  unfold Reste1 in |- *.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	Rabs
        (sum_f_R0
          (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l))) (pred (N - k)))) (
	      pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
          x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
          y ^ (2 * (N - l))) (pred (N - k))) (pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          Rabs
          ((-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l)))) (pred (N - k))) (
	      pred N)).
  apply sum_Rle.
  intros.
  apply
    (Rsum_abs
      (fun l:nat =>
	(-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) *
	((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
	y ^ (2 * (N - l))) (pred (N - n))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) *
          C ^ (2 * S (N + k))) (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
  do 2 rewrite pow_1_abs.
  do 2 rewrite Rmult_1_l.
  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))).
  rewrite (Rabs_right (/ INR (fact (2 * (N - n0))))).
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite <- Rmult_assoc.
  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0))))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  do 2 rewrite <- RPow_abs.
  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
  apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))).
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  apply RmaxLess2.
  right.
  replace (2 * S (N + n))%nat with (2 * (N - n0) + 2 * S (n0 + n))%nat.
  rewrite pow_add.
  apply Rmult_comm.
  apply INR_eq; rewrite plus_INR; do 3 rewrite mult_INR.
  rewrite minus_INR.
  repeat rewrite S_INR; do 2 rewrite plus_INR; ring.
  apply le_trans with (pred (N - n)).
  exact H1.
  apply le_S_n.
  replace (S (pred (N - n))) with (N - n)%nat.
  apply le_trans with N.
  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
  rewrite <- le_plus_minus.
  apply le_plus_r.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply le_n_Sn.
  apply S_pred with 0%nat.
  apply plus_lt_reg_l with n.
  rewrite <- le_plus_minus.
  replace (n + 0)%nat with n; [ idtac | ring ].
  apply le_lt_trans with (pred N).
  assumption.
  apply lt_pred_n_n; assumption.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * C ^ (4 * N))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat.
  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  apply Rle_pow.
  unfold C in |- *; apply RmaxLess1.
  replace (4 * N)%nat with (2 * (2 * N))%nat; [ idtac | ring ].
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * N)%nat with (S (N + pred N)).
  apply le_n_S.
  apply plus_le_compat_l; assumption.
  rewrite pred_of_minus.
  omega.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => C ^ (4 * N) * Rsqr (/ INR (fact (S (N + k)))))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  rewrite <- (Rmult_comm (C ^ (4 * N))).
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with
    (Binomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))).
  apply Rle_trans with
    (Binomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))).
  unfold Rdiv in |- *;
    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply C_maj.
  omega.
  right.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)).
  rewrite Rinv_mult_distr.
  unfold Rsqr in |- *; reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  omega.
  apply INR_fact_neq_0.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat.
  rewrite mult_INR.
  reflexivity.
  omega.
  apply INR_fact_neq_0.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)).
  apply sum_Rle; intros.
  rewrite <-
    (scal_sum (fun _:nat => C ^ (4 * N)) (pred (N - n))
      (Rsqr (/ INR (fact (S (N + n)))))).
  rewrite sum_cte.
  rewrite <- Rmult_assoc.
  do 2 rewrite <- (Rmult_comm (C ^ (4 * N))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N).
  apply Rmult_le_compat_l.
  apply Rle_0_sqr.
  apply le_INR.
  omega.
  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
  apply pos_INR.
  apply Rle_trans with (/ INR (fact (S (N + n)))).
  pattern (/ INR (fact (S (N + n)))) at 2 in |- *; rewrite <- Rmult_1_r.
  unfold Rsqr in |- *.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  replace 1 with (INR 1).
  apply le_INR.
  apply lt_le_S.
  apply INR_lt; apply INR_fact_lt_0.
  reflexivity.
  apply INR_fact_neq_0.
  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (fact (S N))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (INR (fact (S N)))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  apply le_INR.
  apply fact_le.
  apply le_n_S.
  apply le_plus_l.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite sum_cte.
  apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))).
  rewrite <- (Rmult_comm (C ^ (4 * N))).
  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  cut (S (pred N) = N).
  intro; rewrite H0.
  pattern N at 2 in |- *; rewrite <- H0.
  do 2 rewrite fact_simpl.
  rewrite H0.
  repeat rewrite mult_INR.
  repeat rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (/ INR (S N))).
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  pattern (/ INR (fact (pred N))) at 2 in |- *; rewrite <- Rmult_1_r.
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (S N)).
  apply lt_INR_0; apply lt_O_Sn.
  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rmult_1_l.
  apply le_INR; apply le_n_Sn.
  apply not_O_INR; discriminate.
  apply not_O_INR.
  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply not_O_INR.
  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  apply prod_neq_R0.
  apply not_O_INR.
  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply INR_fact_neq_0.
  symmetry  in |- *; apply S_pred with 0%nat; assumption.
  right.
  unfold Majxy in |- *.
  unfold C in |- *.
  replace (S (pred N)) with N.
  reflexivity.
  apply S_pred with 0%nat; assumption.
Qed.

Lemma reste2_maj :
  forall (x y:R) (N:nat), (0 < N)%nat -> Rabs (Reste2 x y N) <= Majxy x y N.
Proof.
  intros.
  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  unfold Reste2 in |- *.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	Rabs
        (sum_f_R0
          (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1)) (pred (N - k)))) (
	      pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
          x ^ (2 * S (l + k) + 1) *
          ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
          y ^ (2 * (N - l) + 1)) (pred (N - k))) (
	    pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          Rabs
          ((-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1))) (pred (N - k))) (
	      pred N)).
  apply sum_Rle.
  intros.
  apply
    (Rsum_abs
      (fun l:nat =>
	(-1) ^ S (l + n) / INR (fact (2 * S (l + n) + 1)) *
	x ^ (2 * S (l + n) + 1) *
	((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
	y ^ (2 * (N - l) + 1)) (pred (N - n))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
          C ^ (2 * S (S (N + k)))) (pred (N - k))) (
	    pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
  do 2 rewrite pow_1_abs.
  do 2 rewrite Rmult_1_l.
  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))).
  rewrite (Rabs_right (/ INR (fact (2 * (N - n0) + 1)))).
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite <- Rmult_assoc.
  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0) + 1)))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  do 2 rewrite <- RPow_abs.
  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
  apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))).
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  apply RmaxLess2.
  right.
  replace (2 * S (S (N + n)))%nat with
    (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat.
  repeat rewrite pow_add.
  ring.
  omega.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
          C ^ (4 * S N)) (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat.
  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  apply Rle_pow.
  unfold C in |- *; apply RmaxLess1.
  replace (4 * S N)%nat with (2 * (2 * S N))%nat; [ idtac | ring ].
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * S N)%nat with (S (S (N + N))).
  repeat apply le_n_S.
  apply plus_le_compat_l.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  ring.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat => C ^ (4 * S N) * Rsqr (/ INR (fact (S (S (N + k))))))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  rewrite <- (Rmult_comm (C ^ (4 * S N))).
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with
    (Binomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) /
      INR (fact (2 * S (S (N + n))))).
  apply Rle_trans with
    (Binomial.C (2 * S (S (N + n))) (S (S (N + n))) /
      INR (fact (2 * S (S (N + n))))).
  unfold Rdiv in |- *;
    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply C_maj.
  apply le_trans with (2 * S (S (n0 + n)))%nat.
  replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
  apply le_n_Sn.
  ring.
  omega.
  right.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))).
  rewrite Rinv_mult_distr.
  unfold Rsqr in |- *; reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  omega.
  apply INR_fact_neq_0.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with
    (2 * (N - n0) + 1)%nat.
  rewrite mult_INR.
  reflexivity.
  omega.
  apply INR_fact_neq_0.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N))
      (pred N)).
  apply sum_Rle; intros.
  rewrite <-
    (scal_sum (fun _:nat => C ^ (4 * S N)) (pred (N - n))
      (Rsqr (/ INR (fact (S (S (N + n))))))).
  rewrite sum_cte.
  rewrite <- Rmult_assoc.
  do 2 rewrite <- (Rmult_comm (C ^ (4 * S N))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N).
  apply Rmult_le_compat_l.
  apply Rle_0_sqr.
  replace (S (pred (N - n))) with (N - n)%nat.
  apply le_INR.
  omega.
  omega.
  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
  apply pos_INR.
  apply Rle_trans with (/ INR (fact (S (S (N + n))))).
  pattern (/ INR (fact (S (S (N + n))))) at 2 in |- *; rewrite <- Rmult_1_r.
  unfold Rsqr in |- *.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  replace 1 with (INR 1).
  apply le_INR.
  apply lt_le_S.
  apply INR_lt; apply INR_fact_lt_0.
  reflexivity.
  apply INR_fact_neq_0.
  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (fact (S (S N)))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (INR (fact (S (S N))))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  apply le_INR.
  apply fact_le.
  omega.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite sum_cte.
  apply Rle_trans with (C ^ (4 * S N) / INR (fact N)).
  rewrite <- (Rmult_comm (C ^ (4 * S N))).
  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  cut (S (pred N) = N).
  intro; rewrite H0.
  do 2 rewrite fact_simpl.
  repeat rewrite mult_INR.
  repeat rewrite Rinv_mult_distr.
  apply Rle_trans with
    (INR (S (S N)) * (/ INR (S (S N)) * (/ INR (S N) * / INR (fact N))) * INR N).
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (INR N)).
  rewrite (Rmult_comm (INR (S (S N)))).
  apply Rmult_le_compat_l.
  repeat apply Rmult_le_pos.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply pos_INR.
  apply le_INR.
  apply le_trans with (S N); apply le_n_Sn.
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  apply Rle_trans with (/ INR (S N) * / INR (fact N) * INR (S N)).
  repeat rewrite Rmult_assoc.
  repeat apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply le_INR; apply le_n_Sn.
  rewrite (Rmult_comm (/ INR (S N))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; right; reflexivity.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
  symmetry  in |- *; apply S_pred with 0%nat; assumption.
  right.
  unfold Majxy in |- *.
  unfold C in |- *.
  reflexivity.
Qed.

Lemma reste1_cv_R0 : forall x y:R, Un_cv (Reste1 x y) 0.
Proof.
  intros.
  assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold R_dist in H.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H eps H0); intros N0 H1.
  exists (S N0); intros.
  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
  apply Rle_lt_trans with (Rabs (Majxy x y (pred n))).
  rewrite (Rabs_right (Majxy x y (pred n))).
  apply reste1_maj.
  apply lt_le_trans with (S N0).
  apply lt_O_Sn.
  assumption.
  apply Rle_ge.
  unfold Majxy in |- *.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  replace (Majxy x y (pred n)) with (Majxy x y (pred n) - 0); [ idtac | ring ].
  apply H1.
  unfold ge in |- *; apply le_S_n.
  replace (S (pred n)) with n.
  assumption.
  apply S_pred with 0%nat.
  apply lt_le_trans with (S N0); [ apply lt_O_Sn | assumption ].
Qed.

Lemma reste2_cv_R0 : forall x y:R, Un_cv (Reste2 x y) 0.
Proof.
  intros.
  assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold R_dist in H.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H eps H0); intros N0 H1.
  exists (S N0); intros.
  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
  apply Rle_lt_trans with (Rabs (Majxy x y n)).
  rewrite (Rabs_right (Majxy x y n)).
  apply reste2_maj.
  apply lt_le_trans with (S N0).
  apply lt_O_Sn.
  assumption.
  apply Rle_ge.
  unfold Majxy in |- *.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  replace (Majxy x y n) with (Majxy x y n - 0); [ idtac | ring ].
  apply H1.
  unfold ge in |- *; apply le_trans with (S N0).
  apply le_n_Sn.
  exact H2.
Qed.

Lemma reste_cv_R0 : forall x y:R, Un_cv (Reste x y) 0.
Proof.
  intros.
  unfold Reste in |- *.
  set (An := fun n:nat => Reste2 x y n).
  set (Bn := fun n:nat => Reste1 x y (S n)).
  cut
    (Un_cv (fun n:nat => An n - Bn n) (0 - 0) ->
      Un_cv (fun N:nat => Reste2 x y N - Reste1 x y (S N)) 0).
  intro.
  apply H.
  apply CV_minus.
  unfold An in |- *.
  replace (fun n:nat => Reste2 x y n) with (Reste2 x y).
  apply reste2_cv_R0.
  reflexivity.
  unfold Bn in |- *.
  assert (H0 := reste1_cv_R0 x y).
  unfold Un_cv in H0; unfold R_dist in H0.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H0 eps H1); intros N0 H2.
  exists N0; intros.
  apply H2.
  unfold ge in |- *; apply le_trans with (S N0).
  apply le_n_Sn.
  apply le_n_S; assumption.
  unfold An, Bn in |- *.
  intro.
  replace 0 with (0 - 0); [ idtac | ring ].
  exact H.
Qed.

Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y.
Proof.
  intros.
  cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)).
  cut (Un_cv (C1 x y) (cos (x + y))).
  intros.
  apply UL_sequence with (C1 x y); assumption.
  apply C1_cvg.
  unfold Un_cv in |- *; unfold R_dist in |- *.
  intros.
  assert (H0 := A1_cvg x).
  assert (H1 := A1_cvg y).
  assert (H2 := B1_cvg x).
  assert (H3 := B1_cvg y).
  assert (H4 := CV_mult _ _ _ _ H0 H1).
  assert (H5 := CV_mult _ _ _ _ H2 H3).
  assert (H6 := reste_cv_R0 x y).
  unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6.
  unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6.
  cut (0 < eps / 3);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H4 (eps / 3) H7); intros N1 H8.
  elim (H5 (eps / 3) H7); intros N2 H9.
  elim (H6 (eps / 3) H7); intros N3 H10.
  set (N := S (S (max (max N1 N2) N3))).
  exists N.
  intros.
  cut (n = S (pred n)).
  intro; rewrite H12.
  rewrite <- cos_plus_form.
  rewrite <- H12.
  apply Rle_lt_trans with
    (Rabs (A1 x n * A1 y n - cos x * cos y) +
      Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))).
  replace
    (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) -
      (cos x * cos y - sin x * sin y)) with
    (A1 x n * A1 y n - cos x * cos y +
      (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n)));
    [ apply Rabs_triang | ring ].
  replace eps with (eps / 3 + (eps / 3 + eps / 3)).
  apply Rplus_lt_compat.
  apply H8.
  unfold ge in |- *; apply le_trans with N.
  unfold N in |- *.
  apply le_trans with (max N1 N2).
  apply le_max_l.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_l.
  apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn.
  assumption.
  apply Rle_lt_trans with
    (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) +
      Rabs (Reste x y (pred n))).
  apply Rabs_triang.
  apply Rplus_lt_compat.
  rewrite <- Rabs_Ropp.
  rewrite Ropp_minus_distr.
  apply H9.
  unfold ge in |- *; apply le_trans with (max N1 N2).
  apply le_max_r.
  apply le_S_n.
  rewrite <- H12.
  apply le_trans with N.
  unfold N in |- *.
  apply le_n_S.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_l.
  apply le_n_Sn.
  assumption.
  replace (Reste x y (pred n)) with (Reste x y (pred n) - 0).
  apply H10.
  unfold ge in |- *.
  apply le_S_n.
  rewrite <- H12.
  apply le_trans with N.
  unfold N in |- *.
  apply le_n_S.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_r.
  apply le_n_Sn.
  assumption.
  ring.
  pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
  ring.
  unfold Rdiv in |- *.
  rewrite <- Rmult_assoc.
  apply Rinv_r_simpl_m.
  discrR.
  apply lt_le_trans with (pred N).
  unfold N in |- *; simpl in |- *; apply lt_O_Sn.
  apply le_S_n.
  rewrite <- H12.
  replace (S (pred N)) with N.
  assumption.
  unfold N in |- *; simpl in |- *; reflexivity.
  cut (0 < N)%nat.
  intro.
  cut (0 < n)%nat.
  intro.
  apply S_pred with 0%nat; assumption.
  apply lt_le_trans with N; assumption.
  unfold N in |- *; apply lt_O_Sn.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
  induction l1.
  - intros. simpl. f_equal. apply IHl1.
  - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
  induction l.
  - simpl. f_equal. apply IHl.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (len (rev x)) (len x).
Proof.
induction x.
  - simpl. rewrite <- IHx. rewrite <- (lem (rev x) Nil n).
 lfind. Admitted.


Require Export Syntax.

Inductive envDom :=
  | env_var : var -> envDom
  | env_loc : loc -> envDom.

Instance ID_envDom : ID envDom := {}.
  intros; repeat (decide equality).
Qed.

Definition env := partial_map envDom ty.

Inductive wfType (P : program) : ty -> Prop :=
  | WF_TClass :
      forall c,
        classLookup P c <> None ->
        wfType P (TClass c)
  | WF_TInterface :
      forall i,
        interfaceLookup P i <> None ->
        wfType P (TInterface i)
  | WF_TUnit : wfType P TUnit.

Inductive wfEnv (P : program) : env -> Prop :=
  | WF_Env :
      (forall Gamma,
        (forall x t, Gamma x = Some t -> wfType P t) ->
        (forall l t, Gamma (env_loc l) = Some t -> exists c, t = TClass c) ->
        wfEnv P Gamma).

Inductive wfFrame (Gamma Gamma1 Gamma2 : env) : Prop :=
  | WF_Frame :
      (forall x t, Gamma1 x = Some t -> Gamma x = Some t) ->
      (forall x t, Gamma2 x = Some t -> Gamma x = Some t) ->
      (forall x t, Gamma1 (env_var x) = Some t -> Gamma2 (env_var x) = None) ->
      (forall x t, Gamma2 (env_var x) = Some t -> Gamma1 (env_var x) = None) ->
      wfFrame Gamma Gamma1 Gamma2.

Inductive wfSubsumption (Gamma Gamma' : env) : Prop :=
  | WF_Subsumption :
      (forall x t, Gamma x = Some t -> Gamma' x = Some t) ->
      wfSubsumption Gamma Gamma'.

Inductive subtypeOf (P : program) : ty -> ty -> Prop :=
  | Sub_Class :
      forall c i fs ms,
        classLookup P c = Some (Cls c i fs ms) ->
        subtypeOf P (TClass c) (TInterface i)
  | Sub_InterfaceLeft :
      forall i i1 i2,
        interfaceLookup P i = Some (ExtInterface i i1 i2) ->
        subtypeOf P (TInterface i) (TInterface i1)
  | Sub_InterfaceRight :
      forall i i1 i2,
        interfaceLookup P i = Some (ExtInterface i i1 i2) ->
        subtypeOf P (TInterface i) (TInterface i2)
  | Sub_Refl :
      forall t,
        wfType P t ->
        subtypeOf P t t
  | Sub_Trans :
      forall t1 t2 t3,
        subtypeOf P t1 t2 ->
        subtypeOf P t2 t3 ->
        subtypeOf P t1 t3.
  (* | Sub_Unit : *)
  (*     forall t, *)
  (*       wfType P t -> *)
  (*       subtypeOf P t TUnit. *)

Tactic Notation "subtypeOf_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "Sub_Class"  | Case_aux c "Sub_InterfaceLeft"
  | Case_aux c "Sub_InterfaceRight" | Case_aux c "Sub_Refl"
  | Case_aux c "Sub_Trans" (*| Case_aux c "Sub_Unit"*)].

Reserved Notation " P ';' Gamma '|-' expr '\in' ty " (at level 40).

Inductive hasType (P : program) (Gamma : env) : expr -> ty -> Prop :=
  | T_Var :
      forall x t,
        wfEnv P Gamma ->
        Gamma (env_var x) = Some t ->
        P ; Gamma |- (EVar x) \in t
  | T_Loc :
      forall l t t2,
        wfEnv P Gamma ->
        Gamma (env_loc l) = Some t2 ->
        subtypeOf P t2 t ->
        P ; Gamma |- (EVal (VLoc l)) \in t
  | T_Null :
      forall t,
        wfEnv P Gamma ->
        wfType P t ->
        P ; Gamma |- EVal VNull \in t
  | T_New :
      forall c,
        wfEnv P Gamma ->
        classLookup P c <> None ->
        P ; Gamma |- ENew c \in TClass c
  | T_Call :
      forall x m e t t1 t2 msigs y,
        P ; Gamma |- (EVar x) \in t1 -> (*Gamma (env_var x) = Some t1 ->*)
        methodSigs P t1 msigs ->
        methodSigLookup msigs m = Some (MethodSig m (y, t2) t) ->
        P ; Gamma |- e \in t2 ->
        P ; Gamma |- ECall x m e \in t
  | T_Select :
      forall x f c t fs,
        P ; Gamma |- (EVar x) \in TClass c ->
        fields P (TClass c) = Some fs ->
        fieldLookup fs f = Some (Field f t) ->
        P ; Gamma |- ESelect x f \in t
  | T_Update :
      forall c x f e t fs,
        P ; Gamma |- (EVar x) \in TClass c ->
        fields P (TClass c) = Some fs ->
        fieldLookup fs f = Some (Field f t) ->
        P ; Gamma |- e \in t ->
        P ; Gamma |- EUpdate x f e \in TUnit
  | T_Let :
      forall x e body t t',
        P ; Gamma |- e \in t ->
        P ; extend Gamma (env_var (SV x)) t |- body \in t' ->
        no_locks body ->
        P ; Gamma |- ELet x e body \in t'
  | T_Cast :
      forall e t1 t2,
        P ; Gamma |- e \in t2 ->
        subtypeOf P t2 t1 ->
        P ; Gamma |- ECast t1 e \in t1
  | T_Par :
      forall Gamma1 Gamma2 e1 e2 e3 t1 t2 t3,
        wfFrame Gamma Gamma1 Gamma2 ->
        P ; Gamma1 |- e1 \in t1 ->
        P ; Gamma2 |- e2 \in t2 ->
        P ; Gamma |- e3 \in t3 ->
        no_locks e1 ->
        no_locks e2 ->
        no_locks e3 ->
        P ; Gamma |- EPar e1 e2 e3 \in t3
  | T_Lock :
      forall x t2 e t,
        P ; Gamma |- (EVar x) \in t2 ->
        P ; Gamma |- e \in t ->
        no_locks e ->
        P ; Gamma |- ELock x e \in t
  | T_Locked :
      forall l t2 e t,
        P ; Gamma |- (EVal (VLoc l)) \in t2 ->
        P ; Gamma |- e \in t ->
        P ; Gamma |- ELocked l e \in t
  where " P ';' Gamma '|-' expr '\in' ty " := (hasType P Gamma expr ty).

Tactic Notation "hasType_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var"
  | Case_aux c "T_Loc"
  | Case_aux c "T_Null"
  | Case_aux c "T_New"
  | Case_aux c "T_Call"
  | Case_aux c "T_Select"
  | Case_aux c "T_Update"
  | Case_aux c "T_Let"
  | Case_aux c "T_Cast"
  | Case_aux c "T_Par"
  | Case_aux c "T_Lock"
  | Case_aux c "T_Locked"
  ].


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e222m117_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


From DEZ Require Export
  Init.
From DEZ.Is Require Import
  LeftModule.
From DEZ.ShouldHave Require Import
  FieldNotations.

Definition unit_eqv (x y : unit) : Prop := True.

Instance unit_has_eqv : HasEqv unit := unit_eqv.

Instance unit_is_reflexive : IsReflexive unit_eqv := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_symmetric : IsSymmetric unit_eqv := {}.
Proof. intros x y p. constructor. Qed.

Instance unit_is_transitive : IsTransitive unit_eqv := {}.
Proof. intros x y z p q. constructor. Qed.

Instance unit_is_setoid : IsSetoid unit_eqv := {}.

Theorem unit_eqv_iff_eq : forall x y : unit,
  x == y <-> x = y.
Proof.
  intros [] []. split.
  - intros _. constructor.
  - intros _. constructor. Qed.

Definition tt2 (x y : unit) : unit := tt.

Instance unit_has_opr : HasOpr unit := tt2.

Instance unit_is_associative : IsAssociative tt2 := {}.
Proof. intros x y z. constructor. Qed.

Instance unit_is_semigroup : IsSemigroup tt2 := {}.
Proof. intros x y p z w q. constructor. Qed.

Instance unit_has_idn : HasIdn unit := tt.

Instance unit_is_left_identifiable : IsLeftIdentifiable tt2 tt := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_right_identifiable : IsRightIdentifiable tt2 tt := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_identifiable : IsBiidentifiable tt2 tt := {}.

Instance unit_is_monoid : IsMonoid tt2 tt := {}.

Instance unit_is_commutative : IsCommutative tt2 := {}.
Proof. intros x y. constructor. Qed.

Instance unit_is_commutative_monoid : IsCommutativeMonoid tt2 tt := {}.

Definition tt1 (x : unit) : unit := tt.

Instance unit_has_inv : HasInv unit := tt1.

Instance unit_is_left_invertible : IsLeftInvertible tt2 tt tt1 := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_right_invertible : IsRightInvertible tt2 tt tt1 := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_invertible : IsBiinvertible tt2 tt tt1 := {}.

Instance unit_is_group : IsGroup tt2 tt tt1 := {}.
Proof. intros x y p. constructor. Qed.

Instance unit_is_abelian_group : IsAbelianGroup tt2 tt tt1 := {}.

Instance unit_has_add : HasAdd unit := tt2.
Instance unit_has_mul : HasMul unit := tt2.

Instance unit_has_zero : HasZero unit := tt.
Instance unit_has_one : HasOne unit := tt.

Instance unit_is_left_distributive : IsLeftDistributive tt2 tt2 := {}.
Proof. intros x y z. constructor. Qed.

Instance unit_is_right_distributive : IsRightDistributive tt2 tt2 := {}.
Proof. intros x y z. constructor. Qed.

Instance unit_is_distributive : IsBidistributive tt2 tt2 := {}.

Instance unit_is_semiring : IsSemiring tt2 tt tt2 tt := {}.

Instance unit_has_neg : HasNeg unit := tt1.

Instance unit_is_ring : IsRing tt2 tt tt1 tt2 tt := {}.

Theorem unit_ring_trivial : 1 == 0.
Proof. reflexivity. Qed.

Section Context.

Context {S : Type} `{is_ring : IsRing S}.

Definition unit_lsmul (x : S) (y : unit) : unit := y.

Global Instance unit_has_lsmul : HasLSMul S unit := unit_lsmul.

Global Instance unit_is_left_module : IsLeftModule tt2 tt tt1
  add zero neg mul one unit_lsmul := {}.
Proof. all: constructor. Qed.

End Context.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal9.

From lfind Require Import LFind.
Lemma lfind_state  (x1:natural) (x2:natural) (x3:natural) (n:natural) (l:lst) (IHl:@eq lst (drop (Succ x1) (drop (Succ x2) (Cons x3 l)))
  (drop (Succ x2) (drop (Succ x1) (Cons x3 l)))):@eq lst (drop (Succ x1) (drop (Succ x2) (Cons x3 (Cons n l))))
  (drop (Succ x2) (drop (Succ x1) (Cons x3 (Cons n l)))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal9_drop_Cons_assoc_32_drop_Cons/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x1:natural) (x2:natural) (x3:natural) (n:natural) (l:lst) :=
 let lfind_var := "x1:" ++ "(" ++ show x1 ++ ")"++ "|" ++"x2:" ++ "(" ++ show x2 ++ ")"++ "|" ++"x3:" ++ "(" ++ show x3 ++ ")"++ "|" ++"n:" ++ "(" ++ show n ++ ")"++ "|" ++"l:" ++ "(" ++ show l ++ ")"
 in let lfind_v := print x1 lfind_var
 in lfind_state lfind_v  x2 x3 n l.
QuickChick collect_data.
Success.


Axiom pair : nat -> nat -> nat -> Prop.
Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop).
Axiom plImpR : forall k P Q,
  pl P Q k -> forall (Q':nat -> Prop),
    (forall k', Q k' -> Q' k') ->
    pl P Q' k.

Definition nexists (P:nat -> nat -> Prop) : nat -> Prop :=
  fun k' => exists k, P k k'.

Goal forall a A m,
  True ->
  (pl A (nexists (fun x => (nexists
    (fun y => pl (pair a (S x)) (pair a (S y))))))) m.
Proof.
  intros.
  eapply plImpR; [ | intros; econstructor; econstructor; eauto].
  clear H;
    match goal with
       | |- (pl _ (pl (pair _ ?x) _)) _ => replace x with 0
    end.
Admitted.


Require Import Forcing.

Axiom Obj : Type.
Axiom Hom : Obj -> Obj -> Type.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Ltac _force c := force Obj Hom c.

Forcing Translate bool using Obj Hom.
Forcing Translate nat using Obj Hom.
Forcing Translate list using Obj Hom.

Inductive vect (A : Type) : nat -> Type :=
| nilv : vect A 0
| consv : A -> forall n, vect A n -> vect A (S n).

Forcing Translate vect using Obj Hom.

Goal True.
Proof.
_force (fun A n (v : vect A n) =>
          match v in vect _ n return (match n with |0 => bool |_ => nat end) with
            |nilv _ => true
            |consv _ _ x r => 1
          end).
exact I.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_5limbs_donna.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e414m17_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.