Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Rminus.
Require Import XR_Rlt_irrefl.
Require Import XR_Rle_trans.
Require Import XR_Rlt_le_trans.
Require Import XR_Ropp_plus_distr.
Require Import XR_Rplus_le_compat_l.
Require Import XR_Ropp_0.
Require Import XR_Ropp_le_cancel.
Require Import XR_Ropp_le_contravar.
Require Import XR_Rplus_le_reg_r.

Local Open Scope R_scope.

Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
Proof.
  intros x y.
  unfold Rabs.
  destruct (Rcase_abs (x-y)) as [ hm | hm ] ;
  destruct (Rcase_abs x) as [ hx | hx ] ;
  destruct (Rcase_abs y) as [ hy | hy ].
  {
    unfold Rminus.
    rewrite Ropp_plus_distr.
    right.
    reflexivity.
  }
  {
    unfold Rminus.
    rewrite Ropp_plus_distr.
    rewrite Ropp_involutive.
    apply Rplus_le_compat_l.
    apply Rle_trans with R0.
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      exact hy.
    }
    { exact hy. }
  }
  {
    exfalso.
    apply Rlt_irrefl with y.
    apply Rlt_le_trans with R0.
    { exact hy. }
    {
      apply Rle_trans with x.
      { exact hx. }
      {
        apply Rplus_le_reg_r with (-y).
        rewrite Rplus_opp_r.
        unfold Rminus in hm.
        left.
        exact hm.
      }
    }
  }
  {
    unfold Rminus.
    rewrite Ropp_plus_distr.
    rewrite Ropp_involutive.
    apply Rle_trans with R0.
    {
      left.
      unfold Rminus in hm.
      exact hm.
    }
    {
      apply Ropp_le_cancel.
      rewrite Ropp_0.
      rewrite Ropp_plus_distr.
      rewrite Ropp_involutive.
      unfold Rminus in hm.
      left.
      exact hm.
    }
  }
  {
    unfold Rminus.
    rewrite Ropp_involutive.
    apply Rle_trans with R0.
    {
      apply Ropp_le_cancel.
      rewrite Ropp_0.
      rewrite Ropp_plus_distr.
      rewrite Ropp_involutive.
      unfold Rminus in hm.
      exact hm.
    }
    {
      unfold Rminus in hm.
      exact hm.
    }
  }
  {
    exfalso.
    apply Rlt_irrefl with x.
    apply Rlt_le_trans with R0.
    { exact hx. }
    {
      apply Rle_trans with y.
      { exact hy. }
      {
        apply Rplus_le_reg_r with (-y).
        rewrite Rplus_opp_r.
        unfold Rminus in hm.
        exact hm.
      }
    }
  }
  {
    unfold Rminus.
    rewrite Ropp_involutive.
    apply Rplus_le_compat_l.
    apply Rle_trans with R0.
    {
      left.
      exact hy.
    }
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      left.
      exact hy.
    }
  }
  {
    right.
    reflexivity.
  }
Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo76:
  prime  201471189889->
  prime  39488365236169.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      39488365236169
      196
      ((201471189889,1)::nil)
      0
      3584
      8
      64)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


(** List with the same size of another list. This constitutes the
    prototype of finite functions. This module is inspired by the
    [ffun] module in Ssreflect. Ssreflect's [ffun] is somehow smarter
    though, as it restricts its attention to lists without duplicate
    in a type with decidable equality, so that there are stronger
    extensionality principles. *)

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import FinSet.Lib.DProp.
Require FinSet.Lib.ListSet.

Inductive T {A B:Type} : list A -> Type :=
| inil : T []
| icons {a l} (b:B) (q:T l) : T (a::l)
.
Arguments T {A} B l : clear implicits.

Fixpoint to_list {A B} {l:list A} (q:T B l) : list B :=
  match q with
  | inil => []
  | icons b q => b::(to_list q)
  end
.

Lemma ext A B (l:list A) :
  forall q₁ q₂:T B l, to_list q₁ = to_list q₂ -> q₁ = q₂.
Proof.
  intros q₁. induction q₁ as [ ? ? | ? ?  b₁ q₁ hq₁].
  + intros q₂. refine match q₂ with inil => _ end.
    reflexivity.
  + intro q₂. revert b₁ q₁ hq₁.
    refine match q₂ with icons b₂ q₂ => _ end. intros b₁ q₁ hq₁. cbn.
    intros [= <- h]. f_equal.
    eauto.
Qed.

(** [Image.T] can be read as an association list with the domain as
    keys. In this variant we return a default value when there is no
    corresponding key. *)
Fixpoint assoc {A B} {l:list A} (E:A->A->DProp) (d:B) (q:T B l) (x:A) : B :=
  match l return T B l -> B with
  | [] => fun _ => d
  | a::l => fun q =>
    match q with icons b q =>
      if dec (E x a) then b
      else assoc E d q x
    end
  end q
.

Lemma assoc_default A B (l:list A) E d (q:T B l) : forall x, ~(ListSet.mem_list E x l) -> assoc E d q x = d.
Proof.
  intros x.
  induction l as [|a l hl].
  + refine match q with inil => _ end. cbn.
    reflexivity.
  + revert hl.
    refine match q with icons b q' => _ end. cbn [assoc].
    intros hl h.
    destruct dec as [hx|_].
    { cbn in h. contradiction h.
      now eexists (ListSet.head _). }
    apply hl. cbn in h|-*.
    intros [m hm]. apply h.
    now exists (ListSet.tail m).
Qed.

(** Conversely, given a function defined on a domain we can create the
    image of the domain. *)
Fixpoint img {A B} (l:list A) : (ListSet.Mem l -> B) -> T B l :=
  match l with
  | [] => fun _ => inil
  | a::l => fun f =>
    icons (f (ListSet.head a)) (img l (fun m => f (ListSet.tail m)))
  end
.

(** Variant of [img] with decidable equality *)
Program Definition img_dec {A B} (E:A->A->DProp) {_:Reflexive E} (l:list A) (f:forall x:A, Canonize (ListSet.mem_list E x l) -> B) : T B l :=
  img l (fun m => f (ListSet.of_mem m) _).
Next Obligation.
  intros **. apply canonize_spec.
  eexists. reflexivity.
Qed.

Lemma assoc_img₀ A B (E:A->A->DProp) (_:Reflexive E)
      (d:B) l m f :
  (forall u v, E u v -> u=v) ->
  (forall m m':ListSet.Mem l, ListSet.of_mem m = ListSet.of_mem m' -> f m = f m') ->
  assoc E d (img l f) (ListSet.of_mem m) = f m.
Proof.
  intros e_eq f_ext.
  induction l as [ | a l hl ].
  { ListSet.use_no_mem_empty. }
  cbn. destruct dec as [he|he].
  + apply e_eq in he.
    now apply f_ext.
  + revert he f f_ext hl.
    refine match m with ListSet.head a' => _ | ListSet.tail m' => _ end.
    { intros he f _ _. cbn in he. rewrite denies_spec in he.
      now pose proof (reflexivity a') as he'. }
    intros _ f f_ext hl. cbn.
    apply hl.
    eauto.
Qed.

Lemma assoc_img A B (E:A->A->DProp) (_:Reflexive E)
      (d:B) l x (h:Canonize (ListSet.mem_list E x l)) f :
  (forall u v, E u v -> u=v) -> assoc E d (img_dec E l f) x = f x h.
Proof.
  intros e_eq.
  assert (forall y hy z hz, y=z -> f y hy = f z hz) as f_ext.
  { intros y hy z hz <-. f_equal.
    apply irrelevant_canonize. }
  unfold img_dec.
  pose proof h as h'. apply canonize_spec in h'.
  pose proof (ListSet.mem_of_mem_list_spec _ _ _ _ h') as hx.
  apply e_eq in hx. rewrite hx at 1.
  rewrite assoc_img₀;cycle 1.
  { typeclasses eauto. }
  { assumption. }
  { intros **.
    now apply f_ext. }
  now apply f_ext.
Qed.

Module Coercions.

  Coercion to_list : T >-> list.

End Coercions.


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

(*i $Id: Exp_prop.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import Ranalysis1.
Require Import PSeries_reg.
Require Import Div2.
Require Import Even.
Require Import Max.
Open Local Scope nat_scope.
Open Local Scope R_scope.

Definition E1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => / INR (fact k) * x ^ k) N.

Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x).
Proof.
  intro; unfold exp in |- *; unfold projT1 in |- *.
  case (exist_exp x); intro.
  unfold exp_in, Un_cv in |- *; unfold infinite_sum, E1 in |- *; trivial.
Qed.

Definition Reste_E (x y:R) (N:nat) : R :=
  sum_f_R0
  (fun k:nat =>
    sum_f_R0
    (fun l:nat =>
      / INR (fact (S (l + k))) * x ^ S (l + k) *
      (/ INR (fact (N - l)) * y ^ (N - l))) (
        pred (N - k))) (pred N).

Lemma exp_form :
  forall (x y:R) (n:nat),
    (0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n.
Proof.
  intros; unfold E1 in |- *.
  rewrite cauchy_finite.
  unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc;
    rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq;
      intros.
  rewrite binomial.
  rewrite scal_sum; apply sum_eq; intros.
  unfold C in |- *; unfold Rdiv in |- *; repeat rewrite Rmult_assoc;
    rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc;
      rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite Rinv_mult_distr.
  ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply H.
Qed.

Definition maj_Reste_E (x y:R) (N:nat) : R :=
  4 *
  (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * N) /
    Rsqr (INR (fact (div2 (pred N))))).

Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
Proof.
  intros; apply Rmult_le_reg_l with x.
  apply H.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with y.
  apply H0.
  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; apply H1.
  red in |- *; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
  red in |- *; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
Qed.

(**********)
Lemma div2_double : forall N:nat, div2 (2 * N) = N.
Proof.
  intro; induction  N as [| N HrecN].
  reflexivity.
  replace (2 * S N)%nat with (S (S (2 * N))).
  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
  ring.
Qed.

Lemma div2_S_double : forall N:nat, div2 (S (2 * N)) = N.
Proof.
  intro; induction  N as [| N HrecN].
  reflexivity.
  replace (2 * S N)%nat with (S (S (2 * N))).
  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
  ring.
Qed.

Lemma div2_not_R0 : forall N:nat, (1 < N)%nat -> (0 < div2 N)%nat.
Proof.
  intros; induction  N as [| N HrecN].
  elim (lt_n_O _ H).
  cut ((1 < N)%nat \/ N = 1%nat).
  intro; elim H0; intro.
  assert (H2 := even_odd_dec N).
  elim H2; intro.
  rewrite <- (even_div2 _ a); apply HrecN; assumption.
  rewrite <- (odd_div2 _ b); apply lt_O_Sn.
  rewrite H1; simpl in |- *; apply lt_O_Sn.
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
Qed.

Lemma Reste_E_maj :
  forall (x y:R) (N:nat),
    (0 < N)%nat -> Rabs (Reste_E x y N) <= maj_Reste_E x y N.
Proof.
  intros; set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  apply Rle_trans with
    (M ^ (2 * N) *
      sum_f_R0
      (fun k:nat =>
        sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
        (pred (N - k))) (pred N)).
  unfold Reste_E in |- *.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
        Rabs
        (sum_f_R0
          (fun l:nat =>
            / INR (fact (S (l + k))) * x ^ S (l + k) *
            (/ INR (fact (N - l)) * y ^ (N - l))) (
              pred (N - k)))) (pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
        sum_f_R0
        (fun l:nat =>
          / INR (fact (S (l + k))) * x ^ S (l + k) *
          (/ INR (fact (N - l)) * y ^ (N - l))) (
            pred (N - k))) (pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
        sum_f_R0
        (fun l:nat =>
          Rabs
          (/ INR (fact (S (l + k))) * x ^ S (l + k) *
            (/ INR (fact (N - l)) * y ^ (N - l)))) (
              pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply
    (Rsum_abs
      (fun l:nat =>
        / INR (fact (S (l + n))) * x ^ S (l + n) *
        (/ INR (fact (N - l)) * y ^ (N - l)))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
        sum_f_R0
        (fun l:nat =>
          M ^ (2 * N) * / INR (fact (S l)) * / INR (fact (N - l)))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  repeat rewrite Rabs_mult.
  do 2 rewrite <- RPow_abs.
  rewrite (Rabs_right (/ INR (fact (S (n0 + n))))).
  rewrite (Rabs_right (/ INR (fact (N - n0)))).
  replace
  (/ INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
    (/ INR (fact (N - n0)) * Rabs y ^ (N - n0))) with
  (/ INR (fact (N - n0)) * / INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
    Rabs y ^ (N - n0)); [ idtac | ring ].
  rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with
    (/ INR (fact (S n0)) * Rabs x ^ S (n0 + n) * Rabs y ^ (N - n0)).
  rewrite (Rmult_comm (/ INR (fact (S (n0 + n)))));
    rewrite (Rmult_comm (/ INR (fact (S n0)))); repeat rewrite Rmult_assoc;
      apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply Rle_Rinv.
  apply INR_fact_lt_0.
  apply INR_fact_lt_0.
  apply le_INR; apply fact_le; apply le_n_S.
  apply le_plus_l.
  rewrite (Rmult_comm (M ^ (2 * N))); rewrite Rmult_assoc;
    apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with (M ^ S (n0 + n) * Rabs y ^ (N - n0)).
  do 2 rewrite <- (Rmult_comm (Rabs y ^ (N - n0))).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr; split.
  apply Rabs_pos.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  unfold M in |- *; apply RmaxLess2.
  apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold M in |- *; apply RmaxLess1.
  apply pow_incr; split.
  apply Rabs_pos.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess2.
  unfold M in |- *; apply RmaxLess2.
  rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat.
  apply Rle_pow.
  unfold M in |- *; apply RmaxLess1.
  replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
  apply plus_le_compat_l.
  replace N with (S (pred N)).
  apply le_n_S; apply H0.
  symmetry  in |- *; apply S_pred with 0%nat; apply H.
  apply INR_eq; do 2 rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR;
    rewrite minus_INR.
  ring.
  apply le_trans with (pred (N - n)).
  apply 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).
  apply H0.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  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.
  rewrite scal_sum.
  apply sum_Rle; intros.
  rewrite <- Rmult_comm.
  rewrite scal_sum.
  apply sum_Rle; intros.
  rewrite (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold M in |- *; apply RmaxLess1.
  assert (H2 := even_odd_cor N).
  elim H2; intros N0 H3.
  elim H3; intro.
  apply Rle_trans with (/ INR (fact n0) * / INR (fact (N - n0))).
  do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_Rinv.
  apply INR_fact_lt_0.
  apply INR_fact_lt_0.
  apply le_INR.
  apply fact_le.
  apply le_n_Sn.
  replace (/ INR (fact n0) * / INR (fact (N - n0))) with
  (C N n0 / INR (fact N)).
  pattern N at 1 in |- *; rewrite H4.
  apply Rle_trans with (C N N0 / INR (fact N)).
  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite H4.
  apply C_maj.
  rewrite <- H4; apply le_trans with (pred (N - n)).
  apply 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).
  apply H0.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))).
  rewrite H4; rewrite div2_S_double; right; reflexivity.
  unfold Rsqr, C, Rdiv in |- *.
  repeat rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (INR (fact N))).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; replace (N - N0)%nat with N0.
  ring.
  replace N with (N0 + N0)%nat.
  symmetry  in |- *; apply minus_plus.
  rewrite H4.
  ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  unfold C, Rdiv in |- *.
  rewrite (Rmult_comm (INR (fact N))).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rinv_mult_distr.
  rewrite Rmult_1_r; ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with
  (C (S N) (S n0) / INR (fact (S N))).
  apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))).
  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  cut (S N = (2 * S N0)%nat).
  intro; rewrite H5; apply C_maj.
  rewrite <- H5; apply le_n_S.
  apply le_trans with (pred (N - n)).
  apply 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).
  apply H0.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  rewrite H4; ring.
  cut (S N = (2 * S N0)%nat).
  intro.
  replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))).
  rewrite H5; rewrite div2_double.
  right; reflexivity.
  unfold Rsqr, C, Rdiv in |- *.
  repeat rewrite Rinv_mult_distr.
  replace (S N - S N0)%nat with (S N0).
  rewrite (Rmult_comm (INR (fact (S N)))).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; reflexivity.
  apply INR_fact_neq_0.
  replace (S N) with (S N0 + S N0)%nat.
  symmetry  in |- *; apply minus_plus.
  rewrite H5; ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite H4; ring.
  unfold C, Rdiv in |- *.
  rewrite (Rmult_comm (INR (fact (S N)))).
  rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rinv_mult_distr.
  reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  unfold maj_Reste_E in |- *.
  unfold Rdiv in |- *; rewrite (Rmult_comm 4).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR (N - k) * / Rsqr (INR (fact (div2 (S N)))))
      (pred N)).
  apply sum_Rle; intros.
  rewrite sum_cte.
  replace (S (pred (N - n))) with (N - n)%nat.
  right; apply Rmult_comm.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N * / Rsqr (INR (fact (div2 (S N))))) (pred N)).
  apply sum_Rle; intros.
  do 2 rewrite <- (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt.
  apply INR_fact_neq_0.
  apply le_INR.
  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).
  apply H0.
  apply le_pred_n.
  rewrite sum_cte; replace (S (pred N)) with N.
  cut (div2 (S N) = S (div2 (pred N))).
  intro; rewrite H0.
  rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR; rewrite Rsqr_mult.
  rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (INR N)); repeat rewrite Rmult_assoc;
    apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
  rewrite <- H0.
  cut (INR N <= INR (2 * div2 (S N))).
  intro; apply Rmult_le_reg_l with (Rsqr (INR (div2 (S N)))).
  apply Rsqr_pos_lt.
  apply not_O_INR; red in |- *; intro.
  cut (1 < S N)%nat.
  intro; assert (H4 := div2_not_R0 _ H3).
  rewrite H2 in H4; elim (lt_n_O _ H4).
  apply lt_n_S; apply H.
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ].
  rewrite Rmult_assoc.
  rewrite Rmult_comm.
  replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
  rewrite <- Rsqr_mult.
  apply Rsqr_incr_1.
  replace 2 with (INR 2).
  rewrite <- mult_INR; apply H1.
  reflexivity.
  left; apply lt_INR_0; apply H.
  left; apply Rmult_lt_0_compat.
  prove_sup0.
  apply lt_INR_0; apply div2_not_R0.
  apply lt_n_S; apply H.
  cut (1 < S N)%nat.
  intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro;
    assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4;
      elim (lt_n_O _ H4).
  apply lt_n_S; apply H.
  assert (H1 := even_odd_cor N).
  elim H1; intros N0 H2.
  elim H2; intro.
  pattern N at 2 in |- *; rewrite H3.
  rewrite div2_S_double.
  right; rewrite H3; reflexivity.
  pattern N at 2 in |- *; rewrite H3.
  replace (S (S (2 * N0))) with (2 * S N0)%nat.
  rewrite div2_double.
  rewrite H3.
  rewrite S_INR; do 2 rewrite mult_INR.
  rewrite (S_INR N0).
  rewrite Rmult_plus_distr_l.
  apply Rplus_le_compat_l.
  rewrite Rmult_1_r.
  simpl in |- *.
  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
    apply Rlt_0_1.
  ring.
  unfold Rsqr in |- *; apply prod_neq_R0; apply INR_fact_neq_0.
  unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; discriminate.
  assert (H0 := even_odd_cor N).
  elim H0; intros N0 H1.
  elim H1; intro.
  cut (0 < N0)%nat.
  intro; rewrite H2.
  rewrite div2_S_double.
  replace (2 * N0)%nat with (S (S (2 * pred N0))).
  replace (pred (S (S (2 * pred N0)))) with (S (2 * pred N0)).
  rewrite div2_S_double.
  apply S_pred with 0%nat; apply H3.
  reflexivity.
  omega.
  omega.
  rewrite H2.
  replace (pred (S (2 * N0))) with (2 * N0)%nat; [ idtac | reflexivity ].
  replace (S (S (2 * N0))) with (2 * S N0)%nat.
  do 2 rewrite div2_double.
  reflexivity.
  ring.
  apply S_pred with 0%nat; apply H.
Qed.

Lemma maj_Reste_cv_R0 : forall x y:R, Un_cv (maj_Reste_E x y) 0.
Proof.
  intros; assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold Un_cv in |- *; intros.
  cut (0 < eps / 4);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H _ H1); intros N0 H2.
  exists (max (2 * S N0) 2); intros.
  unfold R_dist in H2; unfold R_dist in |- *; rewrite Rminus_0_r;
    unfold Majxy in H2; unfold maj_Reste_E in |- *.
  rewrite Rabs_right.
  apply Rle_lt_trans with
    (4 *
      (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
        INR (fact (div2 (pred n))))).
  apply Rmult_le_compat_l.
  left; prove_sup0.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)));
    rewrite
      (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n)))))
      ; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)).
  rewrite Rmult_comm;
    pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2 in |- *;
      rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
  apply pow_le; apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  apply Rmult_le_reg_l with (INR (fact (div2 (pred n)))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
  replace 1 with (INR 1); [ apply le_INR | reflexivity ].
  apply lt_le_S.
  apply INR_lt.
  apply INR_fact_lt_0.
  apply INR_fact_neq_0.
  apply Rle_pow.
  apply RmaxLess1.
  assert (H4 := even_odd_cor n).
  elim H4; intros N1 H5.
  elim H5; intro.
  cut (0 < N1)%nat.
  intro.
  rewrite H6.
  replace (pred (2 * N1)) with (S (2 * pred N1)).
  rewrite div2_S_double.
  omega.
  omega.
  assert (0 < n)%nat.
  apply lt_le_trans with 2%nat.
  apply lt_O_Sn.
  apply le_trans with (max (2 * S N0) 2).
  apply le_max_r.
  apply H3.
  omega.
  rewrite H6.
  replace (pred (S (2 * N1))) with (2 * N1)%nat.
  rewrite div2_double.
  replace (4 * S N1)%nat with (2 * (2 * S N1))%nat.
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * S N1)%nat with (S (S (2 * N1))).
  apply le_n_Sn.
  ring.
  ring.
  reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply Rmult_lt_reg_l with (/ 4).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite Rmult_comm.
  replace
  (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
    INR (fact (div2 (pred n)))) with
  (Rabs
    (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
      INR (fact (div2 (pred n))) - 0)).
  apply H2; unfold ge in |- *.
  cut (2 * S N0 <= n)%nat.
  intro; apply le_S_n.
  apply INR_le; apply Rmult_le_reg_l with (INR 2).
  simpl in |- *; prove_sup0.
  do 2 rewrite <- mult_INR; apply le_INR.
  apply le_trans with n.
  apply H4.
  assert (H5 := even_odd_cor n).
  elim H5; intros N1 H6.
  elim H6; intro.
  cut (0 < N1)%nat.
  intro.
  rewrite H7.
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (pred (2 * N1)) with (S (2 * pred N1)).
  rewrite div2_S_double.
  replace (S (pred N1)) with N1.
  apply le_n.
  apply S_pred with 0%nat; apply H8.
  replace (2 * N1)%nat with (S (S (2 * pred N1))).
  reflexivity.
  pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
  ring.
  symmetry  in |- *; apply S_pred with 0%nat; apply H8.
  apply INR_lt.
  apply Rmult_lt_reg_l with (INR 2).
  simpl in |- *; prove_sup0.
  rewrite Rmult_0_r; rewrite <- mult_INR.
  apply lt_INR_0.
  rewrite <- H7.
  apply lt_le_trans with 2%nat.
  apply lt_O_Sn.
  apply le_trans with (max (2 * S N0) 2).
  apply le_max_r.
  apply H3.
  rewrite H7.
  replace (pred (S (2 * N1))) with (2 * N1)%nat.
  rewrite div2_double.
  replace (2 * S N1)%nat with (S (S (2 * N1))).
  apply le_n_Sn.
  ring.
  reflexivity.
  apply le_trans with (max (2 * S N0) 2).
  apply le_max_l.
  apply H3.
  rewrite Rminus_0_r; apply Rabs_right.
  apply Rle_ge.
  unfold Rdiv in |- *; repeat 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.
  discrR.
  apply Rle_ge.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  left; prove_sup0.
  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 Rsqr_pos_lt; apply INR_fact_neq_0.
Qed.

(**********)
Lemma Reste_E_cv : forall x y:R, Un_cv (Reste_E x y) 0.
Proof.
  intros; assert (H := maj_Reste_cv_R0 x y).
  unfold Un_cv in H; unfold Un_cv in |- *; intros; elim (H _ H0); intros.
  exists (max x0 1); intros.
  unfold R_dist in |- *; rewrite Rminus_0_r.
  apply Rle_lt_trans with (maj_Reste_E x y n).
  apply Reste_E_maj.
  apply lt_le_trans with 1%nat.
  apply lt_O_Sn.
  apply le_trans with (max x0 1).
  apply le_max_r.
  apply H2.
  replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) 0).
  apply H1.
  unfold ge in |- *; apply le_trans with (max x0 1).
  apply le_max_l.
  apply H2.
  unfold R_dist in |- *; rewrite Rminus_0_r; apply Rabs_right.
  apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)).
  apply Rabs_pos.
  apply Reste_E_maj.
  apply lt_le_trans with 1%nat.
  apply lt_O_Sn.
  apply le_trans with (max x0 1).
  apply le_max_r.
  apply H2.
Qed.

(**********)
Lemma exp_plus : forall x y:R, exp (x + y) = exp x * exp y.
Proof.
  intros; assert (H0 := E1_cvg x).
  assert (H := E1_cvg y).
  assert (H1 := E1_cvg (x + y)).
  eapply UL_sequence.
  apply H1.
  assert (H2 := CV_mult _ _ _ _ H0 H).
  assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)).
  unfold Un_cv in |- *; unfold Un_cv in H3; intros.
  elim (H3 _ H4); intros.
  exists (S x0); intros.
  rewrite <- (exp_form x y n).
  rewrite Rminus_0_r in H5.
  apply H5.
  unfold ge in |- *; apply le_trans with (S x0).
  apply le_n_Sn.
  apply H6.
  apply lt_le_trans with (S x0).
  apply lt_O_Sn.
  apply H6.
Qed.

(**********)
Lemma exp_pos_pos : forall x:R, 0 < x -> 0 < exp x.
Proof.
  intros; set (An := fun N:nat => / INR (fact N) * x ^ N).
  cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)).
  intro; apply Rlt_le_trans with (sum_f_R0 An 0).
  unfold An in |- *; simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r;
    apply Rlt_0_1.
  apply sum_incr.
  assumption.
  intro; unfold An in |- *; left; apply Rmult_lt_0_compat.
  apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply (pow_lt _ n H).
  unfold exp in |- *; unfold projT1 in |- *; case (exist_exp x); intro.
  unfold exp_in in |- *; unfold infinite_sum, Un_cv in |- *; trivial.
Qed.

(**********)
Lemma exp_pos : forall x:R, 0 < exp x.
Proof.
  intro; case (total_order_T 0 x); intro.
  elim s; intro.
  apply (exp_pos_pos _ a).
  rewrite <- b; rewrite exp_0; apply Rlt_0_1.
  replace (exp x) with (1 / exp (- x)).
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply Rlt_0_1.
  apply Rinv_0_lt_compat; apply exp_pos_pos.
  apply (Ropp_0_gt_lt_contravar _ r).
  cut (exp (- x) <> 0).
  intro; unfold Rdiv in |- *; apply Rmult_eq_reg_l with (exp (- x)).
  rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
  rewrite <- exp_plus.
  rewrite Rplus_opp_l; rewrite exp_0; reflexivity.
  apply H.
  apply H.
  assert (H := exp_plus x (- x)).
  rewrite Rplus_opp_r in H; rewrite exp_0 in H.
  red in |- *; intro; rewrite H0 in H.
  rewrite Rmult_0_r in H.
  elim R1_neq_R0; assumption.
Qed.

(* ((exp h)-1)/h -> 0 quand h->0 *)
Lemma derivable_pt_lim_exp_0 : derivable_pt_lim exp 0 1.
Proof.
  unfold derivable_pt_lim in |- *; intros.
  set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))).
  cut (CVN_R fn).
  intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }).
  intro cv; cut (forall n:nat, continuity (fn n)).
  intro; cut (continuity (SFL fn cv)).
  intro; unfold continuity in H1.
  assert (H2 := H1 0).
  unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
    unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
  elim (H2 _ H); intros alp H3.
  elim H3; intros.
  exists (mkposreal _ H4); intros.
  rewrite Rplus_0_l; rewrite exp_0.
  replace ((exp h - 1) / h) with (SFL fn cv h).
  replace 1 with (SFL fn cv 0).
  apply H5.
  split.
  unfold D_x, no_cond in |- *; split.
  trivial.
  apply (sym_not_eq H6).
  rewrite Rminus_0_r; apply H7.
  unfold SFL in |- *.
  case (cv 0); intros.
  eapply UL_sequence.
  apply u.
  unfold Un_cv, SP in |- *.
  intros; exists 1%nat; intros.
  unfold R_dist in |- *; rewrite decomp_sum.
  rewrite (Rplus_comm (fn 0%nat 0)).
  replace (fn 0%nat 0) with 1.
  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r;
    rewrite Rplus_0_r.
  replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0.
  rewrite Rabs_R0; apply H8.
  symmetry  in |- *; apply sum_eq_R0; intros.
  unfold fn in |- *.
  simpl in |- *.
  unfold Rdiv in |- *; do 2 rewrite Rmult_0_l; reflexivity.
  unfold fn in |- *; simpl in |- *.
  unfold Rdiv in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
  apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
  unfold SFL, exp in |- *.
  case (cv h); case (exist_exp h); simpl; intros.
  eapply UL_sequence.
  apply u.
  unfold Un_cv in |- *; intros.
  unfold exp_in in e.
  unfold infinite_sum in e.
  cut (0 < eps0 * Rabs h).
  intro; elim (e _ H9); intros N0 H10.
  exists N0; intros.
  unfold R_dist in |- *.
  apply Rmult_lt_reg_l with (Rabs h).
  apply Rabs_pos_lt; assumption.
  rewrite <- Rabs_mult.
  rewrite Rmult_minus_distr_l.
  replace (h * ((x - 1) / h)) with (x - 1).
  unfold R_dist in H10.
  replace (h * SP fn n h - (x - 1)) with
  (sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x).
  rewrite (Rmult_comm (Rabs h)).
  apply H10.
  unfold ge in |- *.
  apply le_trans with (S N0).
  apply le_n_Sn.
  apply le_n_S; apply H11.
  rewrite decomp_sum.
  replace (/ INR (fact 0) * h ^ 0) with 1.
  unfold Rminus in |- *.
  rewrite Ropp_plus_distr.
  rewrite Ropp_involutive.
  rewrite <- (Rplus_comm (- x)).
  rewrite <- (Rplus_comm (- x + 1)).
  rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l.
  replace (pred (S n)) with n; [ idtac | reflexivity ].
  unfold SP in |- *.
  rewrite scal_sum.
  apply sum_eq; intros.
  unfold fn in |- *.
  replace (h ^ S i) with (h * h ^ i).
  unfold Rdiv in |- *; ring.
  simpl in |- *; ring.
  simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
  apply lt_O_Sn.
  unfold Rdiv in |- *.
  rewrite <- Rmult_assoc.
  symmetry  in |- *; apply Rinv_r_simpl_m.
  assumption.
  apply Rmult_lt_0_compat.
  apply H8.
  apply Rabs_pos_lt; assumption.
  apply SFL_continuity; assumption.
  intro; unfold fn in |- *.
  replace (fun x:R => x ^ n / INR (fact (S n))) with
  (pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ].
  apply continuity_div.
  apply derivable_continuous; apply (derivable_pow n).
  apply derivable_continuous; apply derivable_const.
  intro; unfold fct_cte in |- *; apply INR_fact_neq_0.
  apply (CVN_R_CVS _ X).
  assert (H0 := Alembert_exp).
  unfold CVN_R in |- *.
  intro; unfold CVN_r in |- *.
  exists (fun N:nat => r ^ N / INR (fact (S N))).
  cut
    { l:R |
        Un_cv
        (fun n:nat =>
          sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l }.
  intro X.
  elim X; intros.
  exists x; intros.
  split.
  apply p.
  unfold Boule in |- *; intros.
  rewrite Rminus_0_r in H1.
  unfold fn in |- *.
  unfold Rdiv in |- *; rewrite Rabs_mult.
  cut (0 < INR (fact (S n))).
  intro.
  rewrite (Rabs_right (/ INR (fact (S n)))).
  do 2 rewrite <- (Rmult_comm (/ INR (fact (S n)))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply H2.
  rewrite <- RPow_abs.
  apply pow_maj_Rabs.
  rewrite Rabs_Rabsolu; left; apply H1.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply H2.
  apply INR_fact_lt_0.
  cut ((r:R) <> 0).
  intro; apply Alembert_C2.
  intro; apply Rabs_no_R0.
  unfold Rdiv in |- *; apply prod_neq_R0.
  apply pow_nonzero; assumption.
  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
  unfold Un_cv in H0.
  unfold Un_cv in |- *; intros.
  cut (0 < eps0 / r);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ].
  elim (H0 _ H3); intros N0 H4.
  exists N0; intros.
  cut (S n >= N0)%nat.
  intro hyp_sn.
  assert (H6 := H4 _ hyp_sn).
  unfold R_dist in H6; rewrite Rminus_0_r in H6.
  rewrite Rabs_Rabsolu in H6.
  unfold R_dist in |- *; rewrite Rminus_0_r.
  rewrite Rabs_Rabsolu.
  replace
  (Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n))))
    with (r * / INR (fact (S (S n))) * / / INR (fact (S n))).
  rewrite Rmult_assoc; rewrite Rabs_mult.
  rewrite (Rabs_right r).
  apply Rmult_lt_reg_l with (/ r).
  apply Rinv_0_lt_compat; apply (cond_pos r).
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps0).
  apply H6.
  assumption.
  apply Rle_ge; left; apply (cond_pos r).
  unfold Rdiv in |- *.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv.
  rewrite Rinv_mult_distr.
  repeat rewrite Rabs_right.
  rewrite Rinv_involutive.
  rewrite (Rmult_comm r).
  rewrite (Rmult_comm (r ^ S n)).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite (Rmult_comm r).
  rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))).
  apply Rmult_eq_compat_l.
  simpl in |- *.
  rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  ring.
  apply pow_nonzero; assumption.
  apply INR_fact_neq_0.
  apply Rle_ge; left; apply INR_fact_lt_0.
  apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
  apply Rle_ge; left; apply INR_fact_lt_0.
  apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
  apply Rabs_no_R0; apply pow_nonzero; assumption.
  apply Rinv_neq_0_compat; apply Rabs_no_R0; apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  unfold ge in |- *; apply le_trans with n.
  apply H5.
  apply le_n_Sn.
  assert (H1 := cond_pos r); red in |- *; intro; rewrite H2 in H1;
    elim (Rlt_irrefl _ H1).
Qed.

(**********)
Lemma derivable_pt_lim_exp : forall x:R, derivable_pt_lim exp x (exp x).
Proof.
  intro; assert (H0 := derivable_pt_lim_exp_0).
  unfold derivable_pt_lim in H0; unfold derivable_pt_lim in |- *; intros.
  cut (0 < eps / exp x);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ].
  elim (H0 _ H1); intros del H2.
  exists del; intros.
  assert (H5 := H2 _ H3 H4).
  rewrite Rplus_0_l in H5; rewrite exp_0 in H5.
  replace ((exp (x + h) - exp x) / h - exp x) with
  (exp x * ((exp h - 1) / h - 1)).
  rewrite Rabs_mult; rewrite (Rabs_right (exp x)).
  apply Rmult_lt_reg_l with (/ exp x).
  apply Rinv_0_lt_compat; apply exp_pos.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
  apply H5.
  assert (H6 := exp_pos x); red in |- *; intro; rewrite H7 in H6;
    elim (Rlt_irrefl _ H6).
  apply Rle_ge; left; apply exp_pos.
  rewrite Rmult_minus_distr_l.
  rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
    rewrite Rmult_minus_distr_l.
  rewrite Rmult_1_r; rewrite exp_plus; reflexivity.
Qed.


Require Import Program.Basics Program.Tactics.
Require Import Equations.Equations.
Require Import Coq.Vectors.VectorDef.
Require Import List.
Import ListNotations.
Set Equations Transparent.

Derive Signature NoConfusion NoConfusionHom for t.

Inductive Ty : Set :=
| unit : Ty
| arrow (t u : Ty) : Ty.

Derive NoConfusion for Ty.

Infix "⇒" := arrow (at level 80).

Definition Ctx := list Ty.

Reserved Notation " x ∈ s " (at level 70, s at level 10).

Inductive In {A} (x : A) : list A -> Type :=
| here {xs} : x ∈ (x :: xs)
| there {y xs} : x ∈ xs -> x ∈ (y :: xs)
where " x ∈ s " := (In x s).

Arguments here {A x xs}.
Arguments there {A x y xs} _.

Inductive Expr : Ctx -> Ty -> Set :=
| tt {Γ} : Expr Γ unit
| var {Γ} {t} : In t Γ -> Expr Γ t
| abs {Γ} {t u} : Expr (t :: Γ) u -> Expr Γ (t ⇒ u)
| app {Γ} {t u} : Expr Γ (t ⇒ u) -> Expr Γ t -> Expr Γ u.

Derive Signature NoConfusion NoConfusionHom for Expr.

Inductive All {A} (P : A -> Type) : list A -> Type :=
| all_nil : All P []
| all_cons {x xs} : P x -> All P xs -> All P (x :: xs).
Arguments all_nil {A} {P}.
Arguments all_cons {A P x xs} _ _.
Derive Signature NoConfusion NoConfusionHom for All.

Section MapAll.
  Context  {A} {P Q : A -> Type} (f : forall x, P x -> Q x).

  Equations map_all {l : list A} : All P l -> All Q l :=
  map_all all_nil := all_nil;
  map_all (all_cons p ps) := all_cons (f _ p) (map_all ps).
End MapAll.

Inductive Val : Ty -> Set :=
| val_unit : Val unit
| val_closure {Γ t u} : Expr (t :: Γ) u -> All Val Γ -> Val (t ⇒ u).

Derive Signature NoConfusion NoConfusionHom for Val.

Definition Env (Γ : Ctx) : Set := All Val Γ.

Equations lookup : forall {A P xs} {x : A}, All P xs -> x ∈ xs -> P x :=
  lookup (all_cons p _) here := p;
  lookup (all_cons _ ps) (there ins) := lookup ps ins.

Equations update : forall {A P xs} {x : A}, All P xs -> x ∈ xs -> P x -> All P xs :=
  update (all_cons p ps) here        p' := all_cons p' ps;
  update (all_cons p ps) (there ins) p' := all_cons p (update ps ins p').

Equations M : Ctx -> Type -> Type :=
  M Γ A := Env Γ -> option A.

Require Import Utf8.

Equations bind : ∀ {Γ A B}, M Γ A → (A → M Γ B) → M Γ B :=
  bind m f γ := match m γ with
              | None => None
              | Some x => f x γ
              end.
Infix ">>=" := bind (at level 20, left associativity).

Equations ret : ∀ {Γ A}, A → M Γ A :=
  ret a γ := Some a.

Equations getEnv : ∀ {Γ}, M Γ (Env Γ) :=
  getEnv γ := Some γ.

Equations usingEnv : ∀ {Γ Γ' A}, Env Γ → M Γ A → M Γ' A :=
  usingEnv γ m γ' := m γ.

Equations timeout : ∀ {Γ A}, M Γ A :=
  timeout _ := None.

Equations eval : ∀ (n : nat) {Γ t} (e : Expr Γ t), M Γ (Val t) :=
  eval 0 _               := timeout;
  eval (S k) tt          := ret val_unit;
  eval (S k) (var x)     := getEnv >>= fun E => ret (lookup E x);
  eval (S k) (abs be)    := getEnv >>= fun E => ret (val_closure be E);
  eval (S k) (app fe xe) :=
    eval k fe >>= λ{ | val_closure be E =>
    eval k xe >>= fun xv =>
   usingEnv (all_cons xv E) (eval k be)}.

Inductive eval_sem {Γ : Ctx} {env : Env Γ} : forall {t : Ty}, Expr Γ t -> Val t -> Prop :=
| eval_tt (e : Expr Γ unit) : eval_sem e val_unit
| eval_var t (i : t ∈ Γ) : eval_sem (var i) (lookup env i)
| eval_abs {t u} (b : Expr (t :: Γ) u) : eval_sem (abs b) (val_closure b env)
| eval_app
    {xt bt Γ' env'}
    (fe : Expr Γ (xt ⇒ bt))
    (be : Expr (xt :: Γ') bt) bv
    (xe : Expr Γ xt) xv :
    eval_sem fe (val_closure be env') ->
    eval_sem xe xv ->
    @eval_sem (xt :: Γ') (all_cons xv env') _ be bv ->
    eval_sem (app fe xe) bv.

Lemma eval_correct {n} Γ t (e : Expr Γ t) env v : eval n e env = Some v -> @eval_sem _ env _ e v.
Proof.
  pose proof (fun_elim (f:=eval)) as H.
  specialize (H (fun n Γ t e m => forall env v, m env = Some v -> @eval_sem _ env _ e v)
                (fun n Γ t u f a v m => forall env v',
                     @eval_sem _ env _ f v -> m env = Some v' -> @eval_sem _ env _ (app f a) v')).
  - rapply H; clear; intros.
  + discriminate.
  + noconf H; constructor.
  + noconf H; constructor.
  + noconf H; constructor.
  + unfold bind in H1.
    destruct (eval n e0 env) eqn:Heq; try discriminate.
    specialize (H _ _ Heq).
    specialize (H0 v0 _ _ H H1).
    apply H0.
  + unfold bind in H2.
    destruct (eval k xe env) eqn:Heq; try discriminate.
    unfold usingEnv in H2.
    specialize (H _ _ Heq).
    specialize (H0 v (all_cons v a) v').
    econstructor; eauto.
Qed.


Require Export prosa.model.aggregate.workload.
Require Export prosa.analysis.facts.behavior.arrivals.

(** * Lemmas about Workload of Sets of Jobs *)
(** In this file, we establish basic facts about the workload of sets of jobs. *)
Section WorkloadFacts.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any job arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** For simplicity, let's define a local name. *)
  Let arrivals_between := arrivals_between arr_seq.

  (** We prove that workload can be split into two parts. *)
  Lemma workload_of_jobs_cat:
    forall t t1 t2 P,
      t1 <= t <= t2 ->
      workload_of_jobs P (arrivals_between t1 t2) =
      workload_of_jobs P (arrivals_between t1 t)
      + workload_of_jobs P (arrivals_between t t2).
  Proof.
    move => t t1 t2 P /andP [GE LE].
    rewrite /workload_of_jobs /arrivals_between.
      by rewrite (arrivals_between_cat _ _ t) // big_cat.
  Qed.

End WorkloadFacts.


Require Import DBCircuits.
Require Import TypeChecking.
Require Import Denotation.
Require Import Composition.

(*************************)
(* Assertion Correctness *)
(*************************)

Inductive not_assert : forall {W1 W2} (g : Gate W1 W2), Prop :=
  | na_U       : forall W u, not_assert (@U W u)
  | na_NOT     : not_assert BNOT
  | na_init0   : not_assert init0
  | na_init1   : not_assert init1
  | na_new0    : not_assert new0
  | na_new1    : not_assert new1
  | na_meas    : not_assert meas
  | na_discard : not_assert discard.

Inductive ancilla_free {W} : Circuit W -> Prop :=
  | af_output : forall p, ancilla_free (output p)
  | af_gate : forall W1 W2 (g : Gate W1 W2) p c',
                        not_assert g ->
                        (forall p, ancilla_free (c' p)) ->
                        ancilla_free (gate g p c')
  | af_lift : forall p c, (forall b, ancilla_free (c b)) ->
                     ancilla_free (lift p c).

Inductive ancilla_free_box {W1 W2} : Box W1 W2 -> Prop :=
  | af_box : forall c, (forall p, ancilla_free (c p)) -> ancilla_free_box (box c).

Definition valid_ancillae {W} (c : Circuit W) : Prop := forall (Γ Γ0 : Ctx),
  (* Γ' == Γ0 ∙ Γ -> *) (* necessary? *)
  Γ ⊢ c:Circ -> (* <- is this right? *)
  ⟨ Γ0 | Γ ⊩ c ⟩ = ⟨! Γ0 | Γ ⊩ c !⟩.

Definition valid_ancillae_box {W1 W2} (c : Box W1 W2) :=
  Typed_Box c -> (* why are we including typing judgments? *)
  denote_box true c = denote_box false c.

Definition valid_ancillae' {W} (c : Circuit W) := forall (Γ Γ0 : Ctx) ρ,
  Γ ⊢ c:Circ -> (* <- is this right? *)
  Mixed_State ρ ->
  trace (⟨! Γ0 | Γ ⊩ c !⟩ ρ) = 1.

Definition valid_ancillae_box' {W1 W2} (c : Box W1 W2) : Prop := forall ρ,
  Typed_Box c ->
  Mixed_State ρ ->
  trace (denote_box false c ρ) = 1.

Proposition valid_ancillae_equal : forall W (c : Circuit W),
  valid_ancillae c <-> valid_ancillae' c.
Proof.
  intros.
  unfold valid_ancillae, valid_ancillae'.
  split.
  - intros H Γ Γ0 ρ H0 H1.
    rewrite <- H; trivial.
    apply mixed_state_trace_1.
    (* The following lemma is sufficient:
    apply denote_circuit_correct; easy. *)
    admit.
  - induction c as [| W' W0 g p c IH | IH].
    + reflexivity.
    + intros H Γ Γ0 H'.
      replace (gate g p c) with (HOASCircuits.compose (gate g p (fun p' => output p')) c) by auto.
      dependent destruction H'.
      destruct Γ1 as [|Γ1]; try invalid_contradiction.
      erewrite denote_compose with (Γ1:=[]); trivial.
      Locate ":Fun".
      3:{
        intros Γ3 Γ0' p0 H0 H1.
        destruct H0.
        rewrite merge_nil_r in pf_merge.
        subst.
        apply (t0 Γ3); trivial.
        all: admit. }

(*
      rewrite denote_compose with (Γ1:=Γ); trivial.
      apply f_equal2.
      rewrite (IH (add_fresh_pat W0 Γ)).
      reflexivity.
      intros. apply (H Γ1 Γ2).

      denote_compose.

      unfold denote_circuit in *.

      rewrite H1.

      simpl.
      destruct g.
      * simpl.
        unfold denote_db_circuit.
        simpl.
        reflexivity.
        reflexivity.
        matrix_denote. simpl.

    intros VA.
    unfold valid_ancillae, valid_ancillae'.
    induction c.
    intros Γ Γ0 ρ H H0.

*)

Abort.

Fact valid_ancillae_box_equal : forall W1 W2 (c : Box W1 W2),
  valid_ancillae_box c <-> valid_ancillae_box' c.
Proof.
  intros.
  destruct c.
Admitted.

(* This relationship should be easy to prove.
   Alternatively, we could just define one in terms of the other *)
Fact valid_ancillae_unbox : forall W W' (c : Pat W -> Circuit W'),
  (forall p, valid_ancillae (c p)) <-> valid_ancillae_box (box (fun p => c p)).
Proof.
  intros.
  unfold valid_ancillae, valid_ancillae_box.
  unfold denote_box. unfold denote_circuit.
  unfold denote_db_box.
  unfold hoas_to_db_box.
  split.
  - intros H T.
    specialize (H (add_fresh_pat W []) (add_fresh_state W []) []).
    simpl in *.
    rewrite size_fresh_ctx in H.
    simpl in H.
    unfold add_fresh_state, add_fresh_pat in *.
    destruct (add_fresh W []) as [p Γ] eqn:E.
    simpl in *.
    rewrite H.
    easy.
    unfold Typed_Box in T. simpl in T. apply T.
    (* This should be proven in DBCircuits *)
    admit.
  - intros H p Γ Γ0 T.
    simpl in *.
Admitted.

Proposition valid_ancillae_unbox' : forall W W' (c : Box W W') (p : Pat W),
  valid_ancillae (unbox c p) <-> valid_ancillae_box c.
Proof.
  intros W W' c p.
  unfold valid_ancillae, valid_ancillae_box.
  unfold denote_box.
  unfold denote_db_box.
  destruct c.
  simpl.
  unfold denote_circuit.
  simpl.
  split.
  - intros H.
    admit.
Abort.

Lemma id_correct : forall W p, valid_ancillae (@output W p).
Proof.
  intros W p.
  unfold valid_ancillae.
  reflexivity.
Qed.

Lemma update_merge : forall (Γ Γ' :Ctx) W W' v, Γ' == singleton v W ∙ Γ ->
   Valid (update_at Γ' v (Some W')) == singleton v W' ∙ Γ.
Proof.
  intros Γ Γ' W W' v H.
  generalize dependent Γ.
  generalize dependent Γ'.
  induction v.
  - intros Γ' Γ H.
    simpl in *.
    apply merge_fun_ind in H.
    inversion H; subst.
    simpl.
    constructor.
    apply valid_valid.
    reflexivity.
    inversion H5; subst.
    inversion H4; subst.
    constructor.
    apply valid_valid.
    reflexivity.
    inversion H4; subst.
    constructor.
    apply valid_valid.
    reflexivity.
  - intros Γ' Γ H.
    simpl.
    destruct Γ.
    + destruct H.
      rewrite merge_nil_r in pf_merge. inversion pf_merge.
      simpl.
      edestruct IHv.
      constructor.
      2: rewrite merge_nil_r; easy.
      apply valid_valid.
      rewrite merge_nil_r in pf_merge0.
      inversion pf_merge0.
      constructor.
      apply valid_valid.
      rewrite merge_nil_r.
      easy.
    + destruct H.
      constructor.
      apply valid_valid.
      unlock_merge. simpl in *.
      destruct (merge' (singleton v W) Γ) eqn:E.
      rewrite pf_merge in pf_valid. invalid_contradiction.
      simpl.
      edestruct IHv.
      constructor.
      2: symmetry in E; unlock_merge; apply E.
      apply valid_valid.
      unlock_merge.
      rewrite <- pf_merge0.
      inversion pf_merge.
      simpl.
      easy.
Qed.

Lemma change_type_singleton : forall v W W', change_type v W' (singleton v W) = singleton v W'.
Proof.
  intros v W W'.
  unfold change_type.
  erewrite update_at_singleton.
  reflexivity.
  apply singleton_singleton.
  apply singleton_singleton.
Qed.

Lemma ancilla_free_valid : forall W (c : Circuit W),
                           ancilla_free c ->
                           valid_ancillae c.
Proof.
  intros W c AF.
  induction c.
  + unfold valid_ancillae. reflexivity.
  + assert (forall p : Pat w2, valid_ancillae (c p)) as VA.
      intros p'.
      apply H.
      dependent destruction AF.
      apply H1.
    clear H.
    unfold valid_ancillae in *.
    intros Γ0 Γ1 WT.
    dependent destruction WT.
    destruct Γ as [|Γ], Γ2 as [|Γ2]; try invalid_contradiction.
    erewrite 2 denote_gate_circuit; try apply pf1; try apply t.
    destruct g.
    - simpl. erewrite VA. reflexivity. eapply t0; [apply pf1|apply t].
    - simpl. erewrite VA. reflexivity. eapply t0; [apply pf1|apply t].
    - simpl. erewrite VA. reflexivity.
      eapply t0.
      2: constructor; apply singleton_singleton.
      dependent destruction p.
      dependent destruction t.
      destruct pf1.
      rewrite merge_nil_l in pf_merge. inversion pf_merge. subst.
      unfold process_gate_state. simpl.
      split. validate.
      rewrite merge_comm, merge_singleton_append.
      easy.
    - simpl. erewrite VA. reflexivity.
      eapply t0.
      2: constructor; apply singleton_singleton.
      dependent destruction p.
      dependent destruction t.
      destruct pf1.
      rewrite merge_nil_l in pf_merge. inversion pf_merge. subst.
      unfold process_gate_state. simpl.
      split. validate.
      rewrite merge_comm, merge_singleton_append.
      easy.
    - simpl. erewrite VA. reflexivity.
      eapply t0.
      2: constructor; apply singleton_singleton.
      dependent destruction p.
      dependent destruction t.
      destruct pf1.
      rewrite merge_nil_l in pf_merge. inversion pf_merge. subst.
      unfold process_gate_state. simpl.
      split. validate.
      rewrite merge_comm, merge_singleton_append.
      easy.
    - simpl. erewrite VA. reflexivity.
      eapply t0.
      2: constructor; apply singleton_singleton.
      dependent destruction p.
      dependent destruction t.
      destruct pf1.
      rewrite merge_nil_l in pf_merge. inversion pf_merge. subst.
      unfold process_gate_state. simpl.
      split. validate.
      rewrite merge_comm, merge_singleton_append.
      easy.
    - dependent destruction p.
      dependent destruction t.
      simpl. erewrite VA. reflexivity.
      eapply t0.
      2: constructor; apply singleton_singleton.
      apply singleton_equiv in s; subst.
      unfold process_gate_state. simpl.
      split. validate.
      unfold change_type.
      eapply update_merge.
      apply pf1.
    - simpl. erewrite VA. reflexivity. eapply t0; [apply pf1|apply t].
    - dependent destruction p.
      dependent destruction t.
      simpl. erewrite VA. reflexivity.
      unfold process_gate_state. simpl.
      unfold process_gate_pat. simpl.
      apply singleton_equiv in s. subst.
      erewrite remove_bit_merge'.
      apply trim_types_circ.
      eapply t0.
      2: constructor.
      split. validate. rewrite merge_nil_l. easy.
      easy.
    - dependent destruction AF. inversion H.
    - dependent destruction AF. inversion H.
  + dependent destruction AF.
    assert (forall b, valid_ancillae (c b)) as VA. intros; apply H; apply H0.
    clear H.
    unfold valid_ancillae in *.
    intros Γ Γ0 WT.
    unfold denote_circuit in *.
    simpl in *.
    replace (size_ctx Γ - 1)%nat with (size_ctx (DBCircuits.remove_pat p Γ)).
    erewrite VA.
    erewrite VA.
    reflexivity.
    * dependent destruction WT.
      dependent destruction p.
      dependent destruction t.
      apply singleton_equiv in s. subst.
      destruct Γ2 as [|Γ2]; try invalid_contradiction.
      erewrite remove_bit_merge'.
      apply trim_types_circ.
      apply t0.
      easy.
    * dependent destruction WT.
      dependent destruction p.
      dependent destruction t.
      apply singleton_equiv in s. subst.
      destruct Γ2 as [|Γ2]; try invalid_contradiction.
      erewrite remove_bit_merge'.
      apply trim_types_circ.
      apply t0.
      easy.
    * dependent destruction WT.
      dependent destruction p.
      dependent destruction t.
      apply singleton_equiv in s. subst.
      destruct Γ2 as [|Γ2]; try invalid_contradiction.
      rewrite (remove_bit_pred Γ2 Γ).
      easy.
      easy.
Qed.

Lemma ancilla_free_box_valid : forall W W' (c : Box W W'),
    ancilla_free_box c ->
    valid_ancillae_box c.
Proof.
  intros.
  destruct H.
  apply valid_ancillae_unbox.
  intros p.
  apply ancilla_free_valid.
  apply H.
Qed.

(* ---------------------------------------------*)
(*--------- Tactics for Valid Circuits ---------*)
(* ---------------------------------------------*)

(* It turns out, these generally aren't needed. *)
Lemma valid_denote_true : forall W W' (c : Box W W')
  (ρ : Square (2^(⟦W⟧))) (ρ' : Square (2^(⟦W⟧))) (safe : bool),
  (* typically ancilla_free_box c, but we'll make it general *)
  Typed_Box c ->
  valid_ancillae_box c ->
  denote_box true c ρ = ρ' ->
  denote_box safe c ρ = ρ'.
Proof.
  intros W W' c ρ ρ' safe T H D.
  destruct safe; trivial.
  rewrite <- H; assumption.
Qed.

Lemma valid_denote_false : forall W W' (c : Box W W')
  (ρ : Square (2^(⟦W⟧))) (ρ' : Square (2^(⟦W⟧))) (safe : bool),
  Typed_Box c ->
  valid_ancillae_box c ->
  denote_box false c ρ = ρ' ->
  denote_box safe c ρ = ρ'.
Proof.
  intros W W' c ρ ρ' safe T H D.
  destruct safe; trivial.
  rewrite H; assumption.
Qed.

Ltac case_safe := apply valid_denote_true;
                  try solve [type_check; apply ancilla_free_box_valid; repeat constructor].
Ltac case_unsafe := apply valid_denote_false;
                    try solve [type_check; apply ancilla_free_box_valid; repeat constructor].

(* *)


(** * Dual functor categories *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Category.Dual Functor.Dual NaturalTransformation.Dual.
Require Import Functor.Composition.Core Functor.Identity.
Require Import FunctorCategory.Core.
Require Import Functor.Paths.
Require Import HoTT.Tactics Types.Forall.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

Section opposite.
  Context `{Funext}.

  (** ** Functors [(C → D) ↔ (Cᵒᵖ → Dᵒᵖ)ᵒᵖ] *)
  Definition opposite_functor (C D : PreCategory) : Functor (C -> D) (C^op -> D^op)^op
    := Build_Functor
         (C -> D) ((C^op -> D^op)^op)
         (fun F => F^op)%functor
         (fun _ _ T => T^op)%natural_transformation
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Local Ltac op_t C D :=
    split;
    path_functor;
    repeat (apply path_forall; intro);
    simpl;
    destruct_head NaturalTransformation;
    exact idpath.

  (** ** The above functors are isomorphisms *)
  Definition opposite_functor_law C D
  : opposite_functor C D o (opposite_functor C^op D^op)^op = 1
    /\ (opposite_functor C^op D^op)^op o opposite_functor C D = 1.
  Proof.
    op_t C D.
  Qed.
End opposite.


(************************************************************************)
(*  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        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith.
Local Open Scope Z_scope.

Definition base digits := Zpower 2 (Zpos digits).

Section Carry.

 Variable A : Type.

 Inductive carry :=
  | C0 : A -> carry
  | C1 : A -> carry.

 Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c :=
  match c with
  | C0 x => interp x
  | C1 x => sign*B + interp x
  end.

End Carry.

Section Zn2Z.

 Variable znz : Type.

 (** From a type [znz] representing a cyclic structure Z/nZ,
     we produce a representation of Z/2nZ by pairs of elements of [znz]
     (plus a special case for zero). High half of the new number comes
     first.
 *)

 Inductive zn2z :=
  | W0 : zn2z
  | WW : znz -> znz -> zn2z.

 Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) :=
  match x with
  | W0 => 0
  | WW xh xl => w_to_Z xh * wB + w_to_Z xl
  end.

End Zn2Z.

Implicit Arguments W0 [znz].

(** From a cyclic representation [w], we iterate the [zn2z] construct
    [n] times, gaining the type of binary trees of depth at most [n],
    whose leafs are either W0 (if depth < n) or elements of w
    (if depth = n).
*)

Fixpoint word (w:Type) (n:nat) : Type :=
 match n with
 | O => w
 | S n => zn2z (word w n)
 end.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import Coq.Lists.List.
Require Import PL.DenotationalSemantics.
Require Import PL.HoareLogic.
Require Import compcert.lib.Integers.

Local Open Scope Z.

Import WhileD_Expr WhileD_Cmd AssertionLang
       SimpleSymbEval AssertionSem.

(** 请证明下述关于指称语义以及符号执行关系的结论。*)

(** 提示：相关定义与证明中可能要用到标准库中提供的有关_[Forall]_以及_[String.eqb]_
    的性质。*)

(** _[Forall]_有如下四条重要性质：*)

Check Forall_nil.
Check Forall_cons.
Check Forall_cons_iff.
Check Forall_app.

(** 我们在HoareLogic中引入了两条自定义证明指令，其中_[Forall_decomp H]_用于拆分
    证明前提_[H]_中的_[Forall]_，_[Forall_split]_用于拆分证明结论中的_[Forall]_。

    _[String.eqb]_是标准库中定义的字符串相等比较，它有两条重要性质：*)

Check String.eqb_eq.
Check String.eqb_neq.

(** 我们在HoareLogic中引入了_[string_eqb_case_analysis str1 str2]_这一证明指令，
    可以对_[str1]_与_[str2]_是否相等进行分类讨论。*)

(** **** Exercise **** *)
(** 请证明While+D语言表达式行为的确定性 *)

Definition deterministic (D: prog_state -> int64 -> Prop): Prop :=
  forall (s: prog_state) (i1 i2: int64),
    D s i1 -> D s i2 -> i1 = i2.

(** 下面证明中，我们使用了Coq标准库提供的_[congruence]_指令。_[congruence]_能够
    用于解决可以利用反复_[rewrite]_证明（但其中不能化简）的结论。*)
Lemma const_denote_det: forall n, deterministic (const_denote n).
Proof.
  unfold deterministic, const_denote.
  intros.
  destruct H as [H _], H0 as [H0 _].
  congruence.
Qed.

Lemma var_denote_det: forall x, deterministic (var_denote x).
Proof.
  unfold deterministic, var_denote.
  intros x s i1 i2 Hi1 Hi2.
  congruence.
Qed.

(** 提示：在下面几个引理的证明中，我们使用_[specialize]_证明指令可以大大简化证明。*)
Lemma arith_denote1_det: forall D1 D2 Zfun ifun,
  deterministic D1 ->
  deterministic D2 ->
  deterministic (arith_denote1 Zfun ifun D1 D2).
Proof.
  unfold deterministic, arith_denote1.
  intros.
  destruct H1 as [n1 [n2 [H1n1 [H1n2 [H1i1 _]]]]].
  destruct H2 as [n1' [n2' [H2n1 [H2n2 [H2i2 _]]]]].
  specialize (H s n1 n1' H1n1 H2n1).
  specialize (H0 s n2 n2' H1n2 H2n2).
  congruence.
Qed.

Lemma arith_denote2_det: forall D1 D2 ifun,
  deterministic D1 ->
  deterministic D2 ->
  deterministic (arith_denote2 ifun D1 D2).
Proof.
  unfold deterministic, arith_denote2.
  intros.
  destruct H1 as [n1 [n1' [H1n1 [H1n1' [H1i1 _]]]]].
  destruct H2 as [n2 [n2' [H2n2 [H2n2' [H2i2 _]]]]].
  specialize (H s n1 n2 H1n1 H2n2).
  specialize (H0 s n1' n2' H1n1' H2n2').
  congruence.
Qed.

Lemma cmp_denote_det: forall D1 D2 c,
  deterministic D1 ->
  deterministic D2 ->
  deterministic (cmp_denote c D1 D2).
Proof.
  unfold deterministic, cmp_denote.
  intros.
  destruct H1 as [n1 [n1' [H1n1 [H1n1' H1i1]]]].
  destruct H2 as [n2 [n2' [H2n2 [H2n2' H2i2]]]].
  specialize (H s n1 n2 H1n1 H2n2).
  specialize (H0 s n1' n2' H1n1' H2n2').
  rewrite H in H1i1; rewrite H0 in H1i1.
  congruence.
Qed.

(** 在后续几个关于布尔运算的证明中，经常需要用到零与非零是不相等的这条性质。*)
Lemma sign_zero_not_zero_contradiction: forall i (P: Prop),
  i = Int64.repr 0 ->
  Int64.signed i <> 0 ->
  P.
Proof.
  intros.
  subst i.
  rewrite Int64.signed_repr in H0 by int64_lia.
  congruence.
Qed.

(** 下面这个关于_[and_denote]_的证明就反复使用了上述引理。*)
Lemma and_denote_det: forall D1 D2,
  deterministic D1 ->
  deterministic D2 ->
  deterministic (and_denote D1 D2).
Proof.
  unfold deterministic, and_denote; intros.
  destruct H1 as [ [? ?] | [ [n1 [? [? [? ?] ] ] ] | [n1 [n2 [? [? [? [? ?] ] ] ] ] ] ] ],
           H2 as [ [? ?] | [ [n1' [? [? [? ?] ] ] ] | [n1' [n2' [? [? [? [? ?] ] ] ] ] ] ] ].
  + congruence.
  + congruence.
  + specialize (H _ _ _ H1 H2).
    apply (sign_zero_not_zero_contradiction n1'); auto.
  + congruence.
  + congruence.
  + specialize (H0 _ _ _ H3 H6).
    apply (sign_zero_not_zero_contradiction n2'); auto.
  + specialize (H _ _ _ H1 H2).
    apply (sign_zero_not_zero_contradiction n1); auto.
  + specialize (H0 _ _ _ H3 H7).
    apply (sign_zero_not_zero_contradiction n2); auto.
  + congruence.
Qed.

Lemma or_denote_det: forall D1 D2,
  deterministic D1 ->
  deterministic D2 ->
  deterministic (or_denote D1 D2).
Proof.
  unfold deterministic, or_denote; intros.
  destruct H1 as [[n1 [H1n11 [H1n12 H1n13]]] | [[n1' [H1n1'1 [H1n1'2 [H1n1'3 H1n1'4]]]] | [H11 [H12 H13]]]],
           H2 as [[n2 [H2n21 [H2n22 H2n23]]] | [[n2' [H2n2'1 [H2n2'2 [H2n2'3 H2n2'4]]]] | [H21 [H22 H23]]]].
  - congruence.
  - congruence.
  - specialize (H _ _ _ H1n11 H21).
    apply (sign_zero_not_zero_contradiction n1); auto.
  - congruence.
  - congruence.
  - specialize (H0 _ _ _ H1n1'2 H22).
    apply (sign_zero_not_zero_contradiction n1'); auto.
  - specialize (H _ _ _ H2n21 H11).
    apply (sign_zero_not_zero_contradiction n2); auto.
  - specialize (H0 _ _ _ H2n2'2 H12).
    apply (sign_zero_not_zero_contradiction n2'); auto.
  - congruence.
Qed.

Lemma not_denote_det: forall D,
  deterministic D ->
  deterministic (not_denote D).
Proof.
  unfold deterministic, not_denote; intros.
  destruct H0 as [[n0 [H0n01 [H0n02 H0n03]]] | [H01 H02]],
           H1 as [[n1 [H1n11 [H1n12 H1n13]]] | [H11 H12]].
  - congruence.
  - specialize (H _ _ _ H0n01 H11).
    apply (sign_zero_not_zero_contradiction n0); auto.
  - specialize (H _ _ _ H1n11 H01).
    apply (sign_zero_not_zero_contradiction n1); auto.
  - congruence.
Qed.

Lemma neg_denote_det: forall D,
  deterministic D ->
  deterministic (neg_denote D).
Proof.
  unfold deterministic, neg_denote; intros.
  destruct H0 as [n0 [Hn01 [Hn02 _]]],
           H1 as [n1 [Hn11 [Hn12 _]]].
  specialize (H _ _ _ Hn01 Hn11).
  congruence.
Qed.

Lemma deref_denote_det: forall D,
  deterministic D ->
  deterministic (deref_denote D).
Proof.
  unfold deterministic, deref_denote; intros.
  destruct H0 as [p0 [Hp01 Hp02]],
           H1 as [p1 [Hp11 Hp12]].
  specialize (H _ _ _ Hp01 Hp11).
  rewrite H in Hp02.
  congruence.
Qed.

Lemma eeval_det: forall e, deterministic (eeval e).
Proof.
  intros.
  induction e; simpl.
  + apply const_denote_det.
  + apply var_denote_det.
  + destruct op; simpl.
    - apply or_denote_det; tauto.
    - apply and_denote_det; tauto.
    - apply cmp_denote_det; tauto.
    - apply cmp_denote_det; tauto.
    - apply cmp_denote_det; tauto.
    - apply cmp_denote_det; tauto.
    - apply cmp_denote_det; tauto.
    - apply cmp_denote_det; tauto.
    - apply arith_denote1_det; tauto.
    - apply arith_denote1_det; tauto.
    - apply arith_denote1_det; tauto.
    - apply arith_denote2_det; tauto.
    - apply arith_denote2_det; tauto.
  + destruct op; simpl.
    - apply not_denote_det; tauto.
    - apply neg_denote_det; tauto.
  + apply deref_denote_det; tauto.
Qed.

(** **** Exercise **** *)
(** 请证明我们符号执行中所计算的最强后条件的正确性。*)

(** _[remove_var_lit]_函数表示删除标准形式断言的_[var_part]_中所有关于程序变量
    _[x]_的子句（如果有的话）。*)
Fixpoint remove_var_lit
           (Ps: list vars_literal)
           (x: var_name): list vars_literal :=
  match Ps with
  | nil => nil
  | P :: Ps0 =>
      if String.eqb x P.(lit_var_name)
      then remove_var_lit Ps0 x
      else P :: remove_var_lit Ps0 x
  end.

(** _[insert_var_lit]_函数表示插入一下关于程序变量_[x]_的子句，并删除原有的关于
    _[x]_的子句（如果有的话）。插入的子句会被插入到原先_[x]_第一次出现的位置，如
    果原先的断言与_[x]_无关，那就插入到子句列表尾。*)
Fixpoint insert_var_lit
           (Ps: list vars_literal)
           (x: var_name)
           (a: aexpr): list vars_literal :=
  match Ps with
  | nil =>
      {| lit_var_name := x; lit_var_value := a |} :: nil
  | P :: Ps0 =>
      if String.eqb x P.(lit_var_name)
      then {| lit_var_name := x; lit_var_value := a |} ::
           remove_var_lit Ps0 x
      else P :: insert_var_lit Ps0 x a
  end.

(** 首先证明：如果程序状态_[s]_是对变量_[x]_进行赋值后得到的新程序状态，那么对应
    的新的_[vars_literal]_在程序状态_[s]_上成立。*)
Lemma vars_literal_sat_pos: forall J x a n s,
  aexpr_denote J a = Some n ->
  s x = Int64.repr n ->
  n <= Int64.max_signed ->
  n >= Int64.min_signed ->
  vars_literal_sat
    s
    J
    {| lit_var_name := x; lit_var_value := a |}.
Proof.
  unfold vars_literal_sat; intros; simpl.
  exists n.
  split. tauto.
  split. tauto.
  split. tauto.
  congruence.
Qed.

(** 其次证明：如果程序状态_[s2]_是自程序状态_[s1]_对变量_[x]_进行赋值后得到的新
    程序状态，那么除了与_[x]_有关的情况之外，所有的_[vars_literal]_只要在_[s1]_
    上为真就会在_[s2]_上为真。*)
Lemma vars_literal_sat_unchanged: forall J x (P: vars_literal) s1 s2,
  vars_literal_sat s1 J P ->
  (forall y, x <> y -> s1 y = s2 y) ->
  x <> P.(lit_var_name) ->
  vars_literal_sat s2 J P.
Proof.
  unfold vars_literal_sat; intros.
  destruct H as [n [Hn1 [Hn2 [Hn3 Hn4]]]].
  exists n.
  split. tauto.
  split. tauto.
  split. tauto.
  specialize (H0 P.(lit_var_name) H1).
  congruence.
Qed.

(** 进一步，可以证明_[remove_var_lit]_是正确的。*)
Lemma remove_var_lit_sound: forall Ps x (s1 s2: var_name -> int64) J,
  Forall (vars_literal_sat s1 J) Ps ->
  (forall y, x <> y -> s1 y = s2 y) ->
  Forall (vars_literal_sat s2 J) (remove_var_lit Ps x).
Proof.
  intros.
  induction Ps as [| P Ps0 ?]; simpl.
  - apply Forall_nil.
  - apply Forall_cons_iff in H; destruct H as [? ?].
    string_eqb_case_analysis x P.(lit_var_name).
    + apply IHPs.
      apply H1.
    + apply Forall_cons.
      * revert H H0 H2. apply vars_literal_sat_unchanged.
      * specialize (IHPs H1). tauto.
Qed.

(** 再进一步，可以证明_[insert_var_lit]_是正确的。*)
Lemma insert_var_lit_sound: forall Ps x a n s1 s2 J,
  Forall (vars_literal_sat s1 J) Ps ->
  aexpr_denote J a = Some n ->
  s2 x = Int64.repr n ->
  (forall y, x <> y -> s1 y = s2 y) ->
  n <= Int64.max_signed ->
  n >= Int64.min_signed ->
  Forall (vars_literal_sat s2 J) (insert_var_lit Ps x a).
Proof.
  intros.
  induction Ps as [| P Ps0 ?]; simpl.
  - apply Forall_cons.
    + revert H0 H1 H3 H4. apply vars_literal_sat_pos.
    + apply Forall_nil.
  - apply Forall_cons_iff in H; destruct H as [? ?].
    string_eqb_case_analysis x P.(lit_var_name).
    + apply Forall_cons.
      * revert H0 H1 H3 H4. apply vars_literal_sat_pos.
      * revert H5 H2. apply remove_var_lit_sound.
    + apply Forall_cons.
      * revert H H2 H6. apply vars_literal_sat_unchanged.
      * apply IHPs. apply H5.
Qed.


(** * Renaming substitution
      This file contains the definition of renaming substitution and its lemmas.
      The renaming substitution is essential to the let case of the soundness proof
      of algorithm W.
    *)

Set Implicit Arguments.

Require Import Disjoints.
Require Import Sublist.
Require Import ListIds.
Require Import SimpleTypes.
Require Import Subst.
Require Import MyLtacs.
Require Import Arith.Arith_base List Omega.
Require Import Wellfounded.Lexicographic_Product.
Require Import Relation_Operators.
Require Import Coq.Setoids.Setoid.
Require Import LibTactics.

(** * Renaming substitution definition *)
Definition ren_subst := list (id * id).

(** ** Renaming substitution projections *)
Definition dom_ren (rho : ren_subst) : list id := List.map (@fst id id) rho.
Definition img_ren (rho : ren_subst) : list id := List.map (@snd id id) rho.

(** ** Renaming substitution application *)
Fixpoint apply_ren_subst (s : ren_subst) (t : id) : id :=
  match s with
    | nil => t
    | (i,j) :: s' => if eq_id_dec i t then j else apply_ren_subst s' t
  end.

(** Inductive definition that asserts that a given [ren_subst] is realy a renaming. *)
Inductive is_rename_subst : ren_subst ->  Prop :=
| is_rename_intro : forall r, (are_disjoints (dom_ren r) (img_ren r)) ->
                         (forall (x y: id),
                             (in_list_id x (dom_ren r)) = true ->
                             (in_list_id y (dom_ren r)) = true ->
                             x <> y -> (apply_ren_subst r x) <> (apply_ren_subst r y)) ->
                         is_rename_subst r.

(** * Several lemmas about the renaming substitution *)

Lemma nil_is_rename_subst : is_rename_subst nil.
Proof.
  econstructor.
  intro. intros.
  simpl in H. inversion H.
  intros.
  simpl.
  destruct H.
  destruct H0.
  assumption.
Qed.

Lemma dom_ren_simpl : forall rho i j, dom_ren ((i, j)::rho) = i::dom_ren rho.
Proof.
  reflexivity.
Qed.

Lemma img_ren_simpl : forall rho i j, img_ren ((i, j)::rho) = j::img_ren rho.
Proof.
  reflexivity.
Qed.

Inductive renaming_of_not_concerned_with:
  (ren_subst) -> (list id) -> (list id) -> (list id) -> Prop :=
| renaming_of_not_concerned_with_intro : forall (r:ren_subst) (l l1 l2: (list id)),
    (is_rename_subst r) ->
    (dom_ren r) = l ->
    (are_disjoints l1 (img_ren r)) ->
    (are_disjoints l2 (img_ren r)) ->
    (renaming_of_not_concerned_with r l l1 l2).

Lemma dom_img_rename_subst: forall r s,
    (in_list_id s (dom_ren r))=true -> {y: id | (in_list_id y (img_ren r))=true /\
                                               (apply_ren_subst r s) = y}.
Proof.
  intros.
  induction r.
  - simpl in H. inversion H.
  - destruct a.
    simpl in H. simpl.
    destruct (eq_id_dec i s).
    + exists i0.
      destruct (eq_id_dec i0 i0); intuition.
    + apply IHr in H.
      destruct H.
      exists x.
      destruct (eq_id_dec i0 x); intuition.
Qed.

Hint Resolve dom_img_rename_subst:core.

(** Finding this special renaming substitution is an essential step in the let case of the soundness proof*)
Definition compute_renaming : forall (i : id) (l l1 l2 : list id),
    (forall x, in_list_id x l = true -> x < i) -> (forall x, in_list_id x l1 = true -> x < i) ->
    (forall x, in_list_id x l2 = true -> x < i) ->
    {rho : ren_subst | is_rename_subst rho /\
                       dom_ren rho = l /\ (forall y, in_list_id y (img_ren rho) = true -> i <= y) /\
                       (forall x, in_list_id x (dom_ren rho) = true -> x < i) /\
                       are_disjoints l1 (img_ren rho) /\
                       are_disjoints l2 (img_ren rho)}.
  refine (fix compute_renaming i l l1 l2 p p1 p2 :
            {rho : ren_subst | is_rename_subst rho /\ dom_ren rho = l /\
                               (forall y, in_list_id y (img_ren rho) = true -> i <= y) /\
                               (forall x, in_list_id x (dom_ren rho) = true -> x < i) /\
                               are_disjoints l1 (img_ren rho) /\
                               are_disjoints l2 (img_ren rho)} :=
            match l as y return l = y -> _ with
            | nil => fun _ => exist _ nil _
            | p::l' => fun H => match (compute_renaming (S i) l' l1 l2 _ _ _) with
                            | exist _ rl H => exist _ ((p, i)::rl) _
                            end
            end _); try clear compute_renaming.
  - split.
    + apply nil_is_rename_subst.
    + split.
      * subst. reflexivity.
      * simpl. repeat split; intros; inversion H.
  - subst. intros. eapply Nat.lt_lt_succ_r in p0.
    apply p0.
    simpl.
    mysimp.
  - intros.  apply p1 in H0. omega.
  - intros.  apply p2 in H0. omega.
  - split.
    + destruct H, H1, H2, H3, H4.
      assert (are_disjoints (p :: dom_ren rl) (i :: img_ren rl)).
      {
        destruct H.
        rewrite H0 in p0.
        apply in_list_id_le_ex in p0 as p0'.
        apply Nat.lt_neq in p0' as p0''.
        apply are_disjoints_cons.
        assumption.
        auto.
        cases (in_list_id p (img_ren r)).
        apply H2 in Eq.
        omega.
        reflexivity.
        cases (in_list_id i (dom_ren r)).
        specialize p0 with (x:= i).
        simpl in p0.
        destruct (eq_id_dec p i).
        omega.
        rewrite <- H1 in p0.
        intuition.
        reflexivity.
      }
      econstructor.
      * simpl.
        assumption.
      * intros.
        destruct H.
        simpl.
        destruct (eq_id_dec p y).
        {
          rewrite e in *.
          simpl in H7.
          destruct (eq_id_dec y x).
          intuition.
          apply H3 in H7 as ine.
          apply dom_img_rename_subst in H7 as H7'.
          destruct H7', a.
          apply H2 in H11 as ine2.
          rewrite H12.
          omega.
        }
        {
          destruct (eq_id_dec p x).
          {
            simpl in H8.
            destruct (eq_id_dec p y); try omega.
            apply dom_img_rename_subst in H8 as H8'.
            destruct H8', a.
            apply H2 in H11.
            apply H3 in H8.
            omega.
          }
          {
            simpl in H7, H8.
            destruct (eq_id_dec p x); try omega.
            destruct (eq_id_dec p y); try omega.
            apply H10.
            assumption.
            assumption.
            assumption.
          }
        }
    + split.
      * destruct H, H1, H2, H3.
        subst.
        reflexivity.
      * repeat split.
        {
          intros.
          destruct H, H2, H3, H4.
          simpl in H1.
          destruct (eq_id_dec i y).
          omega.
          apply H3 in H1.
          omega.
        }
        {
          intros.
          rewrite H0 in p0.
          simpl in H1.
          destruct (eq_id_dec p x).
          apply p0.
          subst. mysimp.
          apply p0.
          mysimp.
        }
        {
          destruct H, H1, H2, H3, H4.
          simpl.
          intro. intros.
          simpl.
          destruct (eq_id_dec i x).
          specialize p1 with (x:=x).
          rewrite e in *.
          intuition.
          unfold are_disjoints in H4.
          auto.
        }
        {
          destruct H, H1, H2, H3, H4.
          simpl.
          intro. intros.
          simpl.
          destruct (eq_id_dec i x).
          specialize p2 with (x:=x).
          rewrite e in *.
          intuition.
          unfold are_disjoints in H5.
          auto.
        }
  -  reflexivity.
Defined.

Hint Resolve compute_renaming:core.

Lemma exists_renaming_not_concerned_with: forall (l l1 l2: (list id)),
  {r:ren_subst | (renaming_of_not_concerned_with r l l1 l2)}.
Proof.
  intros.
  pose proof (max_list_ids l) as maxl.
  pose proof (max_list_ids l1) as maxl1.
  pose proof (max_list_ids l2) as maxl2.
  destruct maxl as [m1  Hm1], maxl1 as [m2 Hm2], maxl2 as [m3 Hm3].
  pose proof (max_ids_dep m2 m3) as mis2.
  destruct mis2 as [mi2].
  pose proof (max_ids_dep m1 mi2) as mis1.
  destruct mis1 as [mi1].
  destruct a, a0.
  destruct Hm1, Hm2, Hm3.
  sort.
  assert (forall n m p, n <= m /\ m <= p -> n <= p) as le_trans.
  {intros. omega. }
  assert (m2 <= mi1).
  {eapply le_trans. split. apply H. assumption. }
  assert (m3 <= mi1).
  {eapply le_trans. split. apply H0. assumption. }
  assert (forall n m, n <= m -> n < S m) as le_to_lt.
  {intros. omega. }
  assert (forall x : id, in_list_id x l = true -> x < S mi1).
  {intros. apply le_to_lt. eapply le_trans. split. apply H3.
   apply H11. apply H1. }
  assert (forall x : id, in_list_id x l1 = true -> x < S mi1).
  {intros. apply le_to_lt. eapply le_trans. split. apply H5. assumption. assumption. }
  assert (forall x : id, in_list_id x l2 = true -> x < S mi1).
  {intros. apply le_to_lt. eapply le_trans. split. apply H7. assumption. assumption. }
  pose proof (compute_renaming l l1 l2 H11 H12 H13) as COMP.
  inversion COMP.
  destruct H14.
  exists (x).
  econstructor.
  assumption.
  destruct H15.
  assumption.
  destruct H15, H16, H17, H18.
  assumption.
  destruct H15, H16, H17, H18.
  assumption.
Defined.

Hint Resolve exists_renaming_not_concerned_with:core.

Lemma index_rename_aux : forall (rho: ren_subst) (i: id) (l: (list id)) (c : id),
    is_rename_subst rho -> is_sublist_id l (dom_ren rho) -> in_list_id i (dom_ren rho) = true ->
    index_list_id_aux c i l =
    index_list_id_aux c (apply_ren_subst rho i) (List.map (apply_ren_subst rho) l).
Proof.
  induction l;
    intros.
  - reflexivity.
  - destruct (eq_id_dec a i).
    + subst.
      simpl. mysimp.
    + apply sublist_cons in H0 as H2.
      inversion H.
      inversion H0.
      inversion H2.
      simpl. destruct (eq_id_dec a i); try contradiction.
      assert (apply_ren_subst rho a <> apply_ren_subst rho i).
      {apply H4; auto. apply H6. mysimp. }
      mysimp.
Qed.

Hint Resolve index_rename_aux:core.

Lemma index_rename : forall (rho : ren_subst) (i : id) (l: (list id)),
    is_rename_subst rho ->
    is_sublist_id l (dom_ren rho) ->
    in_list_id i (dom_ren rho) = true ->
    index_list_id i l = index_list_id (apply_ren_subst rho i) (List.map (apply_ren_subst rho) l).
Proof.
  intros.
  unfold index_list_id.
  apply index_rename_aux; auto.
Qed.

Hint Resolve index_rename:core.

(** For some l disjoint with img_ren rho, apply_ren_subst rho i is not in l*)
Lemma rename_img : forall (i : id) (rho : ren_subst) (l: list id),
    (is_rename_subst rho) -> (are_disjoints l (img_ren rho)) ->
    (in_list_id i (dom_ren rho)) = true ->
    (in_list_id (apply_ren_subst rho i) l) = false.
Proof.
  intros.
  inversion H.
  apply H2 in H1 as H1'.
  pose proof dom_img_rename_subst rho i H1 as H5.
  destruct H5, a.
  rewrite H6.
  eapply disjoint_inversion2.
  apply H0.
  auto.
Qed.

Hint Resolve rename_img:core.

Lemma in_list_id_dom_img : forall rho i,
    (in_list_id i (dom_ren rho) = true ->
     in_list_id (apply_ren_subst rho i) (img_ren rho) = true).
Proof.
  induction rho.
  intros.
  - inversion H.
  - destruct a.
    intros.
    simpl in *. destruct (eq_id_dec i0 i); intros; simpl in *; mysimp.
Qed.

Hint Resolve in_list_id_dom_img:core.

(** ** Converts a renaming substitute to a usual substitution *)

Fixpoint rename_to_subst (r: ren_subst): substitution :=
  match r with
  | nil => nil
  | vt:: l => ((fst vt), (var (snd vt)))::(rename_to_subst l)
  end.

(** ** Some lemmas about the above conversion *)

Lemma dom_rename_to_subst : forall rho,  (dom (rename_to_subst rho) = dom_ren rho).
Proof.
  intros.
  induction rho.
  - reflexivity.
  - simpl.
    rewrite IHrho.
    reflexivity.
Qed.

(**  A lemma about apply a renaminng substitution *)
Lemma apply_subst_rename_to_subst : forall rho i,
    are_disjoints (dom_ren rho) (img_ren rho) ->
    apply_subst (rename_to_subst rho) (var i) = var (apply_ren_subst rho i).
Proof.
  induction rho; intros.
  - reflexivity.
  - destruct a.
    assert (in_list_id i1 (dom_ren ((i0, i1)::rho)) = false).
    { eapply disjoint_inversion2. apply H. mysimp. }
    rewrite <- dom_rename_to_subst in H0.
    simpl in H0.
    destruct (eq_id_dec i0 i1).
    inversion H0.
    apply apply_subst_dom_false in H0.
    simpl.
    destruct (eq_id_dec i0 i).
    auto.
    fold (apply_subst (rename_to_subst rho) (var i)).
    apply IHrho.
    eapply are_disjoints_cons_inversion.
    apply H.
Qed.

Hint Resolve apply_subst_rename_to_subst:core.