From Hammer Require Import Hammer.

Require Export NSub.

Ltac f_equiv' := repeat (repeat f_equiv; try intros ? ? ?; auto).

Module NStrongRecProp (Import N : NAxiomsRecSig').
Include NSubProp N.

Section StrongRecursion.

Variable A : Type.
Variable Aeq : relation A.
Variable Aeq_equiv : Equivalence Aeq.

Definition strong_rec (a : A) (f : (N.t -> A) -> N.t -> A) (n : N.t) : A :=
recursion (fun _ => a) (fun _ => f) (S n) n.

Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A :=
recursion (fun _ => a) (fun _ => f).

Lemma strong_rec_alt : forall a f n,
strong_rec a f n = strong_rec0 a f (S n) n.
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec_alt".
reflexivity.
Qed.

Instance strong_rec0_wd :
Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq)
strong_rec0.
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec0_wd".
unfold strong_rec0; f_equiv'.
Qed.

Instance strong_rec_wd :
Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec.
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec_wd".
intros a a' Eaa' f f' Eff' n n' Enn'.
rewrite !strong_rec_alt; f_equiv'.
Qed.

Section FixPoint.

Variable f : (N.t -> A) -> N.t -> A.
Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f.

Lemma strong_rec0_0 : forall a m,
(strong_rec0 a f 0 m) = a.
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec0_0".
intros. unfold strong_rec0. rewrite recursion_0; auto.
Qed.

Lemma strong_rec0_succ : forall a n m,
Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m).
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec0_succ".
intros. unfold strong_rec0.
f_equiv.
rewrite recursion_succ; f_equiv'.
Qed.

Lemma strong_rec_0 : forall a,
Aeq (strong_rec a f 0) (f (fun _ => a) 0).
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec_0".
intros. rewrite strong_rec_alt, strong_rec0_succ; f_equiv'.
rewrite strong_rec0_0. reflexivity.
Qed.

Hypothesis step_good :
forall (n : N.t) (h1 h2 : N.t -> A),
(forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n).

Lemma strong_rec0_more_steps : forall a k n m, m < n ->
Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m).
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec0_more_steps".
intros a k n. pattern n.
apply induction; clear n.

intros n n' Hn; setoid_rewrite Hn; auto with *.

intros m Hm. destruct (nlt_0_r _ Hm).

intros n IH m Hm.
rewrite lt_succ_r in Hm.
rewrite add_succ_l.
rewrite 2 strong_rec0_succ.
apply step_good.
intros m' Hm'.
apply IH.
apply lt_le_trans with m; auto.
Qed.

Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t),
Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n).
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec0_fixpoint".
intros.
rewrite strong_rec0_succ.
apply step_good.
intros m Hm.
symmetry.
setoid_replace n with (S m + (n - S m)).
apply strong_rec0_more_steps.
apply lt_succ_diag_r.
rewrite add_comm.
symmetry.
apply sub_add.
rewrite le_succ_l; auto.
Qed.

Theorem strong_rec_fixpoint : forall (a : A) (n : N.t),
Aeq (strong_rec a f n) (f (strong_rec a f) n).
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec_fixpoint".
intros.
transitivity (f (fun n => strong_rec0 a f (S n) n) n).
rewrite strong_rec_alt.
apply strong_rec0_fixpoint.
f_equiv.
intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *.
Qed.

Theorem strong_rec_0_any : forall (a : A)(any : N.t->A),
Aeq (strong_rec a f 0) (f any 0).
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec_0_any".
intros.
rewrite strong_rec_fixpoint.
apply step_good.
intros m Hm. destruct (nlt_0_r _ Hm).
Qed.

Lemma strong_rec_any_fst_arg : forall a a' n,
Aeq (strong_rec a f n) (strong_rec a' f n).
Proof. hammer_hook "NStrongRec" "NStrongRec.NStrongRecProp.strong_rec_any_fst_arg".
intros a a' n.
generalize (le_refl n).
set (k:=n) at -2. clearbody k. revert k. pattern n.
apply induction; clear n.

intros n n' Hn. setoid_rewrite Hn; auto with *.

intros k Hk. rewrite le_0_r in Hk.
rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any.

intros n IH k Hk.
rewrite 2 strong_rec_fixpoint.
apply step_good.
intros m Hm.
apply IH.
rewrite succ_le_mono.
apply le_trans with k; auto.
rewrite le_succ_l; auto.
Qed.

End FixPoint.
End StrongRecursion.

Arguments strong_rec [A] a f n.

End NStrongRecProp.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Arith_base.

(** [fin n] is a convinient way to represent \[1 .. n\]

[fin n] can be seen as a n-uplet of unit where [F1] is the first element of
the n-uplet and [FS] set (n-1)-uplet of all the element but the first.

   Author: Pierre Boutillier
   Institution: PPS, INRIA 12/2010
*)

Inductive t : nat -> Set :=
|F1 : forall {n}, t (S n)
|FS : forall {n}, t n -> t (S n).

Section SCHEMES.
Definition case0 P (p: t 0): P p :=
  match p as p' in t n return
    match n as n' return t n' -> Type
  with |0 => fun f0 => P f0 |S _ => fun _ => @ID end p'
  with |F1 _ => @id |FS _ _ => @id end.

Definition caseS (P: forall {n}, t (S n) -> Type)
  (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p))
  {n} (p: t (S n)): P p :=
  match p as p0 in t n0
  return match n0 as nn return t nn -> Type with
    |0 => fun _ => @ID |S n' => fun p' => P p'
  end p0 with
  |F1 k => P1 k
  |FS k pp => PS pp
  end.

Definition rectS (P: forall {n}, t (S n) -> Type)
  (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)):
  forall {n} (p: t (S n)), P p :=
fix rectS_fix {n} (p: t (S n)): P p:=
  match p as p0 in t n0
  return match n0 as nn return t nn -> Type with
    |0 => fun _ => @ID |S n' => fun p' => P p'
  end p0 with
  |F1 k => P1 k
  |FS 0 pp => case0 (fun f => P (FS f)) pp
  |FS (S k) pp => PS pp (rectS_fix pp)
  end.

Definition rect2 (P: forall {n} (a b: t n), Type)
  (H0: forall n, @P (S n) F1 F1)
  (H1: forall {n} (f: t n), P F1 (FS f))
  (H2: forall {n} (f: t n), P (FS f) F1)
  (HS: forall {n} (f g : t n), P f g -> P (FS f) (FS g)):
    forall {n} (a b: t n), P a b :=
fix rect2_fix {n} (a: t n): forall (b: t n), P a b :=
match a with
  |F1 m => fun (b: t (S m)) => match b as b' in t n'
                   return match n' as n0
                          return t n0 -> Type with
                            |0 => fun _ => @ID
                            |S n0 => fun b0 => P F1 b0
                          end b' with
                     |F1 m' => H0 m'
                     |FS m' b' => H1 b'
                   end
  |FS m a' => fun (b: t (S m)) => match b as b' in t n'
                      return match n' as n0
                             return t n0 -> Type with
                               |0 => fun _ => @ID
                               |S n0 => fun b0 =>
                                 forall (a0: t n0), P (FS a0) b0
                             end b' with
                         |F1 m' => fun aa => H2 aa
                         |FS m' b' => fun aa => HS aa b' (rect2_fix aa b')
                       end a'
end.
End SCHEMES.

(** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *)
Fixpoint to_nat {m} (n : t m) : {i | i < m} :=
  match n in t k return {i | i< k} with
    |F1 j => exist (fun i => i< S j) 0 (Lt.lt_0_Sn j)
    |FS _ p => match to_nat p with |exist i P => exist _ (S i) (Lt.lt_n_S _ _ P) end
  end.

(** [of_nat p n] answers the p{^ th} element of [fin n] if p < n or a proof of
p >= n else *)
Fixpoint of_nat (p n : nat) : (t n) + { exists m, p = n + m } :=
  match n with
   |0 => inright _ (ex_intro (fun x => p = 0 + x) p (@eq_refl _ p))
   |S n' => match p with
      |0 => inleft _ (F1)
      |S p' => match of_nat p' n' with
        |inleft f => inleft _ (FS f)
        |inright arg => inright _ (match arg with |ex_intro m e =>
          ex_intro (fun x => S p' = S n' + x) m (f_equal S e) end)
      end
    end
  end.

(** [of_nat_lt p n H] answers the p{^ th} element of [fin n]
it behaves much better than [of_nat p n] on open term *)
Fixpoint of_nat_lt {p n : nat} : p < n -> t n :=
  match n with
    |0 => fun H : p < 0 => False_rect _ (Lt.lt_n_O p H)
    |S n' => match p with
      |0 => fun _ => @F1 n'
      |S p' => fun H => FS (of_nat_lt (Lt.lt_S_n _ _ H))
    end
  end.

Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p.
Proof.
induction p.
 reflexivity.
 simpl; destruct (to_nat p). simpl. subst p; repeat f_equal. apply Peano_dec.le_unique.
Qed.

(** [weak p f] answers a function witch is the identity for the p{^  th} first
element of [fin (p + m)] and [FS (FS .. (FS (f k)))] for [FS (FS .. (FS k))]
with p FSs *)
Fixpoint weak {m}{n} p (f : t m -> t n) :
  t (p + m) -> t (p + n) :=
match p as p' return t (p' + m) -> t (p' + n) with
  |0 => f
  |S p' => fun x => match x in t n0 return
     match n0 with |0 => @ID |S n0' => n0' = p' + m -> t (S p' + n) end with
     |F1 n' => fun eq : n' = p' + m => F1
     |FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq))
  end (eq_refl _)
end.

(** The p{^ th} element of [fin m] viewed as the p{^ th} element of
[fin (m + n)] *)
Fixpoint L {m} n (p : t m) : t (m + n) :=
  match p with |F1 _ => F1 |FS _ p' => FS (L n p') end.

Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p).
Proof.
induction p.
  reflexivity.
  simpl; destruct (to_nat (L n p)); simpl in *; rewrite IHp. now destruct (to_nat p).
Qed.

(** The p{^ th} element of [fin m] viewed as the p{^ th} element of
[fin (n + m)]
Really really ineficient !!! *)
Definition L_R {m} n (p : t m) : t (n + m).
induction n.
  exact p.
  exact ((fix LS k (p: t k) :=
    match p in t n0 return t (S n0) with
      |F1 _ => F1
      |FS _ p' => FS (LS _ p')
    end) _ IHn).
Defined.

(** The p{^ th} element of [fin m] viewed as the (n + p){^ th} element of
[fin (n + m)] *)
Fixpoint R {m} n (p : t m) : t (n + m) :=
  match n with |0 => p |S n' => FS (R n' p) end.

Lemma R_sanity {m} n (p : t m) : proj1_sig (to_nat (R n p)) = n + proj1_sig (to_nat p).
Proof.
induction n.
  reflexivity.
  simpl; destruct (to_nat (R n p)); simpl in *; rewrite IHn. now destruct (to_nat p).
Qed.

Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) :=
match o with
  |F1 m' => L (m' * n) p
  |FS m' o' => R n (depair o' p)
end.

Lemma depair_sanity {m n} (o : t m) (p : t n) :
  proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)).
induction o ; simpl.
  rewrite L_sanity. now rewrite Mult.mult_0_r.

  rewrite R_sanity. rewrite IHo.
  rewrite Plus.plus_assoc. destruct (to_nat o); simpl; rewrite Mult.mult_succ_r.
    now rewrite (Plus.plus_comm n).
Qed.


(************************************************************************)
(*  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: ArithProp.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rbasic_fun.
Require Import Even.
Require Import Div2.
Require Import ArithRing.

Open Local Scope Z_scope.
Open Local Scope R_scope.

Lemma minus_neq_O : forall n i:nat, (i < n)%nat -> (n - i)%nat <> 0%nat.
Proof.
  intros; red in |- *; intro.
  cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
  intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
    elim (lt_irrefl _ H).
  set (R := fun n m:nat => (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
  cut
    ((forall n m:nat, R n m) ->
      forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
  intro; apply H1.
  apply nat_double_ind.
  unfold R in |- *; intros; inversion H2; reflexivity.
  unfold R in |- *; intros; simpl in H3; assumption.
  unfold R in |- *; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
    assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
  unfold R in |- *; intros; apply H1; assumption.
Qed.

Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat.
Proof.
  set (R := fun m n:nat => (n <= m)%nat -> (m - n <= m)%nat).
  cut
    ((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
  intro; apply H.
  apply nat_double_ind.
  unfold R in |- *; intros; simpl in |- *; apply le_n.
  unfold R in |- *; intros; simpl in |- *; apply le_n.
  unfold R in |- *; intros; simpl in |- *; apply le_trans with n.
  apply H0; apply le_S_n; assumption.
  apply le_n_Sn.
  unfold R in |- *; intros; apply H; assumption.
Qed.

Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat.
Proof.
  intros n m; pattern n, m in |- *; apply nat_double_ind;
    [ intros; rewrite <- minus_n_O; assumption
      | intros; elim (lt_n_O _ H)
      | intros; simpl in |- *; apply H; apply lt_S_n; assumption ].
Qed.

Lemma even_odd_cor :
  forall n:nat,  exists p : nat, n = (2 * p)%nat \/ n = S (2 * p).
Proof.
  intro.
  assert (H := even_or_odd n).
  exists (div2 n).
  assert (H0 := even_odd_double n).
  elim H0; intros.
  elim H1; intros H3 _.
  elim H2; intros H4 _.
  replace (2 * div2 n)%nat with (double (div2 n)).
  elim H; intro.
  left.
  apply H3; assumption.
  right.
  apply H4; assumption.
  unfold double in |- *;ring.
Qed.

  (* 2m <= 2n => m<=n *)
Lemma le_double : forall m n:nat, (2 * m <= 2 * n)%nat -> (m <= n)%nat.
Proof.
  intros; apply INR_le.
  assert (H1 := le_INR _ _ H).
  do 2 rewrite mult_INR in H1.
  apply Rmult_le_reg_l with (INR 2).
  replace (INR 2) with 2; [ prove_sup0 | reflexivity ].
  assumption.
Qed.

(** Here, we have the euclidian division *)
(** This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *)
Lemma euclidian_division :
  forall x y:R,
    y <> 0 ->
    exists k : Z, (exists r : R, x = IZR k * y + r /\ 0 <= r < Rabs y).
Proof.
  intros.
  set
    (k0 :=
      match Rcase_abs y with
	| left _ => (1 - up (x / - y))%Z
	| right _ => (up (x / y) - 1)%Z
      end).
  exists k0.
  exists (x - IZR k0 * y).
  split.
  ring.
  unfold k0 in |- *; case (Rcase_abs y); intro.
  assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl in |- *;
    unfold Rminus in |- *.
  replace (- ((1 + - IZR (up (x / - y))) * y)) with
    ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
  split.
  apply Rmult_le_reg_l with (/ - y).
  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
  rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
  rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ].
  apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
  rewrite Rplus_0_r; unfold Rdiv in |- *; pattern (/ - y) at 4 in |- *;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
  replace
    (IZR (up (x * / - y)) - x * - / y +
      (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1;
    [ idtac | ring ].
  elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
  rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y).
  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
  rewrite <- Rinv_l_sym.
  rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
  rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ];
      apply Rplus_lt_reg_r with (IZR (up (x / - y)) - 1).
  replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y)));
    [ idtac | ring ].
  replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
    with (- (x * / y)); [ idtac | ring ].
  rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0;
    unfold Rdiv in |- *; intros H1 _; exact H1.
  apply Ropp_neq_0_compat; assumption.
  assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl in |- *;
    cut (0 < y).
  intro; unfold Rminus in |- *;
    replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y);
      [ idtac | ring ].
  split.
  apply Rmult_le_reg_l with (/ y).
  apply Rinv_0_lt_compat; assumption.
  rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r;
    rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
      [ rewrite Rmult_1_r | assumption ];
      apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y);
	rewrite Rplus_0_r; unfold Rdiv in |- *;
	  replace
	    (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
	    1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2;
	      exact H2.
  rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y).
  apply Rinv_0_lt_compat; assumption.
  rewrite <- (Rinv_l_sym _ H); rewrite (Rmult_comm (/ y));
    rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
      [ rewrite Rmult_1_r | assumption ];
      apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1);
	replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y)));
	  [ idtac | ring ];
	  replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *;
	      intros H2 _; exact H2.
  case (total_order_T 0 y); intro.
  elim s; intro.
  assumption.
  elim H; symmetry  in |- *; exact b.
  assert (H1 := Rge_le _ _ r); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r0)).
Qed.

Lemma tech8 : forall n i:nat, (n <= S n + i)%nat.
Proof.
  intros; induction  i as [| i Hreci].
  replace (S n + 0)%nat with (S n); [ apply le_n_Sn | ring ].
  replace (S n + S i)%nat with (S (S n + i)).
  apply le_S; assumption.
  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
Qed.


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Rupicola.Lib.ControlFlow.CondSwap.
Require Import bedrock2.Semantics.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Bedrock.Group.Loops.
Require Import Crypto.Bedrock.Group.ScalarMult.LadderStep.
Require Import Crypto.Bedrock.Group.ScalarMult.MontgomeryLadder.
Require Import Crypto.Curves.Montgomery.XZ.
Require Import Crypto.Curves.Montgomery.XZProofs.
Require Import Crypto.Util.Loops.

Section Equivalence.
  Context {semantics : Semantics.parameters}.
  Context {field_parameters : FieldParameters}
          {field_representation : FieldRepresentation}.

  Lemma ladderstep_gallina_equiv X1 P1 P2 :
    ladderstep_gallina X1 P1 P2 =
    @M.xzladderstep
      _ F.add F.sub F.mul a24 X1 P1 P2.
  Proof.
    intros. cbv [ladderstep_gallina M.xzladderstep].
    destruct P1 as [x1 z1]. destruct P2 as [x2 z2].
    cbv [Rewriter.Util.LetIn.Let_In dlet.dlet]. cbn [fst snd].
    rewrite !F.pow_2_r. reflexivity.
  Qed.

  Lemma montladder_gallina_equiv
        n scalarbits testb point :
    (forall i, testb i = Z.testbit n (Z.of_nat i)) ->
    (0 <= scalarbits)%Z ->
    montladder_gallina scalarbits testb point =
    @M.montladder
      _ F.zero F.one F.add F.sub F.mul F.inv
      a24 cswap scalarbits (Z.testbit n) point.
  Proof.
    intros. cbv [montladder_gallina M.montladder].
    cbv [Rewriter.Util.LetIn.Let_In dlet.dlet]. cbn [fst snd].
    rewrite downto_while.
    match goal with
    | |- ?lhs = ?rhs =>
      match lhs with
        | context [while ?ltest ?lbody ?fuel ?linit] =>
        match rhs with
          | context [while ?rtest ?rbody ?fuel ?rinit] =>
            rewrite (while.preservation
                       ltest lbody rtest rbody
                       (fun s1 s2 =>
                          s1 =
                          let '(x2, z2, x3, z3, swap, i) := s2 in
                          (x2, z2, (x3, z3), swap, i)))
              with (init2:=rinit);
              [ remember (while rtest rbody fuel rinit) | .. ]
        end end end.

    (* first, finish proving post-loop equivalence *)
    { destruct_products. rewrite cswap_pair. cbn [fst snd].
      repeat match goal with
             | |- context [match ?e with | pair _ _ => _ end] =>
               destr e
             end.
      reflexivity. }

    (* then, prove loop-equivalence preconditions *)
    { intros. destruct_products. congruence. }
    { intros. destruct_products. LtbToLt.Z.ltb_to_lt.
      rewrite ladderstep_gallina_equiv.
      repeat match goal with
             | _ => progress rewrite Z2Nat.id by lia
             | _ => progress cbn [fst snd]
             | _ => rewrite cswap_pair
             | _ => rewrite <-surjective_pairing
             | H : forall i : nat, _ i = Z.testbit _ _ |- _ =>
               rewrite H
             | H : (_,_) = (_,_) |- _ => inversion H; subst; clear H
             | H : context [match ?e with | pair _ _ => _ end] |- _ =>
               destr e
             | |- context [match ?e with | pair _ _ => _ end] =>
               destr e
             | _ => reflexivity
             end. }
    { rewrite Z2Nat.id by lia. reflexivity. }
  Qed.
End Equivalence.


Require Import XRbase.
Require Import XRfunctions.
Require Import Compare.
Require Import XRcompleteness.
Local Open Scope XR_scope.

Implicit Type r : R.

Lemma Rlt_0_2 : R0 < IZR 2.
Proof.
unfold IZR.
unfold IPR.
unfold IPR_2.
pattern R0 ; rewrite <- Rplus_0_l.
apply Rplus_lt_compat.
exact Rlt_0_1.
exact Rlt_0_1.
Qed.

Remark Rlt_0_half : R0 < / (IZR 2).
Proof.
  apply Rinv_0_lt_compat.
  apply Rlt_0_2.
Qed.

Remark Rlt_half_1 : / (IZR 2) < R1.
Proof.
  rewrite <- Rinv_1.
  apply Rinv_lt_contravar.
  rewrite Rmult_1_l.
  apply Rlt_0_2.
  pattern (IZR 2);rewrite <- Rmult_1_r.
  rewrite double.
  pattern R1 at 1;rewrite <- Rplus_0_r.
  apply Rplus_lt_compat_l.
  apply Rlt_0_1.
Qed.

Remark half_half : / (IZR 2) + / (IZR 2) = R1.
Proof.
  pattern (/ (IZR 2));rewrite <- Rmult_1_r.
  rewrite <- Rmult_plus_distr_l.
  rewrite <- double.
  rewrite Rmult_1_r.
  rewrite Rinv_l.
  reflexivity.
  intro eq.
  apply Rlt_irrefl with R0.
  pattern R0 at 2;rewrite <- eq.
  apply Rlt_0_2.
Qed.

Lemma Rlt_irrefl_le : forall a b, a < b -> b <= a -> False.
Proof.
  intros a b hab hba.
  destruct hba.
  { apply Rlt_irrefl with a. apply Rlt_trans with b;assumption. }
  { subst b. apply Rlt_irrefl with a. exact hab. }
Qed.

Lemma ex_ex : forall (T:Type) (P:T->Prop) (Q:{ t : T | P t }), exists (t:T), P t.
Proof.
  intros T P h.
  destruct h.
  exists x.
  exact p.
Qed.

Lemma ex_ex_inv : forall (T:Type) (P:T->Prop), (exists (t:T), P t) -> exists (Q:{ t : T | P t }), True.
Proof.
  intros T P h.
  destruct h as [ t pt].
  exists (exist P t pt).
  apply I.
Qed.

Lemma exists_fun : forall {A B : Type} (P:A->B->Prop), (forall a, {b | P a b}) -> exists f, forall a, P a (f a).
Proof.
  intros A B P h.
  exists (fun a => match (h a) with exist _ b _ => b end).
  intros a.
  destruct (h a).
  exact p.
Qed.

Lemma exists_fun' : forall {A B : Type} (P:A->B->Prop), (forall a, {b | P a b}) -> { f | forall a, P a (f a) }.
Proof.
  intros A B P h.
  exists (fun a => match (h a) with exist _ b _ => b end).
  intros a.
  destruct (h a).
  exact p.
Qed.

Lemma Rplus_le_compat_0_l : forall u v, R0 <= v -> u <= u + v.
Proof.
  intros u v h.
  pattern u at 1;rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  exact h.
Qed.

Lemma Rplus_le_compat_0_r : forall u v, R0 <= v -> u <= v + u.
Proof.
  intros u v h.
  rewrite Rplus_comm.
  apply Rplus_le_compat_0_l.
  exact h.
Qed.

Lemma Rplus_lt_compat_l_minus : forall u v w, v < w - u -> u + v < w.
Proof.
  intros u v w h.
  apply Rplus_lt_reg_l with (-u).
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  rewrite Rplus_comm.
  fold (w-u).
  exact h.
Qed.

Lemma Rplus_lt_compat_r_minus : forall u v w, u < w - v -> u + v < w.
Proof.
  intros u v w h.
  rewrite Rplus_comm.
  apply Rplus_lt_compat_l_minus.
  exact h.
Qed.

Lemma Rplus_le_compat_l_minus : forall u v w, v <= w - u -> u + v <= w.
Proof.
  intros u v w h.
  apply Rplus_le_reg_l with (-u).
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  rewrite Rplus_comm.
  fold (w-u).
  exact h.
Qed.

Lemma Rplus_le_compat_r_minus : forall u v w, u <= w - v -> u + v <= w.
Proof.
  intros u v w h.
  rewrite Rplus_comm.
  apply Rplus_le_compat_l_minus.
  exact h.
Qed.

Lemma Rminus_diag : forall r, r-r=R0.
Proof.
  intro r.
  unfold Rminus.
  rewrite Rplus_opp_r.
  reflexivity.
Qed.

Lemma lt_disj : (forall n m, S m < S n -> S m < n \/ S m = n)%nat.
Proof.
  intros n m h.
  apply lt_le_S in h.
  apply le_lt_or_eq in h.
  destruct h as [ h | h ].
  {
    apply lt_S_n in h.
    left. exact h.
  }
  {
    apply eq_add_S in h.
    right. exact h.
  }
Qed.

Lemma sum_pow_neq_0: forall x y n, R0 <= x -> R0 < y -> x + y^n = R0 -> False.
Proof.
  intros x y n hx hy heq.
  apply Rlt_irrefl with R0.
  pattern R0 at 2;rewrite <- heq.
  apply Rle_lt_trans with x.
  { exact hx. }
  {
    pattern x at 1;rewrite <- Rplus_0_r.
    apply Rplus_lt_compat_l.
    apply pow_lt.
    exact hy.
  }
Qed.

(* Duplicate from extension of Rfunctions *)
Lemma Rgen : forall r:R, exists n:nat, r <= INR n.
Proof.
  intro r.
  destruct (archimed r) as [ agt ale ].
  exists (Z.abs_nat (up r)).
  destruct (up r) eqn:upeq.
  { (* up r = 0 *)
    simpl.
    left. exact agt.
  }
  { (* up r = Z.pos p *)
    simpl.
    destruct (Pos.to_nat p) eqn:poseq.
    { (* Pos.to_nat p = 0 *)
      simpl.
      generalize (Pos2Nat.is_pos p);intro hpos.
      rewrite poseq in hpos.
      inversion hpos.
    }
    { (* Pos.to_nat p = S n *)
      (* rewrite S_INR. *)
      left.
      rewrite INR_IZR_INZ.
      rewrite <- poseq.
      rewrite positive_nat_Z.
      exact agt.
    }
  }
  { (* up r = Z.neg p *)
    simpl.
    destruct (Pos.to_nat p) eqn:poseq.
    { (* Pos.to_nat p = 0 *)
      simpl.
      generalize (Pos2Nat.is_pos p);intro hpos.
      rewrite poseq in hpos.
      inversion hpos.
    }
    { (* Pos.to_nat p = S n *)
      left.
      rewrite INR_IZR_INZ.
      rewrite <- poseq.
      rewrite positive_nat_Z.
      apply Rlt_trans with (IZR (Z.neg p)).
      { exact agt. }
      {
        apply IZR_lt.
        apply Pos2Z.neg_lt_pos.
      }
    }
  }
Qed.

Lemma Rgen_two_power :
  forall b:R, exists N : nat, b <= (IZR 2) ^ N.
Proof.
  intros.
  destruct (archimed b) as [H0 H1].
  clear H1.
  {
    destruct (Rgen b) as [N H1].
    exists N.
    unfold IZR. unfold IPR. unfold IPR_2.
    apply Rle_trans with (R1 + INR N * R1).
    {
      apply Rle_trans with (INR N).
      { exact H1. }
      {
        apply Rlt_le.
        pattern (INR N) at 1;rewrite <- Rplus_0_l.
        rewrite Rmult_1_r.
        apply Rplus_lt_compat_r.
        apply Rlt_0_1.
      }
    }
    { apply poly. exact Rlt_0_1. }
  }
Qed.

Lemma Neq_2_0 : IZR 2 <> R0.
Proof.
  intro eq. apply Rlt_irrefl with R0. pattern R0 at 2;rewrite <- eq.
  exact Rlt_0_2.
Qed.

Lemma Rgen_half_power :
  forall b:R, R0 < b -> exists N : nat, (/ (IZR 2)) ^ N <= b.
Proof.
  intros.
  generalize Rgen_two_power;intro gtp.
  specialize (gtp (/ b)).
  destruct gtp as [N h].
  exists N.
  rewrite <- Rinv_pow.
  2:{ exact Neq_2_0. }
  rewrite <- Rinv_involutive with b.
  2:{ apply Rlt_dichotomy_converse. right. exact H. }
  apply Rinv_le_contravar.
  1:{ apply Rinv_0_lt_compat. exact H. }
  exact h.
Qed.

Section sequence.

  Fixpoint Rmax_N (U:nat->R) (n:nat) : R :=
    match n with
      | O => U 0%nat
      | S n => Rmax (U (S n)) (Rmax_N U n)
    end.

  Definition EUn (U:nat->R) (r:R) : Prop :=  exists n : nat, r = U n.

  Definition Un_cv (U:nat->R) (l:R) : Prop :=
    forall eps:R,
      R0 < eps ->
      exists N : nat, (forall n:nat, (n >= N)%nat -> R_dist (U n) l < eps).

  Definition Cauchy_crit (U : nat -> R) : Prop :=
    forall eps:R,
      R0 < eps ->
      exists N : nat,
        (forall n m:nat,
          (n >= N)%nat -> (m >= N)%nat -> R_dist (U n) (U m) < eps).

  Definition Un_growing (U : nat -> R) : Prop := forall n:nat, U n <= U (S n).

  Lemma EUn_noempty : forall (U : nat -> R), exists r : R, EUn U r.
  Proof.
    intro U.
    exists (U 0%nat).
    unfold EUn.
    exists 0%nat.
    reflexivity.
  Qed.

  Lemma Un_in_EUn : forall (U : nat -> R) (n:nat), EUn U (U n).
  Proof.
    intros U n.
    unfold EUn.
    exists n.
    reflexivity.
  Qed.

  Lemma Un_bound_imp :
    forall (U : nat -> R)  (x:R), (forall n:nat, U n <= x) -> is_upper_bound (EUn U) x.
  Proof.
    intros U x H.
    unfold is_upper_bound.
    intros xn [n eq].
    subst xn.
    apply H.
  Qed.

  Lemma growing_prop :
    forall (U : nat -> R) (n m:nat), Un_growing U -> (n >= m)%nat -> U m <= U n.
  Proof.
    intros U n m hu hnm.
    unfold ge in hnm.
    induction hnm as [ | n hmn i ].
    { right. reflexivity. }
    {
      unfold Un_growing in hu.
      apply Rle_trans with (U n).
      { exact i. }
      { apply hu. }
    }
  Qed.

  Remark Hi2pn: forall n, R0 < (/ (IZR 2))^n.
  Proof.
    intros n.
    apply pow_lt.
    apply Rinv_0_lt_compat.
    exact Rlt_0_2.
  Qed.

  Definition Un_partial (u u':nat->R) := forall n, u n = R0 \/ u n = u' n.

  Definition pos (u:nat->R) := forall n, R0 <= u n.

  Lemma posn : forall u n, pos u -> R0 <= u n.
  Proof.
    intros u n hpos.
    apply hpos.
  Qed.

  Lemma pos_partial : forall u u', pos u' -> Un_partial u u' -> pos u.
  Proof.
    intros u u' hpo hpa.
    unfold pos in hpo.
    unfold Un_partial in hpa.
    unfold pos.
    intro n.
    destruct (hpa n) as [ h | h ].
    rewrite h. right. reflexivity.
    rewrite h. apply hpo.
  Qed.

  Lemma partial_le : forall u u' n, Un_partial u u' -> pos u' -> u n <= u' n.
  Proof.
    intros u u' n h hp.
    unfold Un_partial in h.
    destruct (h n) as [ h' | h' ].
    { rewrite h'. apply hp. }
    { rewrite h'. right. reflexivity. }
  Qed.

  Definition u_half_pow (n:nat) := (/ (IZR 2))^n.

  Lemma u_half_pow_pos : pos u_half_pow.
  Proof.
    unfold pos.
    intro n.
    unfold u_half_pow.
    apply pow_le.
    left.
    exact Rlt_0_half.
  Qed.

  Fixpoint serie(u:nat->R) (n:nat) := match n with
  | O => R0
  | S n' => u n + (serie u n')
  end.

  Definition s_half_pow := serie u_half_pow.

  Lemma serie_Sn : forall u n, (serie u) (S n) = serie u n + u (S n).
  Proof.
    intros u n.
    simpl.
    rewrite Rplus_comm.
    reflexivity.
  Qed.

  Lemma s_partial_le : forall u u' n, Un_partial u u' -> pos u' -> serie u n <= serie u' n.
  Proof.
    intros u u' n h hp.
    unfold Un_partial in h.
    induction n as [ | n i ].
    {
      simpl. right. reflexivity.
    }
    {
      destruct (h (S n)) as [ h' | h' ].
      {
        rewrite serie_Sn.
        rewrite serie_Sn.
        rewrite h'.
        apply Rplus_le_compat.
        { exact i. }
        { apply hp. }
      }
      {
        rewrite serie_Sn.
        rewrite serie_Sn.
        rewrite h'.
        apply Rplus_le_compat_r.
        exact i.
      }
    }
  Qed.

  Lemma growing_s_half_pow : Un_growing s_half_pow.
  Proof.
    unfold Un_growing.
    intro n.
    unfold s_half_pow.
    simpl.
    apply Rplus_le_compat_0_r.
    unfold u_half_pow.
    apply pow_le.
    left.
    exact Rlt_0_half.
  Qed.

  Lemma s_half_pow_pos : forall n,  R0 <= s_half_pow n.
  Proof.
    intro n.
    unfold s_half_pow.
    induction n as [ | n i ].
    { simpl. right. reflexivity. }
    {
      simpl.
      apply Rle_trans with (serie u_half_pow n).
      { exact i. }
      {
        apply Rplus_le_compat_0_r.
        unfold u_half_pow.
        apply pow_le.
        left.
        exact Rlt_0_half.
      }
    }
  Qed.

  Lemma s_half_pow_le_n : forall n,  s_half_pow n <= R1 - (/ (IZR 2)) ^ n.
  Proof.
    intro n.
    unfold s_half_pow.
    induction n as [ | n i ].
    {
      simpl.
      rewrite Rminus_diag.
      right.
      reflexivity.
    }
    {
      simpl.
      unfold u_half_pow at 1.
      apply Rplus_le_compat_l_minus.
      simpl.
      pose (hsn:=(/ (IZR 2))^n).
      fold hsn.
      fold hsn in i.
      unfold Rminus.
      rewrite Ropp_mult_distr_r.
      rewrite Rplus_assoc.
      rewrite <- Rmult_plus_distr_r.
      rewrite half_half.
      rewrite Rmult_1_l.
      fold (R1-hsn).
      exact i.
    }
  Qed.

  Lemma s_half_pow_lt_1 : forall n,  s_half_pow n < R1.
  Proof.
    intro n.
    apply Rle_lt_trans with (R1 - (/ (IZR 2))^n).
    { apply s_half_pow_le_n. }
    {
      unfold Rminus.
      apply Rplus_lt_compat_l_minus.
      rewrite Rminus_diag.
      rewrite <- Ropp_0.
      apply Ropp_lt_contravar.
      apply pow_lt.
      exact Rlt_0_half.
    }
  Qed.

  Lemma growing_s_half_pow_partial : forall u, Un_partial u u_half_pow -> Un_growing (serie u).
  Proof.
    intros u h.
    unfold Un_growing.
    unfold Un_partial in h.
    intro n;destruct n as [ | n ].
    {
      simpl.
      rewrite Rplus_0_r.
      destruct (h 1%nat) as [ h' | h' ].
      { rewrite h'. right. reflexivity. }
      { rewrite h'. unfold u_half_pow. simpl. rewrite Rmult_1_r. left. exact Rlt_0_half. }
    }
    {
      simpl.
      rewrite <- Rplus_assoc.
      rewrite (Rplus_comm _ (u (S n))).
      rewrite Rplus_assoc.
      apply Rplus_le_compat_l.
      apply Rplus_le_compat_0_r.
      destruct (h (S (S n))) as [ h' | h' ].
      { rewrite h'. right. reflexivity. }
      { rewrite h'. unfold u_half_pow. apply pow_le. left. exact Rlt_0_half. }
    }
  Qed.

  Lemma s_half_pow_pos_partial : forall u, Un_partial u u_half_pow ->
    forall n,  R0 <= (serie u) n.
  Proof.
    intros u h n.
    unfold Un_partial in h.
    induction n as [ | n i ].
    { simpl. right. reflexivity. }
    { simpl. apply Rle_trans with (serie u n).
      { exact i. }
      { apply Rplus_le_compat_0_r. destruct (h (S n)) as [ h' | h' ].
        { rewrite h'. right. reflexivity. }
        { rewrite h'. unfold u_half_pow. apply pow_le. left. exact Rlt_0_half. }
      }
    }
  Qed.

  Lemma s_half_pow_le_n_partial : forall u, Un_partial u u_half_pow ->
    forall n,  (serie u) n <= R1 - (/ (IZR 2)) ^ n.
  Proof.
    intros u h n.
    unfold Un_partial in h.
    induction n as [ | n i ].
    { simpl. rewrite Rminus_diag. right. reflexivity. }
    { simpl. destruct (h (S n)) as [ h' | h' ].
      { rewrite h'. rewrite Rplus_0_l. apply Rle_trans with (R1 - (/ (IZR 2)) ^ n).
        { exact i. }
        { unfold Rminus. apply Rplus_le_compat_l. apply Ropp_le_contravar.
          pattern ( (/ (IZR 2)) ^ n) at 2;rewrite <- Rmult_1_l.
          apply Rmult_le_compat_r.
          apply pow_le. left. exact Rlt_0_half.
          left. exact Rlt_half_1.
        }
      }
      {
        rewrite h'. clear h'.
        apply Rplus_le_compat_l_minus.
        apply Rle_trans with (R1 - (/ (IZR 2)) ^ n).
        { exact i. }
        {
          unfold Rminus.
          rewrite Rplus_assoc.
          apply Rplus_le_compat_l.
          unfold u_half_pow.
          simpl.
          rewrite Ropp_mult_distr_r.
          rewrite <- Rmult_plus_distr_r.
          rewrite half_half.
          rewrite Rmult_1_l.
          right. reflexivity.
        }
      }
    }
  Qed.

  Lemma s_half_pow_lt_1_partial : forall u, Un_partial u u_half_pow ->
    forall n,  (serie u) n <= R1.
  Proof.
    intros u h n.
    apply Rle_trans with (R1 - (/ (IZR 2))^n).
    { apply s_half_pow_le_n_partial. exact h. }
    {
      unfold Rminus.
      apply Rplus_le_compat_l_minus.
      rewrite Rminus_diag.
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      apply pow_le.
      left.
      exact Rlt_0_half.
    }
  Qed.

  Definition crit_test (u : nat->R ) (l e : R) (n:nat) := if Rle_lt_dec (u n) (l - e) then false else true.

  Fixpoint crit (u : nat->R ) (l e : R) (n:nat) := match n with
    | O => R0
    | S n' => if crit_test u l e n' then (/ (IZR 2))^n else R0
    end.

  Lemma crit_partial : forall u l e, Un_partial (crit u l e) u_half_pow.
  Proof.
    intros u l e n.
    destruct n.
    { simpl. left. reflexivity. }
    { simpl. destruct (crit_test u l e n).
      { right. unfold u_half_pow. simpl. reflexivity. }
      { left. reflexivity. }
    }
  Qed.

  Lemma crit_rewrite_l : forall u l e n,
      u n <= l - e -> crit u l e (S n) = R0.
  Proof.
    intros u l e n h.
    simpl.
    unfold crit_test.
    destruct (Rle_lt_dec (u n) (l-e)).
    { reflexivity. }
    { exfalso. eapply Rlt_irrefl_le. exact r. exact h. }
  Qed.

  Lemma crit_rewrite_r : forall u l e n,
      l - e < u n  -> crit u l e (S n) = (/ (IZR 2))^(S n).
  Proof.
    intros u l e n h.
    simpl.
    unfold crit_test.
    destruct (Rle_lt_dec (u n) (l-e)).
    { exfalso. eapply Rlt_irrefl_le. exact h. exact r. }
    { reflexivity. }
  Qed.

  Definition s_crit u l e := serie (crit u l e).

  Lemma crit_bound_l : forall (u : nat -> R) (l e : R) (m n : nat),
    s_crit u l e m <= s_crit u l e (m + n).
  Proof.
    intros u l e m.
    induction n as [ | n i ].
    {
      rewrite<- plus_n_O.
      right.
      reflexivity.
    }
    {
      rewrite <- plus_n_Sm.
      apply Rle_trans with (s_crit u l e (m + n)).
      { exact i. }
      {
        clear i.
        unfold s_crit at 2.
        rewrite serie_Sn.
        apply Rplus_le_compat_0_l.
        apply posn.
        apply pos_partial with u_half_pow.
        { exact u_half_pow_pos. }
        { apply crit_partial. }
      }
    }
  Qed.

  Lemma crit_bound_r : forall (u : nat -> R) (l e : R) (m n : nat),
    s_crit u l e (m + n) <= s_crit u l e m + (/ (IZR 2)) ^ m - (/ (IZR 2)) ^ (m + n).
  Proof.
    intros u l e m n.
    induction n as [ | n i ].
    {
      rewrite<- plus_n_O.
      unfold Rminus.
      rewrite Rplus_assoc.
      rewrite Rplus_opp_r.
      rewrite Rplus_0_r.
      right.
      reflexivity.
    }
    {
      rewrite <- plus_n_Sm.
      simpl.
      {
        unfold s_crit at 1.
        rewrite serie_Sn.
        apply Rplus_le_compat_r_minus.
        apply Rle_trans with (s_crit u l e m + (/ (IZR 2)) ^ m - (/ (IZR 2)) ^ (m + n)).
        { exact i. }
        {
          clear i.
          unfold Rminus.
          repeat (rewrite Rplus_assoc).
          apply Rplus_le_compat_l.
          apply Rplus_le_compat_l.
          rewrite <- Ropp_plus_distr.
          apply Ropp_le_contravar.
          apply Rplus_le_compat_l_minus.
          pose (p:=(/ (IZR 2))^(m+n)).
          fold p.
          unfold Rminus.
          pattern p at 1;rewrite <- Rmult_1_l.
          rewrite Ropp_mult_distr_l.
          rewrite <- Rmult_plus_distr_r.
          rewrite <- half_half.
          rewrite Rplus_assoc.
          rewrite Rplus_opp_r.
          rewrite Rplus_0_r.
          unfold p.
          rewrite tech_pow_Rmult.
          fold (u_half_pow (S (m+n))).
          apply partial_le.
          { apply crit_partial. }
          { apply u_half_pow_pos. }
        }
      }
    }
  Qed.

  Lemma s_crit_pos : forall u l e n, R0 <= s_crit u l e n.
  Proof.
    intros u l e n.
    specialize (crit_bound_l u l e 0 n);intro h.
    simpl in h.
    unfold s_crit at 1 in h.
    simpl in h.
    exact h.
  Qed.

  Lemma crit_bound_O_r : forall u l e n, s_crit u l e n <= R1 - (/ (IZR 2))^n.
  Proof.
    intros u l e n.
    specialize (crit_bound_r u l e 0 n);intro h.
    simpl in h.
    unfold s_crit at 2 in h.
    simpl in h.
    rewrite Rplus_0_l in h.
    exact h.
  Qed.

  Definition crit_exist u l e x := exists n : nat, s_crit u l e n  = x.

  Lemma crit_technic_3 : forall (u : nat -> R) (l e : R),
    is_upper_bound (crit_exist u l e) R0 ->
    forall n : nat, s_crit u l e n = R0.
  Proof.
    intros u l e h n.
    unfold is_upper_bound in h.
    apply Rle_antisym.
    { apply h. unfold crit_exist. exists n. reflexivity. }
    { apply s_crit_pos. }
  Qed.

  Lemma crit_0 : forall u l e n,  crit u l e (S n) = R0 -> u n <= l - e.
  Proof.
    intros u l e n h.
    simpl in h.
    unfold crit_test in h.
    destruct (Rle_lt_dec (u n) (l - e)).
    { assumption. }
    {
      exfalso. apply Rlt_irrefl with R0.
      pattern R0 at 2;rewrite <- h.
      rewrite tech_pow_Rmult.
      apply pow_lt.
      exact Rlt_0_half.
    }
  Qed.

  Lemma crit_0_inv : forall u l e n,  u n <= l - e -> crit u l e (S n) = R0.
  Proof.
    intros u l e n h.
    simpl.
    unfold crit_test.
    destruct (Rle_lt_dec (u n) (l - e)).
    { reflexivity. }
    { exfalso. eapply Rlt_irrefl_le. exact r. exact h. }
  Qed.

  Lemma crit_technic_1 : forall (u : nat -> R) (l e : R),
    (forall n : nat, s_crit u l e n = R0) ->
    forall n : nat, u n <= l - e.
  Proof.
    intros u l e h n.
    induction n as [ | n i ].
    {
      specialize (h 1%nat).
      unfold s_crit in h.
      unfold serie in h.
      rewrite Rplus_0_r in h.
      apply crit_0 in h.
      exact h.
    }
    {
      generalize h;intro hsn;specialize (hsn (S n)).
      generalize h;intro hssn;specialize (hssn (S (S n))).
      unfold s_crit in hssn.
      rewrite serie_Sn in hssn.
      fold (s_crit u l e (S n)) in hssn.
      rewrite hsn in hssn.
      rewrite Rplus_0_l in hssn.
      apply crit_0 in hssn.
      exact hssn.
    }
  Qed.

  Lemma crit_lesn_len: forall (u : nat -> R) (l e : R),
    Un_growing u ->
    forall N : nat, u (S N) <= l - e ->
    u N <= l - e.
  Proof.
    intros u l e hu.
    intros n hn.
    unfold Un_growing in hu.
    apply Rle_trans with (u (S n)).
    - apply hu.
    - assumption.
  Qed.

  Lemma Rlt_abs_half_1 : Rabs (/ (IZR 2)) < R1.
  Proof.
    rewrite Rabs_pos_eq.
    - apply Rlt_half_1.
    - left.
      apply Rlt_0_half.
  Qed.

  Lemma scrit_le_0 : forall (u : nat -> R) (l e : R) (N:nat),
    Un_growing u ->
    u N <= l - e ->
    s_crit u l e N = R0.
  Proof.
      intros.
      induction N as [ | N i ].
      { unfold s_crit. simpl. reflexivity. }
      {
        simpl.
        unfold s_crit.
        rewrite serie_Sn.
        fold (s_crit u l e N).
        rewrite i.
        {
          rewrite Rplus_0_l.
          apply crit_0_inv.
          apply crit_lesn_len.
          { exact H. }
          { exact H0. }
        }
        {
          apply Rle_trans with (u (S N)).
          { apply H. }
          { exact H0. }
        }
      }
  Qed.

  Lemma crit_bounded : forall u l e, bound (crit_exist u l e).
  Proof.
    intros u l e.
    unfold bound.
    exists R1.
    unfold is_upper_bound.
    intros x h.
    unfold crit_exist in h.
    destruct h as [n h].
    rewrite <- h;clear h.
    apply s_half_pow_lt_1_partial.
    apply crit_partial.
  Qed.

  Lemma crit_before_0 : forall u l e N n,
    Un_growing u ->
    u N <= l - e -> (n <= N)%nat ->
    s_crit u l e n = R0.
  Proof.
    intros u l e N n hg hN hn.
    generalize dependent n.
    intro n;induction n as [ | n i ].
    {
      intros hn.
      unfold s_crit. simpl. reflexivity.
    }
    {
      intros hn.
      unfold s_crit.
      rewrite serie_Sn.
      fold (s_crit u l e n).
      rewrite i.
      {
        rewrite Rplus_0_l.
        apply crit_rewrite_l.
        apply Rle_trans with (u N).
        {
          apply growing_prop.
          { exact hg. }
          {
            unfold ge.
            apply le_trans with (S n).
            { constructor. constructor. }
            { exact hn. }
          }
        }
        { exact hN. }
      }
      apply le_trans with (S n).
      { constructor. constructor. }
      { exact hn. }
    }
  Qed.

  Lemma le_0_eq : (forall n, n <= 0 -> n = 0)%nat.
  Proof.
    intros n h.
    inversion h.
    subst n.
    reflexivity.
  Qed.

  (* (/ 2)^n can be made as small as we want *)
  Lemma small_half_pow : forall m : R, R0 < m -> exists n : nat, (/ (IZR 2)) ^ n < m.
  Proof.
    generalize Rgen_half_power;intro rhp.
    intros m hm.
    specialize (rhp m hm).
    destruct rhp as [N h].
    destruct h as [ h | h ].
    { exists N. exact h. }
    {
      subst m.
      exists (S N).
      rewrite <- Rinv_pow.
      2:exact Neq_2_0.
      rewrite <- Rinv_pow.
      2:exact Neq_2_0.
      apply Rinv_lt_contravar.
      1:{
        rewrite <- pow_add.
        apply pow_lt.
        exact Rlt_0_2.
      }
      apply Rlt_pow.
      1:{
        rewrite <- Rinv_involutive.
        2:{ exact Neq_2_0. }
        rewrite <- Rinv_1.
        apply Rinv_lt_contravar.
        1:{ rewrite Rmult_1_r. exact Rlt_0_half. }
        { exact Rlt_half_1. }
      }
      { unfold lt. constructor. }
    }
  Qed.

  Lemma fill_n : (forall n N, n < N -> exists n', n + n' = N)%nat.
  Proof.
    intros n N h.
    generalize dependent n.
    induction n as [ | n i ].
    {
      intro h.
      simpl.
      exists N.
      reflexivity.
    }
    {
      intros h.
      destruct i as [ n' h' ].
      {
        apply lt_trans with (S n).
        { unfold lt. constructor. }
        { exact h. }
      }
      {
        destruct n'.
        {
          rewrite plus_comm in h'.
          simpl in h'.
          subst N.
          exfalso.
          apply lt_irrefl with n.
          apply lt_trans with (S n).
          { unfold lt. constructor. }
          { exact h. }
        }
        {
          exists n'.
          subst N.
          rewrite <- plus_n_Sm.
          rewrite plus_Sn_m.
          reflexivity.
        }
      }
    }
  Qed.

  (* This proof shows that for any positive m and increasing sequence u, if (/2)^n is smaller than m and
     u n is small enough for crit_exist, then (/2)^n is an upper bound of crit_exist. *)
  Lemma crit_technic_d : forall (u : nat -> R) (l e m : R) (n : nat),
    R0 < m ->
    Un_growing u ->
    (/ (IZR 2)) ^ n < m ->
    u n <= l - e ->
    is_upper_bound (crit_exist u l e) ((/ (IZR 2)) ^ n).
  Proof.
    intros u l e m n hm hu hn hun.

    (* Goal : (/2)^n is an upper bound of crit_exist *)

    unfold is_upper_bound.
    (* This means that any x satisfying crit_exist is smaller than (/2)^n *)
    intros x hcrit.
    (* Let x be such that it satisfies crit_exist. Then there is n such that s_crit u l e n = x *)
    destruct hcrit as [ncrit heq].
    subst x.
    (* Because u n <= l - e and u is increasing, s_crit u l e n = 0 *)
    assert (scrit_n_0:s_crit u l e n = R0).
    { apply scrit_le_0. exact hu. exact hun. }
    clear hun.

    (* ncrit can be after or before n *)
    destruct (le_or_lt n ncrit) as [hnn|hnn].
    { (* here, ncrit is after n *)
      apply le_lt_or_eq in hnn.
      destruct hnn.
      {
        apply fill_n in H.
        destruct H.
        subst ncrit.
        apply Rle_trans with (s_crit u l e n + (/ (IZR 2)) ^ n - (/ (IZR 2)) ^ (n + x)).
        { apply crit_bound_r. }
        {
          rewrite scrit_n_0.
          rewrite Rplus_0_l.
          pattern ((/ (IZR 2))^n) at 2;rewrite <- Rplus_0_r.
          apply Rplus_le_compat_l.
          rewrite <- Ropp_0.
          apply Ropp_le_contravar.
          apply pow_le.
          left.
          exact Rlt_0_half.
        }
      }
      {
        subst ncrit.
        rewrite scrit_n_0.
        apply pow_le.
        left.
        exact Rlt_0_half.
      }
    }
    { (* ncrit is before n *)
      (* We go from ncrit to n, then from n to (/2)^n *)
      apply Rle_trans with (s_crit u l e n).
      {
        (* Here, we apply a property of s_crit, which is equivalent to stating that s_crit is increasing *)
        (* We could also prove that because s_crit u l e n = 0 and ncrit < n, then s_crit u l e ncrit = 0 *)
        (* This would be more intuitive *)
        apply fill_n in hnn.
        destruct hnn as [ n' heq ].
        subst n.
        apply crit_bound_l.
      }
      {
        (* 0 <= / 2 *)
        rewrite scrit_n_0.
        apply pow_le.
        left.
        exact Rlt_0_half.
      }
    }
  Qed.

  (* If m is a positive least upper bound of crit_exist and u is increasing, there is N such that u N > l - e *)
  Lemma crit_technic_c : forall (u : nat -> R) (l e m : R),
    Un_growing u ->
    R0 < m ->
    is_lub (crit_exist u l e) m ->
    exists N : nat, l - e < u N .
  Proof.
    intros u l e m hu hm hlub.

    (* Because m is positive, we can find N such that (/ 2)^N < m.
       We don't need any hypothesis on crit_exist for that
     *)
    destruct (small_half_pow m) as [N H4].
    { exact hm. }
    exists N.

    unfold is_lub in hlub.
    apply proj2 in hlub.
    (* We will show that (/2)^N is an upper bound of crit_exist *)
    specialize (hlub ((/ (IZR 2))^N)).

    (* If x < y, then it is not the case that y <= x *)
    apply Rnot_le_lt.
    (* Therefore, we can assume that if x <= y, we get a contradiction *)
    intro h.
    (* Now, if we have x < y in the hypothesis and we need a contradiction, we can try to prove y <= x *)
    eapply Rlt_not_le.
    exact H4.

    apply hlub.
    (* The actual proof that (/2)^N is an upper bound of crit_exist is done in crit_technic_d. *)
    eapply crit_technic_d.
    exact hm.
    exact hu.
    exact H4.
    exact h.
  Qed.

  (* This lemma show that there is a least upper bound of fcrit1 *)
  Lemma lub_of_crit_exist : forall u l e, exists x, is_lub (crit_exist u l e) x.
  Proof.
    intros u l e.
    (* Here, we don't really construct the least upper bound *)
    (* Instead, we use the completeness axiom which states that if fcrit1 is bounded and satisfied for
       at least one number, then the least upper bound exists *)
    apply ex_ex.
    apply completeness.
    { apply crit_bounded. }
    {
      exists R0.
      unfold crit_exist.
      exists 0%nat.
      constructor.
    }
  Qed.

  Lemma crit_flat : forall u l e, is_upper_bound (crit_exist u l e) R0 -> forall n, s_crit u l e n = R0.
  Proof.
    intros u l e h n.
    unfold is_upper_bound in h.
    apply Rle_antisym.
    { apply h. exists n. reflexivity. }
    { apply s_crit_pos. }
  Qed.

  Lemma crit_lub_pos : forall u l e m,
    is_lub (EUn u) l ->
    R0 < e ->
    is_lub (crit_exist u l e) m ->
    R0 < m.
  Proof.
    intros u l e m hlub he h.
    destruct h as [hl hr].
    destruct (Rtotal_order m R0) as [ hm | [ hm | hm ] ].
    { (* m < 0 *)
      exfalso.
      unfold is_upper_bound in hl.
      apply Rlt_not_le in hm.
      apply hm.
      apply hl.
      exists 0%nat.
      unfold s_crit.
      simpl.
      reflexivity.
    }
    { (* m = 0 *)
      subst m.
      exfalso.
      unfold is_lub in hlub.
      destruct hlub as [hlubl hlubr].
      specialize (hlubr (l-e)).
      apply (Rle_not_lt (l-e) l).
      2:{
        pattern l at 2;rewrite <- Rplus_0_r.
        unfold Rminus.
        apply Rplus_lt_compat_l.
        rewrite <- Ropp_0.
        apply Ropp_lt_contravar.
        exact he.
      }
      {
        apply hlubr.
        intros x hex.
        destruct hex as [n eq].
        subst x.
        apply crit_technic_1.
        intro n'.
        apply crit_flat.
        exact hl.
      }
    }
    { exact hm. }
  Qed.

  Lemma Un_cv_crit_lub : forall (U : nat -> R) (l:R), Un_growing U -> is_lub (EUn U) l -> Un_cv U l.
  Proof.
    intros u l hu hul.
    unfold Un_cv.
    intros e he.
    unfold R_dist.

    (* crit_exist has a least upper bound *)
    destruct (lub_of_crit_exist u l e) as [ m hlub].

    (* Given an increasing sequence u and a least upper bound of crit_exist,
        there's a N such that u N > l - e *)
    destruct (crit_technic_c u l e m) as [ N hun ].
    { exact hu. }
    { eapply crit_lub_pos. apply hul. apply he. apply hlub. }
    { exact hlub. }

    (* We just need to show that this N satisfies the goal *)

    exists N.
    intros n hnN.
    unfold R_dist.
    rewrite Rabs_left1.
    2:{
      unfold Rminus.
      apply Rplus_le_reg_r with l.
      rewrite Rplus_assoc.
      rewrite Rplus_opp_l.
      rewrite Rplus_0_l.
      rewrite Rplus_0_r.
      unfold is_lub in hul.
      apply proj1 in hul.
      unfold is_upper_bound in hul.
      apply hul.
      apply Un_in_EUn.
    }
    {
      rewrite Ropp_minus_distr.
      apply Rplus_lt_reg_l with (-e).
      unfold Rminus.
      rewrite <- Rplus_assoc.
      rewrite (Rplus_comm (-e)).
      rewrite Rplus_opp_l.
      apply Rplus_lt_reg_r with (u n).
      rewrite Rplus_0_l.
      rewrite Rplus_assoc.
      rewrite Rplus_opp_l.
      rewrite Rplus_0_r.
      unfold Rminus in hun.
      apply Rlt_le_trans with (u N).
      { assumption. }
      {
        apply growing_prop.
        { assumption. }
        { assumption. }
      }
    }
  Qed.

  Lemma Un_cv_crit : forall u, Un_growing u -> bound (EUn u) ->  exists l : R, Un_cv u l.
  Proof.
    intros u hg hbound.
    destruct (completeness (EUn u)) as [x hlub].
    { exact hbound. }
    { exists (u 0%nat). unfold EUn. exists 0%nat. reflexivity. }
    exists x.
    apply Un_cv_crit_lub.
    { exact hg. }
    { exact hlub. }
  Qed.

  Lemma finite_greater :
    forall (u:nat->R) (N:nat),  exists M : R, (forall n:nat, (n <= N)%nat -> u n <= M).
  Proof.
    intros u N.
    induction N as [ | N i ].
    {
      exists (u 0%nat).
      intros n hn.
      inversion hn. subst n.
      right. reflexivity.
    }
    {
      destruct i as [M h].
      exists (Rmax M (u (S N))).
      intros n hn.
      apply le_lt_or_eq in hn.
      destruct hn as [ hn | hn ].
      { apply Rle_trans with M.
        apply h. unfold lt in hn. apply le_S_n in hn. exact hn.
        apply Rmax_l.
      }
      { subst n. apply Rmax_r. }
    }
  Qed.

  Definition Cauchy_crit_simpl u := forall eps : R, R0 < eps ->
    exists N : nat, forall m : nat, (m >= N)%nat -> R_dist (u N) (u m) < eps.

  Lemma Cauchy_simpler : forall u, Cauchy_crit u -> Cauchy_crit_simpl u.
  Proof.
    intros u h.
    unfold Cauchy_crit_simpl.
    intros e he.
    unfold Cauchy_crit in h.
    specialize (h e he).
    destruct h as [N h].
    exists N.
    intros m hm.
    apply h.
    { unfold ge. constructor. }
    { exact hm. }
  Qed.

  Lemma exists_positive : exists e, R0 < e.
  Proof. exists R1. exact Rlt_0_1. Qed.

  Lemma cauchy_bound : forall u, Cauchy_crit u -> bound (EUn u).
  Proof.
    intro u.
    intros hc.

    apply Cauchy_simpler in hc.

    unfold Cauchy_crit_simpl in hc.

    destruct exists_positive as [e he].

    specialize (hc e).
    specialize (hc he);clear he.
    destruct hc as [ N hc ].

    unfold bound.

    destruct (finite_greater u N) as [ M hM ].
    exists (Rmax M (u N + e)).

    unfold is_upper_bound.
    intros un.
    intros [ n hun ].
    subst un.

    destruct (le_dec N n) as [ hnn | hnn ].
    {

      rewrite Rmax_Rle.
      right.
      apply Rlt_le.

      unfold ge in hc.
      specialize (hc n).
      specialize (hc hnn);clear hnn.
      unfold R_dist in hc.

      apply Rabs_def2 in hc.
      destruct hc as [hl hc];clear hl.

      apply (Rminus_lt (u n) (u N + e)).
      unfold Rminus.
      unfold Rminus in hc.
      apply Rplus_lt_reg_l with (- u n).
      repeat rewrite <- Rplus_assoc, Rplus_opp_l, Rplus_0_l.
      rewrite Ropp_plus_distr.
      apply Rplus_lt_reg_l with (u N).
      repeat rewrite <- Rplus_assoc, Rplus_opp_r, Rplus_0_l.
      rewrite Rplus_0_r.
      exact hc.
    }
    {
      clear hc.
      rewrite Rmax_Rle.
      left.
      apply hM.
      exact hnn.
    }
  Qed.

End sequence.

Section Isequence.
  Variable An : nat -> R.
  Definition Pser (x l:R) : Prop := infinite_sum (fun n:nat => An n * x ^ n) l.
End Isequence.

Definition cstu (x:R) := fun n:nat => x.

Lemma GP_infinite :
  forall x:R, Rabs x < R1 -> Pser (cstu R1) x (/ (R1 - x)).
Proof.
  intros x hx.
  unfold Pser.
  unfold cstu.
  unfold infinite_sum.
  intros e he.
  destruct (Req_dec x R0) as [ heq | hneq ].
  {
    subst x.
    exists 0%nat.
    intros n H2;clear H2.
    rewrite Rminus_0_r.
    rewrite Rinv_1.

    induction n as [ | n i ].
    {
      simpl.
      rewrite Rmult_1_l.
      rewrite R_dist_eq.
      exact he.
    }
    {
      simpl.
      rewrite Rmult_1_l.
      rewrite Rmult_0_l.
      rewrite Rplus_0_r.
      exact i.
    }
  }
  {
    assert (hneqm:R1-x<>R0).
    {
      apply Rminus_eq_contra.
      apply Rlt_dichotomy_converse.
      right.
      apply (Rle_lt_trans x (Rabs x) R1).
      { apply RRle_abs. }
      { exact hx. }
    }
    assert (H2 : R0 < e * (Rabs (R1 - x) * Rabs (/ x))).
    {
      apply Rmult_lt_0_compat.
      { exact he. }
      {
        apply Rmult_lt_0_compat.
        {
          apply Rabs_pos_lt.
          exact hneqm.
        }
        {
          apply Rabs_pos_lt.
          apply Rinv_neq_0_compat.
          exact hneq.
        }
      }
    }
    {
      specialize pow_lt_1_zero as hpow.
      specialize (hpow x).
      specialize (hpow hx).
      specialize (hpow (e * (Rabs (R1 - x) * Rabs (/ x)))).
      specialize (hpow H2).
      destruct hpow as [N H3].
      exists N.
      intros n hnn.
      assert (H5 : sum_f_R0 (fun n0:nat => R1 * x ^ n0) n = sum_f_R0 (fun n0:nat => x ^ n0) n).
      {
        clear hnn.
        induction n as [ | n i ].
        {
          simpl.
          rewrite Rmult_1_l.
          reflexivity.
        }
        {
          simpl.
          rewrite i.
          rewrite Rmult_1_l.
          reflexivity.
        }
      }
      {
        rewrite H5;clear H5.
        apply Rmult_lt_reg_l with (Rabs (R1 - x)).
        {
          apply Rabs_pos_lt.
          exact hneqm.
        }
        {
          unfold R_dist.
          rewrite <- Rabs_mult.
          rewrite Rmult_minus_distr_l.
          assert (H6:
            ((R1 - x) * sum_f_R0 (fun n0:nat => x ^ n0) n =
              - (sum_f_R0 (fun n0:nat => x ^ n0) n * (x - R1)))).
          {
            unfold Rminus.
            rewrite Ropp_mult_distr_r.
            rewrite Ropp_plus_distr.
            rewrite Ropp_involutive.
            rewrite (Rplus_comm (- x)).
            rewrite Rmult_comm.
            reflexivity.
          }
          {
            rewrite H6.
            generalize GP_finite;intro gpf.
            rewrite gpf;clear gpf.
            rewrite Rinv_r.
            {
              assert (H7:(- (x ^ (n + 1) - R1) - R1 = - x ^ (n + 1))).
              {
                unfold Rminus.
                rewrite Ropp_plus_distr.
                rewrite Ropp_involutive.
                rewrite Rplus_assoc.
                rewrite Rplus_opp_r.
                rewrite Rplus_0_r.
                reflexivity.
              }
              {
                rewrite H7.
                rewrite Rabs_Ropp.
                rewrite plus_comm.
                simpl.
                rewrite Rabs_mult.
                apply (Rlt_le_trans _ (Rabs x * (e * (Rabs (R1 - x) * Rabs (/ x)))) _).
                {
                  apply Rmult_lt_compat_l.
                  {
                    apply Rabs_pos_lt.
                    exact hneq.
                  }
                  {
                    apply H3.
                    exact hnn.
                  }
                }
                {
                  assert (H8:
                    (Rabs x * (e * (Rabs (R1 - x) * Rabs (/ x))) =
                      Rabs x * Rabs (/ x) * (e * Rabs (R1 - x)))).
                  {
                    rewrite Rmult_assoc.
                    apply Rmult_eq_compat_l.
                    rewrite <- Rmult_assoc.
                    rewrite Rmult_comm.
                    reflexivity.
                  }
                  {
                    rewrite H8;clear H8.
                    rewrite <- Rabs_mult.
                    rewrite Rinv_r.
                    {
                      rewrite Rabs_R1.
                      rewrite Rmult_1_l.
                      rewrite Rmult_comm.
                      unfold Rle.
                      right.
                      reflexivity.
                    }
                    { exact hneq. }
                  }
                }
              }
            }
            { exact hneqm. }
          }
        }
      }
    }
  }
Qed.

Lemma CV_shift : forall f k l, Un_cv (fun n => f (n + k)%nat) l -> Un_cv f l.
Proof.
  intros f k l h.
  unfold Un_cv.
  intros e he.
  unfold Un_cv in h.
  specialize (h e he).
  destruct h as [ N h ].
  exists (N+k)%nat.
  intros n hn.
  specialize (h (n-k)%nat).
  assert (eqnk: (n = n - k + k)%nat).
  {
    rewrite Nat.sub_add.
    { reflexivity. }
    {
      apply le_trans with (N+k)%nat.
      {
        pattern k at 1;rewrite plus_n_O.
        rewrite plus_comm.
        apply plus_le_compat_r.
        apply le_0_n.
      }
      {
        unfold ge in hn.
        exact hn.
      }
    }
  }
  assert (hn': (n - k >= N)%nat).
  {
    unfold ge.
    unfold ge in hn.
    apply plus_le_reg_l with k.
    rewrite plus_comm.
    rewrite (plus_comm k).
    rewrite <- eqnk.
    exact hn.
  }
  specialize (h hn');clear hn'.
  rewrite <- eqnk in h.
  exact h.
Qed.

Lemma CV_shift' :
  forall f k l, Un_cv f l -> Un_cv (fun n => f (n + k)%nat) l.
Proof.
  intros f k l h.
  unfold Un_cv.
  intros e he.
  unfold Un_cv in h.
  specialize (h e he).
  destruct h as [ N h ].
  exists N.
  intros n hn.
  apply h.
  unfold ge.
  apply le_trans with n.
  { unfold ge in hn. exact hn. }
  { apply Nat.le_add_r. }
Qed.

Lemma Un_growing_shift :
   forall k un, Un_growing un -> Un_growing (fun n => un (n + k)%nat).
Proof.
  intros k u h.
  unfold Un_growing.
  intros n.
  unfold Un_growing in h.
  rewrite plus_Sn_m.
  apply h.
Qed.


Add LoadPath "../..".
Require Import Setoid.
Require Export LibTactics.
Require Export PermutLib.
Require Export LFND_Shared.

Open Scope permut_scope.

Inductive PPermut_LF: list ctx_LF -> list ctx_LF -> Type :=
| PPermut_LF_nil: PPermut_LF nil nil
| PPermut_LF_skip: forall G G' A A',
  A *=* A' -> PPermut_LF G G' -> PPermut_LF (A::G) (A'::G')
| PPermut_LF_swap: forall G A A' B B',
  A *=* A' -> B *=* B' -> PPermut_LF (A::B::G) (B'::A'::G)
| PPermut_LF_trans: forall G G' G'',
  PPermut_LF G G' -> PPermut_LF G' G'' -> PPermut_LF G G''
.
Hint Resolve PPermut_LF_nil PPermut_LF_skip PPermut_LF_swap.
Hint Constructors PPermut_LF : ppermut_rew.

Notation "G ~=~ G'" := (PPermut_LF G G') (at level 70).

Lemma PPermut_LF_reflexive:
   forall G, G ~=~ G.
induction G; eauto.
Qed.

Lemma PPermut_LF_symmetric:
  forall G G', G ~=~ G' -> G' ~=~ G.
intros;
induction H; eauto with ppermut_rew.
  apply PPermut_LF_trans with (G':=A'::G); eauto with ppermut_rew;
  apply PPermut_LF_skip;
  [ apply permut_sym |
    apply PPermut_LF_reflexive];
  auto.
  apply PPermut_LF_swap; apply permut_sym; assumption.
Qed.

Lemma PPermut_LF_transitive:
  forall G0 G1 G2,
    G0 ~=~ G1 -> G1 ~=~ G2 -> G0 ~=~ G2.
exact PPermut_LF_trans.
Qed.
Hint Resolve PPermut_LF_reflexive PPermut_LF_symmetric.

Lemma PPermut_LF_cons:
forall x y L1 L2,
  x *=* y ->
  L1 ~=~ L2 ->
  x :: L1 ~=~ y::L2.
intros. constructor; auto.
Qed.
Hint Resolve PPermut_LF_cons.

Lemma PPermut_LF_app_tail:
forall G G' G0,
  G ~=~ G' ->
  G ++ G0 ~=~ G' ++ G0.
intros; induction H; simpl; rew_app; auto;
econstructor; eauto.
Qed.

Lemma PPermut_LF_app_head:
forall G0 G G',
  G ~=~ G' ->
  G0 ++ G ~=~ G0 ++ G'.
intros; induction G0; simpl; rew_app; auto.
Qed.
Hint Resolve PPermut_LF_app_tail PPermut_LF_app_head.

(*
Add Morphism (@append ctx_LF) : PPermut_LF_app.
*)
Lemma PPermut_LF_app:
forall G G' y y0,
  G ~=~ G' -> y ~=~ y0 ->
  G ++ y ~=~ G' ++ y0.
intros; induction H; simpl in *; rew_app; auto.
apply PPermut_LF_transitive with (G1:= (A'::B'::G ++ y0)); eauto.
apply PPermut_LF_transitive with  (G' ++ y0); auto.
Qed.
Hint Resolve PPermut_LF_app.

Ltac transitivityP G := apply PPermut_LF_transitive with (G1:=G).
Ltac symmetryP := apply PPermut_LF_symmetric.
Ltac reflexivityP := apply PPermut_LF_reflexive.

Theorem PPermut_LF_app_comm:
forall G1 G2,
  G1 ++ G2 ~=~ G2 ++ G1.
induction G1; intros; simpl; rew_app;
[ auto |
 induction G2]; simpl in *;
[ rewrite app_nil_r; auto | ].
transitivityP (a :: a0 :: G2 ++ G1);
[ constructor; auto; apply IHG1 |
  transitivityP (a0 :: a :: G2 ++ G1); auto];
constructor; auto;
transitivityP (a :: G1 ++ G2); auto.
Qed.
Hint Resolve PPermut_LF_app_comm.

(*** Automation **)
(* Based on permutation tactics from tlc's LibListSorted *)

Lemma PPermut_LF_get_1 : forall l1 l2,
  PPermut_LF (l1 ++ l2) (l1 ++ l2).
auto.
Qed.

Lemma PPermut_LF_get_2 : forall l1 l2 l3,
  PPermut_LF (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3).
intros.
assert (l1 ++ l2 ~=~ l2 ++ l1) as H by auto;
transitivityP ((l1 ++ l2) ++ l3). rew_app; auto.
transitivityP ((l2++l1)++l3). apply PPermut_LF_app; auto.
rew_app. auto.
Qed.

Lemma PPermut_LF_get_3 : forall l1 l2 l3 l4,
  PPermut_LF (l1 ++ l2 ++ l3 ++ l4) (l2 ++ l3 ++ l1 ++ l4).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_LF_get_2.
Qed.

Lemma PPermut_LF_get_4 : forall l1 l2 l3 l4 l5,
  PPermut_LF (l1 ++ l2 ++ l3 ++ l4 ++ l5)
         (l2 ++ l3 ++ l4 ++ l1 ++ l5).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_LF_get_3.
Qed.

Lemma PPermut_LF_get_5 : forall l1 l2 l3 l4 l5 l6,
  PPermut_LF (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6)
         (l2 ++ l3 ++ l4 ++ l5 ++ l1 ++ l6).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_LF_get_4.
Qed.

Lemma PPermut_LF_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
  PPermut_LF (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l7)
         (l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l1 ++ l7).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_LF_get_5.
Qed.

Lemma PPermut_LF_tactic_setup : forall l1 l2,
  PPermut_LF (nil ++ l1 ++ nil) (l2 ++ nil) -> PPermut_LF l1 l2.
intros; rew_app in *; auto.
Qed.

Lemma PPermut_LF_tactic_keep : forall l1 l2 l3 l4,
  PPermut_LF ((l1 ++ l2) ++ l3) l4 ->
  PPermut_LF (l1 ++ (l2 ++ l3)) l4.
intros; rew_app in *; auto.
Qed.

Lemma PPermut_LF_tactic_simpl : forall l1 l2 l3 l4,
  PPermut_LF (l1 ++ l3) l4 ->
  PPermut_LF (l1 ++ (l2 ++ l3)) (l2 ++ l4).
intros. transitivityP (l2 ++ l1 ++ l3).
apply PPermut_LF_get_2.
apply PPermut_LF_app; auto.
Qed.

Lemma PPermut_LF_tactic_trans : forall l1 l2 l3,
  PPermut_LF l3 l2 -> PPermut_LF l1 l3 -> PPermut_LF l1 l2.
intros; eauto with ppermut_rew.
Qed.

Hint Rewrite app_assoc app_nil_l app_nil_r : ppermut_rew.

Ltac PPermut_LF_lemma_get n :=
  match nat_from_number n with
  | 1 => constr:(PPermut_LF_get_1)
  | 2 => constr:(PPermut_LF_get_2)
  | 3 => constr:(PPermut_LF_get_3)
  | 4 => constr:(PPermut_LF_get_4)
  | 5 => constr:(PPermut_LF_get_5)
  end.

Ltac PPermut_LF_isolate_cons :=
  do 20 try (* todo : repeat *)
    match goal with |- context [?x::?l] =>
      match l with
      | nil => fail 1
      | _ => rewrite <- (@app_cons_one _ x l)
      end
    end.

Ltac PPermut_LF_simpl_prepare :=
   autorewrite with ppermut_rew;
   PPermut_LF_isolate_cons;
   autorewrite with ppermut_rew;
   apply PPermut_LF_tactic_setup;
   repeat rewrite app_assoc.

Ltac PPermut_LF_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l ++ _ => constr:(1)
  | _ ++ l ++ _ => constr:(2)
  | _ ++ _ ++ l ++ _ => constr:(3)
  | _ ++ _ ++ _ ++ l ++ _ => constr:(4)
  | _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(5)
  | _ ++ _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(6)
  | _ => constr:(0) (* not found *)
  end.

Ltac PPermut_LF_simpl_once :=
  match goal with
  | |- PPermut_LF (_ ++ nil) _ => fail 1
  | |- PPermut_LF (_ ++ (?l ++ _)) ?l' =>
     match PPermut_LF_index_of l l' with
     | 0 => apply PPermut_LF_tactic_keep
     | ?n => let F := PPermut_LF_lemma_get n in
            eapply PPermut_LF_tactic_trans;
            [ apply F
            | apply PPermut_LF_tactic_simpl ]
     end
  end.

Ltac PPermut_LF_simpl :=
  PPermut_LF_simpl_prepare;
  repeat PPermut_LF_simpl_once;
  autorewrite with ppermut_rew;
  try apply PPermut_LF_reflexive;
  auto.

(*** Other lemmas ***)
(* Note:
   Some are covered by PPermut_LF_simpl tactic,
   but we want to use them in auto! *)

(* THE troublemaker -- reason why PPermut is Type, not Prop *)
Lemma PPermut_LF_Mem:
forall G G' X,
  G ~=~ G' ->
  Mem X G ->
  {X' | X' *=* X /\ Mem X' G'}.
assert ( ∀ k k' : list (var * ty), {k = k'} + {k ≠ k'}).
intros; decide equality; destruct a; destruct p; decide equality;
try apply eq_var_dec; try apply eq_ty_dec.
intros; generalize dependent X; induction H0; intros.
rewrite Mem_nil_eq in H1; contradiction.
apply Mem_cons_spec in H1; auto. destruct H1.
subst; exists A'; split; [ symmetry | apply Mem_here]; auto.
apply IHPPermut_LF in m; destruct m as (Gamma''); exists Gamma'';
destruct a; split; auto; rewrite Mem_cons_eq; right; auto.
apply Mem_cons_spec in H1; auto. destruct H1.
subst; exists A'; split; [ symmetry | rewrite Mem_cons_eq];
auto; right; apply Mem_here.
apply Mem_cons_spec in m; auto. destruct m.
subst; exists B'; split; [ symmetry | rewrite Mem_cons_eq];
auto.
exists X; split; auto; repeat rewrite Mem_cons_eq; right; right; auto.
apply IHPPermut_LF1 in H1; destruct H1 as (X'); destruct a.
apply IHPPermut_LF2 in H1; destruct H1 as (X''); destruct a;
exists X''; split; auto; transitivity X'; auto.
Qed.

Lemma PPermut_LF_nil_impl:
forall L,
  nil ~=~ L -> L = nil.
intros; remember (@nil ctx_LF) as L' in H;
induction H; intros;
discriminate || auto.
Qed.

Lemma PPermut_LF_nil_contr:
forall L a,
  PPermut_LF nil (a::L) -> False.
induction L; intros;
apply PPermut_LF_nil_impl in H; discriminate.
Qed.

Hint Resolve PPermut_LF_nil_impl PPermut_LF_nil_contr.

(* Based on Sorting/Permutation/Permutation_ind_bis *)
Theorem PPermut_LF_ind_bis :
 forall P : list ctx_LF -> list ctx_LF -> Type,
   P nil nil ->
   (forall x y l l', l ~=~ l' -> P l l' ->
     x *=* y -> P (x :: l) (y :: l')) ->
   (forall x x' y y' l l', l ~=~ l' -> P l l' -> x *=* x' -> y *=* y' ->
     P (y :: x :: l) (x' :: y' :: l')) ->
   (forall l l' l'', l ~=~ l' -> P l l' -> l' ~=~ l'' -> P l' l'' -> P l l'') ->
   forall l l', l ~=~ l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans;
  intros; induction H; auto.
  apply Htrans with (B :: A :: G); auto.
    apply Hswap; auto; induction G; auto.
    apply Hskip; auto; apply Hskip; auto; induction G; auto;
    destruct a; apply Hskip; auto.
  eauto.
Qed.

Lemma PPermut_LF_app_rev:
forall G G' H H' a a',
  a *=* a' ->
  G & a ++ G' ~=~ H & a' ++ H' ->
  G ++ G' ~=~ H ++ H'.
Proof.
  set (P l l' :=
         forall a a' l1 l2 l3 l4, a *=* a' ->
         l=l1 & a ++ l2 -> l'=l3 & a' ++l4 -> (l1++l2) ~=~ (l3++l4)).
  cut (forall l l', l ~=~ l' -> P l l').
  intros; apply (H _ _ H2 a a'); auto.
  intros; apply (PPermut_LF_ind_bis P); unfold P; clear P;
    try clear H l l'; simpl; auto.
  (* nil *)
  intros; destruct l1; simpl in *; discriminate.
  (* skip *)
  intros x y l l' H IH; intros.
  destruct l1; destruct l3; rew_app in *;
  inversion H2; inversion H3; subst; auto.
    symmetryP; transitivityP (l3 ++ a' :: l4); auto.
    PPermut_LF_simpl; constructor; [transitivity a |] ; auto;
      symmetry; auto.
    symmetryP; transitivityP (l1 ++ a :: l2); auto.
    PPermut_LF_simpl; constructor; auto; transitivity a';
      [ | symmetry]; auto.
  constructor; auto.
  apply (IH a a' l1 l2 l5 l4); rew_app; auto.
  (* swap *)
  intros x x' y y' l l' Hp IH; intros.
  destruct l1; destruct l2; rew_app in *; subst;
  inversion H2; subst; auto; try rewrite Hp; rew_app;
  PPermut_LF_simpl; destruct l3; destruct l4; rew_app in *; subst;
  inversion H3; subst; auto.
    constructor; auto; transitivity a'; auto; transitivity a; auto;
    symmetry; auto.
    constructor; auto; destruct l3; rew_app in *; inversion H6; subst; auto;
      PPermut_LF_simpl. transitivityP (l3 & a'); auto. PPermut_LF_simpl;
    constructor; auto; transitivity a; auto; symmetry; auto.
    constructor; auto; destruct l3; rew_app in *; inversion H6; subst; auto;
      PPermut_LF_simpl. transitivityP (l5 ++ a' :: l1 :: l4); auto.
      PPermut_LF_simpl; constructor; auto; transitivity a; auto; symmetry; auto.
    constructor; auto; destruct l1; rew_app in *; inversion H6; subst; auto;
      PPermut_LF_simpl. transitivityP (l3 & a); auto. PPermut_LF_simpl;
    constructor; auto; transitivity a; auto; symmetry; auto.
    symmetry; rewrite H1; auto.
  destruct l1; destruct l3; rew_app in *; inversion H6; inversion H7; subst.
      constructor; auto; transitivity a'; auto; transitivity a; auto;
        symmetry; auto.
       apply PPermut_LF_nil_impl in Hp; destruct l3; rew_app in *; discriminate.
       apply PPermut_LF_symmetric in Hp; apply PPermut_LF_nil_impl in Hp;
       destruct l4; rew_app in *;
         discriminate.
       clear H2 H3 H6 H7.
       transitivityP (l3 :: l2 :: l4).
         constructor; [ | constructor]; auto.
         PPermut_LF_simpl.
       replace l4 with (l4 ++ nil) by (rew_app; auto);
       replace l5 with (l5 ++ nil) by (rew_app; auto);
       apply IH with (a0:=a) (a'0:=a'); auto;
         rew_app; auto.
  destruct l1; destruct l3; rew_app in *; inversion H6; inversion H7; subst;
    auto.
       apply PPermut_LF_nil_impl in Hp; discriminate.
       apply PPermut_LF_nil_impl in Hp; destruct l3; rew_app in *; discriminate.
       transitivityP (l2::l6 & a); PPermut_LF_simpl; rew_app;
       apply PPermut_LF_swap;
       [ transitivity a' | ]; auto; symmetry; auto;
       clear H7 H3 H2 H6;
       transitivity (l2::l3::l6); auto; PPermut_LF_simpl; rew_app;
       replace l6 with (l6 ++ nil) by (rew_app; auto);
       apply IH with (a0:=a) (a'0:=a'); auto;
         rew_app; auto.
    transitivityP (l1::l0::l6); [PPermut_LF_simpl|];
    constructor; auto; constructor; auto;
    replace l6 with (l6++nil) by (rew_app; auto);
    apply IH with (a0:=a)(a'0:=a'); eauto;
    rew_app; auto.
  transitivityP (l3::l); symmetryP; destruct l1; rew_app in *;
    inversion H6; subst; auto; PPermut_LF_simpl; constructor; auto.
    symmetry; auto.
    constructor; auto; transitivity a'; [ | symmetry]; auto.
  destruct l6; rew_app in *; inversion H7; subst.
    apply PPermut_LF_symmetric in Hp; apply PPermut_LF_nil_impl in Hp;
    subst; inversion H6; subst;
      destruct l1; rew_app in *; inversion H6; subst; destruct l1; rew_app in *;
      discriminate.
    transitivityP (l4 ::l1 ++ l2 :: l5); PPermut_LF_simpl; rew_app.
    destruct l1; rew_app in *; inversion H6; subst.
      transitivityP (l6 & a'); auto. PPermut_LF_simpl.
      constructor; auto;
      transitivity a; auto;
      symmetry; auto.
      constructor; auto; replace l6 with (l6 ++ nil) by (rew_app; auto);
      apply IH with (a0:=a) (a'0:=a'); auto; rew_app; auto.
  destruct l1; destruct l6; rew_app in *; inversion H6;
  inversion H7; subst.
    constructor; auto; transitivity a; auto; transitivity a'; auto;
    symmetry; auto.
    transitivityP (l1:: l2 :: l5).
      constructor; auto.
      PPermut_LF_simpl. rew_app; transitivityP (l6 ++ a' :: l4 :: l7); auto;
                        PPermut_LF_simpl;
      constructor; auto; transitivity a; auto; symmetry; auto.
    transitivityP (l1::l4::l7).
      PPermut_LF_simpl; rew_app. transitivityP (l8 ++ a :: l2 :: l5); auto;
      PPermut_LF_simpl; constructor;
        auto. transitivity a'; auto; symmetry; auto.
      constructor; auto.
    transitivityP (l6 :: l3 :: l8 ++ l2 :: l5).
      constructor; auto; constructor; auto.
      PPermut_LF_simpl. rew_app.
    apply IH with (a0:=a) (a'0:=a'); rew_app; auto.
  (* trans *)
  intros. destruct (PPermut_LF_Mem l l' a) as (a'', (H6a, H6b)); auto.
    subst; rewrite Mem_app_or_eq; left; rewrite Mem_app_or_eq; right;
      apply Mem_here.
  destruct (Mem_split_spec ctx_LF l' a'') as (l'1, (l'2, H6)); auto.
  intros; decide equality; destruct p; destruct a0; decide equality;
  try apply eq_var_dec; try apply eq_ty_dec.
  transitivityP (l'1 ++ l'2).
    apply H0 with (a:=a) (a':=a''); [ symmetry | | ]; auto.
    apply H2 with (a:=a'') (a':=a').
      transitivity a; auto; symmetry; auto.
      auto.
      auto.
Qed.

Lemma PPermut_LF_last_rev_simpl:
forall G G' a,
  G & a ~=~ G' & a ->
  G ~=~ G'.
intros. replace G with (G ++ nil) by (rew_app; auto);
replace G' with (G'++nil) by (rew_app; auto);
apply PPermut_LF_app_rev with (a:=a) (a':=a);
rew_app; eauto.
Qed.

Lemma PPermut_LF_last_rev:
forall G G' Gamma Gamma',
  Gamma *=* Gamma' ->
  G & Gamma ~=~ G' & Gamma' ->
  G ~=~ G'.
intros;
assert (G & Gamma ~=~ G' & Gamma) by eauto with ppermut_rew;
apply PPermut_LF_last_rev_simpl with (a:=Gamma); auto.
Qed.

Lemma PPermut_LF_swap2:
forall C C' G,
  C :: G & C' ~=~ G & C & C'.
intros; PPermut_LF_simpl.
Qed.
Hint Resolve PPermut_LF_swap2.

Lemma PPermut_LF_middle_last:
forall G G' C,
  G ++ G' & C ~=~ G ++ C :: G'.
intros; PPermut_LF_simpl.
Qed.
Hint Resolve PPermut_LF_middle_last.

Lemma PPermut_LF_specialized1:
forall G G' C C',
  G ++ C :: G' & C' ~=~ G ++ G' ++ C' :: C :: nil.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_specialized2:
forall GH GT G Gamma Gamma' Gamma'',
  GH ++ Gamma :: GT & Gamma' ~=~ G & Gamma ->
  GH ++ GT ++ Gamma'' :: Gamma' :: nil ~=~ G & Gamma''.
intros; PPermut_LF_simpl;
apply PPermut_LF_last_rev_simpl with (a:=Gamma).
transitivityP (GH ++ Gamma :: GT & Gamma'); auto.
PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_specialized3:
forall G G' C C',
  G ++ G' ++ C :: C' :: nil ~=~ G ++ C :: G' & C'.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_specialized4:
forall G GH GT Gamma Gamma0 Gamma'0,
  GH ++ Gamma :: GT & Gamma'0 ~=~ G & Gamma ->
  G ++ Gamma0 :: Gamma :: nil ~=~ GH ++ GT ++ Gamma0 :: Gamma'0 :: Gamma :: nil.
intros; PPermut_LF_simpl;
apply PPermut_LF_last_rev_simpl with (a:=Gamma).
transitivityP (GH ++ Gamma :: GT & Gamma'0); auto;
PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_specialized5:
forall G G' C C' C'',
  G ++ C :: G' ++ C' :: C'' :: nil ~=~ (G ++ G' ++ C' :: C'' :: nil) & C.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_specialized6:
forall GH GT C0 C'' C'0,
  GH ++ GT ++ C'0 :: C'' :: C0 :: nil ~=~ GH ++ GT ++ C0 :: C'0 :: C'' :: nil.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_swap_inner:
forall G G' C C',
  C :: G ++ C' :: G' ~=~ C' :: G ++ G' & C.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_swap_inner2:
forall G G' C C',
  C :: G ++ G' & C' ~=~ C' :: G ++ G' & C.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_swap3:
forall C C' G,
  C :: G & C' ~=~ C' :: G & C.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_swap4:
forall C G' G,
  G ++ G' & C ~=~ G & C ++ G'.
intros; PPermut_LF_simpl.
Qed.

Hint Resolve PPermut_LF_swap_inner.
Hint Resolve PPermut_LF_swap_inner2.
Hint Resolve PPermut_LF_swap3 PPermut_LF_swap4.

Hint Resolve PPermut_LF_specialized2 : ppermut_rew.

Hint Resolve PPermut_LF_specialized1
             PPermut_LF_specialized3 PPermut_LF_specialized4
             PPermut_LF_specialized5 PPermut_LF_specialized6.

Lemma PPermut_LF_first_last:
forall c G,
  c::G ~=~ G & c.
intros; PPermut_LF_simpl.
Qed.

Lemma PPermut_LF_split_head_T:
forall G G' Gamma,
  Gamma :: G ~=~ G' ->
  { t | Gamma *=* (fst (fst t)) /\
        G' = (snd (fst t)) & (fst (fst t)) ++ (snd t)}.
intros.
apply PPermut_LF_Mem with (X:=Gamma) in H.
destruct H as (Gamma'); destruct a.
assert (  sigT (fun hd =>
      sigT (fun tl => G' = hd & Gamma' ++ tl))).
 eapply Mem_split_spec; auto; intros; decide equality; destruct a;
 decide equality; try apply eq_var_dec; try apply eq_ty_dec.
destruct H1 as (hd, (tl, H1)).
exists (Gamma', hd, tl); split; simpl; [symmetry | ]; auto.
apply Mem_here.
Qed.

Lemma PPermut_LF_split_neq_T:
forall G G' Gamma Gamma',
  G & Gamma ~=~ G' & Gamma' ->
  ~Gamma *=* Gamma' ->
  { t | fst (fst t) *=* Gamma' /\
        G = snd (fst t) & fst (fst t) ++ (snd t)}.
intros.
assert (Gamma ::G  ~=~ (G' & Gamma')) by
  (transitivityP (G & Gamma); auto; PPermut_LF_simpl).
assert (Gamma :: G ~=~ Gamma' :: G') by
  (transitivityP (G' & Gamma'); auto; PPermut_LF_simpl).
apply PPermut_LF_symmetric in H2;
apply PPermut_LF_split_head_T in H2; destruct H2 as (t, (Ha, Hb));
destruct t as (t', GT); destruct t' as (Gamma'', GH); simpl in *.
destruct GH; rew_app in *.
inversion Hb; subst. elim H0; symmetry; auto.
inversion Hb; subst.
exists (Gamma'', GH, GT); split; simpl;
[symmetry | rew_app]; auto.
Qed.

Lemma PPermut_concat_permut:
forall G G',
  G ~=~ G' -> concat G *=* concat G'.
induction G; intros.
apply PPermut_LF_nil_impl in H; subst; auto.
assert (a::G ~=~ G') by auto;
apply PPermut_LF_split_head_T in H;
destruct H as (t, (H, H1)); destruct t as (t', tl); destruct t' as (a', hd).
subst; rew_concat.
assert (G ~=~ hd ++ tl).
  apply PPermut_LF_last_rev with (Gamma:=a) (Gamma':=a'); auto; simpl in *;
    transitivityP (a::G). PPermut_LF_simpl. transitivityP (hd & a' ++ tl); auto;
                                            PPermut_LF_simpl.
specialize IHG with (G':=hd++tl); apply IHG in H1.
rew_concat in *. rewrite H1; rewrite H; permut_simpl.
Qed.

Close Scope permut_scope.