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

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import Classical.
Require Import Max.
Open Local Scope R_scope.

(*****************************************************************)
(**           Convergence properties of sequences                *)
(*****************************************************************)

Definition Un_decreasing (Un:nat -> R) : Prop :=
  forall n:nat, Un (S n) <= Un n.
Definition opp_seq (Un:nat -> R) (n:nat) : R := - Un n.
Definition has_ub (Un:nat -> R) : Prop := bound (EUn Un).
Definition has_lb (Un:nat -> R) : Prop := bound (EUn (opp_seq Un)).

(**********)
Lemma growing_cv :
  forall Un:nat -> R, Un_growing Un -> has_ub Un -> { l:R | Un_cv Un l }.
Proof.
  unfold Un_growing, Un_cv in |- *; intros;
    destruct (completeness (EUn Un) H0 (EUn_noempty Un)) as [x [H2 H3]].
  exists x; intros eps H1.
  unfold is_upper_bound in H2, H3.
  assert (H5 : forall n:nat, Un n <= x).
  intro n; apply (H2 (Un n) (Un_in_EUn Un n)).
  cut (exists N : nat, x - eps < Un N).
  intro H6; destruct H6 as [N H6]; exists N.
  intros n H7; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
  unfold Rgt in H1.
  apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H1).
  fold Un_growing in H; generalize (growing_prop Un n N H H7); intro H8.
  generalize
    (Rlt_le_trans (x - eps) (Un N) (Un n) H6 (Rge_le (Un n) (Un N) H8));
    intro H9; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
      unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
        rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
          rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
            trivial.
  cut (~ (forall N:nat, Un N <= x - eps)).
  intro H6; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)).
  intro H7; apply H6; intro N; apply Rnot_lt_le; apply H7.
  intro H7; generalize (Un_bound_imp Un (x - eps) H7); intro H8;
    unfold is_upper_bound in H8; generalize (H3 (x - eps) H8);
      apply Rlt_not_le; apply tech_Rgt_minus; exact H1.
Qed.

Lemma decreasing_growing :
  forall Un:nat -> R, Un_decreasing Un -> Un_growing (opp_seq Un).
Proof.
  intro.
  unfold Un_growing, opp_seq, Un_decreasing in |- *.
  intros.
  apply Ropp_le_contravar.
  apply H.
Qed.

Lemma decreasing_cv :
  forall Un:nat -> R, Un_decreasing Un -> has_lb Un -> { l:R | Un_cv Un l }.
Proof.
  intros.
  cut ({ l:R | Un_cv (opp_seq Un) l } -> { l:R | Un_cv Un l }).
  intro X.
  apply X.
  apply growing_cv.
  apply decreasing_growing; assumption.
  exact H0.
  intro X.
  elim X; intros.
  exists (- x).
  unfold Un_cv in p.
  unfold R_dist in p.
  unfold opp_seq in p.
  unfold Un_cv in |- *.
  unfold R_dist in |- *.
  intros.
  elim (p eps H1); intros.
  exists x0; intros.
  assert (H4 := H2 n H3).
  rewrite <- Rabs_Ropp.
  replace (- (Un n - - x)) with (- Un n - x); [ assumption | ring ].
Qed.

(***********)
Lemma ub_to_lub :
  forall Un:nat -> R, has_ub Un -> { l:R | is_lub (EUn Un) l }.
Proof.
  intros.
  unfold has_ub in H.
  apply completeness.
  assumption.
  exists (Un 0%nat).
  unfold EUn in |- *.
  exists 0%nat; reflexivity.
Qed.

(**********)
Lemma lb_to_glb :
  forall Un:nat -> R, has_lb Un -> { l:R | is_lub (EUn (opp_seq Un)) l }.
Proof.
  intros; unfold has_lb in H.
  apply completeness.
  assumption.
  exists (- Un 0%nat).
  exists 0%nat.
  reflexivity.
Qed.

Definition lub (Un:nat -> R) (pr:has_ub Un) : R :=
  let (a,_) := ub_to_lub Un pr in a.

Definition glb (Un:nat -> R) (pr:has_lb Un) : R :=
  let (a,_) := lb_to_glb Un pr in - a.

(* Compatibility with previous unappropriate terminology *)
Notation maj_sup := ub_to_lub (only parsing).
Notation min_inf := lb_to_glb (only parsing).
Notation majorant := lub (only parsing).
Notation minorant := glb (only parsing).

Lemma maj_ss :
  forall (Un:nat -> R) (k:nat),
    has_ub Un -> has_ub (fun i:nat => Un (k + i)%nat).
Proof.
  intros.
  unfold has_ub in H.
  unfold bound in H.
  elim H; intros.
  unfold is_upper_bound in H0.
  unfold has_ub in |- *.
  exists x.
  unfold is_upper_bound in |- *.
  intros.
  apply H0.
  elim H1; intros.
  exists (k + x1)%nat; assumption.
Qed.

Lemma min_ss :
  forall (Un:nat -> R) (k:nat),
    has_lb Un -> has_lb (fun i:nat => Un (k + i)%nat).
Proof.
  intros.
  unfold has_lb in H.
  unfold bound in H.
  elim H; intros.
  unfold is_upper_bound in H0.
  unfold has_lb in |- *.
  exists x.
  unfold is_upper_bound in |- *.
  intros.
  apply H0.
  elim H1; intros.
  exists (k + x1)%nat; assumption.
Qed.

Definition sequence_ub (Un:nat -> R) (pr:has_ub Un)
  (i:nat) : R := lub (fun k:nat => Un (i + k)%nat) (maj_ss Un i pr).

Definition sequence_lb (Un:nat -> R) (pr:has_lb Un)
  (i:nat) : R := glb (fun k:nat => Un (i + k)%nat) (min_ss Un i pr).

(* Compatibility *)
Notation sequence_majorant := sequence_ub (only parsing).
Notation sequence_minorant := sequence_lb (only parsing).

Lemma Wn_decreasing :
  forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr).
Proof.
  intros.
  unfold Un_decreasing in |- *.
  intro.
  unfold sequence_ub in |- *.
  assert (H := ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
  assert (H0 := ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
  elim H; intros.
  elim H0; intros.
  cut (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x);
    [ intro Maj1; rewrite Maj1 | idtac ].
  cut (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0);
    [ intro Maj2; rewrite Maj2 | idtac ].
  unfold is_lub in p.
  unfold is_lub in p0.
  elim p; intros.
  apply H2.
  elim p0; intros.
  unfold is_upper_bound in |- *.
  intros.
  unfold is_upper_bound in H3.
  apply H3.
  elim H5; intros.
  exists (1 + x2)%nat.
  replace (n + (1 + x2))%nat with (S n + x2)%nat.
  assumption.
  replace (S n) with (1 + n)%nat; [ ring | ring ].
  cut
    (is_lub (EUn (fun k:nat => Un (n + k)%nat))
      (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))).
  intro.
  unfold is_lub in p0; unfold is_lub in H1.
  elim p0; intros; elim H1; intros.
  assert (H6 := H5 x0 H2).
  assert
    (H7 := H3 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4).
  apply Rle_antisym; assumption.
  unfold lub in |- *.
  case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
  trivial.
  cut
    (is_lub (EUn (fun k:nat => Un (S n + k)%nat))
      (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))).
  intro.
  unfold is_lub in p; unfold is_lub in H1.
  elim p; intros; elim H1; intros.
  assert (H6 := H5 x H2).
  assert
    (H7 :=
      H3 (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4).
  apply Rle_antisym; assumption.
  unfold lub in |- *.
  case (ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
  trivial.
Qed.

Lemma Vn_growing :
  forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_lb Un pr).
Proof.
  intros.
  unfold Un_growing in |- *.
  intro.
  unfold sequence_lb in |- *.
  assert (H := lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
  assert (H0 := lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
  elim H; intros.
  elim H0; intros.
  cut (glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr) = - x);
    [ intro Maj1; rewrite Maj1 | idtac ].
  cut (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr) = - x0);
    [ intro Maj2; rewrite Maj2 | idtac ].
  unfold is_lub in p.
  unfold is_lub in p0.
  elim p; intros.
  apply Ropp_le_contravar.
  apply H2.
  elim p0; intros.
  unfold is_upper_bound in |- *.
  intros.
  unfold is_upper_bound in H3.
  apply H3.
  elim H5; intros.
  exists (1 + x2)%nat.
  unfold opp_seq in H6.
  unfold opp_seq in |- *.
  replace (n + (1 + x2))%nat with (S n + x2)%nat.
  assumption.
  replace (S n) with (1 + n)%nat; [ ring | ring ].
  cut
    (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
      (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))).
  intro.
  unfold is_lub in p0; unfold is_lub in H1.
  elim p0; intros; elim H1; intros.
  assert (H6 := H5 x0 H2).
  assert
    (H7 := H3 (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)) H4).
  rewrite <-
    (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)))
    .
  apply Ropp_eq_compat; apply Rle_antisym; assumption.
  unfold glb in |- *.
  case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)); simpl.
  intro; rewrite Ropp_involutive.
  trivial.
  cut
    (is_lub (EUn (opp_seq (fun k:nat => Un (S n + k)%nat)))
      (- glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))).
  intro.
  unfold is_lub in p; unfold is_lub in H1.
  elim p; intros; elim H1; intros.
  assert (H6 := H5 x H2).
  assert
    (H7 :=
      H3 (- glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)) H4).
  rewrite <-
    (Ropp_involutive
      (glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)))
    .
  apply Ropp_eq_compat; apply Rle_antisym; assumption.
  unfold glb in |- *.
  case (lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)); simpl.
  intro; rewrite Ropp_involutive.
  trivial.
Qed.

(**********)
Lemma Vn_Un_Wn_order :
  forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un)
    (n:nat), sequence_lb Un pr2 n <= Un n <= sequence_ub Un pr1 n.
Proof.
  intros.
  split.
  unfold sequence_lb in |- *.
  cut { l:R | is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l }.
  intro X.
  elim X; intros.
  replace (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x).
  unfold is_lub in p.
  elim p; intros.
  unfold is_upper_bound in H.
  rewrite <- (Ropp_involutive (Un n)).
  apply Ropp_le_contravar.
  apply H.
  exists 0%nat.
  unfold opp_seq in |- *.
  replace (n + 0)%nat with n; [ reflexivity | ring ].
  cut
    (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
      (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))).
  intro.
  unfold is_lub in p; unfold is_lub in H.
  elim p; intros; elim H; intros.
  assert (H4 := H3 x H0).
  assert
    (H5 := H1 (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) H2).
  rewrite <-
    (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)))
    .
  apply Ropp_eq_compat; apply Rle_antisym; assumption.
  unfold glb in |- *.
  case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)); simpl.
  intro; rewrite Ropp_involutive.
  trivial.
  apply lb_to_glb.
  apply min_ss; assumption.
  unfold sequence_ub in |- *.
  cut { l:R | is_lub (EUn (fun i:nat => Un (n + i)%nat)) l }.
  intro X.
  elim X; intros.
  replace (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x.
  unfold is_lub in p.
  elim p; intros.
  unfold is_upper_bound in H.
  apply H.
  exists 0%nat.
  replace (n + 0)%nat with n; [ reflexivity | ring ].
  cut
    (is_lub (EUn (fun k:nat => Un (n + k)%nat))
      (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1))).
  intro.
  unfold is_lub in p; unfold is_lub in H.
  elim p; intros; elim H; intros.
  assert (H4 := H3 x H0).
  assert
    (H5 := H1 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2).
  apply Rle_antisym; assumption.
  unfold lub in |- *.
  case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)).
  intro; trivial.
  apply ub_to_lub.
  apply maj_ss; assumption.
Qed.

Lemma min_maj :
  forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
    has_ub (sequence_lb Un pr2).
Proof.
  intros.
  assert (H := Vn_Un_Wn_order Un pr1 pr2).
  unfold has_ub in |- *.
  unfold bound in |- *.
  unfold has_ub in pr1.
  unfold bound in pr1.
  elim pr1; intros.
  exists x.
  unfold is_upper_bound in |- *.
  intros.
  unfold is_upper_bound in H0.
  elim H1; intros.
  rewrite H2.
  apply Rle_trans with (Un x1).
  assert (H3 := H x1); elim H3; intros; assumption.
  apply H0.
  exists x1; reflexivity.
Qed.

Lemma maj_min :
  forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
    has_lb (sequence_ub Un pr1).
Proof.
  intros.
  assert (H := Vn_Un_Wn_order Un pr1 pr2).
  unfold has_lb in |- *.
  unfold bound in |- *.
  unfold has_lb in pr2.
  unfold bound in pr2.
  elim pr2; intros.
  exists x.
  unfold is_upper_bound in |- *.
  intros.
  unfold is_upper_bound in H0.
  elim H1; intros.
  rewrite H2.
  apply Rle_trans with (opp_seq Un x1).
  assert (H3 := H x1); elim H3; intros.
  unfold opp_seq in |- *; apply Ropp_le_contravar.
  assumption.
  apply H0.
  exists x1; reflexivity.
Qed.

(**********)
Lemma cauchy_maj : forall Un:nat -> R, Cauchy_crit Un -> has_ub Un.
Proof.
  intros.
  unfold has_ub in |- *.
  apply cauchy_bound.
  assumption.
Qed.

(**********)
Lemma cauchy_opp :
  forall Un:nat -> R, Cauchy_crit Un -> Cauchy_crit (opp_seq Un).
Proof.
  intro.
  unfold Cauchy_crit in |- *.
  unfold R_dist in |- *.
  intros.
  elim (H eps H0); intros.
  exists x; intros.
  unfold opp_seq in |- *.
  rewrite <- Rabs_Ropp.
  replace (- (- Un n - - Un m)) with (Un n - Un m);
  [ apply H1; assumption | ring ].
Qed.

(**********)
Lemma cauchy_min : forall Un:nat -> R, Cauchy_crit Un -> has_lb Un.
Proof.
  intros.
  unfold has_lb in |- *.
  assert (H0 := cauchy_opp _ H).
  apply cauchy_bound.
  assumption.
Qed.

(**********)
Lemma maj_cv :
  forall (Un:nat -> R) (pr:Cauchy_crit Un),
    { l:R | Un_cv (sequence_ub Un (cauchy_maj Un pr)) l }.
Proof.
  intros.
  apply decreasing_cv.
  apply Wn_decreasing.
  apply maj_min.
  apply cauchy_min.
  assumption.
Qed.

(**********)
Lemma min_cv :
  forall (Un:nat -> R) (pr:Cauchy_crit Un),
    { l:R | Un_cv (sequence_lb Un (cauchy_min Un pr)) l }.
Proof.
  intros.
  apply growing_cv.
  apply Vn_growing.
  apply min_maj.
  apply cauchy_maj.
  assumption.
Qed.

Lemma cond_eq :
  forall x y:R, (forall eps:R, 0 < eps -> Rabs (x - y) < eps) -> x = y.
Proof.
  intros.
  case (total_order_T x y); intro.
  elim s; intro.
  cut (0 < y - x).
  intro.
  assert (H1 := H (y - x) H0).
  rewrite <- Rabs_Ropp in H1.
  cut (- (x - y) = y - x); [ intro; rewrite H2 in H1 | ring ].
  rewrite Rabs_right in H1.
  elim (Rlt_irrefl _ H1).
  left; assumption.
  apply Rplus_lt_reg_r with x.
  rewrite Rplus_0_r; replace (x + (y - x)) with y; [ assumption | ring ].
  assumption.
  cut (0 < x - y).
  intro.
  assert (H1 := H (x - y) H0).
  rewrite Rabs_right in H1.
  elim (Rlt_irrefl _ H1).
  left; assumption.
  apply Rplus_lt_reg_r with y.
  rewrite Rplus_0_r; replace (y + (x - y)) with x; [ assumption | ring ].
Qed.

Lemma not_Rlt : forall r1 r2:R, ~ r1 < r2 -> r1 >= r2.
Proof.
  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge in |- *.
  tauto.
Qed.

(**********)
Lemma approx_maj :
  forall (Un:nat -> R) (pr:has_ub Un) (eps:R),
    0 < eps ->  exists k : nat, Rabs (lub Un pr - Un k) < eps.
Proof.
  intros.
  set (P := fun k:nat => Rabs (lub Un pr - Un k) < eps).
  unfold P in |- *.
  cut
    ((exists k : nat, P k) ->
      exists k : nat, Rabs (lub Un pr - Un k) < eps).
  intros.
  apply H0.
  apply not_all_not_ex.
  red in |- *; intro.
  2: unfold P in |- *; trivial.
  unfold P in H1.
  cut (forall n:nat, Rabs (lub Un pr - Un n) >= eps).
  intro.
  cut (is_lub (EUn Un) (lub Un pr)).
  intro.
  unfold is_lub in H3.
  unfold is_upper_bound in H3.
  elim H3; intros.
  cut (forall n:nat, eps <= lub Un pr - Un n).
  intro.
  cut (forall n:nat, Un n <= lub Un pr - eps).
  intro.
  cut (forall x:R, EUn Un x -> x <= lub Un pr - eps).
  intro.
  assert (H9 := H5 (lub Un pr - eps) H8).
  cut (eps <= 0).
  intro.
  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
  apply Rplus_le_reg_l with (lub Un pr - eps).
  rewrite Rplus_0_r.
  replace (lub Un pr - eps + eps) with (lub Un pr);
  [ assumption | ring ].
  intros.
  unfold EUn in H8.
  elim H8; intros.
  rewrite H9; apply H7.
  intro.
  assert (H7 := H6 n).
  apply Rplus_le_reg_l with (eps - Un n).
  replace (eps - Un n + Un n) with eps.
  replace (eps - Un n + (lub Un pr - eps)) with (lub Un pr - Un n).
  assumption.
  ring.
  ring.
  intro.
  assert (H6 := H2 n).
  rewrite Rabs_right in H6.
  apply Rge_le.
  assumption.
  apply Rle_ge.
  apply Rplus_le_reg_l with (Un n).
  rewrite Rplus_0_r;
    replace (Un n + (lub Un pr - Un n)) with (lub Un pr);
    [ apply H4 | ring ].
  exists n; reflexivity.
  unfold lub in |- *.
  case (ub_to_lub Un pr).
  trivial.
  intro.
  assert (H2 := H1 n).
  apply not_Rlt; assumption.
Qed.

(**********)
Lemma approx_min :
  forall (Un:nat -> R) (pr:has_lb Un) (eps:R),
    0 < eps ->  exists k : nat, Rabs (glb Un pr - Un k) < eps.
Proof.
  intros.
  set (P := fun k:nat => Rabs (glb Un pr - Un k) < eps).
  unfold P in |- *.
  cut
    ((exists k : nat, P k) ->
      exists k : nat, Rabs (glb Un pr - Un k) < eps).
  intros.
  apply H0.
  apply not_all_not_ex.
  red in |- *; intro.
  2: unfold P in |- *; trivial.
  unfold P in H1.
  cut (forall n:nat, Rabs (glb Un pr - Un n) >= eps).
  intro.
  cut (is_lub (EUn (opp_seq Un)) (- glb Un pr)).
  intro.
  unfold is_lub in H3.
  unfold is_upper_bound in H3.
  elim H3; intros.
  cut (forall n:nat, eps <= Un n - glb Un pr).
  intro.
  cut (forall n:nat, opp_seq Un n <= - glb Un pr - eps).
  intro.
  cut (forall x:R, EUn (opp_seq Un) x -> x <= - glb Un pr - eps).
  intro.
  assert (H9 := H5 (- glb Un pr - eps) H8).
  cut (eps <= 0).
  intro.
  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
  apply Rplus_le_reg_l with (- glb Un pr - eps).
  rewrite Rplus_0_r.
  replace (- glb Un pr - eps + eps) with (- glb Un pr);
  [ assumption | ring ].
  intros.
  unfold EUn in H8.
  elim H8; intros.
  rewrite H9; apply H7.
  intro.
  assert (H7 := H6 n).
  unfold opp_seq in |- *.
  apply Rplus_le_reg_l with (eps + Un n).
  replace (eps + Un n + - Un n) with eps.
  replace (eps + Un n + (- glb Un pr - eps)) with (Un n - glb Un pr).
  assumption.
  ring.
  ring.
  intro.
  assert (H6 := H2 n).
  rewrite Rabs_left1 in H6.
  apply Rge_le.
  replace (Un n - glb Un pr) with (- (glb Un pr - Un n));
  [ assumption | ring ].
  apply Rplus_le_reg_l with (- glb Un pr).
  rewrite Rplus_0_r;
    replace (- glb Un pr + (glb Un pr - Un n)) with (- Un n).
  apply H4.
  exists n; reflexivity.
  ring.
  unfold glb in |- *.
  case (lb_to_glb Un pr); simpl.
  intro.
  rewrite Ropp_involutive.
  trivial.
  intro.
  assert (H2 := H1 n).
  apply not_Rlt; assumption.
Qed.

(** Unicity of limit for convergent sequences *)
Lemma UL_sequence :
  forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2.
Proof.
  intros Un l1 l2; unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  apply cond_eq.
  intros; cut (0 < eps / 2);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H (eps / 2) H2); intros.
  elim (H0 (eps / 2) H2); intros.
  set (N := max x x0).
  apply Rle_lt_trans with (Rabs (l1 - Un N) + Rabs (Un N - l2)).
  replace (l1 - l2) with (l1 - Un N + (Un N - l2));
  [ apply Rabs_triang | ring ].
  rewrite (double_var eps); apply Rplus_lt_compat.
  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H3;
    unfold ge, N in |- *; apply le_max_l.
  apply H4; unfold ge, N in |- *; apply le_max_r.
Qed.

(**********)
Lemma CV_plus :
  forall (An Bn:nat -> R) (l1 l2:R),
    Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2).
Proof.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  cut (0 < eps / 2);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H (eps / 2) H2); intros.
  elim (H0 (eps / 2) H2); intros.
  set (N := max x x0).
  exists N; intros.
  replace (An n + Bn n - (l1 + l2)) with (An n - l1 + (Bn n - l2));
  [ idtac | ring ].
  apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)).
  apply Rabs_triang.
  rewrite (double_var eps); apply Rplus_lt_compat.
  apply H3; unfold ge in |- *; apply le_trans with N;
    [ unfold N in |- *; apply le_max_l | assumption ].
  apply H4; unfold ge in |- *; apply le_trans with N;
    [ unfold N in |- *; apply le_max_r | assumption ].
Qed.

(**********)
Lemma cv_cvabs :
  forall (Un:nat -> R) (l:R),
    Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l).
Proof.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H eps H0); intros.
  exists x; intros.
  apply Rle_lt_trans with (Rabs (Un n - l)).
  apply Rabs_triang_inv2.
  apply H1; assumption.
Qed.

(**********)
Lemma CV_Cauchy :
  forall Un:nat -> R, { l:R | Un_cv Un l } -> Cauchy_crit Un.
Proof.
  intros Un X; elim X; intros.
  unfold Cauchy_crit in |- *; intros.
  unfold Un_cv in p; unfold R_dist in p.
  cut (0 < eps / 2);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (p (eps / 2) H0); intros.
  exists x0; intros.
  unfold R_dist in |- *;
    apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)).
  replace (Un n - Un m) with (Un n - x + (x - Un m));
  [ apply Rabs_triang | ring ].
  rewrite (double_var eps); apply Rplus_lt_compat.
  apply H1; assumption.
  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1; assumption.
Qed.

(**********)
Lemma maj_by_pos :
  forall Un:nat -> R,
    { l:R | Un_cv Un l } ->
    exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l).
Proof.
  intros Un X; elim X; intros.
  cut { l:R | Un_cv (fun k:nat => Rabs (Un k)) l }.
  intro X0.
  assert (H := CV_Cauchy (fun k:nat => Rabs (Un k)) X0).
  assert (H0 := cauchy_bound (fun k:nat => Rabs (Un k)) H).
  elim H0; intros.
  exists (x0 + 1).
  cut (0 <= x0).
  intro.
  split.
  apply Rplus_le_lt_0_compat; [ assumption | apply Rlt_0_1 ].
  intros.
  apply Rle_trans with x0.
  unfold is_upper_bound in H1.
  apply H1.
  exists n; reflexivity.
  pattern x0 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
    apply Rlt_0_1.
  apply Rle_trans with (Rabs (Un 0%nat)).
  apply Rabs_pos.
  unfold is_upper_bound in H1.
  apply H1.
  exists 0%nat; reflexivity.
  exists (Rabs x).
  apply cv_cvabs; assumption.
Qed.

(**********)
Lemma CV_mult :
  forall (An Bn:nat -> R) (l1 l2:R),
    Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2).
Proof.
  intros.
  cut { l:R | Un_cv An l }.
  intro X.
  assert (H1 := maj_by_pos An X).
  elim H1; intros M H2.
  elim H2; intros.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  cut (0 < eps / (2 * M)).
  intro.
  case (Req_dec l2 0); intro.
  unfold Un_cv in H0; unfold R_dist in H0.
  elim (H0 (eps / (2 * M)) H6); intros.
  exists x; intros.
  apply Rle_lt_trans with
    (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)).
  replace (An n * Bn n - l1 * l2) with
  (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
  [ apply Rabs_triang | ring ].
  replace (Rabs (An n * Bn n - An n * l2)) with
  (Rabs (An n) * Rabs (Bn n - l2)).
  replace (Rabs (An n * l2 - l1 * l2)) with 0.
  rewrite Rplus_0_r.
  apply Rle_lt_trans with (M * Rabs (Bn n - l2)).
  do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))).
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  apply H4.
  apply Rmult_lt_reg_l with (/ M).
  apply Rinv_0_lt_compat; apply H3.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)).
  apply Rlt_trans with (eps / (2 * M)).
  apply H8; assumption.
  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  replace (2 * (eps * (/ 2 * / M))) with (2 * / 2 * (eps * / M));
  [ idtac | ring ].
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite double.
  pattern (eps * / M) at 1 in |- *; rewrite <- Rplus_0_r.
  apply Rplus_lt_compat_l; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; assumption ].
  discrR.
  discrR.
  red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
  red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
  rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus in |- *;
    rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity.
  replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); [ idtac | ring ].
  symmetry  in |- *; apply Rabs_mult.
  cut (0 < eps / (2 * Rabs l2)).
  intro.
  unfold Un_cv in H; unfold R_dist in H; unfold Un_cv in H0;
    unfold R_dist in H0.
  elim (H (eps / (2 * Rabs l2)) H8); intros N1 H9.
  elim (H0 (eps / (2 * M)) H6); intros N2 H10.
  set (N := max N1 N2).
  exists N; intros.
  apply Rle_lt_trans with
    (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)).
  replace (An n * Bn n - l1 * l2) with
  (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
  [ apply Rabs_triang | ring ].
  replace (Rabs (An n * Bn n - An n * l2)) with
  (Rabs (An n) * Rabs (Bn n - l2)).
  replace (Rabs (An n * l2 - l1 * l2)) with (Rabs l2 * Rabs (An n - l1)).
  rewrite (double_var eps); apply Rplus_lt_compat.
  apply Rle_lt_trans with (M * Rabs (Bn n - l2)).
  do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))).
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  apply H4.
  apply Rmult_lt_reg_l with (/ M).
  apply Rinv_0_lt_compat; apply H3.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)).
  apply Rlt_le_trans with (eps / (2 * M)).
  apply H10.
  unfold ge in |- *; apply le_trans with N.
  unfold N in |- *; apply le_max_r.
  assumption.
  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
  right; ring.
  discrR.
  red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
  red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
  apply Rmult_lt_reg_l with (/ Rabs l2).
  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)).
  apply H9.
  unfold ge in |- *; apply le_trans with N.
  unfold N in |- *; apply le_max_l.
  assumption.
  unfold Rdiv in |- *; right; rewrite Rinv_mult_distr.
  ring.
  discrR.
  apply Rabs_no_R0; assumption.
  apply Rabs_no_R0; assumption.
  replace (An n * l2 - l1 * l2) with (l2 * (An n - l1));
  [ symmetry  in |- *; apply Rabs_mult | ring ].
  replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2));
  [ symmetry  in |- *; apply Rabs_mult | ring ].
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  assumption.
  apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
    [ prove_sup0 | apply Rabs_pos_lt; assumption ].
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption
      | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
        [ prove_sup0 | assumption ] ].
  exists l1; assumption.
Qed.

Lemma tech9 :
  forall Un:nat -> R,
    Un_growing Un -> forall m n:nat, (m <= n)%nat -> Un m <= Un n.
Proof.
  intros; unfold Un_growing in H.
  induction  n as [| n Hrecn].
  induction  m as [| m Hrecm].
  right; reflexivity.
  elim (le_Sn_O _ H0).
  cut ((m <= n)%nat \/ m = S n).
  intro; elim H1; intro.
  apply Rle_trans with (Un n).
  apply Hrecn; assumption.
  apply H.
  rewrite H2; right; reflexivity.
  inversion H0.
  right; reflexivity.
  left; assumption.
Qed.

Lemma tech10 :
  forall (Un:nat -> R) (x:R), Un_growing Un -> is_lub (EUn Un) x -> Un_cv Un x.
Proof.
  intros; cut (bound (EUn Un)).
  intro; assert (H2 := Un_cv_crit _ H H1).
  elim H2; intros.
  case (total_order_T x x0); intro.
  elim s; intro.
  cut (forall n:nat, Un n <= x).
  intro; unfold Un_cv in H3; cut (0 < x0 - x).
  intro; elim (H3 (x0 - x) H5); intros.
  cut (x1 >= x1)%nat.
  intro; assert (H8 := H6 x1 H7).
  unfold R_dist in H8; rewrite Rabs_left1 in H8.
  rewrite Ropp_minus_distr in H8; unfold Rminus in H8.
  assert (H9 := Rplus_lt_reg_r x0 _ _ H8).
  assert (H10 := Ropp_lt_cancel _ _ H9).
  assert (H11 := H4 x1).
  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H11)).
  apply Rle_minus; apply Rle_trans with x.
  apply H4.
  left; assumption.
  unfold ge in |- *; apply le_n.
  apply Rgt_minus; assumption.
  intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
  apply H4; unfold EUn in |- *; exists n; reflexivity.
  rewrite b; assumption.
  cut (forall n:nat, Un n <= x0).
  intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
  cut (forall y:R, EUn Un y -> y <= x0).
  intro; assert (H8 := H6 _ H7).
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 r)).
  unfold EUn in |- *; intros; elim H7; intros.
  rewrite H8; apply H4.
  intro; case (Rle_dec (Un n) x0); intro.
  assumption.
  cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0).
  intro; unfold Un_cv in H3; cut (0 < Un n - x0).
  intro; elim (H3 (Un n - x0) H5); intros.
  cut (max n x1 >= x1)%nat.
  intro; assert (H8 := H6 (max n x1) H7).
  unfold R_dist in H8.
  rewrite Rabs_right in H8.
  unfold Rminus in H8; do 2 rewrite <- (Rplus_comm (- x0)) in H8.
  assert (H9 := Rplus_lt_reg_r _ _ _ H8).
  cut (Un n <= Un (max n x1)).
  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H9)).
  apply tech9; [ assumption | apply le_max_l ].
  apply Rge_trans with (Un n - x0).
  unfold Rminus in |- *; apply Rle_ge; do 2 rewrite <- (Rplus_comm (- x0));
    apply Rplus_le_compat_l.
  apply tech9; [ assumption | apply le_max_l ].
  left; assumption.
  unfold ge in |- *; apply le_max_r.
  apply Rplus_lt_reg_r with x0.
  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm x0);
    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
      apply H4; apply le_n.
  intros; apply Rlt_le_trans with (Un n).
  case (Rlt_le_dec x0 (Un n)); intro.
  assumption.
  elim n0; assumption.
  apply tech9; assumption.
  unfold bound in |- *; exists x; unfold is_lub in H0; elim H0; intros;
    assumption.
Qed.

Lemma tech13 :
  forall (An:nat -> R) (k:R),
    0 <= k < 1 ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
    exists k0 : R,
      k < k0 < 1 /\
      (exists N : nat,
        (forall n:nat, (N <= n)%nat -> Rabs (An (S n) / An n) < k0)).
Proof.
  intros; exists (k + (1 - k) / 2).
  split.
  split.
  pattern k at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1;
    [ elim H; intros; assumption | ring ].
  apply Rinv_0_lt_compat; prove_sup0.
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  unfold Rdiv in |- *; rewrite Rmult_1_r; rewrite Rmult_plus_distr_l;
    pattern 2 at 1 in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
      rewrite <- Rinv_l_sym; [ idtac | discrR ]; rewrite Rmult_1_r;
        replace (2 * k + (1 - k)) with (1 + k); [ idtac | ring ].
  elim H; intros.
  apply Rplus_lt_compat_l; assumption.
  unfold Un_cv in H0; cut (0 < (1 - k) / 2).
  intro; elim (H0 ((1 - k) / 2) H1); intros.
  exists x; intros.
  assert (H4 := H2 n H3).
  unfold R_dist in H4; rewrite <- Rabs_Rabsolu;
    replace (Rabs (An (S n) / An n)) with (Rabs (An (S n) / An n) - k + k);
    [ idtac | ring ];
    apply Rle_lt_trans with (Rabs (Rabs (An (S n) / An n) - k) + Rabs k).
  apply Rabs_triang.
  rewrite (Rabs_right k).
  apply Rplus_lt_reg_r with (- k); rewrite <- (Rplus_comm k);
    repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
      repeat rewrite Rplus_0_l; apply H4.
  apply Rle_ge; elim H; intros; assumption.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; elim H; intros;
    replace (k + (1 - k)) with 1; [ assumption | ring ].
  apply Rinv_0_lt_compat; prove_sup0.
Qed.

(**********)
Lemma growing_ineq :
  forall (Un:nat -> R) (l:R),
    Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l.
Proof.
  intros; case (total_order_T (Un n) l); intro.
  elim s; intro.
  left; assumption.
  right; assumption.
  cut (0 < Un n - l).
  intro; unfold Un_cv in H0; unfold R_dist in H0.
  elim (H0 (Un n - l) H1); intros N1 H2.
  set (N := max n N1).
  cut (Un n - l <= Un N - l).
  intro; cut (Un N - l < Un n - l).
  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 H4)).
  apply Rle_lt_trans with (Rabs (Un N - l)).
  apply RRle_abs.
  apply H2.
  unfold ge, N in |- *; apply le_max_r.
  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
    apply Rplus_le_compat_l.
  apply tech9.
  assumption.
  unfold N in |- *; apply le_max_l.
  apply Rplus_lt_reg_r with l.
  rewrite Rplus_0_r.
  replace (l + (Un n - l)) with (Un n); [ assumption | ring ].
Qed.

(** Un->l => (-Un) -> (-l) *)
Lemma CV_opp :
  forall (An:nat -> R) (l:R), Un_cv An l -> Un_cv (opp_seq An) (- l).
Proof.
  intros An l.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H eps H0); intros.
  exists x; intros.
  unfold opp_seq in |- *; replace (- An n - - l) with (- (An n - l));
    [ rewrite Rabs_Ropp | ring ].
  apply H1; assumption.
Qed.

(**********)
Lemma decreasing_ineq :
  forall (Un:nat -> R) (l:R),
    Un_decreasing Un -> Un_cv Un l -> forall n:nat, l <= Un n.
Proof.
  intros.
  assert (H1 := decreasing_growing _ H).
  assert (H2 := CV_opp _ _ H0).
  assert (H3 := growing_ineq _ _ H1 H2).
  apply Ropp_le_cancel.
  unfold opp_seq in H3; apply H3.
Qed.

(**********)
Lemma CV_minus :
  forall (An Bn:nat -> R) (l1 l2:R),
    Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i - Bn i) (l1 - l2).
Proof.
  intros.
  replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i).
  unfold Rminus in |- *; apply CV_plus.
  assumption.
  apply CV_opp; assumption.
  unfold Rminus, opp_seq in |- *; reflexivity.
Qed.

(** Un -> +oo *)
Definition cv_infty (Un:nat -> R) : Prop :=
  forall M:R,  exists N : nat, (forall n:nat, (N <= n)%nat -> M < Un n).

(** Un -> +oo => /Un -> O *)
Lemma cv_infty_cv_R0 :
  forall Un:nat -> R,
    (forall n:nat, Un n <> 0) -> cv_infty Un -> Un_cv (fun n:nat => / Un n) 0.
Proof.
  unfold cv_infty, Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H0 (/ eps)); intros N0 H2.
  exists N0; intros.
  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
    rewrite (Rabs_Rinv _ (H n)).
  apply Rmult_lt_reg_l with (Rabs (Un n)).
  apply Rabs_pos_lt; apply H.
  rewrite <- Rinv_r_sym.
  apply Rmult_lt_reg_l with (/ eps).
  apply Rinv_0_lt_compat; assumption.
  rewrite Rmult_1_r; rewrite (Rmult_comm (/ eps)); rewrite Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; apply Rlt_le_trans with (Un n).
  apply H2; assumption.
  apply RRle_abs.
  red in |- *; intro; rewrite H4 in H1; elim (Rlt_irrefl _ H1).
  apply Rabs_no_R0; apply H.
Qed.

(**********)
Lemma decreasing_prop :
  forall (Un:nat -> R) (m n:nat),
    Un_decreasing Un -> (m <= n)%nat -> Un n <= Un m.
Proof.
  unfold Un_decreasing in |- *; intros.
  induction  n as [| n Hrecn].
  induction  m as [| m Hrecm].
  right; reflexivity.
  elim (le_Sn_O _ H0).
  cut ((m <= n)%nat \/ m = S n).
  intro; elim H1; intro.
  apply Rle_trans with (Un n).
  apply H.
  apply Hrecn; assumption.
  rewrite H2; right; reflexivity.
  inversion H0; [ right; reflexivity | left; assumption ].
Qed.

(** |x|^n/n! -> 0 *)
Lemma cv_speed_pow_fact :
  forall x:R, Un_cv (fun n:nat => x ^ n / INR (fact n)) 0.
Proof.
  intro;
    cut
      (Un_cv (fun n:nat => Rabs x ^ n / INR (fact n)) 0 ->
        Un_cv (fun n:nat => x ^ n / INR (fact n)) 0).
  intro; apply H.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros; case (Req_dec x 0);
    intro.
  exists 1%nat; intros.
  rewrite H1; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
    rewrite Rabs_R0; rewrite pow_ne_zero;
      [ unfold Rdiv in |- *; rewrite Rmult_0_l; rewrite Rabs_R0; assumption
        | red in |- *; intro; rewrite H3 in H2; elim (le_Sn_n _ H2) ].
  assert (H2 := Rabs_pos_lt x H1); set (M := up (Rabs x)); cut (0 <= M)%Z.
  intro; elim (IZN M H3); intros M_nat H4.
  set (Un := fun n:nat => Rabs x ^ (M_nat + n) / INR (fact (M_nat + n))).
  cut (Un_cv Un 0); unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H5 eps H0); intros N H6.
  exists (M_nat + N)%nat; intros;
    cut (exists p : nat, (p >= N)%nat /\ n = (M_nat + p)%nat).
  intro; elim H8; intros p H9.
  elim H9; intros; rewrite H11; unfold Un in H6; apply H6; assumption.
  exists (n - M_nat)%nat.
  split.
  unfold ge in |- *; apply (fun p n m:nat => plus_le_reg_l n m p) with M_nat;
    rewrite <- le_plus_minus.
  assumption.
  apply le_trans with (M_nat + N)%nat.
  apply le_plus_l.
  assumption.
  apply le_plus_minus; apply le_trans with (M_nat + N)%nat;
    [ apply le_plus_l | assumption ].
  set (Vn := fun n:nat => Rabs x * (Un 0%nat / INR (S n))).
  cut (1 <= M_nat)%nat.
  intro; cut (forall n:nat, 0 < Un n).
  intro; cut (Un_decreasing Un).
  intro; cut (forall n:nat, Un (S n) <= Vn n).
  intro; cut (Un_cv Vn 0).
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H10 eps0 H5); intros N1 H11.
  exists (S N1); intros.
  cut (forall n:nat, 0 < Vn n).
  intro; apply Rle_lt_trans with (Rabs (Vn (pred n) - 0)).
  repeat rewrite Rabs_right.
  unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
    replace n with (S (pred n)).
  apply H9.
  inversion H12; simpl in |- *; reflexivity.
  apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
    apply H13.
  apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
    apply H7.
  apply H11; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n;
    [ unfold ge in H12; exact H12 | inversion H12; simpl in |- *; reflexivity ].
  intro; apply Rlt_le_trans with (Un (S n0)); [ apply H7 | apply H9 ].
  cut (cv_infty (fun n:nat => INR (S n))).
  intro; cut (Un_cv (fun n:nat => / INR (S n)) 0).
  unfold Un_cv, R_dist in |- *; intros; unfold Vn in |- *.
  cut (0 < eps1 / (Rabs x * Un 0%nat)).
  intro; elim (H11 _ H13); intros N H14.
  exists N; intros;
    replace (Rabs x * (Un 0%nat / INR (S n)) - 0) with
    (Rabs x * Un 0%nat * (/ INR (S n) - 0));
    [ idtac | unfold Rdiv in |- *; ring ].
  rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs (Rabs x * Un 0%nat)).
  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
  apply prod_neq_R0.
  apply Rabs_no_R0; assumption.
  assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
    elim (Rlt_irrefl _ H16).
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (/ Rabs (Rabs x * Un 0%nat) * eps1) with (eps1 / (Rabs x * Un 0%nat)).
  apply H14; assumption.
  unfold Rdiv in |- *; rewrite (Rabs_right (Rabs x * Un 0%nat)).
  apply Rmult_comm.
  apply Rle_ge; apply Rmult_le_pos.
  apply Rabs_pos.
  left; apply H7.
  apply Rabs_no_R0.
  apply prod_neq_R0;
    [ apply Rabs_no_R0; assumption
      | assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
        elim (Rlt_irrefl _ H16) ].
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  assumption.
  apply Rinv_0_lt_compat; apply Rmult_lt_0_compat.
  apply Rabs_pos_lt; assumption.
  apply H7.
  apply (cv_infty_cv_R0 (fun n:nat => INR (S n))).
  intro; apply not_O_INR; discriminate.
  assumption.
  unfold cv_infty in |- *; intro; case (total_order_T M0 0); intro.
  elim s; intro.
  exists 0%nat; intros.
  apply Rlt_trans with 0; [ assumption | apply lt_INR_0; apply lt_O_Sn ].
  exists 0%nat; intros; rewrite b; apply lt_INR_0; apply lt_O_Sn.
  set (M0_z := up M0).
  assert (H10 := archimed M0).
  cut (0 <= M0_z)%Z.
  intro; elim (IZN _ H11); intros M0_nat H12.
  exists M0_nat; intros.
  apply Rlt_le_trans with (IZR M0_z).
  elim H10; intros; assumption.
  rewrite H12; rewrite <- INR_IZR_INZ; apply le_INR.
  apply le_trans with n; [ assumption | apply le_n_Sn ].
  apply le_IZR; left; simpl in |- *; unfold M0_z in |- *;
    apply Rlt_trans with M0; [ assumption | elim H10; intros; assumption ].
  intro; apply Rle_trans with (Rabs x * Un n * / INR (S n)).
  unfold Un in |- *; replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
  rewrite pow_add; replace (Rabs x ^ 1) with (Rabs x);
    [ idtac | simpl in |- *; ring ].
  unfold Rdiv in |- *; rewrite <- (Rmult_comm (Rabs x));
    repeat rewrite Rmult_assoc; repeat apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply pow_lt; assumption.
  replace (M_nat + n + 1)%nat with (S (M_nat + n)).
  rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR;
    rewrite Rinv_mult_distr.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
    intro; assert (H10 := sym_eq H9); elim (fact_neq_0 _ H10).
  left; apply Rinv_lt_contravar.
  apply Rmult_lt_0_compat; apply lt_INR_0; apply lt_O_Sn.
  apply lt_INR; apply lt_n_S.
  pattern n at 1 in |- *; replace n with (0 + n)%nat; [ idtac | reflexivity ].
  apply plus_lt_compat_r.
  apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  ring.
  ring.
  unfold Vn in |- *; rewrite Rmult_assoc; unfold Rdiv in |- *;
    rewrite (Rmult_comm (Un 0%nat)); rewrite (Rmult_comm (Un n)).
  repeat apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  apply decreasing_prop; [ assumption | apply le_O_n ].
  unfold Un_decreasing in |- *; intro; unfold Un in |- *.
  replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
  rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
    apply Rmult_le_compat_l.
  left; apply pow_lt; assumption.
  replace (Rabs x ^ 1) with (Rabs x); [ idtac | simpl in |- *; ring ].
  replace (M_nat + n + 1)%nat with (S (M_nat + n)).
  apply Rmult_le_reg_l with (INR (fact (S (M_nat + n)))).
  apply lt_INR_0; apply neq_O_lt; red in |- *; intro; assert (H9 := sym_eq H8);
    elim (fact_neq_0 _ H9).
  rewrite (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  rewrite fact_simpl; rewrite mult_INR; rewrite Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; apply Rle_trans with (INR M_nat).
  left; rewrite INR_IZR_INZ.
  rewrite <- H4; assert (H8 := archimed (Rabs x)); elim H8; intros; assumption.
  apply le_INR; omega.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  ring.
  ring.
  intro; unfold Un in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply pow_lt; assumption.
  apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
    assert (H8 := sym_eq H7); elim (fact_neq_0 _ H8).
  clear Un Vn; apply INR_le; simpl in |- *.
  induction  M_nat as [| M_nat HrecM_nat].
  assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros.
  rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7.
  simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)).
  replace 1 with (INR 1); [ apply le_INR | reflexivity ]; apply le_n_S;
    apply le_O_n.
  apply le_IZR; simpl in |- *; left; apply Rlt_trans with (Rabs x).
  assumption.
  elim (archimed (Rabs x)); intros; assumption.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H eps H0); intros.
  exists x0; intros;
    apply Rle_lt_trans with (Rabs (Rabs x ^ n / INR (fact n) - 0)).
  unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
    rewrite (Rabs_right (Rabs x ^ n / INR (fact n))).
  unfold Rdiv in |- *; rewrite Rabs_mult; rewrite (Rabs_right (/ INR (fact n))).
  rewrite RPow_abs; right; reflexivity.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt;
    red in |- *; intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
  apply Rle_ge; unfold Rdiv in |- *; apply Rmult_le_pos.
  case (Req_dec x 0); intro.
  rewrite H3; rewrite Rabs_R0.
  induction  n as [| n Hrecn];
    [ simpl in |- *; left; apply Rlt_0_1
      | simpl in |- *; rewrite Rmult_0_l; right; reflexivity ].
  left; apply pow_lt; apply Rabs_pos_lt; assumption.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
    intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
  apply H1; assumption.
Qed.


Require Import HoTT.HoTT.
Require Import Common Notations.

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

Local Open Scope morphism_scope.

Record PreCategory :=
  Build_PreCategory' {
    Object :> Type;
    Morphism : Object -> Object -> Type;

    Identity : forall x, Morphism x x;
    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' where "f ∘ g" := (Compose f g);

    Associativity : forall x1 x2 x3 x4
                           (m1 : Morphism x1 x2)
                           (m2 : Morphism x2 x3)
                           (m3 : Morphism x3 x4),
                      (m3 ∘ m2) ∘ m1 = m3 ∘ (m2 ∘ m1);
    (* Ask for the symmetrized version of [Associativity], so that [(C ᵒᵖ) ᵒᵖ] and [C] are equal without [Funext] *)
    Associativity_sym : forall x1 x2 x3 x4
                               (m1 : Morphism x1 x2)
                               (m2 : Morphism x2 x3)
                               (m3 : Morphism x3 x4),
                          m3 ∘ (m2 ∘ m1) = (m3 ∘ m2) ∘ m1;

    LeftIdentity : forall a b (f : Morphism a b), (Identity b) ∘ f = f;
    RightIdentity : forall a b (f : Morphism a b), f ∘ (Identity a) = f;
    (* Ask for the double-identity version so that [FunctorFromTerminal Cᵒᵖ X] and [(FunctorFromTerminal C X)ᵒᵖ] are convertible. *)
    IdentityIdentity : forall x, Identity x ∘ Identity x = Identity x;

    MorphismIsHSet : forall s d, IsHSet (Morphism s d)
  }.

Bind Scope category_scope with PreCategory.
Bind Scope object_scope with Object.
Bind Scope morphism_scope with Morphism.

Arguments Object C%category : rename.
Arguments Morphism !C%category s d : rename.
Arguments Identity [!C%category] x%object : rename.
Arguments Compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.

Infix "o" := Compose : morphism_scope.
Infix "∘" := Compose : morphism_scope.
Notation "1" := (Identity _) : morphism_scope.

Definition Build_PreCategory
           Object Morphism Compose Identity Associativity LeftIdentity RightIdentity
  := @Build_PreCategory' Object
                         Morphism
                         Compose
                         Identity
                         Associativity
                         (fun _ _ _ _ _ _ _ => symmetry _ _ (Associativity _ _ _ _ _ _ _))
                         LeftIdentity
                         RightIdentity
                         (fun _ => LeftIdentity _ _ _).

Existing Instance MorphismIsHSet.
Instance MorphismIsHSet' C s d (m1 m2 : Morphism C s d) (pf1 pf2 : m1 = m2)
: Contr (pf1 = pf2)
  := @MorphismIsHSet C s d m1 m2 pf1 pf2.

(* create a hint db for all category theory things *)
Create HintDb category discriminated.
(* create a hint db for morphisms in categories *)
Create HintDb morphism discriminated.

Hint Resolve @LeftIdentity @RightIdentity @Associativity : category morphism.
Hint Rewrite @LeftIdentity @RightIdentity : category.
Hint Rewrite @LeftIdentity @RightIdentity : morphism.

Section IdentityUnique.
  Variable C : PreCategory.

  (** The Identity morphism is unique. *)
  Lemma IdentityUnique (id0 id1 : forall x, Morphism C x x)
        (id1_left : forall s d (m : Morphism C s d), id1 _ ∘ m = m)
        (id0_right : forall s d (m : Morphism C s d), m ∘ id0 _ = m)
  : id0 == id1.
    intro.
    etransitivity;
      [ symmetry; apply id1_left
      | apply id0_right ].
  Qed.

  (** Anything equal to the identity acts like it.  This is obvious,
      but useful as a helper lemma for automation. *)
  Definition concat_LeftIdentity s d (m : Morphism C s d) i
  : i = 1 -> i ∘ m = m
    := fun H => (ap10 (ap _ H) _ @ LeftIdentity _ _ _ m)%path.

  Definition concat_RightIdentity s d (m : Morphism C s d) i
  : i = 1 -> m ∘ i = m
    := fun H => (ap _ H @ RightIdentity _ _ _ m)%path.
End IdentityUnique.
(** * Version of [Associativity] that avoids going off into the weeds in the presence of unification variables *)

Definition NoEvar T (_ : T) := True.

Lemma AssociativityNoEvar (C : PreCategory) x1 x2 x3 x4
      (m1 : C.(Morphism) x1 x2)
      (m2 : C.(Morphism) x2 x3)
      (m3 : C.(Morphism) x3 x4)
: NoEvar (m1, m2) \/ NoEvar (m2, m3) \/ NoEvar (m1, m3)
  -> (m3 ∘ m2) ∘ m1 = m3 ∘ (m2 ∘ m1).
Proof.
  intros; apply Associativity.
Qed.

Ltac noEvar_tauto :=
  (eassumption
     || (left; noEvar_tauto)
     || (right; noEvar_tauto)).

Ltac noEvar := match goal with
                 | [ |- context[NoEvar ?X] ]
                   => (has_evar X; fail 1)
                        || cut (NoEvar X); [ intro; noEvar_tauto | constructor ]
               end.

Hint Rewrite @AssociativityNoEvar using noEvar : category.
Hint Rewrite @AssociativityNoEvar using noEvar : morphism.

Ltac try_associativity_quick tac := try_rewrite Associativity tac.
Ltac try_associativity tac := try_rewrite_by AssociativityNoEvar ltac:(idtac; noEvar) tac.
Ltac try_associativity_quick_rewrite H := try_associativity_quick ltac:(rewrite H).
Ltac try_associativity_quick_rewrite_rev H := try_associativity_quick ltac:(rewrite <- H).
Ltac try_associativity_rewrite H := try_associativity ltac:(rewrite H).
Ltac try_associativity_rewrite_rev H := try_associativity ltac:(rewrite <- H).


Add LoadPath "." as OmegaCategories.
Require Import path.

Inductive Pos : Type :=
| one : Pos
| succ_pos : Pos -> Pos.

Definition not (T : Type) := T -> Empty.

Notation "~~ A" := (not A) (at level 75).

Definition one_neq_succ_pos (z : Pos) : ~~ (one = succ_pos z)
  := fun p => transport (fun s => match s with one => unit | succ_pos t => Empty end) p tt.

Definition succ_pos_injective {z w : Pos} (p : succ_pos z = succ_pos w) : z = w
  := transport (fun s => z = (match s with one => w | succ_pos a => a end)) p (eq_refl z).

Inductive Int : Type :=
| neg : Pos -> Int
| zero : Int
| pos : Pos -> Int.

Definition neg_injective {z w : Pos} (p : neg z = neg w) : z = w
  := transport (fun s => z = (match s with neg a => a | zero => w | pos a => w end)) p (eq_refl z).

Definition pos_injective {z w : Pos} (p : pos z = pos w) : z = w
  := transport (fun s => z = (match s with neg a => w | zero => w | pos a => a end)) p (eq_refl z).

Definition neg_neq_zero {z : Pos} : ~~ (neg z = zero)
  := fun p => transport (fun s => match s with neg a => z = a | zero => Empty | pos _ => Empty end) p (eq_refl z).

Definition pos_neq_zero {z : Pos} : ~~ (pos z = zero)
  := fun p => transport (fun s => match s with pos a => z = a | zero => Empty | neg _ => Empty end) p (eq_refl z).

Definition neg_neq_pos {z w : Pos} : ~~ (neg z = pos w)
  := fun p => transport (fun s => match s with neg a => z = a | zero => Empty | pos _ => Empty end) p (eq_refl z).

(* And prove that they are a set. *)

Class Decidable (A : Type) :=
  dec : A + (~~ A).
Arguments dec A {_}.

Class DecidablePaths (A : Type) :=
  dec_paths : forall (x y : A), Decidable (x = y).
Global Existing Instance dec_paths.

Definition comp {T U V} (f : T -> U) (g:U -> V) := fun x => g (f x).

Notation "g 'o' f" := (comp f g) (at level 50).

Global Instance decpaths_int : DecidablePaths Int.
Proof.
  intros [n | | n] [m | | m].
  revert m; induction n as [|n IHn]; intros m; induction m as [|m IHm].
  exact (inl eq_refl).
  exact (inr (fun p => one_neq_succ_pos _ (neg_injective p))).
  exact (inr (fun p => one_neq_succ_pos _ (inverse (neg_injective p)))).
  destruct (IHn m) as [p | np].
  exact (inl (ap neg (ap succ_pos (neg_injective p)))).
  exact (inr (fun p => np (ap neg (succ_pos_injective (neg_injective p))))).
  exact (inr neg_neq_zero).
  exact (inr neg_neq_pos).
  exact (inr (neg_neq_zero o inverse)).
  exact (inl eq_refl).
  exact (inr (pos_neq_zero o inverse)).
  exact (inr (neg_neq_pos o inverse)).
  exact (inr pos_neq_zero).
  revert m; induction n as [|n IHn]; intros m; induction m as [|m IHm].
  exact (inl eq_refl).
  exact (inr (fun p => one_neq_succ_pos _ (pos_injective p))).
  exact (inr (fun p => one_neq_succ_pos _ (inverse (pos_injective p)))).
  destruct (IHn m) as [p | np].
  exact (inl (ap pos (ap succ_pos (pos_injective p)))).
  exact (inr (fun p => np (ap pos (succ_pos_injective (pos_injective p))))).
Defined.

Instance decpaths_nat : DecidablePaths nat.
intros x. induction x.
- destruct y.
 + left ;reflexivity.
 + right; intro H; inversion H.
- induction y.
  + right; intro H; inversion H.
  + case (IHx y). intro H. left. exact (f_equal S H).
    intro H; right. intro e. inversion e. apply (H H1).
Defined.

(* Successor is an autoequivalence of [Int]. *)

Definition succ_int (z : Int) : Int
  := match z with
       | neg (succ_pos n) => neg n
       | neg one => zero
       | zero => pos one
       | pos n => pos (succ_pos n)
     end.

Definition pred_int (z : Int) : Int
  := match z with
       | neg n => neg (succ_pos n)
       | zero => neg one
       | pos one => zero
       | pos (succ_pos n) => pos n
     end.

Fixpoint plus_pos (z z' : Pos) : Pos := match z with
     | one => succ_pos z'
     | succ_pos p => succ_pos (plus_pos p z')
   end.

Fixpoint pos_sub (x y:Pos) : Int :=
  match x, y with
    | one, one => zero
    | one, succ_pos n => neg n
    | succ_pos n, one => pos n
    | succ_pos n, succ_pos n' => pos_sub n n'
  end.

Definition plus_int (z z' : Int) : Int
  := match z,z' with
       | neg n, neg n' => neg (plus_pos n n')
       | pos n, pos n' => pos (plus_pos n n')
       | zero, _ => z'
       | _ , zero => z
       | pos n, neg n' => pos_sub n n'
       | neg n, pos n' => pos_sub n' n
     end.

Notation "z '.+' z'" := (plus_int z z') (at level 50).


From Coq Require Import Int63.

Inductive vec8 (T: Type)
:= Vec8 (a b c d e f g h: T).
Arguments Vec8 {_}.

Definition t := vec8.

Definition map {A B: Type} (F: A -> B) (v: vec8 A)
: vec8 B
:= match v with
   | Vec8 a b c d
          e f g h => Vec8 (F a) (F b) (F c) (F d)
                          (F e) (F f) (F g) (F h)
   end.

Definition to_list {T: Type} (v: vec8 T)
: list T
:= match v with
   | Vec8 a b c d
          e f g h => (a :: b :: c :: d :: e :: f :: g :: h :: nil)%list
   end.

Definition get {T: Type} (v: vec8 T) (i: int)
: T
:= match v with
   | Vec8 v0 v1 v2 v3 v4 v5 v6 v7 =>
         if (0 < (i land 4))%int63 then
           if (0 < (i land 2))%int63 then
             if (0 < (i land 1))%int63 then v7 else v6
           else
             if (0 < (i land 1))%int63 then v5 else v4
         else
           if (0 < (i land 2))%int63 then
             if (0 < (i land 1))%int63 then v3 else v2
           else
             if (0 < (i land 1))%int63 then v1 else v0
  end.

Definition set {T: Type} (v: vec8 T) (i: int) (XX: T)
: vec8 T
:= match v with
   | Vec8 v0 v1 v2 v3 v4 v5 v6 v7 =>
         if (0 < (i land 4))%int63 then
           if (0 < (i land 2))%int63 then
             if (0 < (i land 1))%int63 then
               Vec8 v0 v1 v2 v3 v4 v5 v6 XX
             else
               Vec8 v0 v1 v2 v3 v4 v5 XX v7
           else
             if (0 < (i land 1))%int63 then
               Vec8 v0 v1 v2 v3 v4 XX v6 v7
             else
               Vec8 v0 v1 v2 v3 XX v5 v6 v7
         else
           if (0 < (i land 2))%int63 then
             if (0 < (i land 1))%int63 then
               Vec8 v0 v1 v2 XX v4 v5 v6 v7
             else
               Vec8 v0 v1 XX v3 v4 v5 v6 v7
           else
             if (0 < (i land 1))%int63 then
               Vec8 v0 XX v2 v3 v4 v5 v6 v7
             else
               Vec8 XX v1 v2 v3 v4 v5 v6 v7
  end.


Require Export Basics.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true". (* <----- here *)
    reflexivity.
  Case "b = false". (* <---- and here *)
    rewrite <- H.
    reflexivity.
Qed.

Theorem andb_true_elim2 :
  forall b c : bool,
    andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct c.
  Case "c = true".
  reflexivity.
  Case "c = false".
  rewrite <- H.
  destruct b.
  SCase "b = true".
  reflexivity.
  SCase "b = false".
  reflexivity.
Qed.

Theorem plus_O_r_firsttry:
  forall n : nat,
    n + O = n.
Proof.
  intros n.
  simpl.
Abort.

Theorem plus_O_r_secondtry:
  forall n : nat,
    n + O = n.
Proof.
  intros n.
  destruct n as [| n'].
  Case "n = O".
  reflexivity.
  Case "n = S n'".
  simpl.
Abort.

Theorem plus_O_r:
  forall n : nat,
    n + O = n.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem minus_diag:
  forall n : nat,
    minus n n = O.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem mult_O_r:
  forall n : nat,
    n * O = O.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_n_Sm:
  forall n m : nat,
    S (n + m) = n + (S m).
Proof.
  intros n m.
  induction n as [| n'].
  Case "n = O".
  simpl.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_comm:
  forall n m : nat,
    n + m = m + n.
Proof.
  intros n m.
  induction n as [| n'].
  Case "n = O".
  simpl.
  rewrite -> plus_O_r.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  rewrite -> plus_n_Sm.
  reflexivity.
Qed.

Theorem plus_assoc:
  forall n m p : nat,
    n + (m + p) = (n + m) + p.
Proof.
  intros n m p.
  induction n as [| n'].
  Case "n = O".
  simpl.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Fixpoint double (n : nat) :=
  match n with
    | O => O
    | S n' => S (S (double n'))
  end.

Lemma double_plus:
  forall n,
    double n = n + n.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
  simpl.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  rewrite -> plus_n_Sm.
  reflexivity.
Qed.

Theorem mult_O_plus':
  forall n m : nat,
    (O + n) * m = n * m.
Proof.
  intros n m.
  assert (H: O + n = n).
  Case "Proof of assertion". reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_rearrange_firsttry:
  forall n m p q : nat,
    (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  rewrite -> plus_comm.
Abort.

Theorem plus_rearrange_secondtry:
  forall n m p q : nat,
    (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  Case "Proof of assertion".
  rewrite -> plus_comm.
  reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem beq_nat_refl:
  forall n : nat,
    true = beq_nat n n.
Proof.
  intros n.
  induction n as [| n].
  simpl. reflexivity.
  simpl. rewrite -> IHn. reflexivity.
Qed.

Theorem plus_swap:
  forall n m p : nat,
    n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc.
  rewrite -> plus_assoc.
  assert (H: n + m = m + n).
  Case "Proof of assertion".
  rewrite -> plus_comm.
  reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_elim:
  forall m n : nat,
    n + n * m = n * S m.
Proof.
  intros m n.
  induction n as [| n'].
  reflexivity.
  simpl.
  rewrite -> plus_swap.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem mult_comm:
  forall m n : nat,
    m * n = n * m.
Proof.
  intros m n.
  induction m as [| m'].
  Case "m = O".
    simpl.
    rewrite -> mult_O_r.
    reflexivity.
  Case "m = S m'".
    simpl.
    rewrite -> IHm'.
    rewrite -> plus_elim.
    reflexivity.
Qed.

Theorem evenb_n__oddb_Sn:
  forall n : nat,
    evenb n = negb (evenb (S n)).
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
    simpl. reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'.
    rewrite -> negb_involutive.
    destruct n'.
    simpl. reflexivity.
    simpl. reflexivity.
Qed.

Theorem ble_nat_refl:
  forall n : nat,
    true = ble_nat n n.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
  simpl. reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem zero_nbeq_S:
  forall n : nat,
    beq_nat O (S n) = false.
Proof.
  intros n.
  simpl. reflexivity.
Qed.

Theorem andb_false_r:
  forall b : bool,
    andb b false = false.
Proof.
  intros b.
  destruct b.
  Case "b = true".
  simpl. reflexivity.
  Case "b = false".
  simpl. reflexivity.
Qed.

Theorem plus_ble_compat_l:
  forall n m p : nat,
    ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  intros n m p.
  intros H.
  induction p as [| p'].
  Case "p = O".
  simpl.
  rewrite -> H.
  reflexivity.
  Case "p = S p'".
  simpl.
  rewrite -> IHp'.
  reflexivity.
Qed.

Theorem S_nbeq_O:
  forall n : nat,
    beq_nat (S n) O = false.
Proof.
  intros n.
  simpl. reflexivity.
Qed.

Theorem mult_1_l:
  forall n : nat,
    1 * n = n.
Proof.
  intros n.
  simpl.
  rewrite -> plus_O_r.
  reflexivity.
Qed.

Theorem all3_spec:
  forall b c : bool,
    orb
      (andb b c)
      (orb
         (negb b)
         (negb c))
      = true.
Proof.
  intros b c.
  destruct b as [| b].
  Case "b = true".
  simpl.
  destruct c as [| c].
  simpl. reflexivity.
  simpl. reflexivity.
  Case "b = false".
  simpl. reflexivity.
Qed.

Theorem mult_plus_distr_r:
  forall n m p : nat,
    (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p.
  induction p as [| p'].
  Case "p = O".
  rewrite -> mult_O_r.
  rewrite -> mult_O_r.
  simpl.
  rewrite -> mult_O_r.
  reflexivity.
  Case "p = S p'".
  rewrite <- plus_elim.
  rewrite -> IHp'.
  assert (H: n * S p' = n + n * p').
  rewrite <- plus_elim. reflexivity.
  rewrite -> H.
  assert (H': m * S p' = m + m * p').
  rewrite <- plus_elim. reflexivity.
  rewrite -> H'.
Abort.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.DownwardsSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Sound_Downwards.

Context {L: Language}
        {minL: MinimumLanguage L}
        {iffpL: IffLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        (M: Kmodel)
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {dSA: DownwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {kminSM: KripkeMinimumSemantics L MD M SM}
        {kiffpSM: KripkeIffSemantics L MD M SM}
        {dsepconSM: DownwardsSemantics.SepconSemantics L MD M SM}
        {dwandSM: DownwardsSemantics.WandSemantics L MD M SM}.

Lemma sound_sepcon_comm:
  forall x y: expr,
    forall m,
      KRIPKE: M, m |= x * y --> y * x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0 |- *; intros.
  destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  exists m0, m2, m1.
  split; [| split]; auto.
  apply join_comm; auto.
Qed.

Lemma sound_sepcon_assoc:
  forall x y z: expr,
    forall m,
      KRIPKE: M, m |= x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  apply sat_iffp.
  split; intros.
  + rewrite sat_sepcon in H0.
    destruct H0 as [n' [mx' [myz' [? [? [? ?]]]]]].
    rewrite sat_sepcon in H3.
    destruct H3 as [myz'' [my'' [mz'' [? [? [? ?]]]]]].
    apply join_comm in H1.
    apply join_comm in H4.
    assert (mx' <= mx') by reflexivity.
    destruct (join_Korder_down _ _ _ _ _ H1 H3 H7) as [n'' [? ?]].
    destruct (join_assoc mz'' my'' mx' myz'' n'' H4 H8) as [mxy'' [? ?]].
    apply join_comm in H10.
    apply join_comm in H11.
    rewrite sat_sepcon.
    exists n'', mxy'', mz''.
    split; [| split; [| split]]; auto.
    - etransitivity; eauto.
    - rewrite sat_sepcon.
      exists mxy'', mx', my''.
      split; [| split; [| split]]; auto.
      reflexivity.
  + rewrite sat_sepcon in H0.
    destruct H0 as [n' [mxy' [mz' [? [? [? ?]]]]]].
    rewrite sat_sepcon in H2.
    destruct H2 as [mxy'' [mx'' [my'' [? [? [? ?]]]]]].
    assert (mz' <= mz') by reflexivity.
    destruct (join_Korder_down _ _ _ _ _ H1 H2 H7) as [n'' [? ?]].
    destruct (join_assoc mx'' my'' mz' mxy'' n'' H4 H8) as [myz'' [? ?]].
    rewrite sat_sepcon.
    exists n'', mx'', myz''.
    split; [| split; [| split]]; auto.
    - etransitivity; eauto.
    - rewrite sat_sepcon.
      exists myz'', my'', mz'.
      split; [| split; [| split]]; auto.
      reflexivity.
Qed.

Lemma sound_wand_sepcon_adjoint:
  forall x y z: expr,
   (forall m, KRIPKE: M, m |= x * y --> z) <-> (forall m, KRIPKE: M, m |= x --> (y -* z)).
Proof.
  intros.
  split; intro.
  + assert (ASSU: forall m0 m1 m2 m, m0 <= m -> join m1 m2 m0 -> KRIPKE: M, m1 |= x -> KRIPKE: M, m2 |= y -> KRIPKE: M, m |= z).
    {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      apply (H m); [reflexivity |].
      rewrite sat_sepcon.
      exists m0, m1, m2; auto.
    }
    clear H.
    intros.
    rewrite sat_impp; intros.
    rewrite sat_wand; intros.
    apply (ASSU m2 n m1 m2); auto.
    reflexivity.
  + assert (ASSU: forall m1 m2 m, join m m1 m2 -> KRIPKE: M, m |= x -> KRIPKE: M, m1 |= y -> KRIPKE: M, m2 |= z).
    {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      revert m1 m2 H0 H2.
      rewrite <- sat_wand.
      apply (H m); [reflexivity | auto].
    }
    intros.
    rewrite sat_impp; intros.
    rewrite sat_sepcon in H1.
    destruct H1 as [m0 [m1 [m2 [? [? [? ?]]]]]].
    pose proof (ASSU m2 m0 m1 H2 H3 H4).
    eapply sat_mono; eauto.
Qed.

Lemma sound_sepcon_mono:
  forall x1 x2 y1 y2: expr,
   (forall m, KRIPKE: M, m |= x1 --> x2) ->
   (forall m, KRIPKE: M, m |= y1 --> y2) ->
   (forall m, KRIPKE: M, m |= x1 * y1 --> x2 * y2).
Proof.
  intros.
  assert (ASSUx: forall m, KRIPKE: M, m |= x1 -> KRIPKE: M, m |= x2).
  {
    intros.
    specialize (H m0).
    rewrite sat_impp in H.
    apply (H m0); [reflexivity | auto].
  }
  assert (ASSUy: forall m, KRIPKE: M, m |= y1 -> KRIPKE: M, m |= y2).
  {
    intros.
    specialize (H0 m0).
    rewrite sat_impp in H0.
    apply (H0 m0); [reflexivity | auto].
  }
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H2 |- *.
  destruct H2 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  exists m0, m1, m2; auto.
Qed.

Lemma sound_sepcon_elim1 {incrSA: IncreasingSeparationAlgebra (Kworlds M)}:
  forall x y: expr,
    forall m, KRIPKE: M, m |= x * y --> x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0.
  destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  apply join_comm in H1.
  apply all_increasing in H1.
  eapply sat_mono; eauto.
  eapply sat_mono; eauto.
Qed.

Context {empL: EmpLanguage L}
        {dempSM: DownwardsSemantics.EmpSemantics L MD M SM}.

Lemma sound_sepcon_emp {USA: UnitalSeparationAlgebra (Kworlds M)}:
  forall x: expr,
    forall m, KRIPKE: M, m |= x * emp <--> x.
Proof.
  intros.
  apply sat_iffp.
  split; intros.
  + clear m H.
    rewrite sat_sepcon in H0.
    destruct H0 as [m'' [m' [u [? [? [? ?]]]]]].
    rewrite sat_emp in H2.
    apply join_comm in H0.
    unfold increasing in H2.
    apply H2 in H0.
    eapply sat_mono; eauto.
    eapply sat_mono; eauto.
  + rewrite sat_sepcon.
    destruct (incr_exists n) as [u [? ?]].
    destruct H1 as [n' [H1 H1']].
    exists n, n', u.
    split; [| split; [| split]]; auto.
    - reflexivity.
    - apply join_comm; auto.
    - eapply sat_mono; eauto.
    - rewrite sat_emp.
      auto.
Qed.

End Sound_Downwards.


Require Import HoTT.
Require Import HottCat.TFunctors.

Section Option_is_monad.
  Notation T := option.

  Local Definition T_bind (A B : Type) (x: T A) (f: A -> T B): T B
    := match x with
       | None => None
       | Some a => f a
       end.

  Local Definition T_ret: forall A : Type, A -> T A := Some.

  Local Definition T_ret_unit_left: forall (A B : Type) (k : A -> T B)
        (a : A), T_bind A B (T_ret A a) k = k a.
    intros; auto. Defined.

  Local Definition T_ret_unit_right : forall (A : Type) (m : T A),
        T_bind A A m (T_ret A) = m.
    intros; destruct m; auto.
    Defined.

  Local Definition T_bind_assoc : forall (A B C : Type) (m : T A)
        (k : A -> T B) (h : B -> T C), T_bind A C m (fun x : A
        => T_bind B C (k x) h) = T_bind B C (T_bind A B m k) h.
    intros; destruct m; auto.
    Defined.

  Global Instance option_is_monad: TMonad option
    := Build_TMonad option T_bind T_ret T_ret_unit_left
        T_ret_unit_right T_bind_assoc.

End Option_is_monad.

Section Option_eq.
  Context {A: Type}.
  Implicit Types (x y: option A).

  Local Fixpoint option_eq (x y: option A): Type :=
    match x, y with
    | None, None => Unit
    | Some a, Some b => a = b
    | _, _ => Empty
    end.

  Infix "=opt" := option_eq (at level 75, right associativity).

  Local Definition option_encode {x y}: x = y -> x =opt y.
    induction 1; destruct x; done.
    Defined.

  Local Definition option_decode {x y}: x =opt y -> x = y.
    destruct x, y; simpl; induction 1; auto.
    Defined.

  Global Instance isequiv_option_encode {x y}: IsEquiv (@option_encode x y).
    refine (isequiv_adjointify option_encode option_decode _ _).
    - unfold Sect.
      destruct x, y; unfold option_encode, option_decode; simpl;
          intros; induction x; done.
    - unfold Sect, option_encode, option_decode; simpl; intros.
      path_induction. induction x; done.
    Defined.

  Definition equiv_path_opt {x y}: x = y <~> x =opt y
    := BuildEquiv _ _ option_encode isequiv_option_encode.

  Lemma error_ne_some (x: A): (error = Some x) -> Empty.
    intro p; apply (equiv_fun equiv_path_opt) in p.
    done. Qed.

End Option_eq.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_upp_nom_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_upp x1 L1 T1') ->
                  forall T2 L2 t T2', T2 = (t_nom L2 t T2') ->
                                 subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.


Require Import Coq.Sets.Ensembles.

Require Import SpecCert.Formalism.ComputingSystem.
Require Import SpecCert.Formalism.Security.

(**
    A hardware-software mapping is a function which maps a hardware state
    to the currently executed software.
**)
Definition HardwareSoftwareMapping
           (H S: Type)
  := H -> S.

Definition EventSoftwareMapping
           (H E S: Type)
  := H -> E -> option S.

Definition is
           {A: Type}
           (a: A)
           (o: option A)
  : Prop :=
  match o with
  | Some a' => a = a'
  | None    => False
  end.

Definition software_tampering
           {H E S: Type}
           (context:   HardwareSoftwareMapping H S)
           (fetched:   EventSoftwareMapping H E S)
           (h:         H)
           (ev:        E)
           (x y:       S)
  : Prop :=
  context h = x /\ is y (fetched h ev).

Definition software_step_isolation
           {H E S:   Type}
           (context: HardwareSoftwareMapping H S)
           (fetched: EventSoftwareMapping H E S)
           (T:       Ensemble S)
           (h:       H)
           (ev:      E)
  : Prop :=
  forall t u: S,
    In S T t
    -> ~ In S T u
    -> ~software_tampering context fetched h ev t u.

Definition software_execution_isolation
           {H E S:     Type}
          `{Event E}
           {init last: H}
           {C:         ComputingSystem H E}
           (context:   HardwareSoftwareMapping H S)
           (fetched:   EventSoftwareMapping H E S)
           (T:         Ensemble S)
           (r:         Run C init last)
  : Prop :=
  always_true (software_step_isolation context fetched T) r.


Require Import Word.
Require Import ZArith.

Set Implicit Arguments.

Definition wordToZ sz (w : word sz) : Z := Z.of_N (wordToN w).
Definition ZToWordTrunc sz (z : Z) : word sz :=
  match z with
  | Z0 => $0
  | Zpos p => posToWord sz p
  | Zneg p => wneg (posToWord sz p)
  end.

Definition ZToWord sz (z : Z) : option (word sz) :=
  match z with
  | Z0 => Some $0
  | Zpos p =>
    match Z.compare z (2 ^ (Z.of_nat sz))%Z with
    | Lt => Some (posToWord sz p)
    | _ => None
    end
  | Zneg p => None
  end.

Theorem wordToZ_nat : forall sz (w : word sz), wordToZ w = Z_of_nat (wordToNat w).
Proof.
  unfold wordToZ.
  intros.
  rewrite wordToN_nat.
  unfold Z.of_N, N.of_nat, Z.of_nat.
  destruct # (w); auto.
Qed.

Theorem ZToWordTrunc_wordToZ : forall sz w,
  ZToWordTrunc sz (wordToZ w) = w.
Proof.
  intros.
  rewrite wordToZ_nat.
  unfold Z.of_nat.
  case_eq (# w); simpl; intros.
  - rewrite <- natToWord_wordToNat.
    congruence.
  - rewrite posToWord_nat.
    rewrite SuccNat2Pos.id_succ.
    rewrite <- natToWord_wordToNat.
    congruence.
Qed.

Lemma Z_pow_Npow2 : forall p,
  Z.pow 2 (Z.of_nat p) = Z.of_N (Npow2 p).
Proof.
  intros.
  rewrite pow2_N.
  rewrite nat_N_Z.
  induction p; auto.
  rewrite Nat2Z.inj_succ.
  rewrite Z.pow_succ_r.
  rewrite IHp.
  rewrite Z.mul_comm.
  rewrite <- Zplus_diag_eq_mult_2.
  simpl.
  rewrite Nat2Z.inj_add.
  rewrite <- plus_n_O.
  reflexivity.
  replace (0%Z) with (Z.of_nat 0) by reflexivity.
  apply inj_le.
  omega.
Qed.

Theorem wordToZ_ZToWordTrunc_idempotent : forall sz z,
  (0 <= z < (2 ^ (Z.of_nat sz)))%Z -> wordToZ (ZToWordTrunc sz z) = z.
Proof.
  intros.
  rewrite wordToZ_nat.
  destruct z; simpl.
  - rewrite roundTrip_0. reflexivity.
  - rewrite posToWord_nat.
    rewrite wordToNat_natToWord_idempotent.
    rewrite positive_nat_Z; reflexivity.
    rewrite positive_nat_N.
    inversion H.
    apply N2Z.inj_lt.
    rewrite positive_N_Z.
    rewrite Z_pow_Npow2 in H1.
    auto.
  - inversion H.
    compute in *.
    congruence.
Qed.

Lemma wordToZ_bound : forall sz (w : word sz),
  (0 <= wordToZ w < (2 ^ (Z.of_nat sz)))%Z.
Proof.
  unfold wordToZ; split.
  - apply N2Z.is_nonneg.
  - rewrite wordToN_nat.
    rewrite Z_pow_Npow2.
    rewrite <- (Nnat.N2Nat.id (Npow2 sz)).
    rewrite Npow2_nat.
    repeat rewrite nat_N_Z.
    apply Nat2Z.inj_lt.
    apply wordToNat_bound.
Qed.

Theorem ZToWord_wordToZ : forall sz w,
  ZToWord sz (wordToZ w) = Some w.
Proof.
  intros.
  pose proof (ZToWordTrunc_wordToZ w).
  destruct (wordToZ_bound w).
  remember (wordToZ w).
  destruct z.
  - simpl in *; congruence.
  - unfold ZToWord.
    replace (Z.compare (Z.pos p) (2 ^ Z.of_nat sz)%Z) with (Lt).
    unfold ZToWordTrunc in H; congruence.
  - pose proof (Pos2Z.neg_is_neg p).
    apply Zle_not_lt in H0.
    congruence.
Qed.

Theorem wordToZ_ZToWord : forall sz w z,
  ZToWord sz z = Some w ->
  wordToZ w = z.
Proof.
  unfold ZToWord; intros.
  destruct z.
  - inversion H. unfold wordToZ.
    rewrite wordToN_nat. rewrite roundTrip_0. reflexivity.
  - destruct (Z.compare (Z.pos p) (2 ^ Z.of_nat sz))%Z eqn:Heq; try congruence.
    assert (Z.pos p < 2 ^ Z.of_nat sz)%Z by (apply Z.compare_lt_iff; auto).
    inversion H.
    replace (posToWord sz p) with (ZToWordTrunc sz (Z.pos p)) by reflexivity.
    rewrite wordToZ_ZToWordTrunc_idempotent; auto.
    split; auto.
    apply Zle_0_pos.
  - congruence.
Qed.


Require Import List.
Require Import matchingl.
Require Import matchinglreduction.

Module MatchLProofSystem(Base : ObjectLanguage).

Module Reduction := MatchLReduction Base.
Export Reduction.

Inductive PS (strict : bool) : System -> Formula -> Formula -> Prop :=
| ps_refl :
  strict = false ->
  forall phi : Formula, forall A : System,
  PS strict A phi phi
| ps_axiom :
  forall A : System, forall phi phi' : Formula,
  A (phi, phi') ->
  PS strict A phi phi'
| ps_subst :
  forall A : System, forall phi phi' : Formula,
  PS strict A phi phi' ->
  forall rho,
  PS strict A (ApplyF rho phi) (ApplyF rho phi')
| ps_trans :
  forall A : System, forall phi1 phi2 phi3 : Formula,
  PS strict A phi1 phi2 ->
  PS false A phi2 phi3 ->
  PS strict A phi1 phi3
| ps_case :
  forall A : System, forall phi phi1 phi2 : Formula,
  PS strict A phi1 phi ->
  PS strict A phi2 phi ->
  PS strict A (Or phi1 phi2) phi
| ps_lf :
  forall A : System, forall phi phi' psi : Formula,
  PS strict A phi phi' ->
  patternless psi ->
  PS strict A (And phi psi) (And phi' psi)
| ps_conseq :
  forall A : System, forall phi1 phi1' phi2 phi2' : Formula,
  Valid (Implies phi1 phi1') ->
  PS strict A phi1' phi2' ->
  Valid (Implies phi2' phi2) ->
  PS strict A phi1 phi2
| ps_abstr :
  forall A : System, forall phi phi' : Formula, forall X : Var,
  PS strict A phi phi' ->
  notFree X phi' ->
  PS strict A (Exists X phi) phi'
| ps_circ :
  forall A : System, forall phi phi' phi'' : Formula,
  PS true A phi phi'' ->
  PS false (cons_System (phi, phi') A) phi'' phi' ->
  PS strict A phi phi'.

Definition PS29 := PS true.

Definition PS19 := PS false.

End MatchLProofSystem.


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

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

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

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

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

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
   + intros. reflexivity.
   + destruct n2.
   * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
   * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
   + intros. destruct n. reflexivity. reflexivity.
   + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

Theorem theorem0 : forall (v : natural) (w : natural) (x : natural) (y : natural) (z : lst), eq (drop (Succ v) (drop w (drop x (Cons y z)))) (drop v (drop w (drop x z))).
Proof.
intros.
rewrite lem.
 lfind. Admitted.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e256m4294968273_8limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Proset.
Require Import Blech.Proset.Heyting.

Import ProsetNotations.
Import HeytingNotations.

(* Ostensibly, a first order system of logic is a free heyting algebra over the
set of free variables *)
Inductive free (T: Type) :=
| var (_: T)
| top
| bot
| meet (_ _: free T)
| join (_ _: free T)
| impl (_ _: free T)
.

Arguments var [T].
Arguments top {T}.
Arguments bot {T}.
Arguments meet {T}.
Arguments join {T}.
Arguments impl {T}.

Inductive entails {T}: relation (free T) :=
| reflexive: reflexive (free T) entails
| transitive: transitive (free T) entails

| bang {A}: entails A top
| fanout {C A B}: entails C A → entails C B → entails C (meet A B)
| fst {A B}: entails (meet A B) A
| snd {A B}: entails (meet A B) B

| absurd {A}: entails top A
| fanin {C A B}: entails A C → entails B C → entails (join A B) C
| inl {A B}: entails A (join A B)
| inr {A B}: entails B (join A B)

| curry {A B C}: entails (meet A B) C → entails A (impl B C)
| eval {A B}: entails (meet (impl A B) A) B
.

#[program]
Definition Free (S: Type) : Heyting := {|
  P := {|
        T := free S ;
        preorder := entails ;
  |} ;

  Heyting.top := top ;
  Heyting.bot := bot ;

  Heyting.meet := meet ;
  Heyting.join := join ;
  Heyting.impl := impl ;
|}.

Next Obligation.
Proof.
  admit.
Admitted.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.

(* Why3 goal *)
Lemma infix_plpl_def : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)),
  ((Init.Datatypes.app l1 l2) = match l1 with
  | Init.Datatypes.nil => l2
  | (Init.Datatypes.cons x1 r1) =>
      (Init.Datatypes.cons x1 (Init.Datatypes.app r1 l2))
  end).
Proof.
now intros a a_WT [|h1 q1] l2.
Qed.

Require Import Lists.List.

(* Why3 goal *)
Lemma Append_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)),
  ((Init.Datatypes.app l1 (Init.Datatypes.app l2 l3)) = (Init.Datatypes.app (Init.Datatypes.app l1 l2) l3)).
Proof.
intros a a_WT l1 l2 l3.
apply app_assoc.
Qed.

(* Why3 goal *)
Lemma Append_l_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((Init.Datatypes.app l Init.Datatypes.nil) = l).
Proof.
intros a a_WT l.
apply app_nil_r.
Qed.

(* Why3 goal *)
Lemma Append_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)),
  ((list.Length.length (Init.Datatypes.app l1 l2)) = ((list.Length.length l1) + (list.Length.length l2))%Z).
Proof.
intros a a_WT l1 l2.
rewrite 3!Length.length_std.
now rewrite app_length, inj_plus.
Qed.

(* Why3 goal *)
Lemma mem_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), (list.Mem.mem x
  (Init.Datatypes.app l1 l2)) <-> ((list.Mem.mem x l1) \/ (list.Mem.mem x
  l2)).
Proof.
intros a a_WT x l1 l2.
split.
intros H.
apply Mem.mem_std in H.
apply in_app_or in H.
destruct H as [H|H].
left.
now apply Mem.mem_std.
right.
now apply Mem.mem_std.
intros H.
apply Mem.mem_std.
apply in_or_app.
destruct H as [H|H].
left.
now apply Mem.mem_std.
right.
now apply Mem.mem_std.
Qed.

(* Why3 goal *)
Lemma mem_decomp : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), (list.Mem.mem x l) -> exists l1:(list a), exists l2:(list a),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons x l2))).
Proof.
intros a a_WT x l h1.
apply in_split.
now apply Mem.mem_std.
Qed.


(* http://d.hatena.ne.jp/hzkr/20100902 *)

(* ゴールを変形する *)
Goal forall P Q R: Prop, (P -> Q -> R) -> (Q -> P) -> Q -> R.
Proof.
  intros.
  apply H.
  (* Pについて *)
  apply H0.
  apply H1.
  (* Qについて *)
  apply H1.
Qed.

(* ↑をexactで *)
Goal forall P Q R: Prop, (P -> Q -> R) -> (Q -> P) -> Q -> R.
Proof.
  intros.
  exact (H (H0 H1) H1).
Qed.

(* 仮定を増やす *)
Goal forall P Q R: Prop, (P -> Q -> R) -> (Q -> P) -> Q -> R.
Proof.
  intros.
  assert (H2 := H0 H1).
  assert (H3 := H H2 H1).
  exact H3.
Qed.

(* ↑をexactで *)
Goal forall P Q R: Prop, (P -> Q -> R) -> (Q -> P) -> Q -> R.
Proof.
  intros.
  specialize (H0 H1).  (* H0を置き換える*)
  exact (H H0 H1).
Qed.


Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.
Import AState.

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption. Qed.

Example auto_example3 : forall P Q R S T U,
    (P -> Q) ->
    (Q -> R) ->
    (R -> S) ->
    (S -> T) ->
    (T -> U) ->
    P -> U.
Proof.
  auto. auto 6.
Qed.

Lemma le_antisym : forall  n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Lemma auto_example6 : forall n m p,
    (n <= p -> n <= m /\ m <= n) ->
    n <= p -> n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.

Lemma auto_example6' : forall n m p,
    (n <= p -> n <= m /\ m <= n) ->
    n <= p -> n = m.
Proof.
  intros.
  auto.
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto. Abort.

Hint Unfold is_fortytwo.

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

Theorem ceval_deterministic'_alt: forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwinv H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0...
Qed.

Ltac find_rwinv :=
  match goal with
    H1 : ?E = true,
    H2 : ?E = false
    |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0...
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0...
Qed.

Theorem ceval_deterministic'''': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

Ltac find_eqn :=
  match goal with
    H1 : forall x, ?P x -> ?L = ?R,
    H2 : ?P ?X
    |- _ => rewrite (H1 X H2) in *
end.

Theorem ceval_deterministic''''': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

Module Repeat.

  Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

  Notation "'SKIP'" :=
    CSkip.
  Notation "c1 ; c2" :=
    (CSeq c1 c2) (at level 80, right associativity).
  Notation "X '::=' a" :=
    (CAsgn X a) (at level 60).
  Notation "'WHILE' b 'DO' c 'END'" :=
    (CWhile b c) (at level 80, right associativity).
  Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
    (CIf e1 e2 e3) (at level 80, right associativity).
  Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
    (CRepeat e1 b2) (at level 80, right associativity).

 Inductive ceval : state -> com -> state -> Prop :=
 | E_Skip  st:
     ceval st SKIP st
 | E_Ass st a1 n X :
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq  c1 c2 st st' st'' :
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue  st st' b1 c1 c2 :
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse st st' b1 c1 c2 :
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse  b1 st c1 :
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue  st st' st'' b1 c1 :
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd  st st' b1 c1 :
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop  st st' st'' b1 c1 :
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

 Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                    (at level 40, st at level 39).

 Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't find_rwinv solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.

 Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.
End Repeat.


Require Import FiatFormal.Data.List.Base.
Require Import FiatFormal.Tactics.

(* Update the element at the given position in a list.
   If the position is not in the list then return the original list. *)
Fixpoint update {A: Type} (ix: nat) (y: A) (xx: list A) : list A :=
 match ix, xx with
 | _,    nil       => nil
 | O,    x :: xs   => y :: xs
 | S n', x :: xs   => x :: update n' y xs
 end.

(* Updating an element in a list preserves that list's length *)
Lemma update_length
 : forall {A} i (x : A) (xs : list A)
 , length (update i x xs) = length xs.
Proof.
 intros. gen i.
 induction xs.
  destruct i; burn.
  intros.
   destruct i; burn.
Qed.

Lemma Forall_update
 :  forall A (P: A -> Prop) ix x xs
 ,  P x
 -> Forall P xs
 -> Forall P (update ix x xs).
Proof.
 intros. gen ix.
 induction xs; intros.
  destruct ix; simpl; auto.
  destruct ix; inverts H0.
   simpl. auto.
   simpl. apply Forall_cons; auto.
Qed.

Lemma Forall_update_result
 :  forall A (P: A -> Prop) ix x y xs
 ,  get ix xs = Some y
 -> Forall P (update ix x xs)
 -> P x.
Proof.
 intros. gen xs.
 induction ix; intros.
  destruct xs.
   inverts H.
   simpl in H. inverts H.
   simpl in H0. inverts H0. auto.
  destruct xs.
   simpl in H. false.
   simpl in H.
   simpl in H0. inverts H0.
   eauto.
Qed.

Lemma Forall2_update_right
 : forall {A B : Type}
          (R   : A -> B -> Prop)
          (xs  : list A)
          (ys  : list B)
          ix x y
 ,  R x y
 -> Forall2 R xs ys
 -> get ix ys = Some y
 -> Forall2 R (update ix x xs) ys.
Proof.
 intros. gen ix.
 induction H0; intros.
  false.
  induction ix.
   simpl. simpl in H2. inverts H2. auto.
   simpl. eauto.
Qed.