(** TestRefman.v:  examples from the  reference manual. *)

Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary.
Import Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".

Open Scope R_scope.

Section WITHNANS.
Context {NANS: Nans}.

Definition h := (1/32)%F32.
Definition F(x: ftype Tsingle) : ftype Tsingle := (3.0-x)%F32.
Definition step (x v: ftype Tsingle) := (x + h*(v+(h/2)*F(x)))%F32.

Definition _x : ident := 1%positive.  (* Variable name for position *)
Definition _v : ident := 2%positive.  (* Variable name for velocity *)

Definition step' := ltac:(let e' := HO_reify_float_expr constr:([_x; _v]) step in exact e').

Definition step_vmap_list (x v : ftype Tsingle) := [(_x, existT ftype _ x);(_v, existT ftype _ v)].

(** Step two, build that into "varmap" data structure, taking care to
  compute it into a lookup-tree ___here___, not later in each place
  where we look something up. *)
Definition step_vmap (x v : ftype Tsingle) : valmap :=
 ltac:(let z := compute_PTree (valmap_of_list (step_vmap_list x v)) in exact z).

(**  Demonstration of reification and reflection.   When you have a
  deep-embedded "expr"ession, you can get back the shallow embedding
   by applying the "fval" function *)

Definition reflected_step (x v: ftype Tsingle) :=
   fval (env_ (step_vmap x v)) step'.

Lemma reflect_reify : forall x v, reflected_step x v = step x v.
Proof. reflexivity. Qed.

Definition step_realmodel' (x v: ftype Tsingle) : R :=
   FT2R x + (1/32)*(FT2R v + ((1/32)/2)*(3- FT2R x)).

Coercion FT2R: ftype >-> R.

Definition step_realmodel (x v: ftype Tsingle) : R :=
   x + (1/32)*(v + ((1/32)/2)*(3-x)).

Lemma correspond_floatmodel_realmodel:
  forall x v, rval (env_ (step_vmap x v)) step' = step_realmodel x v.
Proof. intros.
 unfold step_realmodel.
 simpl.
 repeat f_equal; compute; lra.
Qed.

(** To create the boundsmap, first we make an association list.  This one says
   that    2.0 <= x <= 4.0   and   -2.0 <= v <= 2.0  *)
Definition step_bmap_list : list varinfo :=
  [ Build_varinfo Tsingle _x 2 4 ;  Build_varinfo Tsingle _v (-2)  2 ].

(** Then we calculate an efficient lookup table, the "boundsmap". *)
Definition step_bmap : boundsmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list step_bmap_list) in exact z).

(** Now we prove that the leapfrogx expression (deep-embedded as  x' )
   has a roundoff error less than 1.0e-5 *)
Lemma prove_roundoff_bound_step:
  forall vmap,
     prove_roundoff_bound step_bmap vmap step'  (/ 4000000).
Proof.
intros.
prove_roundoff_bound.
-
 prove_rndval.
 all: interval.
-
 prove_roundoff_bound2.
 prune_terms (cutoff 30).
 do_interval.
Qed.

(* The next part demonstrates that you don't have to guess the
  upper bound in advance, to use the tool. *)
Definition find_and_prove_roundoff_bound (bmap: boundsmap) (e: expr) :=
  {bound: R | forall vmap, prove_roundoff_bound bmap vmap e bound}.

(* This proof returns a pair,
   {bound | proof that it really is a bound for step }
 where "bound" is a simple real-valued expression with only constants. *)
Derive step_b
 SuchThat  (forall vmap,  prove_roundoff_bound step_bmap vmap step' step_b)
 As prove_step_bound.
Proof.
subst step_b.
intro.
 prove_roundoff_bound.
-
 prove_rndval; interval.
-
prove_roundoff_bound2.
prune_terms (cutoff 30).
do_interval.
Qed.

(* Let's calculate the floating-point representation of the bound. *)
Check ltac:(ShowBound step_b).

(* We claimed that the roundoff error is less than 1/4000000; let's check! *)
Lemma bound_less_than_one_over_four_million: step_b <= 1 / 4000000.
Proof. compute; lra. Qed.

(* Let's make sure that we really have a proof that
  this is a bound on the roundoff error of the step function *)
Check prove_step_bound.

End WITHNANS.

(* Below are tests of the "prune_terms" tactic and various steps
  of the algorithm *)

Lemma test1:
 forall
 (x v e0 d e1 e2 d0 e3 : R)
 (BOUND : -2 <= v <= 2)
 (BOUND0 : -2 <= x <= 2)
 (E : Rabs e0 <= / 713623846352979940529142984724747568191373312)
 (E0 : Rabs d <= / 16777216)
 (E1 : Rabs e1 <= / 1427247692705959881058285969449495136382746624)
 (E2 : Rabs e2 <= / 713623846352979940529142984724747568191373312)
 (E3 : Rabs d0 <= / 16777216)
 (E4 : Rabs e3 <= / 1427247692705959881058285969449495136382746624),
Rabs
  (((x + (1 / 32 * v + e2)) * (1 + d) + e3 + (1 / 2048 * - x + e0)) *
   (1 + d0) + e1 - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x)) <=
   2.46e-7.
Proof.
intros.
prune_terms (cutoff 30).
(*match goal with |- Rabs ?a <= _ => field_simplify a end.*)
match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end.
eapply Rle_trans; [ apply H99 | clear  ].
compute; lra.
Qed.

Import Tree.

Lemma test1_double_precision:
 forall
 (x v e0 d e1 e2 d0 e3 : R)
 (BOUND : -2 <= v <= 2)
 (BOUND0 : -2 <= x <= 2)
 (E : Rabs e0 <= / bpow' 2 298)
 (E0 : Rabs d <= / bpow' 2 48)
 (E1 : Rabs e1 <= / bpow' 2 300)
 (E2 : Rabs e2 <= / bpow' 2 298)
 (E3 : Rabs d0 <= / bpow' 2 48)
 (E4 : Rabs e3 <= / bpow' 2 298),
Rabs
  (((x + (1 / 32 * v + e2)) * (1 + d) + e3 + (1 / 2048 * - x + e0)) *
   (1 + d0) + e1 - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x)) <=
   2.46e-7.
Proof.
intros.
prune_terms (cutoff 60).
(*match goal with |- Rabs ?a <= _ => field_simplify a end.*)
match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end.
eapply Rle_trans; [ apply H99 | clear  ].
compute; lra.
Qed.

Lemma test3: forall
 (x v d1 d2 e0 e1 e3 : R)
 (BOUND : -2 <= v <= 2)
 (BOUND0 : 2 <= x <= 4)
 (E : Rabs d1 <= / 16777216)
 (E0 : Rabs d2 <= / 16777216)
 (E1 : Rabs e0 <= / 713623846352979940529142984724747568191373312)
 (E2 : Rabs e1 <= / 1427247692705959881058285969449495136382746624)
 (E3 : Rabs e3 <= / 713623846352979940529142984724747568191373312),
Rabs
  (((x + (1 / 32 * v + e0)) * (1 + d2) + (1 / 2048 * (3 - x) + e3)) *
   (1 + d1) + e1 -
   (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * (3 - x))) <=
/ 2000000.
Proof.
intros.
prune_terms (cutoff 30).
match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end.
eapply Rle_trans; [ apply H99 | clear  ].
simpl; compute; lra.
Qed.

Lemma test3_alt: forall
 (x v d1 d2 e0 e1 e3 : R)
 (BOUND : -2 <= v <= 2)
 (BOUND0 : 2 <= x <= 4)
 (E : Rabs e0 <= / 713623846352979940529142984724747568191373312)
 (E0 : Rabs d1 <= / 16777216)
 (E1 : Rabs e1 <= / 713623846352979940529142984724747568191373312)
 (E2 : Rabs d2 <= / 16777216)
 (E3 : Rabs e3 <= / 1427247692705959881058285969449495136382746624),
Rabs
  ((x + (1 / 32 * ((v + (1 / 64 * (3 - x) + e1)) * (1 + d1) + e3) + e0)) *
   (1 + d2) - (x + 1 / 32 * (v + 1 / 32 / 2 * (3 - x)))) <=
  1/4000000.
Proof.
intros.
prune_terms (cutoff 30).
match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end.
eapply Rle_trans; [ apply H99 | clear  ].
compute; simpl; lra.
Qed.

Lemma test2:
 forall
 (d d0 d1 e0 d2 e1 e2 e3 e4 e5 d3 e6 e7 e8 e9 e10 e11 e12 e13 d4 e14
e15 e16 e17 e18 d5 d6 d7 d8 e19 e20 d9 d10 d11 d12 e21 d13 e22 e23 e24
x v : R)
 (BOUND : (-2) <= v <= 2)
 (BOUND0 : (-2) <= x <= 2)
 (E : (Rabs d) <= (/ 16777216))
 ( E0 : (Rabs d0) <= (/ 16777216))
 ( E1 : (Rabs d1) <= (/ 16777216))
( E2 : (Rabs e0) <= (/ 1427247692705959881058285969449495136382746624))
 (E3 : (Rabs d2) <= (/ 16777216))
 (E4 : (Rabs e1) <= (/ 713623846352979940529142984724747568191373312))
 ( E5 : (Rabs e2) <= (/ 1427247692705959881058285969449495136382746624))
 ( E6 : (Rabs e3) <= (/ 1427247692705959881058285969449495136382746624))
 ( E7 : (Rabs e4) <= (/ 1427247692705959881058285969449495136382746624))
 ( E8 : (Rabs e5) <= (/ 1427247692705959881058285969449495136382746624))
( E9 : (Rabs d3) <= (/ 16777216))
 ( E10 : (Rabs e6) <= (/ 713623846352979940529142984724747568191373312))
( E11 : (Rabs e7) <= (/ 713623846352979940529142984724747568191373312))
 ( E12 : (Rabs e8) <= (/ 713623846352979940529142984724747568191373312))
 ( E13 : (Rabs e9) <= (/ 713623846352979940529142984724747568191373312))
 ( E14 : (Rabs e10) <= (/ 1427247692705959881058285969449495136382746624))
 ( E15 : (Rabs e11) <= (/ 1427247692705959881058285969449495136382746624))
( E16 : (Rabs e12) <= (/ 1427247692705959881058285969449495136382746624))
 ( E17 : (Rabs e13) <= (/ 1427247692705959881058285969449495136382746624))
 ( E18 : (Rabs d4) <= (/ 16777216))
 ( E19 : (Rabs e14) <= (/ 713623846352979940529142984724747568191373312))
 ( E20 : (Rabs e15) <= (/ 1427247692705959881058285969449495136382746624))
 (E21 : (Rabs e16) <= (/ 1427247692705959881058285969449495136382746624) )
( E22 : (Rabs e17) <= (/ 1427247692705959881058285969449495136382746624))
 ( E23 : (Rabs e18) <= (/ 1427247692705959881058285969449495136382746624))
( E24 : (Rabs d5) <= (/ 16777216))
(E25 : (Rabs d6) <= (/ 16777216))
(E26 : (Rabs d7) <= (/ 16777216))
(E27 : (Rabs d8) <= (/ 16777216))
(E28 : (Rabs e19) <= (/ 713623846352979940529142984724747568191373312))
(E29 : (Rabs e20) <= (/ 1427247692705959881058285969449495136382746624))
(E30 : (Rabs d9) <= (/ 16777216))
(E31 : (Rabs d10) <= (/ 16777216))
(E32 : (Rabs d11) <= (/ 16777216))
(E33 : (Rabs d12) <= (/ 16777216))
(E34 : (Rabs e21) <= (/ 713623846352979940529142984724747568191373312))
(E35 : (Rabs d13) <= (/ 16777216))
(E36 : (Rabs e22) <= (/ 713623846352979940529142984724747568191373312))
(E37 : (Rabs e23) <= (/ 713623846352979940529142984724747568191373312))
(E38 : (Rabs e24) <= (/ 1427247692705959881058285969449495136382746624)),
  Rabs
    (((((x + (1 / 32 * v + e14)) * (1 + d3) + e20 + (1 / 2048 * - x + e1)) *
       (1 + d5) + e10) *
      (((x + (1 / 32 * v + e21)) * (1 + d1) + e17 + (1 / 2048 * - x + e8)) *
       (1 + d11) + e4) * (1 + d8) + e13 +
      (((v +
         (1 / 64 *
          ((- x +
            -
            (((x + (1 / 32 * v + e23)) * (1 + d0) + e16 +
              (1 / 2048 * - x + e7)) * (1 + d10) + e3)) *
           (1 + d7) + e12) + e22)) * (1 + d2) + e18) *
       ((v +
         (1 / 64 *
          ((- x +
            -
            (((x + (1 / 32 * v + e9)) * (1 + d12) + e5 +
              (1 / 2048 * - x + e19)) * (1 + d4) + e24)) *
           (1 + d) + e15) + e6)) * (1 + d9) + e2) *
       (1 + d6) + e11)) * (1 + d13) + e0 -
     ((x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x) *
      (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x) +
      (v +
       1 / 2 * (1 / 32) *
       (- x + - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x))) *
      (v +
       1 / 2 * (1 / 32) *
       (- x + - (x + 1 / 32 * v + 1 / 2 * (1 / 32 * (1 / 32)) * - x))))) <=
  3e-6.
Proof.
intros.
destruct true.
-
Time prune_terms (cutoff 30).
(* before collapse_terms was added to the algorithm, this
   took about 1.8-2.0 sec.
  Now it takes 1.55-6.0 sec. *)

(*Time match goal with |- Rabs ?a <= _ => field_simplify a end.*)
match goal with |- Rabs ?t <= ?r => interval_intro (Rabs t) as H99 end;
eapply Rle_trans; [ apply H99 | clear  ].
simpl; compute; lra.
-
simple_reify.
pose (nodes_and_terms e := (count_nodes e, count_terms e)).

pose (counts0 := nodes_and_terms __expr);
vm_compute in counts0;
let e1 := constr:(ring_simp false 100 __expr) in
let e1 := eval vm_compute in e1 in
pose (counts1 := nodes_and_terms e1);
vm_compute in counts1;
let e2 := constr:(fst (prune (map b_hyps __hyps) e1 (cutoff 30))) in
let e2 := eval vm_compute in e2 in
pose (counts2 := nodes_and_terms e2);
vm_compute in counts2;
let e3 := constr:(cancel_terms e2) in
let e3 := eval vm_compute in e3 in
pose (counts3 := nodes_and_terms e3);
vm_compute in counts3;
let e4 := constr:(ring_simp true 100 e3) in
let e4 := eval vm_compute in e4 in
pose (counts4 := nodes_and_terms e4);
vm_compute in counts4;
pose (t3 := eval e3 __vars);
pose (t4 := eval e4 __vars);
cbv [eval nth nullary_real unary_real binary_real bpow' __vars] in t3, t4;
elimtype False; clear - t3 t4 counts0 counts1 counts2 counts3 counts4.
Open Scope Z.

(*
counts0 := (242, 4) : Z * Z
counts1 := (612284, 31759) : Z * Z
counts2 := (1456, 244) : Z * Z
counts3 := (289, 25) : Z * Z ,  before collapse_terms was added
counts3 := (219, 24) : Z * Z   with collapse_terms
counts4 := (395, 46) : Z * Z
*)
Abort.


(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* A basic argument about encountering a specific value in a list of randomly-generated values. *)

Require Import FCF.FCF.
Require Import FCF.CompFold.

Section RndDup.

  Variable eta : nat.

  Definition RndDup_G (A : Set)(ls : list A) (x : Bvector eta) :=
    rs <-$ compMap _ (fun _ => {0, 1} ^ eta) ls;
      ret (if (in_dec (EqDec_dec _) x rs) then true else false).

  (*
  Definition RndDup_G q (x : Bvector eta) :=
    rs <-$ compMap _ (fun _ => {0, 1} ^ eta) (allNatsLt q);
    ret (if (in_dec (EqDec_dec _) x rs) then true else false).
   *)

  Theorem bool_Comp_seq :
    forall (A : Set)(c1 : Comp bool)(c2 : bool -> Comp A) a,
      evalDist (b <-$ c1; c2 b) a ==
      (evalDist c1 true * evalDist (c2 true) a) +
      (evalDist c1 false * evalDist (c2 false) a).

    intros.
    simpl.

    remember (getSupport c1) as ls.
    destruct ls.
    unfold sumList.
    simpl.
    assert (Pr  [c1 ] == 0).
    eapply getSupport_not_In_evalDist.
    rewrite <- Heqls.
    simpl.
    intuition.

    rewrite H.
    assert (evalDist c1 false == 0).
    eapply getSupport_not_In_evalDist.
    rewrite <- Heqls.
    simpl.
    intuition.
    rewrite H0.
    repeat rewrite ratMult_0_l.
    eapply ratAdd_0_l.

    destruct b.
    destruct ls.
    unfold sumList.
    simpl.
    rewrite <- ratAdd_0_l.
    rewrite ratAdd_0_r at 1.
    eapply ratAdd_eqRat_compat.
    intuition.
    symmetry.

    assert (evalDist c1 false == 0).
    eapply getSupport_not_In_evalDist.
    rewrite <- Heqls.
    simpl.
    intuition.
    rewrite H.
    eapply ratMult_0_l.

    destruct b.
    exfalso.
    assert (NoDup (true :: true :: ls))%list.
    rewrite Heqls.
    eapply getSupport_NoDup.
    inversion H; clear H; subst.
    simpl in *.
    intuition.

    destruct ls.

    unfold sumList.
    simpl.
    rewrite <- ratAdd_0_l.
    intuition.

    destruct b.
    assert (NoDup (true :: false :: true :: ls)%list).
    rewrite Heqls.
    eapply getSupport_NoDup.
    inversion H; clear H; subst.
    simpl in *.
    intuition.
    assert (NoDup (true :: false :: false  :: ls)%list).
    rewrite Heqls.
    eapply getSupport_NoDup.
    inversion H; clear H; subst.
    inversion H3; clear H3; subst.
    simpl in *.
    intuition.

    destruct ls.
    unfold sumList.
    simpl.
    eapply ratAdd_eqRat_compat; intuition.
    assert ( Pr  [c1 ] == 0).
    eapply getSupport_not_In_evalDist.
    rewrite <- Heqls.
    simpl.
    intuition.
    rewrite H.
    rewrite ratMult_0_l.
    intuition.

    destruct b.
    destruct ls.
    unfold sumList.
    simpl.
    rewrite <- ratAdd_0_l.
    eapply ratAdd_comm.

    destruct b.
    assert (NoDup (false :: true :: true :: ls)%list).
    rewrite Heqls.
    eapply getSupport_NoDup.
    inversion H; clear H; subst.
    inversion H3; clear H3; subst.
    simpl in *.
    intuition.

    assert (NoDup (false :: true :: false  :: ls)%list).
    rewrite Heqls.
    eapply getSupport_NoDup.
    inversion H; clear H; subst.
    simpl in *.
    intuition.

    assert (NoDup (false :: false  :: ls)%list).
    rewrite Heqls.
    eapply getSupport_NoDup.
    inversion H; clear H; subst.
    simpl in *.
    intuition.

  Qed.

  Theorem Prob_or_indep :
    forall (c1 c2 : Comp bool),
      well_formed_comp c2 ->
      Pr[b1 <-$ c1; b2 <-$ c2; ret (b1 || b2)] == Pr[c1] + (evalDist c1 false) * Pr[c2].

    intuition.

    rewrite bool_Comp_seq.

    assert (Pr  [b2 <-$ c2; ret true || b2 ] == 1).
    comp_irr_l.
    rewrite evalDist_ret_1; simpl; intuition.
    rewrite H0.
    clear H0.

    assert (Pr  [b2 <-$ c2; ret false || b2 ] == Pr[c2]).
    rewrite bool_Comp_seq.
    rewrite evalDist_ret_1.
    rewrite evalDist_ret_0.
    rewrite ratMult_0_r.
    rewrite <- ratAdd_0_r.
    eapply ratMult_1_r.
    simpl.
    intuition.
    simpl; intuition.
    rewrite H0.
    clear H0.
    rewrite ratMult_1_r.

    intuition.
  Qed.

  Theorem evalDist_right_ident_eqb :
    forall (A : Set)(eqd : EqDec A)(c : Comp A)(a : A),
      Pr[x <-$ c; ret (eqb a x)] == evalDist c a.

    intuition.
    symmetry.
    rewrite <-(@evalDist_right_ident _ eqd).
    comp_skip.
    simpl.
    repeat match goal with
             |- context [ if ?X then _ else _ ] => destruct X
           end; rewrite ?@eqb_leibniz in *; reflexivity || congruence.

  Qed.

  Theorem Prob_or_indep_le :
    forall (c1 c2 : Comp bool),
      Pr[b1 <-$ c1; b2 <-$ c2; ret (b1 || b2)] <= Pr[c1] + Pr[c2].

    intuition.

    rewrite bool_Comp_seq.

    eapply ratAdd_leRat_compat.
    eapply leRat_trans.
    eapply ratMult_leRat_compat.
    eapply leRat_refl.
    eapply evalDist_le_1.
    eapply eqRat_impl_leRat.
    eapply ratMult_1_r.

    eapply leRat_trans.
    eapply ratMult_leRat_compat.
    eapply evalDist_le_1.
    eapply leRat_refl.
    rewrite ratMult_1_l.
    unfold orb.
    rewrite evalDist_right_ident.
    intuition.
  Qed.

  Theorem ratS_num':
    forall n d,
      RatIntro (S n) d == (RatIntro 1 d) + (RatIntro n d).

    intuition.
    rattac.
  Qed.

  Theorem RndDup_P :
    forall (A : Set)(ls : list A) x,
      Pr [RndDup_G _ ls x] <= (length ls) / expnat 2 eta.

    unfold RndDup_G in *.
    induction ls; intros.

    unfold compMap.
    comp_simp.
    destruct (in_dec (EqDec_dec (Bvector_EqDec eta)) x nil).
    simpl in *. intuition.
    rewrite evalDist_ret_0; intuition.
    symmetry.
    eapply rat_num_0.

    eapply leRat_trans.
    (* posnat existential is added here *)

    eapply eqRat_impl_leRat.
    eapply evalDist_seq_eq.

    intros.
    eapply compMap_cons.
    intros.
    eapply eqRat_refl.

    fcf_inline leftc.

    comp_at comp_inline leftc 1%nat.
    dist_at dist_ret leftc 2%nat.

    assert (
        Pr
          [a0 <-$ { 0 , 1 }^eta;
           a1 <-$ (foreach  (_ in ls){ 0 , 1 }^eta);
           ret (if in_dec (EqDec_dec (Bvector_EqDec eta)) x (a0 :: a1)
                then true
                else false) ] ==
        Pr
          [b1 <-$ (a0 <-$ { 0 , 1 }^eta; ret (eqb x a0));
           b2 <-$ (a1 <-$ (foreach  (_ in ls){ 0 , 1 }^eta);
                   ret (if (in_dec (EqDec_dec _) x a1) then true else false));
           ret (b1 || b2) ]
      ).

    fcf_inline rightc.
    comp_skip.
    comp_simp.
    comp_inline_r.
    comp_skip.
    comp_simp.
    case_eq (eqb x x0); intuition.
    destruct (in_dec (EqDec_dec (Bvector_EqDec eta)) x (x0 :: x1)).
    simpl.
    intuition.

    rewrite eqb_leibniz in H1.
    subst.
    simpl in *.
    intuition.

    destruct (in_dec (EqDec_dec (Bvector_EqDec eta)) x x1).
    destruct (in_dec (EqDec_dec (Bvector_EqDec eta)) x (x0 :: x1)).
    simpl.
    intuition.

    simpl in *.
    intuition.

    destruct (in_dec (EqDec_dec (Bvector_EqDec eta)) x (x0 :: x1)).
    simpl in i, n; intuition.
    subst.
    rewrite eqb_refl in H1.
    congruence.

    simpl.
    intuition.

    rewrite H.
    clear H.

    rewrite Prob_or_indep_le.
    rewrite IHls.

    assert (Pr  [a0 <-$ { 0 , 1 }^eta; ret eqb x a0 ] == 1 / expnat 2 eta) as HA. {
      rewrite evalDist_right_ident_eqb.
      simpl.
      intuition.
    } rewrite HA; clear HA.

    eapply eqRat_impl_leRat.
    simpl.

    rewrite (ratS_num' (length ls)).
    reflexivity.

    Unshelve.
    eapply 1.
  Qed.
End RndDup.


(* Pattern matching *)

Require Import Env.
Require Import TransitiveClosure.

Inductive Ty :=
        | t_unit  : Ty
        | t_arr   : Ty -> Ty -> Ty
        | t_pair  : Ty -> Ty -> Ty
        | t_sum   : Ty -> Ty -> Ty.

Inductive Pattern :=
        | p_wild  : Pattern
        | p_var   : Pattern
        | p_unit  : Pattern
        | p_pair  : Pattern -> Pattern -> Pattern
        | p_inl   : Pattern -> Pattern
        | p_inr   : Pattern -> Pattern.

Fixpoint pattern_vars p :=
 match p with
 | p_wild => 0
 | p_var  => 1
 | p_unit => 0
 | p_pair p q => pattern_vars p + pattern_vars q
 | p_inl p => pattern_vars p
 | p_inr p => pattern_vars p
 end.

(*
Inductive Pattern : nat -> Set :=
        | p_wild  : Pattern 0
        | p_var   : Pattern 1
        | p_unit  : Pattern 0
        | p_pair  n m
                  : Pattern n -> Pattern m -> Pattern (n+m)
        | p_inl   n : Pattern n -> Pattern n
        | p_inr   n : Pattern n -> Pattern n.
*)

Inductive Exp :=
        | var    : Var -> Exp
        | lambda : Ty  -> Exp -> Exp
        | app    : Exp -> Exp -> Exp
        | pair   : Exp -> Exp -> Exp
        | inl    : Exp  -> Exp
        | inr    : Exp -> Exp
        | unitt  : Exp
        | matchh
          : Exp -> listne -> Exp
with
 listne := | lne : listPE -> Pattern -> Exp -> listne
with
 listPE := | lpe_nil : listPE
           | lpe_cons: Pattern -> Exp -> listPE -> listPE.

Check Exp_rec.

Scheme Exp_all_rec := Induction for Exp Sort Set
with listne_all_rec := Induction for listne Sort Set
with listPE_all_rec := Induction for listPE Sort Set.

Check Exp_all_rec.

Definition TEnv := Env Ty.

(* This is the ||- judgment in the book *)
Inductive DBLTACK : TEnv -> Pattern -> Ty -> Prop :=
 | dt_var t
   : DBLTACK [t] p_var t (* x : t ||- _ x : t *)
 | dt_wild t
   : DBLTACK [] p_wild t (* nil ||- _ : t *)
 | dt_unit
   : DBLTACK [] p_unit t_unit
 | dt_pair e1 e2 p1 p2 t1 t2
   : DBLTACK e1 p1 t1
  -> DBLTACK e2 p2 t2
  -> DBLTACK (e1 ++ e2) (p_pair p1 p2) (t_pair t1 t2)
 | dt_inl e1 p1 t1 t2
   : DBLTACK e1 p1 t1
  -> DBLTACK e1 (p_inl p1) (t_sum t1 t2)
 | dt_inr e2 p2 t1 t2
   : DBLTACK e2 p2 t2
  -> DBLTACK e2 (p_inr p2) (t_sum t1 t2).

Lemma DBLTACK_env_len__pattern_vars env p t :
   DBLTACK env p t ->
   length env = pattern_vars p.
Proof.
 intros Hdb.
 induction Hdb; auto.
 simpl.
 rewrite app_length.
 auto.
Qed.

Inductive TYPE (env : TEnv) : Exp -> Ty -> Prop :=
 | ty_env v t
   : InEnv v t env
  -> TYPE env (var v) t

 | ty_lambda b ty tb
   : TYPE (ty :: env) b tb
  -> TYPE env (lambda ty b) (t_arr ty tb)
 | ty_app f x t1 t2
   : TYPE env f        (t_arr t1 t2)
  -> TYPE env x         t1
  -> TYPE env (app f x) t2

 | ty_pair e1 e2 t1 t2
   : TYPE env e1 t1
  -> TYPE env e2 t2
  -> TYPE env (pair e1 e2) (t_pair t1 t2)
 | ty_inl e1 t1 t2
   : TYPE env e1 t1
  -> TYPE env (inl e1) (t_sum t1 t2)
 | ty_inr e2 t1 t2
   : TYPE env e2 t2
  -> TYPE env (inr e2) (t_sum t1 t2)

 | ty_unitt : TYPE env unitt t_unit

 | ty_matchh_nil es penv px pt ex tx
   : DBLTACK penv px pt
  -> TYPE (penv ++ env) ex tx
  -> TYPE env           es pt
  -> TYPE env   (matchh es (lne (lpe_nil) px ex)) tx

 | ty_matchh_cons es penv px pt ex tx rest pts ets
   : DBLTACK penv px pt
  -> TYPE (penv ++ env) ex tx
  -> TYPE env           es pt
  -> TYPE env   (matchh es (lne rest pts ets)) tx
  -> TYPE env   (matchh es (lne (lpe_cons px ex rest) pts ets)) tx.

(* I don't think we can prove unicity of typing
   without the explicit types on inl/inr. *)

(*Lemma unicity
	(env: TEnv) (e : Exp) (t1 t2 : Ty)
	(Ht1 : TYPE env e t1)
	(Ht2 : TYPE env e t2)
	: t1 = t2.
*)

Fixpoint raise (e : Exp) (a b : nat) :=
 match e with
 | var v       => var (raise' a b v)
 | lambda t x  => lambda t (raise x a (S b))
 | app f x     => app (raise f a b) (raise x a b)
 | pair p q    => pair (raise p a b) (raise q a b)
 | inl  x      => inl (raise x a b)
 | inr  x      => inr (raise x a b)
 | unitt       => unitt
 | matchh s l =>
        matchh (raise s a b) (raiseNE l a b)
 end
with raiseNE (p : listne) (a b : nat) :=
 match p with
 | lne r p e => (lne (raiseLIST r a b) p (raise e a (b + pattern_vars p)))
 end
with raiseLIST (p : listPE) (a b : nat) :=
 match p with
 | lpe_nil => lpe_nil
 | lpe_cons p e rest => lpe_cons p (raise e a (b + pattern_vars p)) (raiseLIST rest a b)
 end.

Lemma raise_0_id (e : Exp) (n : nat) :
	raise e 0 n = e.
Proof.
 revert n.
 einduction e using Exp_all_rec
   with
   (P0 := (fun l => (forall n, raiseNE l 0 n = l)))
   (P1 := (fun l => (forall n, raiseLIST l 0 n = l)));
 intros; simpl; try (rewrite IHe0_1, IHe0_2); try rewrite IHe0; try rewrite IHe3; try reflexivity.
 unfold raise, raise'.
 destruct (ge_dec v n); auto.

 rewrite IHe1. reflexivity.

 rewrite IHe1. reflexivity.

 rewrite IHe1. reflexivity.
Qed.

Lemma raise_S (e : Exp) (a b : nat) :
	raise e (S a) b = raise (raise e a b) 1 b.
Proof.
 revert a b.
 einduction e using Exp_all_rec
   with
   (P0 := fun l => forall a b, raiseNE l (S a) b = raiseNE (raiseNE l a b) 1 b)
   (P1 := fun l => forall a b, raiseLIST l (S a) b = raiseLIST (raiseLIST l a b) 1 b)
; intros; simpl; try (rewrite IHe0_1, IHe0_2); try rewrite IHe0; try rewrite IHe0_3; try reflexivity.
 unfold raise, raise'.
 destruct (ge_dec v b); auto.
 destruct (ge_dec (a+v) b); auto.
  omega.
 destruct (ge_dec v b); auto.
  omega.

 rewrite IHe1. reflexivity.
 rewrite IHe1. reflexivity.
 rewrite IHe1. reflexivity.
Qed.

Lemma insert_app_start {T} e1 e2 v (t:T) :
      (e1 ++ insert e2 v t) = insert (e1 ++ e2) (length e1 + v) t.
Proof.
 induction e1.
  reflexivity.
  simpl.
  rewrite IHe1.
  reflexivity.
Qed.

Lemma weakening_insert
        (env : TEnv) (e : Exp) (te tvi : Ty) (vi : Var) :
        TYPE env e te ->
        TYPE (insert env vi tvi) (raise e 1 vi) te.
 intros Hte.
 revert vi tvi.
 induction Hte; intros; try solve [constructor; auto]; simpl.
 apply ty_env.
 unfold raise'.
 destruct (ge_dec v vi).
 apply get_insert_ge; assumption.
 apply get_insert_lt; try assumption; omega.

 apply ty_lambda.
  rewrite <- uninsert; auto.

 eapply ty_app; auto.

 eapply ty_matchh_nil.
  eassumption.
  rewrite insert_app_start.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  rewrite plus_comm.
  eapply IHHte1.
  assumption.
 apply IHHte2.

 eapply ty_matchh_cons.
  eassumption.
  rewrite insert_app_start.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  rewrite plus_comm.
  eapply IHHte1. assumption.
  eapply IHHte2.
  eapply IHHte3.
Qed.

Lemma weakening_cons
	(env : TEnv) (e : Exp) (te : Ty) tv :
	TYPE env e te ->
	TYPE (tv :: env) (raise e 1 0) te.
Proof.
 rewrite <- insert_0.
 apply weakening_insert.
Qed.

Lemma weakening_app
	(env1 env2 : TEnv) (e : Exp) (te : Ty) :
	TYPE env2 e te ->
	TYPE (env1 ++ env2) (raise e (length env1) 0) te.
Proof.
 intros Ht.
 induction env1.
 simpl. rewrite raise_0_id. assumption.
 simpl.
 rewrite raise_S.
 apply weakening_cons.
 assumption.
Qed.

Fixpoint subst (e e' : Exp) (v : Var) :=
 match e with
 | var v'       => subst' v v' var e'
 | lambda t x   => lambda t (subst x (raise e' 1 0) (S v))
 | app    f x   => app (subst f e' v) (subst x e' v)
 | matchh s ps  => matchh (subst s e' v) (substNE ps e' v)

 | pair   x y   => pair (subst x e' v) (subst y e' v)
 | inl    x     => inl  (subst x e' v)
 | inr      y   => inr  (subst y e' v)
 | unitt        => unitt
 end
with substNE ps e' v :=
 match ps with
 | lne l p e => lne (substPE l e' v) p (subst e (raise e' (pattern_vars p) 0) (v + pattern_vars p))
 end
with substPE l e' v :=
 match l with
 | lpe_nil => lpe_nil
 | lpe_cons p e l' => lpe_cons p (subst e (raise e' (pattern_vars p) 0) (v + pattern_vars p)) (substPE l' e' v)
 end.

Lemma substitution_ix env x t t' e e':
      TYPE (insert env x t) e'             t' ->
      TYPE env              e              t  ->
      x <= length env                         ->
      TYPE env              (subst e' e x) t'.
Proof.
 intros He' He Hlen.
 remember (insert env x t) as ENV.
 revert e x t env HeqENV He Hlen.
 induction He'; intros; subst; simpl; try constructor.
  apply subst_cases; intros; subst.
   eapply InEnv_insert in H. rewrite <- H. assumption.
   apply insert_minus in H; try apply ty_env; try assumption; try omega.
   apply insert_pre in H; try apply ty_env; try assumption; try omega.

 eapply IHHe'; auto.
  reflexivity.
  apply weakening_cons. assumption.
  simpl. omega.

 apply ty_app with (t1 := t1).
  eapply IHHe'1; auto.
  eapply IHHe'2; auto.

 eapply IHHe'1; auto.
 eapply IHHe'2; auto.

 eapply IHHe'; auto.
 eapply IHHe'; auto.

 eapply ty_matchh_nil.
  eassumption.
  eapply IHHe'1.
  rewrite insert_app_start.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  rewrite plus_comm.
  reflexivity.
  assumption.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  apply weakening_app. assumption.
  assumption.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  rewrite app_length.
  omega.
  assumption.
  eapply IHHe'2.
  reflexivity.
  assumption.
  assumption.

 eapply ty_matchh_cons.
  eassumption.

  eapply IHHe'1.
  rewrite insert_app_start.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  rewrite plus_comm.
  reflexivity.
  assumption.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  apply weakening_app. assumption.
  assumption.
  rewrite <- DBLTACK_env_len__pattern_vars with (p := px) (t := pt) (env := penv).
  rewrite app_length.
  omega.
  assumption.
  eapply IHHe'2.
  reflexivity.
  assumption.
  assumption.

 eapply IHHe'3.
 reflexivity.
 assumption.
 assumption.
Qed.

Lemma substitution env t t' e e':
      TYPE (t :: env)       e'             t' ->
      TYPE env              e              t  ->
      TYPE env              (subst e' e 0) t'.
Proof.
 intros.
 eapply substitution_ix; try rewrite insert_0; try eassumption; try omega.
Qed.

Definition Sub(*stitution*) := Env Exp.

Inductive Match : Sub -> Pattern -> Exp -> Prop :=
 | m_var  e : Match [e] p_var e
 | m_wild e : Match []  p_wild e
 | m_unit   : Match []  p_unit unitt
 | m_pair s1 s2 p1 p2 e1 e2
   : Match s1 p1 e1
  -> Match s2 p2 e2
  -> Match (s1++s2) (p_pair p1 p2) (pair e1 e2)
 | m_inl s p e
   : Match s p e
  -> Match s (p_inl p) (inl e)
 | m_inr s p e
   : Match s p e
  -> Match s (p_inr p) (inr e).

Inductive NoMatch : Pattern -> Exp -> Prop :=
 | nm_pair1 p1 p2 e1 e2
   : NoMatch p1 e1
  -> NoMatch (p_pair p1 p2) (pair e1 e2)
 | nm_pair2 p1 p2 e1 e2
   : NoMatch p2 e2
  -> NoMatch (p_pair p1 p2) (pair e1 e2)
 | nm_lr p e
   : NoMatch (p_inl p) (inr e)
 | nm_rl p e
   : NoMatch (p_inr p) (inl e)
 | nm_ll p e
   : NoMatch p e
  -> NoMatch (p_inl p) (inl e)
 | nm_rr p e
   : NoMatch p e
  -> NoMatch (p_inr p) (inr e).

Lemma Match_sub_length s p e:
      Match s p e ->
      length s = pattern_vars p.
Proof.
 intros Hm.
 induction Hm; try rewrite app_length; simpl; auto.
Qed.

Lemma Match_NoMatch_ex s p e:
      Match s p e -> ~ NoMatch p e.
Proof.
 intros Hm Hnot.
 induction Hm; inversion Hnot; auto.
Qed.

Lemma NoMatch_Match_ex s p e:
      NoMatch p e -> ~ Match s p e.
Proof.
 intros Hm Hnot.  revert s Hnot.
 induction Hm; intros; inversion Hnot; auto; subst.
  apply IHHm in H3. destruct H3.
  apply IHHm in H5. destruct H5.
  apply IHHm in H2. destruct H2.
  apply IHHm in H2. destruct H2.
Qed.

Lemma Match_determ s s' p e:
      Match s p e -> Match s' p e ->
      s = s'.
Proof.
 intros Hs Hs'.
 revert s' Hs'.
 induction Hs; intros; inversion Hs'; subst; try reflexivity.
 erewrite IHHs1. erewrite IHHs2. reflexivity.
 eassumption. eassumption.
 erewrite IHHs. reflexivity. assumption.
 erewrite IHHs. reflexivity. assumption.
Qed.

Inductive val : Exp -> Prop :=
 | v_l t b : val (lambda t b)
 | v_pair p q: val p -> val q -> val (pair p q)
 | v_inl p : val p -> val (inl p)
 | v_inr p : val p -> val (inr p)
 | v_unitt : val unitt.

Lemma t13_1 env e t penv p :
  TYPE env e t ->
  val e ->
  DBLTACK penv p t ->
  (exists s, Match s p e /\ Forall2 (TYPE env) s penv) \/ NoMatch p e.
Proof.
 intros Ht Hv Hd. revert e Ht Hv.
 induction Hd; intros;
  inversion Hv; subst; inversion Ht; subst;
  try solve [left; eexists; split; try repeat econstructor; eauto];
  try solve [right; try econstructor; eauto].

 edestruct IHHd1; try eassumption.
 destruct H1.
 destruct H1.
 edestruct IHHd2; try eassumption.
 destruct H3.
 destruct H3.

 left; eexists; split; try econstructor; eauto.
 apply Forall2_app; assumption.

 right; apply nm_pair2; assumption.
 right; apply nm_pair1; assumption.

 edestruct IHHd; try eassumption.
 destruct H0.
 destruct H0.
 left; eexists; split; try econstructor; eauto.

 right; econstructor; assumption.

 edestruct IHHd; try eassumption.
 destruct H0.
 destruct H0.
 left; eexists; split; try econstructor; eauto.
 right; econstructor; assumption.
Qed.

Fixpoint subst_all subs e r :=
 match subs with
 | []    => e
 | s::ss => (subst_all ss (subst e (raise s (r-1) 0) 0) (r-1))
 end.

(*Definition subst_all subs e := fold_right (fun p q => subst q p 0) e subs. *)

Lemma Forall2_length {A B} P (a : list A) (b : list B):
      Forall2 P a b ->
      length a = length b.
Proof.
 intros Hf.
 induction Hf; simpl; auto.
Qed.

Lemma substitution_all env subs e t tys:
      Forall2 (TYPE env) subs tys ->
      TYPE (tys++env) e t ->
      TYPE (env) (subst_all subs e (length subs)) t.
Proof.
 intros Hf Ht.
 revert e t Ht.
 induction Hf; intros.
  assumption.

 simpl.
 rewrite <- minus_n_O.
  eapply IHHf.
  eapply substitution.
 eassumption.

 revert l x y e t H Hf Ht IHHf.
 induction l'; intros.
  inversion Hf; subst.
  simpl.
   rewrite raise_0_id. assumption.

  inversion Hf; subst.
  simpl.
  rewrite raise_S.
  eapply weakening_cons.

  eapply IHl'.
 assumption.
 assumption.
 assert ((y :: a :: l') ++ env = insert ((y :: l') ++ env) 1 a) by (destruct l'; destruct env; reflexivity).
 rewrite H0 in Ht.

 eapply substitution_ix. eassumption.
 eapply weakening_app. eassumption.
 simpl. omega.

 intros.
 revert l0 x y e t e0 t0 x0 H Hf Ht IHHf H4 H3 Ht0.
 induction l'; intros.
  inversion H4; subst.
  simpl. assumption.
  inversion H4; subst.
  simpl. rewrite <- minus_n_O.
 eapply IHl'0; intros; try eassumption; eauto.

 assert (length l0 = length l').
  eapply Forall2_length. eassumption.
 rewrite H1.
 eapply weakening_app.
 assumption.

 assert ((a0 :: a :: l') ++ env = insert ((a0 :: l') ++ env) 1 a) by (destruct l'; destruct env;simpl; reflexivity).
 rewrite H0. eapply weakening_insert. eassumption.
 simpl. rewrite <- minus_n_O.
 rewrite H0 in Ht.

 eapply substitution_ix. eassumption.

   inversion Hf.

   rewrite raise_0_id. assumption.

  inversion Hf; subst.
  simpl.
  rewrite raise_S.
  eapply weakening_cons.

  eapply IHl'.
 assumption.
 assumption.
 assert ((y :: a :: l') ++ env = insert ((y :: l') ++ env) 1 a) by (destruct l'; destruct env; reflexivity).
 rewrite H0 in Ht.

 eapply substitution_ix. eassumption.
 eapply weakening_app. eassumption.
 simpl. omega.

  simpl.
  rewrite raise_S.
  eapply weakening_cons.

 assert (r = length l').
  induction l'.
 eapply weakening_cons.

 induction subs; intros.
  destruct tys.
   assumption.
   inversion Hf.

  destruct tys.
   inversion Hf.
  simpl.
  inversion Hf; subst.

  eapply substitution.
  eapply weakening_cons.
  eapply IHsubs.
  eassumption.

  simpl. reflexivity.
  eassumption.
  simpl.
  eapply weakening_cons.
  eassumption.
  .

Inductive e_step: Exp -> Exp -> Prop :=
 | e_ap1 e1 e1' e2
            : e_step      e1          e1'
           -> e_step (app e1 e2) (app e1' e2)
 | e_ap2 e1 e2 e2'
            : val e1
           -> e_step         e2          e2'
           -> e_step (app e1 e2) (app e1 e2')
 | e_lam  t b x
            : val x
           -> e_step (app (lambda t b) x) (subst b x 0)

 | e_pa1 e1 e1' e2
            : e_step      e1          e1'
           -> e_step (pair e1 e2) (pair e1' e2)
 | e_pa2 e1 e2 e2'
            : val e1
           -> e_step         e2          e2'
           -> e_step (pair e1 e2) (pair e1 e2')

 | e_inl e e'
            : e_step      e       e'
           -> e_step (inl e) (inl e')
 | e_inr e e'
            : e_step      e       e'
           -> e_step (inr e) (inr e')

 | matchh1 e e' rs
            : e_step      e       e'
           -> e_step (matchh e rs) (matchh e' rs)

 | matchh_here_pe s sub p e rest nep nee
            : val s
           -> Match sub p s
           -> e_step (matchh s (lne (lpe_cons p e rest) nep nee))
                     (subst_all sub e)

 | matchh_next_pe s p e rest nep nee
            : val s
           -> NoMatch p s
           -> e_step (matchh s (lne (lpe_cons p e rest) nep nee))
                     (matchh s (lne rest nep nee))

 | matchh_here_ne s sub nep nee
            : val s
           -> Match sub nep s
           -> e_step (matchh s (lne (lpe_nil) nep nee))
                     (subst_all sub nee).

Theorem preservation env e e' t:
        TYPE env e t ->
        e_step e e'  ->
        TYPE env e' t.
Proof.
 intros Ht He.
 revert env t Ht.
 induction He; intros;
   try solve [inversion Ht; subst; try econstructor; try eapply IHHe; eassumption].

  inversion Ht; subst;
  inversion H2; subst.
  eapply substitution; eassumption.

  destruct rs.
  induction l.
  inversion Ht; subst.
   eapply ty_matchh_nil; try eassumption.
   apply IHHe. assumption.

  inversion Ht; subst.
   eapply ty_matchh_cons; try eassumption.
   apply IHHe. assumption.
   apply IHl. assumption.

  inversion Ht; subst.
  assert (length sub = pattern_vars p) by (eapply Match_sub_length; eassumption).
  assert (length penv = pattern_vars p) by (eapply DBLTACK_env_len__pattern_vars; eassumption).

 assert ((exists sub, Match sub p s /\ Forall2 (TYPE env) sub penv) \/ NoMatch p s).
  eapply t13_1; eassumption.
 destruct H3.
 destruct H3.
 destruct H3.

 assert (x = sub).
  eapply Match_determ; eassumption.

 subst.

(*  generalize dependent e.
  generalize dependent env.
  generalize dependent t.
  generalize dependent penv.
  generalize dependent pt.
  generalize dependent p.
  generalize dependent s.*)
  generalize dependent env.
  induction sub; intros.
   simpl.
   assert (penv = []). destruct penv; subst; auto. simpl in H2. rewrite <- H2 in H1. simpl in H1. omega.
   subst.
   assumption.

  simpl.
  eapply substitution.
  destruct penv.
   simpl in H1. rewrite <- H1 in H2. inversion H2.

  eapply IHsub.

 (*TODO need to track types of substitution *)

(*  eapply IHsub; try eassumption.

  inversion H3.
  eapply substitution;
   eassumption.

  eapply substitution; eassumption.
Qed.

Theorem progress e t:
        TYPE [] e t ->
        val e \/ exists e', e_step e e'.
Proof.
 remember [] as ENV.
 intros Ht.
 induction Ht; subst;
  try solve [apply not_InEnv_nil in H; destruct H];
  try solve [left; econstructor; eassumption].

 destruct IHHt. reflexivity.
 left. constructor. assumption.
 destruct H.
  right. eexists. constructor. eassumption.

 right.
 destruct IHHt1; try reflexivity.
  destruct n; inversion H.
   eexists. apply e_ifz.
   eexists. apply e_ifs. assumption.
   inversion Ht1.
 destruct H.
 eexists. apply e_if1. eassumption.

 destruct IHHt1; try reflexivity.
 destruct IHHt2; try reflexivity.
 inversion H; subst; inversion Ht1; subst.
 right.
  eexists. apply e_lam. assumption.
 destruct H0.
 right.
  eexists. apply e_ap2; eassumption.

 destruct H.
 right.
  eexists. apply e_ap1; eassumption.

 right.
  eexists. apply e_fixx.
Qed.


Require Import BinPosDef List.
Require Import Crypto.Spec.ModularArithmetic.

Context {q : positive}.

Definition sig := F q.

Definition sigArray := list sig.

Module Get.

  Inductive iget : sigArray -> sig -> nat -> Prop :=
  | iget_frst: forall ss s, iget (s :: ss) s 0
  | iget_step: forall ss s s' i, iget ss s i -> iget (s' :: ss) s (S i).

  Fixpoint get (ss : sigArray) (s : sig) (i : nat) : Prop :=
    match ss, i with
    | nil, _ => False
    | s' :: _, O => s' = s
    | _ :: ss', S i' => get ss' s i'
    end.

End Get.

Module Init.

  Inductive iinit : sig -> nat -> sigArray -> Prop :=
  | iinit_zero: forall s, iinit s 0 nil
  | iinit_succ: forall s n ss, iinit s n ss -> iinit s (S n) (s :: ss).

  Fixpoint init (s : sig) (n : nat) (ss : sigArray) : Prop :=
    match ss, n with
    | nil, O => True
    | s' :: ss', S n' => s' = s /\ init s n' ss'
    | _, _ => False
    end.

  Lemma init_sound: forall s n ss, init s n ss -> ss = repeat s n.
  Proof.
    intro. induction n; intros; simpl in H; simpl; destruct ss; intuition.
    - apply IHn in H1. rewrite H0, <- H1. reflexivity.
  Qed.

  Lemma init_complete: forall s n, init s n (repeat s n).
  Proof.
    intro. induction n; simpl; auto.
  Qed.

End Init.

Module Scale.

  Definition scale_fn (c : sig) := List.map (F.mul c).

  Inductive iscale : sig -> sigArray -> sigArray -> Prop :=
  | iscale_nil: forall c, iscale c nil nil
  | iscale_cons: forall c ss ss' s, iscale c ss ss' -> iscale c (s :: ss) (F.mul c s :: ss').

  Fixpoint scale (c : sig) (s1 s2 : sigArray) : Prop :=
    match s1, s2 with
    | nil, nil => True
    | s' :: s1', s'' :: s2' => s'' = F.mul c s' /\ scale c s1' s2'
    | _, _ => False
    end.

  Lemma scale_sound: forall c s1 s2, scale c s1 s2 -> scale_fn c s1 = s2.
  Proof.
    intro. induction s1; intros; simpl in H; simpl; destruct s2; intuition.
    - apply IHs1 in H1. rewrite H0, H1. reflexivity.
  Qed.

  Lemma scale_complete: forall c ss, scale c ss (scale_fn c ss).
  Proof.
    intro. induction ss; simpl; auto.
  Qed.

End Scale.

Module Sum.

  Definition sum_fn (ss : sigArray) := fold_right F.add F.zero ss.

  Inductive isum : sigArray -> sig -> Prop :=
  | isum_nil: isum nil F.zero
  | isum_cons: forall ss s s', isum ss s -> isum (s' :: ss) (F.add s' s).

  Fixpoint sum (ss : sigArray) (s : sig) : Prop :=
    match ss with
    | nil => s = F.zero
    | s' :: ss' => sum ss' (F.sub s s')
    end.

  Lemma sum_sound: forall ss s, sum ss s -> sum_fn ss = s.
  Proof.
    induction ss; intros.
    - auto.
    - simpl in H. apply IHss in H. unfold sum_fn in H.
      unfold sum_fn. simpl. rewrite H. admit.
  Admitted.

End Sum.

Module Map.

  Inductive imap {A : Type} : (sig -> A) -> sigArray -> list A -> Prop :=
  | imap_nil: forall f, imap f nil nil
  | imap_cons: forall f ss a s, imap f ss a -> imap f (s :: ss) (f s :: a).

  Fixpoint map {A : Type} (f : sig -> A) (ss : sigArray) (l : list A) : Prop :=
    match ss, l with
    | nil, nil => True
    | s' :: ss', a :: l' => a = f s' /\ map f ss' l'
    | _, _ => False
    end.

  Lemma map_sound: forall A (f : sig -> A) ss l, map f ss l -> List.map f ss = l.
  Proof.
    intros A f.
    induction ss; intros; simpl in H; simpl; destruct l; intuition.
    - apply IHss in H1. rewrite <- H0, H1. reflexivity.
  Qed.

  Lemma map_complete: forall A (f : sig -> A) ss, map f ss (List.map f ss).
  Proof.
    intros A f. induction ss; simpl; auto.
  Qed.

End Map.

Module Fold.

  Inductive ifoldl {A : Type} : (A -> sig -> A) -> sigArray -> A -> A -> Prop :=
  | ifoldl_nil: forall f a, ifoldl f nil a a
  | ifoldl_app: forall f ss a a' s, ifoldl f ss a a' -> ifoldl f (ss ++ (cons s nil)) a (f a' s).

  Fixpoint foldl {A : Type} (f : A -> sig -> A) (ss : sigArray) (acc a : A) : Prop :=
    match ss with
    | nil => a = acc
    | s' :: ss' =>
        let acc' := f acc s' in
        foldl f ss' acc' a
    end.

  Lemma foldl_sound: forall A (f : A -> sig -> A) ss acc a,
      foldl f ss acc a -> fold_left f ss acc = a.
  Proof.
    intros A f. induction ss; intros; simpl in H; simpl; auto.
  Qed.

  Lemma foldl_complete: forall A (f : A -> sig -> A) ss acc,
      foldl f ss acc (fold_left f ss acc).
  Proof.
    intros A f. induction ss; intros; simpl; auto.
  Qed.

  Inductive ifoldr {A : Type} : (sig -> A -> A) -> A -> sigArray -> A -> Prop :=
  | ifoldr_nil: forall f a, ifoldr f a nil a
  | ifoldr_cons: forall f ss a a' s, ifoldr f a ss a' -> ifoldr f a (s :: ss) (f s a').

  Definition foldr {A : Type} (f : sig -> A -> A) (acc : A) (ss : sigArray) (a : A) : Prop :=
    foldl (fun acc s => f s acc) (rev ss) acc a.

  Lemma foldr_sound: forall A (f : sig -> A -> A) acc ss a,
      foldr f acc ss a -> fold_right f acc ss = a.
  Proof.
    intros A f acc ss. revert acc.
    induction ss; intros; unfold foldr in H; simpl in H; simpl.
    - auto.
    - apply foldl_sound in H. rewrite fold_left_app in H. simpl in H.
      assert (H0: foldl (fun (acc : A) (s : sig) => f s acc) (rev ss) acc
                    (fold_left (fun (acc : A) (s : sig) => f s acc) (rev ss) acc)).
      { apply foldl_complete. }
      unfold foldr in IHss. apply IHss in H0. rewrite <- H0 in H. apply H.
  Qed.

  Lemma foldr_complete: forall A (f : sig -> A -> A) acc ss,
      foldr f acc ss (fold_right f acc ss).
  Proof.
    intros A f acc ss. revert acc.
    induction ss; intros; unfold foldr; simpl.
    - auto.
    - assert (H0: fold_left (fun (acc0 : A) (s : sig) => f s acc0)
                    (rev ss ++ a :: nil) acc = (f a (fold_right f acc ss))).
      { rewrite fold_left_app. simpl. unfold foldr in IHss.
        specialize IHss with (acc := acc) as H0'.
        apply foldl_sound in H0'. rewrite H0'. reflexivity. }
      rewrite <- H0. apply foldl_complete.
  Qed.

End Fold.

Module Map2.

  Fixpoint map2_fn {A : Type} (f : sig -> sig -> A) (s1 s2 : sigArray) : list A :=
    match s1, s2 with
    | s' :: s1', s'' :: s2' =>
        (f s' s'') :: map2_fn f s1' s2'
    | _, _ => nil
    end.

  Inductive imap2 {A : Type} : (sig -> sig -> A) -> sigArray -> sigArray -> list A -> Prop :=
  | imap2_nil_l: forall f ss, imap2 f nil ss nil
  | imap2_nil_r: forall f ss, imap2 f ss nil nil
  | imap2_cons: forall f ss1 ss2 a s1 s2, imap2 f ss1 ss2 a -> imap2 f (s1 :: ss1) (s2 :: ss2) (f s1 s2 :: a).

  Fixpoint map2 {A : Type} (f : sig -> sig -> A) (s1 s2 : sigArray) (l : list A) : Prop :=
    match s1, s2, l with
    | nil, nil, nil => True
    | s' :: s1', s'' :: s2', a :: l' =>
        a = f s' s'' /\ map2 f s1' s2' l'
    | _, _, _ => False
    end.

End Map2.

Module Fold2.

  Fixpoint foldl2_fn {A : Type} (f : A -> sig -> sig -> A) (s1 s2 : sigArray) (acc : A) : A :=
    match s1, s2 with
    | s' :: s1', s'' :: s2' =>
        foldl2_fn f s1' s2' (f acc s' s'')
    | _, _ => acc
    end.

  Inductive ifoldl2 {A : Type} : (A -> sig -> sig -> A) -> sigArray -> sigArray -> A -> A -> Prop :=
  | ifoldl2_nil_l: forall f ss a, ifoldl2 f nil ss a a
  | ifoldl2_nil_r: forall f ss a, ifoldl2 f ss nil a a
  | ifoldl2_app: forall f ss1 ss2 a a' s1 s2,
      ifoldl2 f ss1 ss2 a a' -> ifoldl2 f (ss1 ++ (cons s1 nil)) (ss2 ++ (cons s2 nil)) a (f a' s1 s2).

  Fixpoint foldl2 {A : Type} (f : A -> sig -> sig -> A) (s1 s2 : sigArray) (acc a : A) : Prop :=
    match s1, s2 with
    | nil, nil => a = acc
    | s' :: s1', s'' :: s2' =>
        let acc' := f acc s' s'' in
        foldl2 f s1' s2' acc' a
    | _, _ => False
    end.

  Fixpoint foldr2_fn {A : Type} (f : sig -> sig -> A -> A) (acc : A) (s1 s2 : sigArray) : A :=
    match s1, s2 with
    | s' :: s1', s'' :: s2' =>
        foldr2_fn f (f s' s'' acc) s1' s2'
    | _, _ => acc
    end.

  Inductive ifoldr2 {A : Type} : (sig -> sig -> A -> A) -> A -> sigArray -> sigArray -> A -> Prop :=
  | ifoldr2_nil_l: forall f ss a, ifoldr2 f a nil ss a
  | ifoldr2_nil_r: forall f ss a, ifoldr2 f a ss nil a
  | ifoldr2_cons: forall f ss1 ss2 a a' s1 s2,
      ifoldr2 f a ss1 ss2 a' -> ifoldr2 f a (s1 :: ss1) (s2 :: ss2) (f s1 s2 a').

  Definition foldr2 {A : Type} (f : sig -> sig -> A -> A) (acc : A) (s1 s2 : sigArray) (a : A) : Prop :=
    foldl2 (fun acc s' s'' => f s' s'' acc) (rev s1) (rev s2) acc a.

End Fold2.

Module Elem.

  Definition ielem_add := Map2.imap2 F.add.
  Definition ielem_sub := Map2.imap2 F.sub.
  Definition ielem_mul := Map2.imap2 F.mul.

  Definition elem_add := Map2.map2 F.add.
  Definition elem_sub := Map2.map2 F.sub.
  Definition elem_mul := Map2.map2 F.mul.

  Inductive ielem_eq : sigArray -> sigArray -> Prop :=
  | ielem_eq_nil: ielem_eq nil nil
  | ielem_eq_cons: forall s1 s2 s, ielem_eq s1 s2 -> ielem_eq (s :: s1) (s :: s2).

  Fixpoint elem_eq (s1 s2 : sigArray) : Prop :=
    match s1, s2 with
    | nil, nil => True
    | s' :: s1', s'' :: s2' =>
        s' = s'' /\ elem_eq s1' s2'
    | _, _ => False
    end.

End Elem.


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

(* File Eqdep.v created by Christine Paulin-Mohring in Coq V5.6, May 1992 *)
(* Further documentation and variants of eq_rect_eq by Hugo Herbelin,
   Apr 2003 *)
(* Abstraction with respect to the eq_rect_eq axiom and renaming to
   EqdepFacts.v by Hugo Herbelin, Mar 2006 *)
(* Modified by Jason Gross to not need full decidable equality on all pairs, April 2013 *)

(** This file defines dependent equality and shows its equivalence with
    equality on dependent pairs (inhabiting sigma-types). It derives
    the consequence of axiomatizing the invariance by substitution of
    reflexive equality proofs and shows the equivalence between the 4
    following statements

    - Invariance by Substitution of Reflexive Equality Proofs.
    - Injectivity of Dependent Equality
    - Uniqueness of Identity Proofs
    - Uniqueness of Reflexive Identity Proofs
    - Streicher's Axiom K

  These statements are independent of the calculus of constructions [2].

  References:

  [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
      Habilitationsschrift, LMU MÃ¼nchen, 1993.
  [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
      Proceedings of the meeting Twenty-five years of constructive
      type theory, Venice, Oxford University Press, 1998

Table of contents:

1. Definition of dependent equality and equivalence with equality of
   dependent pairs and with dependent pair of equalities

2. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K

3. Definition of the functor that builds properties of dependent
   equalities assuming axiom eq_rect_eq

*)

(************************************************************************)
(** * Definition of dependent equality and equivalence with equality of dependent pairs *)

Import EqNotations.

Section Dependent_Equality.

  Variable U : Type.
  Variable P : U -> Type.

  (** Dependent equality *)

  Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop :=
    eq_dep_intro : eq_dep p x p x.
  Hint Constructors eq_dep: core.

  Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x.
  Proof eq_dep_intro.

  Lemma eq_dep_sym :
    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x.
  Proof.
    destruct 1; auto.
  Qed.
  Hint Immediate eq_dep_sym: core.

  Lemma eq_dep_trans :
    forall (p q r:U) (x:P p) (y:P q) (z:P r),
      eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z.
  Proof.
    destruct 1; auto.
  Qed.

  Scheme eq_indd := Induction for eq Sort Prop.

  (** Equivalent definition of dependent equality as a dependent pair of
      equalities *)

  Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
    eq_dep1_intro : forall h:q = p, x = rew h in y -> eq_dep1 p x q y.

  Lemma eq_dep1_dep :
    forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
  Proof.
    destruct 1 as (eq_qp, H).
    destruct eq_qp using eq_indd.
    rewrite H.
    apply eq_dep_intro.
  Qed.

  Lemma eq_dep_dep1 :
    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
  Proof.
    destruct 1.
    apply eq_dep1_intro with (eq_refl p).
    simpl; trivial.
  Qed.

End Dependent_Equality.

Arguments eq_dep  [U P] p x q _.
Arguments eq_dep1 [U P] p x q y.

(** Dependent equality is equivalent to equality on dependent pairs *)

Lemma eq_sigT_eq_dep :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    existT P p x = existT P q y -> eq_dep p x q y.
Proof.
  intros.
  dependent rewrite H.
  apply eq_dep_intro.
Qed.

Notation eq_sigS_eq_dep := eq_sigT_eq_dep (compat "8.2"). (* Compatibility *)

Lemma eq_dep_eq_sigT :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    eq_dep p x q y -> existT P p x = existT P q y.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma eq_sigT_iff_eq_dep :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    existT P p x = existT P q y <-> eq_dep p x q y.
Proof.
  split; auto using eq_sigT_eq_dep, eq_dep_eq_sigT.
Qed.

Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing). (* Compat *)

Lemma eq_sig_eq_dep :
  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    exist P p x = exist P q y -> eq_dep p x q y.
Proof.
  intros.
  dependent rewrite H.
  apply eq_dep_intro.
Qed.

Lemma eq_dep_eq_sig :
  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    eq_dep p x q y -> exist P p x = exist P q y.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma eq_sig_iff_eq_dep :
  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    exist P p x = exist P q y <-> eq_dep p x q y.
Proof.
  split; auto using eq_sig_eq_dep, eq_dep_eq_sig.
Qed.

(** Dependent equality is equivalent to a dependent pair of equalities *)

Set Implicit Arguments.

Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}.
Proof.
  intros; split; intro H.
  - change x2 with (projT1 (existT P x2 H2)).
    change H2 with (projT2 (existT P x2 H2)) at 5.
    destruct H. simpl.
    exists eq_refl.
    reflexivity.
  - destruct H as (->,<-).
    reflexivity.
Defined.

Lemma eq_sigT_fst :
  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2.
Proof.
  intros.
  change x2 with (projT1 (existT P x2 H2)).
  destruct H.
  reflexivity.
Defined.

Lemma eq_sigT_snd :
  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2.
Proof.
  intros.
  unfold eq_sigT_fst.
  change x2 with (projT1 (existT P x2 H2)).
  change H2 with (projT2 (existT P x2 H2)) at 3.
  destruct H.
  reflexivity.
Defined.

Lemma eq_sig_fst :
  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2.
Proof.
  intros.
  change x2 with (proj1_sig (exist P x2 H2)).
  destruct H.
  reflexivity.
Defined.

Lemma eq_sig_snd :
  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2.
Proof.
  intros.
  unfold eq_sig_fst, eq_ind.
  change x2 with (proj1_sig (exist P x2 H2)).
  change H2 with (proj2_sig (exist P x2 H2)) at 3.
  destruct H.
  reflexivity.
Defined.

Unset Implicit Arguments.

(** Exported hints *)

Hint Resolve eq_dep_intro: core.
Hint Immediate eq_dep_sym: core.

(************************************************************************)
(** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K          *)

Section Equivalences.

  Variable U:Type.

  Variable p:U.

  (** Invariance by Substitution of Reflexive Equality Proofs *)

  Definition Eq_rect_eq :=
    forall (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.

  (** Injectivity of Dependent Equality *)

  Definition Eq_dep_eq :=
    forall (P:U->Type) (x y:P p), eq_dep p x p y -> x = y.

  (** Uniqueness of Identity Proofs (UIP) *)

  Definition UIP_ :=
    forall (y:U) (p1 p2:p = y), p1 = p2.

  (** Uniqueness of Reflexive Identity Proofs *)

  Definition UIP_refl_ :=
    forall (H:p = p), H = eq_refl p.

  (** Streicher's axiom K *)

  Definition Streicher_K_ :=
    forall (P:p = p -> Prop), P (eq_refl p) -> forall H:p = p, P H.

  (** Injectivity of Dependent Equality is a consequence of *)
  (** Invariance by Substitution of Reflexive Equality Proof *)

  Lemma eq_rect_eq__eq_dep1_eq :
    Eq_rect_eq -> forall (P:U->Type) (x y:P p), eq_dep1 p x p y -> x = y.
  Proof.
    intro eq_rect_eq.
    simple destruct 1; intro.
    rewrite <- eq_rect_eq; auto.
  Qed.

  Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq.
  Proof.
    intros eq_rect_eq; red; intros.
    apply (eq_rect_eq__eq_dep1_eq eq_rect_eq); apply eq_dep_dep1; trivial.
  Qed.

  (** Uniqueness of Identity Proofs (UIP) is a consequence of *)
  (** Injectivity of Dependent Equality *)
  Lemma sym_iff0 T (x y : T) (p1 : x = y) (p2 : y = x) : p1 = eq_sym p2 <-> p2 = eq_sym p1.
    split; intros; (subst p1 || subst p2); simpl; (destruct p1 || destruct p2); simpl; reflexivity.
  Qed.
  Lemma sym_iff T (x y : T) (p1 p2 : x = y) : p1 = p2 <-> eq_sym p1 = eq_sym p2.
    split; intros; try solve [ subst; trivial ]; simpl in *.
    transitivity (eq_sym (eq_sym p2));
      (apply sym_iff0 || (symmetry; apply sym_iff0)); intuition.
  Qed.

  Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_.
  Proof.
    intro eq_dep_eq; red.
    intro y.
    intros; apply sym_iff; apply eq_dep_eq with (P := fun y0 => y = y0).
    elim (eq_sym p2) using eq_indd.
    elim (eq_sym p1) using eq_indd.
    apply eq_dep_intro.
  Qed.

  (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)

  Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
  Proof.
    intro UIP; red; intros; apply UIP.
  Qed.

  (** Streicher's axiom K is a direct consequence of Uniqueness of
      Reflexive Identity Proofs *)

  Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_.
  Proof.
    intro UIP_refl; red; intros; rewrite UIP_refl; assumption.
  Qed.

  (** We finally recover from K the Invariance by Substitution of
      Reflexive Equality Proofs *)

  Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
  Proof.
    intro Streicher_K; red; intros.
    apply Streicher_K with (H := h).
    reflexivity.
  Qed.

(** Remark: It is reasonable to think that [eq_rect_eq] is strictly
    stronger than [eq_rec_eq] (which is [eq_rect_eq] restricted on [Set]):

   [Definition Eq_rec_eq :=
      forall (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.]

    Typically, [eq_rect_eq] allows to prove UIP and Streicher's K what
    does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP]
    requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not
    in [Set].
*)

End Equivalences.

(** UIP_refl is downward closed (a short proof of the key lemma of Voevodsky's
    proof of inclusion of h-level n into h-level n+1; see hlevelntosn
    in https://github.com/vladimirias/Foundations.git). *)

Theorem UIP_shift : forall U (x:U), UIP_refl_ U x -> forall H, UIP_refl_ (x = x) H.
Proof.
  intros X x UIP_refl y.
  rewrite (UIP_refl y).
  intros z.
  assert (UIP:forall y' y'' : x = x, y' = y'').
  { intros. apply eq_trans with (eq_refl x). apply UIP_refl.
    symmetry. apply UIP_refl. }
  transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
                         (eq_sym (UIP (eq_refl x) (eq_refl x)))).
  - destruct z. unfold e. destruct (UIP _ _). reflexivity.
  - change
      (match eq_refl x as y' in _ = x' return y' = y' -> Type with
       | eq_refl => fun z => z = (eq_refl (eq_refl x))
       end (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
                     (eq_sym (UIP (eq_refl x) (eq_refl x))))).
    destruct z. unfold e. destruct (UIP _ _). reflexivity.
Qed.

Section Corollaries.

  Variable U:Type.

  Variable p:U.

  (** UIP implies the injectivity of equality on dependent pairs in Type *)

 Definition Inj_dep_pair :=
   forall (P:U -> Type) (x y:P p), existT P p x = existT P p y -> x = y.

 Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U p -> Inj_dep_pair.
 Proof.
   intro eq_dep_eq; red; intros.
   apply eq_dep_eq.
   apply eq_sigT_eq_dep.
   assumption.
 Qed.

End Corollaries.

Notation Inj_dep_pairS := Inj_dep_pair.
Notation Inj_dep_pairT := Inj_dep_pair.
Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2.

(************************************************************************)
(** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *)

Module Type EqdepElimination.

  Axiom eq_rect_eq :
    forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
      x = eq_rect p Q x p h.

End EqdepElimination.

Module EqdepTheory (M:EqdepElimination).

  Section Axioms.

    Variable U:Type.

(** Invariance by Substitution of Reflexive Equality Proofs *)

Lemma eq_rect_eq :
  forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof M.eq_rect_eq U.

Lemma eq_rec_eq :
  forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h.
Proof (fun p Q => M.eq_rect_eq U p Q).

(** Injectivity of Dependent Equality *)

Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
Proof (fun P p => @eq_rect_eq__eq_dep_eq U p (eq_rect_eq p) P).

(** Uniqueness of Identity Proofs (UIP) is a consequence of *)
(** Injectivity of Dependent Equality *)

Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
Proof (fun p => @eq_dep_eq__UIP U p (fun P => @eq_dep_eq P p)).

(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)

Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
Proof (fun x => @UIP__UIP_refl U x (UIP x)).

(** Streicher's axiom K is a direct consequence of Uniqueness of
    Reflexive Identity Proofs *)

Lemma Streicher_K :
  forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof (fun x => UIP_refl__Streicher_K U x (UIP_refl x)).

End Axioms.

(** UIP implies the injectivity of equality on dependent pairs in Type *)

Lemma inj_pair2 :
 forall (U:Type) (P:U -> Type) (p:U) (x y:P p),
   existT P p x = existT P p y -> x = y.
Proof (fun U P p => eq_dep_eq__inj_pair2 U p (fun P => eq_dep_eq U P p) P).

Notation inj_pairT2 := inj_pair2.

End EqdepTheory.

Arguments eq_dep  U P p x q _ : clear implicits.
Arguments eq_dep1 U P p x q y : clear implicits.


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (c) 2010-2015, ENS de Lyon and Inria.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

Require Import Rdefinitions Raxioms RIneq Rbasic_fun Zwf.
Require Import Epsilon FunctionalExtensionality Ranalysis1 Rsqrt_def.
Require Import Rtrigo1 Reals.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import choice bigop ssralg fintype poly.
From mathcomp Require Import mxpoly ssrnum.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GRing.Theory Num.Def Num.Theory.

Local Open Scope R_scope.

Lemma Req_EM_T (r1 r2 : R) : {r1 = r2} + {r1 <> r2}.
Proof.
case: (total_order_T r1 r2) => [[r1Lr2 | <-] | r1Gr2].
- by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {2}r1Er2.
- by left.
by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {1}r1Er2.
Qed.

Definition eqr (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 is left _ then true else false.

Lemma eqrP : Equality.axiom eqr.
Proof.
by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP).
Qed.

Canonical Structure R_eqMixin := EqMixin eqrP.
Canonical Structure R_eqType := Eval hnf in EqType R R_eqMixin.

Fact inhR : inhabited R.
Proof. exact: (inhabits 0). Qed.

Definition pickR (P : pred R) (n : nat) :=
  let x := epsilon inhR P in if P x then Some x else None.

Fact pickR_some P n x : pickR P n = Some x -> P x.
Proof. by rewrite /pickR; case: (boolP (P _)) => // Px [<-]. Qed.

Fact pickR_ex (P : pred R) :
  (exists x : R, P x) -> exists n, pickR P n.
Proof. by rewrite /pickR; move=> /(epsilon_spec inhR)->; exists 0%N. Qed.

Fact pickR_ext (P Q : pred R) : P =1 Q -> pickR P =1 pickR Q.
Proof.
move=> PEQ n; rewrite /pickR; set u := epsilon _ _; set v := epsilon _ _.
suff->: u = v by rewrite PEQ.
by congr epsilon; apply: functional_extensionality=> x; rewrite PEQ.
Qed.

Definition R_choiceMixin : choiceMixin R :=
  Choice.Mixin pickR_some pickR_ex pickR_ext.

Canonical R_choiceType := Eval hnf in ChoiceType R R_choiceMixin.

Fact RplusA : associative (Rplus).
Proof. by move=> *; rewrite Rplus_assoc. Qed.

Definition R_zmodMixin := ZmodMixin RplusA Rplus_comm Rplus_0_l Rplus_opp_l.

Canonical Structure R_zmodType := Eval hnf in ZmodType R R_zmodMixin.

Fact RmultA : associative (Rmult).
Proof. by move=> *; rewrite Rmult_assoc. Qed.

Fact R1_neq_0 : R1 != R0.
Proof. by apply/eqP/R1_neq_R0. Qed.

Definition R_ringMixin := RingMixin RmultA Rmult_1_l Rmult_1_r
  Rmult_plus_distr_r Rmult_plus_distr_l R1_neq_0.

Canonical Structure R_ringType := Eval hnf in RingType R R_ringMixin.
Canonical Structure R_comRingType := Eval hnf in ComRingType R Rmult_comm.

Import Monoid.

Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r.
Canonical Radd_comoid := ComLaw Rplus_comm.

Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r.
Canonical Rmul_comoid := ComLaw Rmult_comm.

Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r.
Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.

Definition Rinvx r := if (r != 0) then / r else r.

Definition unit_R r := r != 0.

Lemma RmultRinvx : {in unit_R, left_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_l //; apply/eqP.
Qed.

Lemma RinvxRmult : {in unit_R, right_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_r //; apply/eqP.
Qed.

Lemma intro_unit_R x y : y * x = 1 /\ x * y = 1 -> unit_R x.
Proof.
move=> [yxE1 xyE1]; apply/eqP=> xZ.
by case/eqP: R1_neq_0; rewrite -yxE1 xZ Rmult_0_r.
Qed.

Lemma Rinvx_out : {in predC unit_R, Rinvx =1 id}.
Proof. by move=> x; rewrite inE /= /Rinvx -if_neg => ->. Qed.

Definition R_unitRingMixin :=
  UnitRingMixin RmultRinvx RinvxRmult intro_unit_R Rinvx_out.

Canonical Structure R_unitRing :=
  Eval hnf in UnitRingType R R_unitRingMixin.

Canonical Structure R_comUnitRingType :=
  Eval hnf in [comUnitRingType of R].

Lemma R_idomainMixin x y : x * y = 0 -> (x == 0) || (y == 0).
Proof.
(do 2 case: (boolP (_ == _))=> // /eqP)=> yNZ xNZ xyZ.
by case: (Rmult_integral_contrapositive_currified _ _ xNZ yNZ).
Qed.

Canonical Structure R_idomainType :=
   Eval hnf in IdomainType R R_idomainMixin.

Lemma R_fieldMixin : GRing.Field.mixin_of [unitRingType of R].
Proof. by done. Qed.

Definition R_fieldIdomainMixin := FieldIdomainMixin R_fieldMixin.

Canonical Structure R_fieldType := FieldType R R_fieldMixin.

(** Reflect the order on the reals to bool *)

Definition Rleb r1 r2 := if Rle_dec r1 r2 is left _ then true else false.
Definition Rltb r1 r2 := Rleb r1 r2 && (r1 != r2).
Definition Rgeb r1 r2 := Rleb r2 r1.
Definition Rgtb r1 r2 := Rltb r2 r1.

Lemma RlebP r1 r2 : reflect (r1 <= r2) (Rleb r1 r2).
Proof. by rewrite /Rleb; apply: (iffP idP); case: Rle_dec. Qed.

Lemma RltbP r1 r2 : reflect (r1 < r2) (Rltb r1 r2).
Proof.
rewrite /Rltb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
- by case=> // r1Er2 /eqP[].
- by move=> _ r1Lr2; apply/eqP/Rlt_not_eq.
by move=> Nr1Lr2 r1Lr2; case: Nr1Lr2; left.
Qed.

Lemma RgebP r1 r2 : reflect (r1 >= r2) (Rgeb r1 r2).
Proof.
rewrite /Rgeb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
  by move=> r2Lr1 _; apply: Rle_ge.
by move=> Nr2Lr1 r1Gr2; case: Nr2Lr1; apply: Rge_le.
Qed.

Lemma RgtbP r1 r2 : reflect (r1 > r2) (Rgtb r1 r2).
Proof.
rewrite /Rleb; apply: (iffP idP) => r1Hr2; first by apply: Rlt_gt; apply/RltbP.
by apply/RltbP; apply: Rgt_lt.
Qed.

(*
Ltac toR := rewrite /GRing.add /GRing.opp /GRing.zero /GRing.mul /GRing.inv
  /GRing.one //=.
*)

Section ssreal_struct.

Import GRing.Theory.
Import Num.Theory.
Import Num.Def.

Local Open Scope R_scope.

Lemma Rleb_norm_add x y : Rleb (Rabs (x + y)) (Rabs x + Rabs y).
Proof. by apply/RlebP/Rabs_triang. Qed.

Lemma addr_Rgtb0 x y : Rltb 0 x -> Rltb 0 y -> Rltb 0 (x + y).
Proof. by move/RltbP=> Hx /RltbP Hy; apply/RltbP/Rplus_lt_0_compat. Qed.

Lemma Rnorm0_eq0 x : Rabs x = 0 -> x = 0.
Proof. by move=> H; case: (x == 0) /eqP=> // /Rabs_no_R0. Qed.

Lemma Rleb_leVge x y : Rleb 0 x -> Rleb 0 y -> (Rleb x y) || (Rleb y x).
Proof.
move/RlebP=> Hx /RlebP Hy; case: (Rlt_le_dec x y).
by move/Rlt_le/RlebP=> ->.
by move/RlebP=> ->; rewrite orbT.
Qed.

Lemma RnormM : {morph Rabs : x y / x * y}.
exact: Rabs_mult. Qed.

Lemma Rleb_def x y : (Rleb x y) = (Rabs (y - x) == y - x).
apply/(sameP (RlebP x y))/(iffP idP)=> [/eqP H| /Rle_minus H].
  apply: Rminus_le; rewrite -Ropp_minus_distr.
  apply/Rge_le/Ropp_0_le_ge_contravar.
  by rewrite -H; apply: Rabs_pos.
apply/eqP/Rabs_pos_eq.
rewrite -Ropp_minus_distr.
by apply/Ropp_0_ge_le_contravar/Rle_ge.
Qed.

Lemma Rltb_def x y : (Rltb x y) = (y != x) && (Rleb x y).
apply/(sameP (RltbP x y))/(iffP idP).
  case/andP=> /eqP H /RlebP/Rle_not_gt H2.
  by case: (Rtotal_order x y)=> // [][] // /esym.
move=> H; apply/andP; split; [apply/eqP|apply/RlebP].
  exact: Rgt_not_eq.
exact: Rlt_le.
Qed.

Definition R_numMixin := NumMixin Rleb_norm_add addr_Rgtb0 Rnorm0_eq0
Rleb_leVge RnormM Rleb_def Rltb_def.
Canonical Structure R_numDomainType := NumDomainType R R_numMixin.

Lemma RleP : forall x y, reflect (Rle x y) (Num.le x y).
Proof. exact: RlebP. Qed.

Lemma RltP : forall x y, reflect (Rlt x y) (Num.lt x y).
Proof. exact: RltbP. Qed.

Canonical Structure R_numFieldType := [numFieldType of R].

Lemma Rreal_axiom (x : R) : (Rleb 0 x) || (Rleb x 0).
Proof.
case: (Rle_dec 0 x)=> [/RlebP ->|] //.
by move/Rnot_le_lt/Rlt_le/RlebP=> ->; rewrite orbT.
Qed.

Canonical Structure R_realDomainType := RealDomainType R Rreal_axiom.
Canonical Structure R_realFieldType := [realFieldType of R].

Lemma Rarchimedean_axiom : Num.archimedean_axiom R_numDomainType.
Proof.
move=> x; exists (Zabs_nat (up x) + 2)%N.
have [Hx1 Hx2]:= (archimed x).
have Hz (z : Z): z = (z - 1 + 1)%Z by rewrite Zplus_comm Zplus_minus.
have Zabs_nat_Zopp z : Zabs_nat (- z)%Z = Zabs_nat z by case: z.
apply/RltbP/Rabs_def1.
  apply: (Rlt_trans _ ((Zabs_nat (up x))%:R)%R); last first.
    rewrite -[((Zabs_nat _)%:R)%R]Rplus_0_r mulrnDr.
    by apply/Rplus_lt_compat_l/Rlt_0_2.
  apply: (Rlt_le_trans _ (IZR (up x)))=> //.
  elim/(well_founded_ind (Zwf_well_founded 0)): (up x) => z IHz.
  case: (Z_lt_le_dec 0 z) => [zp | zn].
    rewrite [z]Hz plus_IZR Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE mulrnDr.
    apply/Rplus_le_compat_r/IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_trans _ (IZR 0)); first exact: IZR_le.
  by apply/RlebP/(ler0n R_numDomainType (Zabs_nat z)).
apply: (Rlt_le_trans _ (IZR (up x) - 1)).
  apply: Ropp_lt_cancel; rewrite Ropp_involutive.
  rewrite Ropp_minus_distr /Rminus -opp_IZR -{2}(Zopp_involutive (up x)).
  elim/(well_founded_ind (Zwf_well_founded 0)): (- up x)%Z => z IHz .
  case: (Z_lt_le_dec 0 z) => [zp | zn].
  rewrite [z]Hz Zabs_nat_Zopp plus_IZR.
  rewrite Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE -Rplus_assoc -addnA [(_ + 2)%N]addnC addnA mulrnDr.
    apply: Rplus_lt_compat_r; rewrite -Zabs_nat_Zopp.
    apply: IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_lt_trans _ 1).
    rewrite -{2}[1]Rplus_0_r; apply: Rplus_le_compat_l.
    by rewrite -/(IZR 0); apply: IZR_le.
  rewrite mulrnDr; apply: (Rlt_le_trans _ 2).
    by rewrite -{1}[1]Rplus_0_r; apply/Rplus_lt_compat_l/Rlt_0_1.
  rewrite -[2]Rplus_0_l; apply: Rplus_le_compat_r.
  by apply/RlebP/(ler0n R_numDomainType (Zabs_nat _)).
apply: Rminus_le.
rewrite /Rminus Rplus_assoc [- _ + _]Rplus_comm -Rplus_assoc -!/(Rminus _ _).
exact: Rle_minus.
Qed.

Canonical Structure R_numArchiDomainType := NumArchiDomainType R Rarchimedean_axiom.
Canonical Structure R_numArchiFieldType := [numArchiFieldType of R].
Canonical Structure R_realArchiDomainType := [realArchiDomainType of R].
Canonical Structure R_realArchiFieldType := [realArchiFieldType of R].

(** Here are the lemmas that we will use to prove that R has
the rcfType structure. *)

Lemma continuity_eq f g : f =1 g -> continuity f -> continuity g.
Proof.
move=> Hfg Hf x eps Heps.
have [y [Hy1 Hy2]]:= Hf x eps Heps.
by exists y; split=> // z; rewrite -!Hfg; exact: Hy2.
Qed.

Lemma continuity_sum (I : finType) F (P : pred I):
(forall i, P i -> continuity (F i)) ->
continuity (fun x => (\sum_(i | P i) ((F i) x)))%R.
Proof.
move=> H; elim: (index_enum I)=> [|a l IHl].
  set f:= fun _ => _.
  have Hf: (fun x=> 0) =1 f by move=> x; rewrite /f big_nil.
  by apply: (continuity_eq Hf); exact: continuity_const.
set f := fun _ => _.
case Hpa: (P a).
  have Hf: (fun x => F a x + \sum_(i <- l | P i) F i x)%R =1 f.
    by move=> x; rewrite /f big_cons Hpa.
  apply: (continuity_eq Hf); apply: continuity_plus=> //.
  exact: H.
have Hf: (fun x => \sum_(i <- l | P i) F i x)%R =1 f.
  by move=> x; rewrite /f big_cons Hpa.
exact: (continuity_eq Hf).
Qed.

Lemma continuity_exp f n: continuity f -> continuity (fun x => (f x)^+ n)%R.
Proof.
move=> Hf; elim: n=> [|n IHn]; first exact: continuity_const.
set g:= fun _ => _.
have Hg: (fun x=> f x * f x ^+ n)%R =1 g.
  by move=> x; rewrite /g exprS.
by apply: (continuity_eq Hg); exact: continuity_mult.
Qed.

Lemma Rreal_closed_axiom : Num.real_closed_axiom R_numDomainType.
Proof.
move=> p a b; rewrite !ler_eqVlt.
case Hpa: ((p.[a])%R == 0%R).
  by move=> ? _ ; exists a=> //; rewrite lerr ler_eqVlt.
case Hpb: ((p.[b])%R == 0%R).
  by move=> ? _; exists b=> //; rewrite lerr ler_eqVlt andbT.
case Hab: (a == b).
  by move=> _; rewrite (eqP Hab) eq_sym Hpb (ltrNge 0) /=; case/andP=> /ltrW ->.
rewrite eq_sym Hpb /=; clear=> /RltbP Hab /andP [] /RltbP Hpa /RltbP Hpb.
suff Hcp: continuity (fun x => (p.[x])%R).
  have [z [[Hza Hzb] /eqP Hz2]]:= IVT _ a b Hcp Hab Hpa Hpb.
  by exists z=> //; apply/andP; split; apply/RlebP.
rewrite -[p]coefK poly_def.
set f := fun _ => _.
have Hf: (fun (x : R) => \sum_(i < size p) (p`_i * x^+i))%R =1 f.
  move=> x; rewrite /f horner_sum.
  by apply: eq_bigr=> i _; rewrite hornerZ hornerXn.
apply: (continuity_eq Hf); apply: continuity_sum=> i _.
apply:continuity_scal; apply: continuity_exp=> x esp Hesp.
by exists esp; split=> // y [].
Qed.

Canonical Structure R_rcfType := RcfType R Rreal_closed_axiom.
Canonical Structure R_realClosedArchiFieldType := [realClosedArchiFieldType of R].

(* proprietes utiles de l'exp *)

Open Scope ring_scope.

Lemma expR0 :
    exp(GRing.zero R_zmodType) = 1.
Proof. by rewrite exp_0. Qed.

Lemma expRD x y :
    exp(x) * exp(y) = exp(GRing.add x y).
Proof. by rewrite exp_plus. Qed.

Lemma expRX x :
  forall n : nat,
    exp(x) ^+ n = exp(x *+ n).
Proof.
elim => [|n Ihn].
  by rewrite expr0 mulr0n exp_0.
by rewrite exprS Ihn mulrS expRD.
Qed.

 Lemma Rplus_add x y :
  Rplus x y = GRing.add x y.
Proof. by done. Qed.

Lemma Rmult_mul x y :
  Rmult x y = GRing.mul x y.
Proof. by done. Qed.

Lemma Ropp_opp x :
  Ropp x = GRing.opp x.
Proof. by done. Qed.

Lemma Rdiv_div x y :
  y != 0 -> Rdiv x y = x / y.
Proof.
move=> Hneq0.
apply: (@mulIr _ y).
  by rewrite unitfE.
rewrite -!mulrA.
rewrite mulVr;
  last by rewrite unitfE.
rewrite -[X in _*X]Rmult_mul.
rewrite Rinv_l //.
by apply: (elimN eqP Hneq0).
Qed.

Lemma sin_add x y :
   sin (GRing.add x y) = sin x * cos y + cos x * sin y.
Proof. by rewrite sin_plus. Qed.

Lemma cos_add x y :
   cos (GRing.add x y) = (cos x * cos y - sin x * sin y).
Proof. by rewrite cos_plus. Qed.

End ssreal_struct.