Require Export Iron.Language.SystemF2.Ty.

(* Type Enviroments *)
Definition tyenv := list ty.
Hint Unfold tyenv.

(* Lift type indices in type environments. *)
Definition liftTE d te    := map (liftTT 1 d) te.
Hint Unfold liftTE.

(* Substitution of types in type environments. *)
Definition substTE d t te := map (substTT d t) te.
Hint Unfold substTE.

(********************************************************************)
Lemma length_liftTE
 :  forall d te
 ,  length te = length (liftTE d te).
Proof.
 induction te; burn.
Qed.

(********************************************************************)
Lemma liftTE_liftTE
 :  forall n n' te
 ,  liftTE n              (liftTE (n + n') te)
 =  liftTE (1 + (n + n')) (liftTE n te).
Proof.
 intros. induction te; rip.
  unfold liftTE.
  simpl. rewrite liftTT_liftTT_11. burn.
Qed.

Lemma substTE_liftTE
 :  forall d te t2
 ,  substTE d t2 (liftTE d te) = te.
Proof.
 intros.
 unfold substTE. unfold liftTE.
 lists.
 induction te; simpl; burn.
Qed.

Lemma liftTE_substTE
 :  forall n n' t2 te
 ,  liftTE n (substTE (n + n') t2 te)
 =  substTE (1 + n + n') (liftTT 1 n t2) (liftTE n te).
Proof.
 intros. induction te; rip.
  unfold substTE. unfold liftTE.
   simpl. rewrite liftTT_substTT.
   unfold liftTE  in IHte.
   unfold substTE in IHte. rewrite IHte. auto.
Qed.

Lemma liftTE_closedT_id
 :  forall n se
 ,  Forall closedT se
 -> liftTE n se = se.
Proof.
 intros.
 unfold liftTE.
 induction se; rip.
  inverts H. rip.
  rs. rw (liftTT 1 n a = a).
  auto.
Qed.
Hint Resolve liftTE_closedT_id.

Lemma substTE_closedT_id
 :  forall n t2 se
 ,  Forall closedT se
 -> substTE n t2 se = se.
Proof.
 intros.
 unfold substTE.
 induction se; rip.
  inverts H. rip.
  rs. rw (substTT n t2 a = a).
  auto.
Qed.
Hint Resolve substTE_closedT_id.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Max.
Require Import Reals.
Require Import Rintegral.
Require Import Rintegral_usual.
Require Import Rintegral_tactic.
Require Import Lra.
Require Import Rsequence_facts.
Require Import Rsequence_subsequence.
Require Import Rpser.
Require Import RTaylor.
Require Import MyRfunctions.
Require Import Rsequence_tactics.

Local Open Scope R_scope.

Section Wallis.
(** printing ~	~ *)
Local Coercion INR : nat >-> R.

Definition sin_n n := fun x => pow (sin x) n.

Lemma integrable_sin_n : forall n, Riemann_integrable (comp (fun x => pow x n) sin) 0 (PI/2).
Proof.
intro n.
apply RiemannInt_P6.
pose proof PI_RGT_0; lra.
intros x Hx; apply continuity_pt_comp.
  apply continuity_sin.
  apply derivable_continuous; apply derivable_pow.
Qed.

Definition W_even n := ((PI/2)*(fact (2 * n))/(2 ^ (2 * n) * (fact n) ^2 )).
Definition W_odd n := ((2^(2*n) * (fact n) ^2)/(fact (S (2 * n)))).

Lemma Wallis_0 : Rint (sin_n 0)  0 (PI/2) (PI/2).
Proof.
apply Rint_eq_compat with (fct_cte 1).
  trivial.
assert(Hrew : (PI/2) = (1*(PI/2 -0))) by ring.
apply Rint_eq with (1 * (PI / 2 - 0)).
 auto with Rint.
 ring.
Qed.

Lemma Wallis_1 : Rint (sin_n 1)  0 (PI/2) 1.
Proof.
unfold sin_n.
apply Rint_eq_compat with sin.
  auto with *.
assert(Heq : 1 = (cos 0 - cos (PI/2))).
  rewrite cos_PI2, cos_0; ring.
apply Rint_eq with (cos 0 - cos (PI / 2)) ; auto with Rint.
Qed.

(** Recurrence formula *)
Lemma Wallis_formula : forall Wn n,
  Rint (sin_n n) 0 (PI/2) Wn->
    Rint (sin_n (S (S n))) 0 (PI/2) (Wn * (S n)/(S (S n))).
Proof.
intros Wn n H.
pose (RiemannInt (integrable_sin_n (S (S n)))) as W2n.
pose proof (Rint_RiemannInt_link _ _ _ (integrable_sin_n (S (S n)))) as HW2.
assert (W2n = (S n) * (Wn - W2n)) as Heq.
replace (S n * (Wn - W2n)) with
  (comp (fun x => x ^ (S n)) sin (PI/2) *((- cos)%F (PI/2)) - comp (fun x => x ^ (S n)) sin 0 *((- cos)%F 0) - (-(S n) * (Wn - W2n))).
eapply Rint_parts with (f' := fun x => ((S n) * sin x ^ n)* cos x) (g' := sin).
  left; apply PI2_RGT_0.

  intros.
  apply derivable_pt_lim_comp.
    auto with Rcont.
    apply derivable_pt_lim_pow.

  intros.
  replace (sin x) with (- - sin x) by ring.
  auto with Rcont.

  intros.
  apply continuity_pt_mult.
    apply continuity_pt_mult; auto with Rcont.
      apply continuity_pt_const; intros u v; reflexivity.
      reg.
    auto with Rcont.
    auto with Rcont.

  apply Rint_eq_compat with (comp (fun x : R => x ^ S (S n)) sin).
  intros; unfold comp, mult_fct; simpl; ring.
  apply Rint_RiemannInt_link.

  apply Rint_eq_compat with (fun x => (- S n) * (sin x ^ n - sin x ^ (S (S n)))).
  intros.
  unfold mult_fct, opp_fct.
  rewrite Rmult_assoc.
  replace (cos x * - cos x) with (-(1 - (sin x)^2)).
  unfold Rsqr; simpl; ring.
  replace ((sin x) ^ 2) with ((sin x)²) by (unfold Rsqr; ring).
  rewrite <- (cos2 x); unfold Rsqr; ring.
  apply Rint_scalar_mult_compat_l.
  apply Rint_minus; trivial.

  unfold opp_fct, comp;
  rewrite cos_0, cos_PI2, sin_PI2, sin_0;
  simpl; ring.

replace (Wn * S n / S (S n)) with (W2n).
  trivial.
rewrite Rmult_comm.
replace W2n with (/(S (S n)) * (S (S n))* W2n).
replace Wn with ((Wn - W2n) + W2n) by ring.
rewrite Rmult_plus_distr_l.
rewrite <- Heq.
unfold Rdiv.
rewrite Rmult_comm with (r1 := (W2n + S n * W2n)).
rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
simpl; ring.
field.
auto with *.
Qed.

Lemma Wallis_even : forall n, Rint (sin_n (2 * n)) 0 (PI/2) (W_even n).
Proof.
unfold W_even.
induction n.
  simpl; unfold Rsqr; field_simplify; apply Wallis_0.

apply Rint_eq_compat with (sin_n (S (S (2 *  n)))).
  intros; simpl;
  replace (S (n + S (n + 0))) with (S (S (n + (n + 0)))) by auto;
  reflexivity.

replace (PI / 2 * fact (2 * S n) / (2 ^ (2 * S n) * (fact (S n)) ^2)) with
  ((PI / 2 * fact (2 * n) / (2 ^ (2 * n) * (fact n)^2)) * S (2 * n) / (S (S (2 * n)))).
apply Wallis_formula; apply IHn.

replace (2 * S n)%nat with (S (S (2 * n))) by auto with *.
repeat rewrite fact_simpl.
repeat rewrite <- tech_pow_Rmult.
unfold Rsqr.
replace (S (S (2*n))) with (2 * (S n))%nat by auto with *.
repeat rewrite mult_INR.
replace (INR 2) with 2 by trivial; field.

repeat split.
apply not_0_INR; apply fact_neq_0.
auto with *.
apply pow_nonzero; pose proof Rlt_R0_R2; intro; lra.
Qed.

Lemma Wallis_odd : forall n, Rint (sin_n (S (2 * n))) 0 (PI/2) ((2^(2*n) * (fact n) ^2)/(fact (S (2 * n)))).
Proof.
unfold W_odd.
induction n.
  simpl; replace (1 * (1 * (1*1)) / 1) with 1 by field; apply Wallis_1.
apply Rint_eq_compat with (sin_n (S (S (S (2 * n))))).
  intros; simpl.
replace (n + S (n + 0))%nat with (S (n + (n + 0))) by auto;
reflexivity.
replace (2 ^ (2 * S n) * (fact (S n))^2 / fact (S (2 * S n))) with
  ((2 ^ (2 * n) * (fact n)^2 / fact (S (2 * n))) * (S (S (2 * n)))/(S (S (S (2 * n))))).
apply Wallis_formula; apply IHn.

replace (2 * S n)%nat with (S (S (2 * n))) by auto with *.
repeat rewrite fact_simpl.
repeat rewrite <- tech_pow_Rmult.
unfold Rsqr.
replace (S (S (2*n))) with (2 * (S n))%nat by auto with *.
repeat rewrite mult_INR.
replace (INR 2) with 2 by trivial; field.

repeat split;apply not_0_INR; try (auto with * ).
apply fact_neq_0.
Qed.

Lemma Wallis_odd_le_even : forall n, W_odd n <= W_even n.
Proof.
intro n.
apply (Rint_le_compat (sin_n (S (2 * n))) (sin_n (2 * n)) 0 (PI/2)).
  left; apply PI2_RGT_0.

  intros; unfold sin_n.
  replace (sin u ^ (2 * n)) with (1 * sin u ^ (2 * n)) by ring.
  rewrite <- tech_pow_Rmult.
  apply Rmult_le_compat_r.
    apply pow_le.
    apply sin_ge_0; intuition; lra.
    pose proof (SIN_bound u); intuition.

apply Wallis_odd.
apply Wallis_even.
Qed.

Lemma Wallis_even_le_odd : forall n, W_even (S n) <= W_odd n.
Proof.
intro n.
apply (Rint_le_compat (sin_n (2 * (S n))) (sin_n (S (2 * n))) 0 (PI/2)).
  left; apply PI2_RGT_0.

  intros; unfold sin_n.
  replace (2 * (S n))%nat with (S (S (2 * n))) by auto with *.
  replace (sin u ^ (S (2 * n))) with (1 * sin u ^ (S (2 * n))) by ring.
  rewrite <- tech_pow_Rmult.
  apply Rmult_le_compat_r.
    apply pow_le.
    apply sin_ge_0; intuition; lra.
    pose proof (SIN_bound u); intuition.

apply Wallis_even.
apply Wallis_odd.
Qed.

Lemma Wallis_maj : forall n : nat, (2*n/ (S (2 * n))) * (W_even n) <= W_odd n.
Proof.
intro n.
destruct n.

  unfold W_even, W_odd, Rsqr.
  simpl; field_simplify; lra.

   replace 2 with (INR 2) by trivial; rewrite <- mult_INR.
  replace (2 * S n)%nat with (S (S (2 * n))) by auto with *.

  replace (W_odd (S n)) with (INR (S (S (2 * n))) / INR (S (S (S (2 * n)))) * W_odd n).

  apply Rmult_le_compat_l.
  unfold Rdiv.
  repeat apply Rmult_le_pos; auto with *.

  apply Wallis_even_le_odd.

  rewrite Rmult_comm.
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  eapply (Rint_uniqueness _ 0 (PI/2)).
  apply Wallis_formula.
  apply Wallis_odd.
  replace (S (S (2 * n))) with (2 * (S n))%nat by auto with *.
  apply Wallis_odd.
Qed.

Lemma W_even_pos : forall n, 0 < W_even n.
Proof.
intro n.
 unfold W_even, Rsqr, Rdiv.
 repeat apply Rmult_lt_0_compat; try lra.
  now apply Rlt_le_trans with (7 / 8); lra || apply pi2_int.
  now apply INR_fact_lt_0.
  repeat rewrite Rinv_mult_distr ; repeat apply Rmult_lt_0_compat.
   rewrite Rinv_pow.
    apply pow_lt ; lra.
    apply Rgt_not_eq ; lra.
   apply Rinv_0_lt_compat, pow_lt, INR_fact_lt_0.
   apply Rgt_not_eq, pow_lt ; lra.
   apply Rgt_not_eq, pow_lt, INR_fact_lt_0.
Qed.

Lemma Wallis_bound : forall (n : nat),  2*n / (S(2 * n)) <= W_odd n / W_even n <= 1.
Proof.
intro n ; split.
 apply Rle_trans with (2 * n / S (2 * n) * (W_even n / W_even n)).
 right ; field ; split.
 apply Rgt_not_eq ; apply W_even_pos.
 apply not_0_INR ; discriminate.
 unfold Rdiv ; rewrite <- Rmult_assoc ; apply Rmult_le_compat_r.
 left ; apply Rinv_0_lt_compat ; apply W_even_pos.
 apply Wallis_maj.
 rewrite <- Rinv_r with (W_even n).
 unfold Rdiv ; apply Rmult_le_compat_r.
 left ; apply Rinv_0_lt_compat ; apply W_even_pos.
 apply Wallis_odd_le_even.
 apply Rgt_not_eq ; apply W_even_pos.
Qed.

Lemma Wallis_quotient_lim1 : Rseq_cv (fun n => W_odd n / W_even n) 1.
Proof.
apply Rseq_sandwich_theorem
  with (Un := fun (n : nat) => 2 * n / (S (2 * n))) (Wn := fun n => 1).
  apply Rseq_cv_eq_compat with (Un := fun n => 2 * n / (2 * n + 1)).
    intros n.
    rewrite S_INR; rewrite mult_INR; reflexivity.
  apply Rseq_equiv_cv_div.
    apply Rseq_equiv_sym.
    apply Rseq_equiv_plus_little_O_compat_l.
    apply Rseq_equiv_refl.
    apply Rseq_little_O_Rmult_compat_r; [|intro H; lra].
    eapply Rseq_little_O_eq_compat
      with (Un := Rseq_poly 0) (Vn := Rseq_poly 1).
      intros n; unfold Rseq_poly; apply pow_O.
      intros n; unfold Rseq_poly; apply pow_1.
      apply Rseq_poly_little_O; constructor.
    intros n; assert (H := pos_INR n); intros Hc; lra.
  apply Rseq_constant_cv.
  apply Wallis_bound.
Qed.

Lemma Wallis_quotient :
  forall n, W_odd n / W_even n = (2*2 ^ (4*n) * (fact n) ^ 4)/(PI*fact (2 * n) * fact (S (2 * n))).
Proof.
intro n; unfold W_odd, W_even, Rsqr, Rdiv.
replace (2 ^ (4 * n)) with ((2 ^ (2 * n)) * (2 ^ (2 * n))).
field; repeat split.
  apply not_0_INR; apply fact_neq_0.
  apply not_0_INR; apply fact_neq_0.
  apply PI_neq0.
  apply not_0_INR; apply fact_neq_0.
  apply pow_nonzero; intros H; lra.
  replace (4 * n)%nat with (2 * n + 2 * n)%nat by omega.
  rewrite pow_add.
  reflexivity.
Qed.

Lemma Rseq_cv_eq_compat1 : forall Un Vn l,
  {m | forall n, (n >= m)%nat -> Un n = Vn n} ->
    Rseq_cv Un l -> Rseq_cv Vn l.
Proof.
intros Un Vn l Heq Hseq.
intros eps Heps.
destruct Heq as (m, Heq).
destruct (Hseq eps Heps) as (N, Hseq2).
exists (max N m).
intros n Hn.
assert (Hm : (n >= m)%nat). apply le_trans with (max N m) ; intuition.
unfold R_dist in *.
rewrite <- (Heq n) ; intuition.
apply Hseq2; intuition. apply le_trans with (max N m) ; intuition.
Qed.

Lemma sqrt_id : forall n : nat, (INR n <> 0)%R -> sqrt (2 * n) / (2 * n) = /sqrt (2 * n).
Proof.
intros n H1.
rewrite <- (sqrt_sqrt (2 * n)) at 2.
field.
intro H. apply H1. apply Rmult_eq_reg_l with 2. rewrite Rmult_0_r. apply sqrt_eq_0 ; intuition.
apply Rmult_le_pos ; intuition. intro ; lra.
apply Rmult_le_pos ; intuition.
Qed.

Lemma Rseq_equiv_eq : forall Un Vn,
  {m | forall n, (n >= m)%nat -> Un n = Vn n} -> Un ~ Vn.
Proof.
intros Un Vn Heq eps Heps.
destruct Heq as (N, Heq).
exists N. intros n HN.
unfold Rseq_constant, Rseq_minus, Rseq_plus.
rewrite (Heq n).
ring_simplify (Vn n - Vn n).
rewrite Rabs_R0. apply Rmult_le_pos.
intuition.
apply Rabs_pos.
assumption.
Qed.

Lemma DL_sqrt_1 : forall Un, Rseq_cv Un 0 -> (fun n => sqrt (1 + Un n) - 1) = o(1).
Proof.
intros Un Un0.
intros eps Heps.
destruct (Un0 eps Heps) as (N, HUn).
assert (H01 : 0 < 1) by lra.
destruct (Un0 1 H01) as (N1, HUn1).
exists (max N N1).
intros n HNmax.
unfold Rseq_constant. rewrite Rabs_R1. rewrite Rmult_1_r.
apply Rle_trans with (Rabs (Un n)).
apply sqrt_var_maj.
unfold R_dist in *. left.
assert (HN : (n >= N1)%nat). apply le_trans with (max N N1) ; intuition.
generalize (HUn1 n HN) ; intros HU1.
rewrite Rminus_0_r in HU1. assumption.
left.
assert (HN : (n >= N)%nat). apply le_trans with (max N N1) ; intuition.
generalize (HUn n HN) ; intros HU1.
unfold R_dist in HU1.
rewrite Rminus_0_r in HU1. assumption.
Qed.

Lemma Rseq_cv_inv_INR : Rseq_cv (fun n => /INR (n + 1)) 0.
Proof.
generalize RinvN_cv. intros useful.
intros eps Heps.
destruct (useful eps Heps) as (N, H).
exists N.
intros n Hn.
generalize (H n Hn). intros H1.
unfold pos in  H1. simpl in H1.
rewrite plus_INR. apply H1.
Qed.

Lemma Rinv_plus : forall a b c : R, c <> 0 -> (a + b) / c = a / c + (b / c).
Proof.
intros a b c d.
field ; apply d.
Qed.

Lemma Rinv_eq_1 : forall a, a <> 0 -> a / a = 1.
Proof.
intros.
field ; assumption.
Qed.

Lemma pow_exp_ln : forall x n, 0 < x -> x ^ n = exp (n * ln x).
Proof.
intros x n H.
induction n.
 simpl. rewrite Rmult_0_l. rewrite exp_0. reflexivity.

 rewrite S_INR. rewrite Rmult_plus_distr_r.
 rewrite <- tech_pow_Rmult. rewrite exp_plus.
 rewrite Rmult_1_l. rewrite exp_ln ; [ | apply H].
 rewrite IHn. ring.
Qed.

Lemma Rseq_equiv_ln : forall Un, Rseq_cv Un 0 -> (fun n => ln (1 + Un n)) ~ Un.
Proof.
intros Un Hu.
destruct (Hu 1) as [M HM]; [lra|].
apply Rseq_equiv_sym.
intros eps Heps.
assert (H1 : 0 < 1) by lra.
destruct (Rpser_little_O_partial_sum _ Un 1 1 H1 Hu ln_plus_cv_radius eps Heps) as [N HN].
exists (Max.max M N); intros n Hn.
unfold Rseq_minus; simpl.
pattern Un at 2; replace (Un n) with (Un n ^ 1) by field.
eapply Rle_trans; [right|apply HN].
  simpl; rewrite ln_plus_taylor_sum.
  rewrite Rabs_minus_sym.
  apply f_equal; field.
  replace (Un n) with (Un n - 0) by field; apply HM.
  eapply le_trans; [apply Max.le_max_l|eassumption].
eapply le_trans; [apply Max.le_max_r|eassumption].
Qed.

Lemma Rseq_cv_inv_INR_0_1 : Rseq_cv (fun n => - / (2 * INR n + 1))%R 0%R.
Proof.
replace 0 with (-0)%R by intuition. apply Rseq_cv_opp_compat.
generalize RinvN_cv. intros useful.
intros eps Heps;
destruct (Rseq_cv_inv_INR eps Heps) as (N, Hun).
exists N. intros n Hn.
generalize (Hun n Hn) ; intros Hun1.
apply Rle_lt_trans with (/INR (n + 1))%R.
 unfold R_dist. rewrite Rminus_0_r. rewrite Rabs_pos_eq.
  apply Rle_Rinv.
   generalize (pos_INR n) ; intros ; rewrite plus_INR ; intuition.
   generalize (pos_INR n) ; intros ; lra.
   rewrite plus_INR. simpl. apply Rplus_le_compat_r. replace (INR n)%R with ((INR n ) * 1)%R by ring. rewrite Rmult_comm. apply Rmult_le_compat.
    intuition.
    apply pos_INR.
    intuition.
    intuition.
 left. apply Rinv_0_lt_compat. generalize (pos_INR n) ; intros ; lra.
unfold R_dist in Hun1. rewrite Rminus_0_r in Hun1. rewrite Rabs_right in Hun1. apply Hun1.
left. apply Rgt_lt. apply Rinv_0_lt_compat. intuition.
Qed.

Lemma Rseq_equiv_continuity : forall Un Vn l f, continuity_pt f l ->
  f l <> 0 -> Rseq_cv Un l -> Rseq_cv Vn l ->
    (fun n : nat => f (Un n)) ~ (fun n : nat => f (Vn n)).
Proof.
intros Un Vn l f Hcont H0 Hun Hvn.
apply Rseq_equiv_trans with (f l).
 apply Rseq_cv_equiv_constant.
  assumption.
  apply Rseq_cv_continuity_compat ; [assumption | reg].

 apply Rseq_equiv_sym.
 apply Rseq_cv_equiv_constant.
  assumption.
  apply Rseq_cv_continuity_compat ; [assumption | reg].
Qed.

Lemma Wallis_quotient_lim2 : forall l,
l <> 0 ->
  (fun n => fact n) ~ (fun n => (n /(exp 1)) ^ n * sqrt n * l) ->
    Rseq_cv (fun n => W_odd n / W_even n) (l^2/(2*PI)).
Proof.
intros l Hneq Hl.
apply Rseq_cv_eq_compat with (fun n => (2*2 ^ (4*n) * (fact n) ^ 4)/(PI*fact (2 * n) * fact (S (2 * n)))).
  intro; rewrite Wallis_quotient; reflexivity.
assert (H2n : (fun n => fact (2 * n)) ~ (fun n => (2 * n / exp 1) ^ (2 * n) * sqrt (2 * n) * l)).
  assert (Hex : is_extractor (mult 2)).
    intros n; omega.
  pose (exist _ _ Hex) as db.
  assert (Hrw1 : extracted db fact == (fun n => fact (2 * n))).
    intros n; reflexivity.
  assert (Hrw2 : extracted db (fun n => (n / exp 1) ^ n * sqrt n * l) == (fun n => (2 * n / exp 1) ^ (2 * n) * sqrt (2 * n) * l)).
    intros n; unfold extracted. simpl.
    repeat rewrite plus_INR; simpl.
    replace (n + (n + 0)) with (2 * n) by field.
    reflexivity.
  eapply Rseq_equiv_eq_compat; [eassumption|eassumption|].
  apply Rseq_equiv_subseq_compat with (Un := fact) (Vn := fun k : nat => (k / exp 1) ^ k * sqrt k * l) (phi := db).
  assumption.
assert (H2n1 : (fun n : nat => fact (S(2*n))) ~ (fun n : nat => (S(2*n) / exp 1) ^ (S(2*n)) * sqrt (S(2*n)) * l)).
  assert (Hex : is_extractor (fun n => S (mult 2 n))).
    intros n; omega.
  pose (exist _ _ Hex) as db.
  apply Rseq_equiv_eq_compat with (extracted db fact) (extracted db (fun n : nat => (n / exp 1) ^ n * sqrt n * l)).
    intro n; unfold db; reflexivity.
    intro n; unfold db; reflexivity.
  apply Rseq_equiv_subseq_compat with (Un := fact) (Vn := fun k : nat => (k / exp 1) ^ k * sqrt k * l)(phi := db).
  assumption.

apply Rseq_equiv_cv_constant.
Local Open Scope Rseq_scope.
apply Rseq_equiv_eq_compat with
  (Un := 2 * (fun n => 2 ^ (4 * n)) * fact * fact * fact * fact *
  / (PI * (fun n => fact (2 * n)) * (fun n => fact (S (2 * n))))) (Vn := (l^2 / (2 * PI))%R).
intro n; unfold Rseq_mult, Rseq_inv, Rdiv, Rseq_constant; ring.
intro; reflexivity.
apply Rseq_equiv_trans with
(2 * (fun n => 2 ^ (4 * n)) * ((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*
  / (PI * (fun n : nat => ((2 * n / exp 1) ^ (2 * n) * sqrt (2 * n) * l)%R) *  (fun n => (S (2 * n) / exp 1) ^ S (2 * n) * sqrt (S (2 * n)) * l)%R)).

repeat apply Rseq_equiv_mult_compat;
  try apply Rseq_equiv_refl; try assumption.
apply Rseq_equiv_inv_compat.
exists O. intros n Hn.
unfold Rseq_mult, Rseq_constant.
apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ apply PI_neq0 | apply INR_fact_neq_0] | apply INR_fact_neq_0 ].

exists (S O). intros n Hn; unfold Rseq_mult, Rseq_constant.

assert(H : {m | n = S m}). exists (pred n). intuition.
destruct H as (m, Subst).
rewrite Subst.

apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ apply PI_neq0 | apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ (apply pow_nonzero ; unfold Rdiv ; apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ (intro ; lra) | (apply not_0_INR ; intuition) ] | (apply Rinv_neq_0_compat ; generalize (exp_pos 1) ; intros ; intro ; lra)])
| (intro H ; apply sqrt_eq_0 in H ; [ (apply Rmult_integral in H ; destruct H as [H|H] ; [ lra | (generalize H ; apply not_0_INR ; intuition) ])
| apply Rmult_le_pos ; intuition ]) ]
| apply Hneq ] ] | apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ (apply pow_nonzero ; unfold Rdiv ; apply Rmult_integral_contrapositive ; split ;
[ apply not_0_INR ; intuition | (apply Rinv_neq_0_compat ; generalize (exp_pos 1) ; intros ; intro ; lra) ])
| (intro H ; apply sqrt_eq_0 in H ; [ (apply not_0_INR in H ; intuition )
| apply pos_INR ])
] | apply Hneq ] ].

apply Rseq_equiv_mult_compat.
apply Rseq_equiv_mult_compat.
apply Rseq_equiv_refl.
assumption.
assumption.
clear Hl H2n H2n1.
apply Rseq_cv_equiv_constant.
unfold Rdiv.
apply Rmult_integral_contrapositive ; split .
 apply pow_nonzero; assumption.
 apply Rinv_neq_0_compat.
 apply Rmult_integral_contrapositive; split.
  intro ; lra.
  apply PI_neq0.
unfold Rseq_constant, Rseq_mult, Rseq_div, Rseq_plus, Rseq_minus, Rseq_inv.
(* Simplification of the expression ! *)
apply Rseq_cv_eq_compat1 with
(fun n:nat => (sqrt (2 * n) / sqrt (S (2 * n))) * (Rsqr l / PI * exp 1) * ((2 * n) / S (2 * n)) ^ (S (2 * n)) * /2)%R.
exists (S O). intros n Hn.
(* need to have n <> 0 *)
assert(H : {m | n = S m}). exists (pred n). intuition.
destruct H as (m, Subst).
(* Solving the simplification equation *)
unfold Rseq_constant.
unfold Rdiv.
ring_simplify.
replace (sqrt n ^ 4) with (n ^ 2) by (rewrite <- (sqrt_sqrt n) at 1 ; [ring | intuition]).
repeat rewrite Rpow_mult_distr.
repeat rewrite <- pow_mult.
repeat rewrite Rinv_mult_distr.
replace (2 ^ (4 * n))%R with (2 ^ (2 * n) * 2 ^ (2 * n))%R by (repeat rewrite pow_mult ;
rewrite <- Rpow_mult_distr ; replace (2 ^ 2 * 2 ^ 2)%R with (2 ^ 4)%R by (unfold pow ; ring) ; ring).
rewrite (mult_comm n 4).
replace (n ^ (4 * n))%R with (n ^ (2 * n) * n ^ (2 * n))%R by
(rewrite <- pow_add ; ring_simplify (2 * n + 2 * n)%nat ; ring).
replace ((/exp 1) ^ (4 * n))%R with ((/exp 1) ^ (2 * n) * (/exp 1) ^ (2 * n))%R by
(rewrite <- pow_add ; ring_simplify (2 * n + 2 * n)%nat ; ring).
repeat rewrite Rinv_pow. rewrite Rinv_involutive.
rewrite <- tech_pow_Rmult with (exp 1) (2 * n)%nat.
rewrite <- (Rinv_pow (exp 1) _).
do 2 rewrite <- tech_pow_Rmult.
replace (/sqrt (2 * n))%R with (sqrt (2 * n) / (2 * n))%R by (apply sqrt_id ; inversion Hn ; [intuition | apply not_0_INR ; intuition]).
unfold Rsqr. unfold Rdiv.
repeat rewrite <- Rinv_pow. field.

(* Solving the "<> 0" equations *)

split. assumption.
split. intro H. apply sqrt_eq_0 in H. apply not_0_INR in H. assumption.
intuition.
intuition.
split. apply pow_nonzero. apply not_0_INR. intuition.
split. apply not_0_INR. intuition.
split. apply pow_nonzero. apply not_0_INR. intuition.
split. apply pow_nonzero. intro. lra.
split. apply PI_neq0.
apply pow_nonzero. intro. generalize (exp_pos 1) ; intros ; lra.
apply not_0_INR. intuition.
intro ; lra.
apply not_0_INR. intuition.
intro. generalize (exp_pos 1) ; intros ; lra.
intro. generalize (exp_pos 1) ; intros ; lra.
apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply not_0_INR ; intuition.
apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply not_0_INR ; intuition.
intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply not_0_INR ; intuition.
apply pos_INR.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply not_0_INR ; intuition.
apply pos_INR.
apply Hneq.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition.
intuition.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition. intuition.
assumption.
apply PI_neq0.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition. intuition.
assumption.
apply Rmult_integral_contrapositive ; split.
apply PI_neq0.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition. intuition.
assumption.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply not_0_INR. intuition.
apply pos_INR. assumption.
(* End of "<> 0" *)

(* end of simplification *)

eapply Rseq_equiv_cv_compat.
  2: reflexivity.
 symmetry; instantiate (1 := (1 * (Rsqr l / PI * exp 1) * /exp 1 * /2)).
 apply Rseq_equiv_mult_compat ; [ | apply Rseq_equiv_eq ; exists O ; intro ; intuition ].
 apply Rseq_equiv_mult_compat.
  apply Rseq_equiv_mult_compat ; [ | apply Rseq_equiv_eq ; exists O ; intro ; intuition ].
  pose (Un := (fun n => - / (2 * INR n + 1))%R).
  assert (Hcv0 : Rseq_cv Un 0). unfold Un.
   apply Rseq_cv_inv_INR_0_1.
  intros eps Heps.
  destruct (DL_sqrt_1 Un Hcv0 eps Heps) as (N, DL).
  exists N.
  intros n HN. generalize (DL n HN). intros DL1.
  unfold Rseq_constant, Rseq_plus, Rseq_minus, Rseq_mult, Rseq_inv, Un in *.
  rewrite <-sqrt_div ; [ | (apply Rmult_le_pos ; intuition) | intuition ].
  rewrite S_INR. rewrite mult_INR. do 2 rewrite S_INR.
  replace (2 * n)%R with ((2 * n + 1) - 1)%R by ring. rewrite Rplus_0_l.
  unfold Rminus. rewrite Rinv_plus.
   rewrite Rinv_eq_1. unfold Rdiv in *. rewrite Ropp_mult_distr_l_reverse. rewrite Rmult_1_l. rewrite Rabs_minus_sym in DL1. apply DL1.
    generalize (pos_INR n) ; intuition ; lra.
    generalize (pos_INR n) ; intuition ; lra.
 apply Rseq_equiv_trans with (fun n : nat => exp ((2 * n + 1) * ln (1 - /(2 * INR n + 1)))).
 pose (Un := (fun n:nat => - /(2 * (INR n) + 1))%R).
 assert (Hcv0 : Rseq_cv Un 0).
  apply Rseq_cv_inv_INR_0_1.
 apply Rseq_equiv_trans with (fun n : nat => exp ((2 * n + 1) * (- / (2 * n + 1)))).
  apply Rseq_equiv_eq. exists O. intros n Hn.
  field_simplify ((2 * n + 1) * - / (2 * n + 1))%R. unfold Rseq_constant, Rseq_inv.
   rewrite <- exp_Ropp. unfold Rdiv. try rewrite Rinv_1. try rewrite Rmult_1_r. reflexivity.
   generalize (pos_INR n) ; intuition ; lra.
  apply Rseq_equiv_continuity with ((-1)).
   reg.
   generalize (exp_pos (-1)) ; intros l1 H1 ; lra.
   apply Rseq_cv_eq_compat with (-R1).
   intros n. unfold Rseq_constant, Rseq_minus, Rseq_plus, Rseq_opp.
   field. intros H1 ; generalize (pos_INR n) ; intros ; lra.
   change (-1)%R with (-(1%R))%R. intuition.
   eapply Rseq_equiv_cv_compat.
     2: reflexivity.
    symmetry; instantiate (1 := (fun n => (2 * INR n + 1) * - / (2 * INR n + 1))%R).
    apply Rseq_equiv_mult_compat.
     apply Rseq_equiv_refl.
     apply Rseq_equiv_sym. apply Rseq_equiv_ln.
     apply Hcv0.
    apply Rseq_cv_eq_compat with (-R1).
    unfold Rseq_opp, Rseq_constant, Rseq_minus.
    intros n. field. generalize (pos_INR n) ; intuition ; lra.
    change (-1)%R with (-(1%R))%R. intuition.
 apply Rseq_equiv_eq.
 exists 1%nat.
 intros n Hn.
 rewrite pow_exp_ln.
  replace (2 * n)%R with ((2 * n + 1) - 1)%R by ring.
  rewrite S_INR. rewrite mult_INR. repeat rewrite S_INR.
  rewrite Rplus_0_l.
  unfold Rminus. rewrite Rinv_plus. rewrite Rinv_eq_1.
   ring_simplify (2 * n + 1 + -(1) + 1)%R. unfold Rdiv. ring_simplify (1 + -(1) * / ((1 + 1) * n + 1))%R.
   rewrite (Rplus_comm (- / (2 * n + 1)) _). reflexivity.
   generalize (pos_INR n) ; intuition ; lra.
   generalize (pos_INR n) ; intuition ; lra.
   unfold Rdiv. apply Rmult_lt_0_compat. apply Rmult_lt_0_compat ; intuition.
   apply Rinv_0_lt_compat.
   rewrite S_INR. generalize (pos_INR n) ; intuition ; lra.
apply Rseq_cv_eq_compat with (Rsqr l / (2 * PI)).
intro. unfold Rseq_mult, Rseq_plus, Rseq_constant, Rseq_div, Rseq_inv.
field. split.
apply PI_neq0.
intro. generalize (exp_pos 1) ; intros ; lra.
intros eps Heps. exists O. intros n Hn.
unfold R_dist. unfold Rseq_constant, Rseq_div, Rseq_inv, Rseq_mult.
unfold Rdiv, Rsqr. rewrite Rminus_diag_eq.
rewrite Rabs_R0. apply Heps.
ring.
Qed.

End Wallis.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Require Import ssreflect ssrfun.
Require Import FunctionalExtensionality.
Set Automatic Coercions Import.
Require Import relations.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Functional.
Variables A B C : Type.

Definition FuncType : Type :=
  forall (T : monadType), (A -> T B) -> T C.
End Functional.

Section Purity.
Variables A B C : Type.

Definition isPure (F : FuncType A B C) : Prop
  := forall (T T' : monadType) (TRacc : TRaccType T T'),
    ((IdR (X := A) =R=> (TR TRacc) _ _ (IdR (X := B))) =R=>
       (TR TRacc) _ _ (IdR (X := C))) (F T) (F T').
End Purity.

Section Strategy.
Variables A B C : Type.

Inductive Tree :=
  Ans : C -> Tree
| Que : A -> (B -> Tree) -> Tree.
End Strategy.

Section TreeMonad.
Variables A B : Type.

Fixpoint subst X Y (g : X -> Tree A B Y) (t : Tree A B X) :=
  match t with
    | Ans x => g x
    | Que a f => Que a (fun b => subst g (f b))
  end.

Definition TreeM : monadType.
exists (@Tree A B) (@Ans A B) (fun _ _ t f => @subst _ _ f t).
- by [].
- rewrite /Monad.axiom1 => X.
  elim => [// | a f IH /=].
  f_equal; by extensionality b.
- rewrite /Monad.axiom2 => X Y Z.
  elim => [// | a f IH /=].
  move => g h /=.
  f_equal; by extensionality b.
Defined.

(*Definition valTree := @tval (TreeM).
Definition bindTree := @tbind (TreeM).*)
End TreeMonad.

Section RepresentationTheorems.
Variables A B C : Type.

Definition fun2tree (F : FuncType A B C) : Tree A B C
  := F (TreeM _ _) (fun a => Que a (@Ans _ _ _)).

Fixpoint tree2funT (T : monadType) (t : Tree A B C) :=
  match t with
    | Ans c => fun k => tval T c
    | Que a f =>
        fun k => tbind (k a) (fun b => tree2funT T (f b) k)
  end.

Definition tree2fun (t : Tree A B C) : FuncType A B C.
move => T. by apply: (tree2funT t).
Defined.

Lemma tree2fun_simpl (t : Tree A B C) (T : monadType) :
  @tree2fun t T = tree2funT t.
Proof.
by rewrite /tree2fun.
Qed.

Lemma tree2fun_pure (t : Tree A B C) : isPure (@tree2fun t).
Proof.
rewrite /isPure.
elim: t => [| a f Hind].
- rewrite /ArrR. by intuition; apply TRacc.
- rewrite /ArrR /=. rewrite /ArrR /= in Hind.
  move => T T' TRacc k k' H /=.
  eapply (proj2 (Acc TRacc)); first by eapply H.
  rewrite /ArrR => b b' /=; elim. by apply: Hind.
Qed.

Lemma tree2fun2tree (t : Tree A B C) : fun2tree (tree2fun t) = t.
Proof.
rewrite /fun2tree.
elim: t => [// | a f Hind /=].
f_equal. by apply: functional_extensionality.
Qed.

Section TopTopMonadicRelation.
Variable T : monadType.
Variable f : A -> T B.

Definition RelTop X X' (R : Rel X X') : Rel (X -> TreeM A B C) (X' -> T C)
  := fun h h' =>
       forall x x', R x x' -> tree2fun (h x) f  = h' x'.

Definition RelTopTop X X' (R : Rel X X') : Rel (TreeM A B X) (T X')
  := fun t t' =>
       forall h h', RelTop R h h' -> tree2fun (tbind t h) f = tbind t' h' .

Definition TRacc1 : TRaccType (@TreeM A B) T.
exists RelTopTop.
split.
- rewrite /RelTopTop /RelTop /=.
  by intuition; rewrite taxiom0; auto.
- move => X X' Y Y' Q R g g' t t' H H0.
  rewrite /RelTopTop => h h' Hhh'. rewrite !taxiom2.
  apply: H. by firstorder.
Defined.

End TopTopMonadicRelation.

Theorem fun2tree2fun (F : FuncType A B C) (Hpure : isPure F) :
  forall (T : monadType), @tree2fun (fun2tree F) T = @F T.
Proof.
move => T.
extensionality f.
have H := @Hpure _ _ (TRacc1 f) => {Hpure}.
rewrite /fun2tree.
rewrite -[X in _ = X]taxiom1.
rewrite -[X in tree2fun X f]taxiom1.
have Harg : (IdR (X:=A) =R=>  TR (TRacc1 f) (IdR (X:=B))) (fun a => Que a (@Ans _ _ _)) f.
  move => a a'; elim.
  move => g g' Hgg' /=. f_equal.
  by extensionality b; intuition.
have Htmp := H _ _ Harg => {H Harg}.
apply: Htmp. by rewrite /RelTop => c c'; elim.
Qed.

End RepresentationTheorems.


Require Export Prelim.

Export ListNotations.
Notation "x 'el' A" := (In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).
Notation "| A |" := (length A) (at level 65).
Definition equi X (A B : list X) : Prop := incl A B /\ incl B A.
Notation "A === B" := (equi A B) (at level 70).
Hint Unfold equi.

Hint Extern 4 =>
match goal with
|[ H: ?x el nil |- _ ] => destruct H
end.

(*** Lists *)

(* Register additional simplification rules with autorewrite / simpl_list *)
(* Print Rewrite HintDb list. *)
Hint Rewrite <- app_assoc : list.
Hint Rewrite rev_app_distr map_app prod_length : list.

Lemma list_cycle  (X : Type) (A : list X) x :
  x::A <> A.
Proof.
  intros B.
  assert (C: |x::A| <> |A|) by (cbn; omega).
  apply C. now rewrite B.
Qed.

(**** Decisions for lists *)

Instance list_in_dec X (x : X) (A : list X) :
  eq_dec X -> dec (x el A).
Proof.
  intros D. apply in_dec. exact D.
Qed.

(* Certifying find *)

Lemma cfind X A (p: X -> Prop) (p_dec: forall x, dec (p x)) :
  {x | x el A /\ p x} + {forall x, x el A -> ~ p x}.
Proof.
  destruct (find (fun x => Dec (p x)) A) eqn:E.
  - apply find_some in E. firstorder.
  - right. intros. eapply find_none in E; eauto.
Qed.

Arguments cfind {X} A p {p_dec}.

Instance list_forall_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (forall x, x el A -> p x).
Proof.
  intros p_dec.
  destruct (find (fun x => Dec (~ p x)) A) eqn:Eq.
  - apply find_some in Eq as [H1 H0 %Dec_true]; right; auto.
  - left. intros x E. apply find_none with (x := x) in Eq. apply dec_DN; auto. auto.
Qed.

Instance list_exists_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (exists x, x el A /\ p x).
Proof.
  intros p_dec.
  destruct (find (fun x => Dec (p x)) A) eqn:Eq. (* New: eta expansion needed *)
  - apply find_some in Eq as [H0 H1 %Dec_true]. firstorder. (* New: Need firstorder here *)
  - right. intros [x [E F]]. apply find_none with (x := x) in Eq; auto. eauto. (* New: Why can't auto solve this? *)
Qed.

Lemma list_exists_DM X A  (p : X -> Prop) :
  (forall x, dec (p x)) ->
  ~ (forall x, x el A -> ~ p x) -> exists x, x el A /\ p x.
Proof.
  intros D E.
  destruct (find (fun x => Dec (p x)) A) eqn:Eq.
  + apply find_some in Eq as [? ?%Dec_true]. eauto.
  + exfalso. apply E. intros. apply find_none with (x := x) in Eq;  eauto.
Qed.

Lemma list_exists_not_incl (X: eqType) (A B : list X) :
  ~ A <<= B -> exists x, x el A /\ ~ x el B.
Proof.
  intros E.
  apply list_exists_DM; auto.
  intros F. apply E. intros x G.
  apply dec_DN; auto.
Qed.

Lemma list_cc X (p : X -> Prop) A :
  (forall x, dec (p x)) ->
  (exists x, x el A /\ p x) -> {x | x el A /\ p x}.
Proof.
  intros D E.
  destruct (cfind A p) as [[x [F G]]|F].
  - eauto.
  - exfalso. destruct E as [x [G H]]. apply (F x); auto.
Qed.

(**** Membership

We use the following lemmas from Coq's standard library List.
- [in_eq :  x el x::A]
- [in_nil :  ~ x el nil]
- [in_cons :  x el A -> x el y::A]
- [in_or_app :  x el A \/ x el B -> x el A++B]
- [in_app_iff :  x el A++B <-> x el A \/ x el B]
- [in_map_iff :  y el map f A <-> exists x, f x = y /\ x el A]
*)

Hint Resolve in_eq in_nil in_cons in_or_app.

Section Membership.
  Variable X : Type.
  Implicit Types (x y: X) (A B: list X).

  Lemma in_sing x y :
    x el [y] -> x = y.
  Proof.
    cbn. intros [[]|[]]. reflexivity.
  Qed.

  Lemma in_cons_neq x y A :
    x el y::A -> x <> y -> x el A.
  Proof.
    cbn. intros [[]|D] E; congruence.
  Qed.

  Lemma not_in_cons x y A :
    ~ x el y :: A -> x <> y /\ ~ x el A.
  Proof.
    intuition; subst; auto.
  Qed.

(**** Disjointness *)

  Definition disjoint A B :=
    ~ exists x, x el A /\ x el B.

  Lemma disjoint_forall A B :
    disjoint A B <-> forall x, x el A -> ~ x el B.
  Proof.
    split.
    - intros D x E F. apply D. exists x. auto.
    - intros D [x [E F]]. exact (D x E F).
  Qed.

  Lemma disjoint_symm A B :
    disjoint A B -> disjoint B A.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_incl A B B' :
    B' <<= B -> disjoint A B -> disjoint A B'.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_nil B :
    disjoint nil B.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_nil' A :
    disjoint A nil.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_cons x A B :
    disjoint (x::A) B <-> ~ x el B /\ disjoint A B.
  Proof.
    split.
    - intros D. split.
      + intros E. apply D. eauto.
      + intros [y [E F]]. apply D. eauto.
    - intros [D E] [y [[F|F] G]].
      + congruence.
      + apply E. eauto.
  Qed.

  Lemma disjoint_app A B C :
    disjoint (A ++ B) C <-> disjoint A C /\ disjoint B C.
  Proof.
    split.
    - intros D. split.
      + intros [x [E F]]. eauto 6.
      + intros [x [E F]]. eauto 6.
    - intros [D E] [x [F G]].
      apply in_app_iff in F as [F|F]; eauto.
  Qed.

End Membership.

Hint Resolve disjoint_nil disjoint_nil'.

(**** Inclusion

We use the following lemmas from Coq's standard library List.
- [incl_refl :  A <<= A]
- [incl_tl :  A <<= B -> A <<= x::B]
- [incl_cons : x el B -> A <<= B -> x::A <<= B]
- [incl_appl : A <<= B -> A <<= B++C]
- [incl_appr : A <<= C -> A <<= B++C]
- [incl_app : A <<= C -> B <<= C -> A++B <<= C]
*)

Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app.

Lemma incl_nil X (A : list X) :
  nil <<= A.

Proof. intros x []. Qed.

Hint Resolve incl_nil.

Lemma incl_map X Y A B (f : X -> Y) :
  A <<= B -> map f A <<= map f B.

Proof.
  intros D y E. apply in_map_iff in E as [x [E E']].
  subst y. apply in_map_iff. eauto.
Qed.

Section Inclusion.
  Variable X : Type.
  Implicit Types A B : list X.

  Lemma incl_nil_eq A :
    A <<= nil -> A=nil.

  Proof.
    intros D. destruct A as [|x A].
    - reflexivity.
    - exfalso. apply (D x). auto.
  Qed.

  Lemma incl_shift x A B :
    A <<= B -> x::A <<= x::B.

  Proof. auto. Qed.

  Lemma incl_lcons x A B :
    x::A <<= B <-> x el B /\ A <<= B.
  Proof.
    split.
    - intros D. split; hnf; auto.
    - intros [D E] z [F|F]; subst; auto.
  Qed.

  Lemma incl_sing x A y :
    x::A <<= [y] -> x = y /\ A <<= [y].
  Proof.
    rewrite incl_lcons. intros [D E].
    apply in_sing in D. auto.
  Qed.

  Lemma incl_rcons x A B :
    A <<= x::B -> ~ x el A -> A <<= B.

  Proof. intros C D y E. destruct (C y E) as [F|F]; congruence. Qed.

  Lemma incl_lrcons x A B :
    x::A <<= x::B -> ~ x el A -> A <<= B.

  Proof.
    intros C D y E.
    assert (F: y el x::B) by auto.
    destruct F as [F|F]; congruence.
  Qed.

  Lemma incl_app_left A B C :
    A ++ B <<= C -> A <<= C /\ B <<= C.
  Proof.
    firstorder.
  Qed.

End Inclusion.

Definition inclp (X : Type) (A : list X) (p : X -> Prop) : Prop :=
  forall x, x el A -> p x.

(**** Setoid rewriting with list inclusion and list equivalence *)

Instance incl_preorder X :
  PreOrder (@incl X).
Proof.
  constructor; hnf; unfold incl; auto.
Qed.

Instance equi_Equivalence X :
  Equivalence (@equi X).
Proof.
  constructor; hnf; firstorder.
Qed.

Instance incl_equi_proper X :
  Proper (@equi X ==> @equi X ==> iff) (@incl X).
Proof.
  hnf. intros A B D. hnf. firstorder.
Qed.

Instance cons_incl_proper X x :
  Proper (@incl X ==> @incl X) (@cons X x).
Proof.
  hnf. apply incl_shift.
Qed.

Instance cons_equi_proper X x :
  Proper (@equi X ==> @equi X) (@cons X x).
Proof.
  hnf. firstorder.
Qed.

Instance in_incl_proper X x :
  Proper (@incl X ==> Basics.impl) (@In X x).
Proof.
  intros A B D. hnf. auto.
Qed.

Instance in_equi_proper X x :
  Proper (@equi X ==> iff) (@In X x).
Proof.
  intros A B D. firstorder.
Qed.

Instance app_incl_proper X :
  Proper (@incl X ==> @incl X ==> @incl X) (@app X).
Proof.
  intros A B D A' B' E. auto.
Qed.

Instance app_equi_proper X :
  Proper (@equi X ==> @equi X ==> @equi X) (@app X).
Proof.
  hnf. intros A B D. hnf. intros A' B' E.
  destruct D, E; auto.
Qed.

Section Equi.
  Variable X : Type.
  Implicit Types A B : list X.

  Lemma equi_push x A :
    x el A -> A === x::A.
  Proof.
    auto.
  Qed.

  Lemma equi_dup x A :
    x::A === x::x::A.

  Proof.
    auto.
  Qed.

  Lemma equi_swap x y A:
    x::y::A === y::x::A.
  Proof.
    split; intros z; cbn; tauto.
  Qed.

  Lemma equi_shift x A B :
    x::A++B === A++x::B.
  Proof.
    split; intros y.
    - intros [D|D].
      + subst; auto.
      + apply in_app_iff in D as [D|D]; auto.
    - intros D. apply in_app_iff in D as [D|D].
      + auto.
      + destruct D; subst; auto.
  Qed.

  Lemma equi_rotate x A :
    x::A === A++[x].
  Proof.
    split; intros y; cbn.
    - intros [D|D]; subst; auto.
    - intros D. apply in_app_iff in D as [D|D].
      + auto.
      + apply in_sing in D. auto.
  Qed.

End Equi.

Lemma in_concat_iff A l (a:A) : a el concat l <-> exists l', a el l' /\ l' el l.
Proof.
  induction l; cbn.
  - intuition. now destruct H.
  - rewrite in_app_iff, IHl. firstorder subst. auto. (* TODO: find something faster than firstorder subst *)
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  environments.v                                                          *)
(*                                                                          *)
(*  This file contains the definitions of type environments,                *)
(*  operational semantics environments, and configurations.                 *)
(*  It also contains the function mapsto which interprets                   *)
(*  type environments as partial mappings, and functions that               *)
(*  return the domains of environments.                                     *)
(*                                                                          *)
(*                                                                          *)
(*  Jill Seaman                                                             *)
(*  Coq V5.8                                                                *)
(*  November  1993                                                          *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                              environments.v                              *)
(****************************************************************************)

Require Import syntax.

Require Import List.

(******************************)
(* (member x L)               *)
(*                            *)
(*  Defines when an element x *)
(*  is contained in a list L. *)
(*                            *)
(******************************)
Fixpoint member (A : Set) (b : A) (l : list A) {struct l} : Prop :=
  match l with
  | nil => False
  | a :: m => a = b \/ member A b m
  end.
(*
Definition member :=
 [A:Set][b:A][l:(list A)] (<Prop>Match l with
                  (* nil *)      False
                  (* cons a m *) [a:A][m:(list A)][P:Prop]
                                      (a=b) \/ P end).
*)

(******************************************************)
(*                                                    *)
(*  ty_env:  type environment, variable-type list.    *)
(*  OS_env:  Operational semantics environment,       *)
(*           variable-type-term list.                 *)
(*                                                    *)
(******************************************************)

Definition VT := (vari * ty)%type.
Definition ty_env := list VT.

Definition VTT := (VT * tm)%type.
Definition OS_env := list VTT.

(****************************************)
(*   Mapsto - 				*)
(*      Implements type environments as	*)
(*      partial mappings.		*)
(*					*)
(*   (mapsto x t H) -> H(x) = t		*)
(****************************************)

Definition mapsto (indx : vari) (val : ty) (l : list VT) :=
  (fix F (l0 : list VT) : Prop :=
     match l0 with
     | nil => False
     | v :: l1 => IF fst v = indx :>vari then snd v = val :>ty else F l1
     end) l.
(* Nil *)
(* cons a m *)

(******************************************)
(*   Configurations and their destructors *)
(******************************************)

Inductive config : Set :=
    cfg : tm -> OS_env -> config.

Definition cfgexp (c : config) := let (e, A) return tm := c in e.

Definition cfgenv (c : config) := let (e, A) return OS_env := c in A.

(**************************************************)
(*  Domain functions for type and OS environments *)
(*						  *)
(*  TE_Dom    : ty_env -> var list                *)
(*  OS_Dom    : OS_env -> var list                *)
(*  OS_Dom_ty : OS_env -> VT list                 *)
(* 						  *)
(**************************************************)

Definition TE_Dom (H : ty_env) :=
  (fix F (l : list VT) : list vari :=
     match l with
     | nil => nil (A:=vari)
     | v :: l0 => cons (fst v) (F l0)
     end) H.
(* nil *)
(* cons vt H' *)

Definition OS_Dom (A : OS_env) :=
  (fix F (l : list VTT) : list vari :=
     match l with
     | nil => nil (A:=vari)
     | v :: l0 => cons (fst (fst v)) (F l0)
     end) A.
(* nil *)
(* cons vtt A' *)

Definition OS_Dom_ty (A : OS_env) :=
  (fix F (l : list VTT) : list VT :=
     match l with
     | nil => nil (A:=VT)
     | v :: l0 => cons (fst v) (F l0)
     end) A.
(* nil *)
(* cons vtt A' *)


Require Import Iron.Data.List.Base.
Require Import Iron.Tactics.

(********************************************************************)
(* Lemmas: Forall *)
Lemma Forall_in
 :  forall {A} (P: A -> Prop) x xs
 ,  Forall P xs
 -> In x xs
 -> P x.
Proof.
 intros. gen x.
 induction xs; intros.
 - inverts H0.
 - inverts H0.
   + inverts H. eauto.
   + inverts H. eauto.
Qed.

Lemma Forall_get
 :  forall {A} (P: A -> Prop) ix x xs
 ,  Forall P xs
 -> get ix xs = Some x
 -> P x.
Proof.
 intros. gen x xs.
 induction ix; intros.
  destruct xs.
   false.
   simpl in H0. inverts H0. inverts H. auto.
  destruct xs.
   false.
   simpl in H0.
   eapply IHix.
    inverts H. eapply H4. auto.
Qed.

Lemma Forall_impl_in
 : forall {A}
          (P1: A -> Prop) (P2: A -> Prop)
          (xs: list A)
 ,  (forall x, In x xs -> P1 x -> P2 x)
 -> Forall P1 xs
 -> Forall P2 xs.
Proof.
 intros.
 induction xs.
  auto.
  inverts H0. intuition.
Qed.

Lemma Forall_snoc
 :  forall {A} (P: A -> Prop) x xs
 ,  P x
 -> Forall P xs
 -> Forall P (x <: xs).
Proof.
 intros. gen x.
 induction xs; intros.
  simpl. auto.
  simpl.
   eapply Forall_cons.
    inverts H0. auto.
   eapply IHxs.
    inverts H0. auto. auto.
Qed.
Hint Resolve Forall_snoc.

Lemma Forall_split_cons
 :  forall {A} P (x : A) xs
 ,  Forall P (x :: xs)
 -> P x /\ Forall P xs.
Proof.
 intros.
  rewrite Forall_forall in H.
  rewrite Forall_forall.
  split; eauto.
Qed.
Hint Resolve Forall_split_cons.

Lemma Forall_app
 :  forall {A} (P: A -> Prop) xs ys
 ,  Forall P xs
 -> Forall P ys
 -> Forall P (xs ++ ys).
Proof.
 intros.
 rewrite Forall_forall in *.
 intros.
 apply in_app_split in H1.
  firstorder.
Qed.
Hint Resolve Forall_app.

Lemma Forall_app_left
 :  forall {A} (P: A -> Prop) xs ys
 ,  Forall P (xs ++ ys)
 -> Forall P xs.
Proof.
 intros.
 rewrite Forall_forall in *.
 eauto.
Qed.
Hint Resolve Forall_app_left.

Lemma Forall_app_right
 :  forall {A} (P: A -> Prop) xs ys
 ,  Forall P (xs ++ ys)
 -> Forall P ys.
Proof.
 intros.
 rewrite Forall_forall in *.
 eauto.
Qed.
Hint Resolve Forall_app_right.

Lemma Forall_map
 :  forall {A B}
           (P: B -> Prop) (f: A -> B)
           (xs: list A)
 ,  Forall (fun x => P (f x)) xs
 -> Forall P (map f xs).
Proof.
 intros. induction xs.
  apply Forall_nil.
  inverts H. simpl. intuition.
Qed.
Hint Resolve Forall_map.

Lemma Forall_mp
 :  forall {A} (P Q: A -> Prop)  xs
 ,  Forall (fun x => P x -> Q x) xs
 -> Forall (fun x => P x)        xs
 -> Forall (fun x => Q x)        xs.
Proof.
 intros.
 induction xs.
 - auto.
 - eapply Forall_cons.
   + inverts H. inverts H0. auto.
   + inverts H. inverts H0. auto.
Qed.

Lemma Forall_mp_const
 :  forall {A} P (Q: A -> Prop)  xs
 ,  P
 -> Forall (fun x => P -> Q x) xs
 -> Forall (fun x => Q x)      xs.
Proof.
 intros.
 induction H.
 - auto.
 - apply Forall_cons.
   + auto.
   + auto.
Qed.

Lemma Forall_inst
 :  forall {A B} a' xs (P: A -> B -> Prop)
 ,  Forall (fun x => forall a, P a x) xs
 -> Forall (fun x => P a' x) xs.
Proof.
 intros.
 induction xs.
 - auto.
 - eapply Forall_cons.
   + inverts H. eapply H2.
   + inverts H. eapply IHxs. assumption.
Qed.


Add LoadPath "." as OmegaCategories.
Require Export Unicode.Utf8_core.
Require Import Vector.
Require Export path.

Set Universes Polymorphic.
Set Implicit Arguments.

Class Contr_internal (A : Type) := BuildContr {
  center : A ;
  contr : (forall y : A, center = y)
}.

Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

(** We will use [Notation] for [trunc_index]es, so define a scope for them here. *)
Delimit Scope trunc_scope with trunc.
Bind Scope trunc_scope with trunc_index.
Arguments trunc_S _%trunc_scope.

Fixpoint nat_to_trunc_index (n : nat) : trunc_index
  := match n with
       | 0 => trunc_S (trunc_S minus_two)
       | S n' => trunc_S (nat_to_trunc_index n')
     end.

Coercion nat_to_trunc_index : nat >-> trunc_index.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | minus_two => Contr_internal A
    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Notation minus_one:=(trunc_S minus_two).
(** Include the basic numerals, so we don't need to go through the coercion from [nat], and so that we get the right binding with [trunc_scope]. *)
Notation "0" := (trunc_S minus_one) : trunc_scope.
Notation "1" := (trunc_S 0) : trunc_scope.
Notation "2" := (trunc_S 1) : trunc_scope.

Arguments IsTrunc_internal n A : simpl nomatch.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.

(** We use the priciple that we should always be doing typeclass resolution on truncation of non-equality types.  We try to change the hypotheses and goals so that they never mention something like [IsTrunc n (_ = _)] and instead say [IsTrunc (S n) _].  If you're evil enough that some of your paths [a = b] are n-truncated, but others are not, then you'll have to either reason manually or add some (local) hints with higher priority than the hint below, or generalize your equality type so that it's not a path anymore. *)

Typeclasses Opaque IsTrunc. (* don't auto-unfold [IsTrunc] in typeclass search *)

Arguments IsTrunc : simpl never. (* don't auto-unfold [IsTrunc] with [simpl] *)

Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A)
: IsTrunc n (x = y)
  := H x y. (* but do fold [IsTrunc] *)

Notation Contr := (IsTrunc minus_two).

Notation IsHProp := (IsTrunc minus_one).

Notation IsHSet := (IsTrunc 0).