From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.

Import List ListNotations.

From vcfloat Require Import FPLang FPLangOpt RAux Rounding Reify Float_notations Automate.
Set Bullet Behavior "Strict Subproofs".

Section WITHNANS.
Context {NANS: Nans}.

Definition sum {A: Type} (sum_op : A -> A -> A) (a b : A) : A := sum_op a b.

Inductive sum_rel {A : Type} (default: A) (sum_op : A -> A -> A) : list A -> A -> Prop :=
| sum_rel_nil  : sum_rel default sum_op [] default
| sum_rel_cons : forall l a s,
    sum_rel default sum_op l s ->
    sum_rel default sum_op (a::l) (sum sum_op a s).

Definition sum_rel_F := @sum_rel (ftype Tsingle) 0%F32 (BPLUS Tsingle).
Definition sum_rel_R := @sum_rel R 0%R Rplus.

Definition _a := 1%positive. (* current element *)
Definition _b := 2%positive. (* accumulator *)

Definition vmap_list ty (a b : ftype ty) :=
   [(_a, existT ftype _ a); (_b, existT ftype _ b)].

Definition vmap {ty} (a b : ftype ty) : valmap :=
 ltac:(let z := compute_PTree (valmap_of_list (vmap_list ty a b)) in exact z).

Definition bmap_list {ty} : list varinfo :=
  let ov := powerRZ 2 (femax ty) in
  [ Build_varinfo Tsingle _a (-ov) ov;
    Build_varinfo Tsingle _b (-ov) ov ].

Definition bmap {ty} : boundsmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list (@bmap_list ty ) ) in exact z).

Definition sum_expr {ty} (a b : ftype ty) := ltac :( let e' :=
  HO_reify_float_expr constr:([_a; _b]) (BPLUS ty) in exact e').

Require Import Interval.Tactic.

Lemma real_lt_1 :
forall a b c,
a <= b -> b < c -> a < c.
Proof. intros; apply Rle_lt_trans with b; auto. Qed.

Lemma bnd_lt_overflow n :
  (2 <= n )%nat ->
  let e  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let d := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  let ov := powerRZ 2 (femax Tsingle) in
  let bnd := (ov - (INR n - 1) * 2 * e * (1 + d) ^ (n - 2)) /
       ((INR n - 1) * d * (1 + d) ^ (n - 2) + 1)  in
bnd * (1 + d) + e < 0x1p128%xR.
Proof.
intros.
subst bnd.
rewrite <- Rcomplements.Rlt_minus_r.
replace (0x1p128%xR) with ov by (subst ov; simpl; nra).
match goal with |- context [?a / ?b * ?c] =>
replace (a/b  *c) with ((a  *c) / b)
end.
assert (Hn: 1 <= INR n - 1).
assert (Hn2: INR 2 <= INR n); try apply le_INR; auto.
eapply Rle_trans; [  | apply  Rplus_le_compat; [ apply Hn2| apply Rle_refl]]; try simpl; nra.
assert (Hd: 1 <= (1 + d) ^ (n - 2)).
assert (H1: 1 = (1 + d) ^ 0) by nra.
eapply Rle_trans; [ rewrite H1  | apply Rle_refl]; apply Rle_pow;
  subst d; simpl; try nra; try lia.
apply Rdiv_lt_left.
eapply Rlt_le_trans; [ idtac | apply  Rplus_le_compat;
    [apply  Rmult_le_compat ; [| | apply Rmult_le_compat |]| apply Rle_refl]];
   try apply Hn; try apply Hd; try nra; try rewrite Rmult_1_l; try rewrite Rmult_0_l;
   try apply Rle_refl; try subst d; try simpl; nra.
set (A:= (INR n - 1) * (1 + d) ^ (n - 2)).
assert (HA: 1 <= A).
subst A.
eapply Rle_trans; [ idtac | apply  Rmult_le_compat];
   try apply Hn; try apply Hd; try nra.
replace ((INR n - 1) * d * (1 + d) ^ (n - 2)) with (A * d) by (subst A; nra).
replace ((INR n - 1) * 2 * e * (1 + d) ^ (n - 2)) with (A * 2 * e) by (subst A; nra).
replace ((ov - A * 2 * e) * (1 + d)) with (ov + (- 2 * A * e * d + ov * d - 2 * A * e )) by nra.
replace ((ov - e) * (A * d + 1)) with (ov + (- A * e * d + ov * A * d - e )) by nra.
apply Rplus_lt_compat_l.
apply Rplus_lt_compat.
apply Rplus_lt_le_compat.
assert (lem: forall a b c,
  0 < c -> a < b -> a * c < b * c) by (intros;nra).
repeat apply lem; try subst d; try simpl; try nra;
  try subst e; try simpl; try nra;
  try subst A; try simpl;
  try apply Hneg.
rewrite Rmult_assoc.
eapply Rle_trans; [ | apply Rmult_le_compat_l; [ subst ov; simpl; nra|
  apply Rmult_le_compat_r; [ subst d; simpl; nra | apply HA ]]]; nra.
apply Ropp_lt_contravar.
rewrite Rmult_comm.
eapply Rle_lt_trans with (e * 1); try nra.
apply Rmult_lt_compat_l; try subst e; simpl; try nra.
nra.
Qed.

Lemma prove_rndoff' :
  forall (a b : ftype Tsingle) vmap n,
  (2 <= n )%nat ->
  let e  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let d := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  let ov := powerRZ 2 (femax Tsingle) in
  let bnd := (ov - (INR n - 1) * 2 * e * (1 + d) ^ (n - 2)) /
       ((INR n - 1) * d * (1 + d) ^ (n - 2) + 1)  in
  - (bnd * (INR n - 1) / INR n) <= FT2R b <= bnd * (INR n - 1) / INR n ->
  - (bnd * / INR n) <= FT2R a <= bnd * / INR n ->
  prove_roundoff_bound (@bmap Tsingle) (vmap a b) (@sum_expr Tsingle a b)
     (Rabs ( FT2R a + FT2R b) * d + e).
Proof.
intros ? ?  ?  ? ? ? ? ? ? ?bnd1 ?bnd2.
prove_roundoff_bound.
-
prove_rndval.
clear BOUND BOUND0.
(* prove_rndval SHOULD SUBST V_A  & V_B ABOVE THE LINE *)
assert (Ha : FT2R v_a = FT2R a) by admit.
assert (Hb : FT2R v_b = FT2R b) by admit.
rewrite Ha, Hb; clear Ha Hb.
simpl in e; simpl in d.
assert (Rabs (1 + u0) <= 1 + d) as Hu2.
{ subst e; eapply Rle_trans;
 [apply Rabs_triang | eapply Rplus_le_compat;
                                      [ rewrite Rabs_R1; apply Rle_refl | apply H1 ]]. }
apply Rlt_Rminus.
rewrite Rmult_1_l.
try apply Rabs_le in bnd1, bnd2.
eapply real_lt_1; [eapply Rabs_triang |
    rewrite Rabs_mult; eapply real_lt_1; [ eapply Rplus_le_compat;
          [eapply Rmult_le_compat; try apply Rabs_pos;
                      [eapply Rle_trans; [apply Rabs_triang | eapply Rplus_le_compat;
                                      [apply bnd2| apply bnd1]]
                          | eapply Rle_trans; [ apply Hu2 | apply Rle_refl] ] | apply H0 ] | ]].
replace (bnd * / INR n + bnd * (INR n - 1) / INR n) with bnd.
apply Rle_lt_trans with (bnd * (1+d) + e).
  apply Rplus_le_compat; [apply Rle_refl| subst e; simpl; nra].
apply bnd_lt_overflow; auto.
field.
apply not_0_INR; try lia.
-
prove_roundoff_bound2.
clear BOUND BOUND0.
(* prove_roundoff_bound2 SHOULD SUBST V_A  & V_B IN
  RHS *)
assert (Ha : v_a = a) by admit.
assert (Hb : v_b = b) by admit.
rewrite Ha, Hb; clear Ha Hb.
try apply Rabs_le in bnd1, bnd2.
match goal with |- context[Rabs ?a <= _] =>
field_simplify a
end.
assert (He0: Rabs e1 <= e).
{ eapply Rle_trans. apply E. subst e; simpl; nra. }
assert (Hd: Rabs d0 <= d).
{ eapply Rle_trans. apply E0. subst d; simpl; nra. }
replace (a * d0 + b * d0 + e1) with ((a + b) * d0 + e1) by nra.
eapply Rle_trans; [
apply Rabs_triang | eapply Rle_trans; [apply Rplus_le_compat; [rewrite Rabs_mult; eapply Rle_trans;
  [apply Rmult_le_compat;
      [ apply Rabs_pos | apply Rabs_pos |   apply Rle_refl | apply Hd ] |
  apply Rle_refl ]  | apply He0 ] | ]  ].
nra.
Admitted.

End WITHNANS.

Lemma reflect_reify_sumF :
  forall a b,
  fval (env_ (vmap a b)) (@sum_expr Tsingle a b) = sum Tsingle a b .
Proof. reflexivity. Qed.

Lemma reflect_reify_sumR :
  forall a b,
  rval (env_ (vmap a b)) (@sum_expr Tsingle a b) = FT2R a + FT2R b .
Proof. reflexivity. Qed.

Lemma prove_rndoff:
  forall (a b : ftype Tsingle) (n : nat),
  let ty:= Tsingle in let nr := INR n in
( 1 <= n)%nat ->
  let u  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let u0 := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
boundsmap_denote (@bmap Tsingle n) (vmap a b)  ->
   Rabs (FT2R (sum Tsingle a b) - (FT2R a + FT2R b)) <=
     ( Rabs ( FT2R a + FT2R b ) * u0 + u) .
Proof.
intros ? ? ? ? ? Hn ? ? HBMD.
pose proof prove_rndoff' a b  vmap  n Hn HBMD.
unfold roundoff_error_bound in H.
rewrite <- reflect_reify_sumR.
rewrite <- reflect_reify_sumF.
destruct H as (H1 & H2); eapply Rle_trans; [apply H2| subst u0 u; nra].
Qed.

Definition Flist_to_Rlist {ty} (L : list ( ftype ty)) :=
  map (fun a => (FT2R a)) L.

Definition Flist_to_Rlist_abs {ty} (L : list ( ftype ty)) :=
  map (fun a => Rabs (FT2R a)) L.

Lemma Rabs_list_rel {ty} (L : list ( ftype ty)):
  Rabs (sum_fixR (Flist_to_Rlist L)) <= sum_fixR (Flist_to_Rlist_abs L).
Proof.
induction L.
+ simpl. rewrite Rabs_R0. nra.
+ simpl.
  apply Rle_trans with
  (Rabs (FT2R a) + Rabs (sum_fixR (Flist_to_Rlist L))).
  apply Rabs_triang.
  apply Rplus_le_compat; nra.
Qed.

Definition default_val : ftype Tsingle := 0%F32.

Lemma sum_lt_overflow :
  forall (L1 : list (ftype Tsingle)),
FT2R (hd default_val L1) <= (@strict_overflow_bnd Tsingle ) / INR (length L1) ->
FT2R  (sum_fixF Tsingle (tl L1)) <= (@strict_overflow_bnd Tsingle ) * INR (length L1 - 1) / INR (length L1) ->
FT2R (sum_fixF Tsingle L1) <= (@strict_overflow_bnd Tsingle ).
Proof.
destruct L1.
-simpl.
intros.
unfold strict_overflow_bnd.
simpl; nra.
-
intros.
simpl.
set (b:= (sum_fixF Tsingle L1)) in *.
pose proof prove_rndoff f b (length (f::L1)).
Admitted.

Lemma prove_rndoff_n_sum_aux :
  forall (L1 : list (ftype Tsingle)) ,
  let n:= length L1 in
  (1 <= n )%nat ->
  let u  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let u0 := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  (forall a, In a L1 -> Rabs (FT2R a) <= (@strict_overflow_bnd Tsingle ) / INR (length L1))->
  Rabs (FT2R (sum_fixF Tsingle L1) - sum_fixR (Flist_to_Rlist L1)) <=
      (sum_fixR (Flist_to_Rlist_abs L1)) * ((1 + u0)^n - 1) +
      u * ((1 + u0)^n - 1) / u0.
Proof.
intros.
induction L1.
+ simpl. rewrite Rminus_0_r. rewrite Rabs_R0.
  assert ((1 - 1) = 0). { nra. } rewrite H1. nra.
+ simpl in IHL1.
  remember (length L1) as m.
  assert (n = (m+1)%nat). { unfold n. simpl. rewrite Heqm. lia. }
  assert (L1 = [:: ] \/ L1 <> [::]).
  { destruct L1.
    + by left.
    + by right.
  } destruct H2.
  - rewrite H2. simpl. rewrite !Rplus_0_r.
    assert (length L1 = 0%nat).
    { rewrite H2 //=. } rewrite H3 //=.
    pose proof (prove_rndoff a 0%F32 2%nat).
    simpl in H4.
    assert ((1 <= 2)%nat). { lia. } specialize (H4 H5).
    assert (boundsmap_denote (@bmap Tsingle 2) (vmap a 0%F32)).
    { admit. } specialize (H4 H6).
    rewrite Rplus_0_r in H4.
    apply Rle_trans with
    (Rabs (FT2R a) * (/ 2 * / IZR (Z.pow_pos 2 23)) +
     / 2 * / IZR (Z.pow_pos 2 149)).
    * apply H4.
    * apply Rplus_le_compat.
      ++ apply Rmult_le_compat_l.
         -- apply Rabs_pos.
         -- unfold u0. simpl. nra.
      ++ unfold u, u0. simpl. nra.
  - simpl.
    assert ((1 <= m)%nat).
    { rewrite Heqm. destruct L1.
      + by contradict H2.
      + simpl. lia.
    } specialize (IHL1 H3).
    assert (forall a : ftype Tsingle,
              In a L1 ->
              Rabs (FT2R a) <= @strict_overflow_bnd Tsingle / INR m).
    { intros. specialize (H0 a0).
      assert (In a0 (a :: L1)).
      { simpl. by right. } apply H0 in H5.
      apply Rle_trans with
      (@strict_overflow_bnd Tsingle / INR (length (a :: L1))).
      + apply H5.
      + apply Rmult_le_compat_l.
        - apply overflow_pos.
        - simpl. destruct (length L1).
          * rewrite Heqm in H3. contradict H3. lia.
          * apply Rlt_le. apply Rinv_1_lt_contravar.
            ++ assert (1 = INR 1). { reflexivity. } rewrite H6.
               apply le_INR. lia.
            ++ rewrite Heqm. nra.
    } specialize (IHL1 H4).
    rewrite -Heqm.
    apply Rle_trans with
       (Rabs(FT2R (sum Tsingle a (sum_fixF Tsingle L1)) -
                (FT2R a + FT2R (sum_fixF Tsingle L1))) +
        Rabs ((FT2R a + FT2R (sum_fixF Tsingle L1)) -
               (FT2R a + sum_fixR (Flist_to_Rlist L1)))).
    -- assert ((FT2R (sum Tsingle a (sum_fixF Tsingle L1)) -
                    (FT2R a + sum_fixR (Flist_to_Rlist L1))) =
                  (FT2R (sum Tsingle a (sum_fixF Tsingle L1)) -
                    (FT2R a + FT2R (sum_fixF Tsingle L1))) +
                  ((FT2R a + FT2R (sum_fixF Tsingle L1)) -
                   (FT2R a + sum_fixR (Flist_to_Rlist L1)))).
       { nra. } rewrite H5. apply Rabs_triang.
    -- pose proof (prove_rndoff a (sum_fixF Tsingle L1) n).
       specialize (H5 H). simpl in H5.
       assert (boundsmap_denote (@bmap Tsingle n)
                      (vmap a (sum_fixF Tsingle L1))).
       { admit. } specialize (H5 H6).
       apply Rle_trans with
       ( (Rabs (FT2R a + FT2R (sum_fixF Tsingle L1)) *
           (/ 2 * / IZR (Z.pow_pos 2 23)) +
           / 2 * / IZR (Z.pow_pos 2 149)) +
         ( sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
             u * ((1 + u0) ^ m - 1) / u0)).
       ** apply Rplus_le_compat.
          ++ apply H5.
          ++ assert ((FT2R a + FT2R (sum_fixF Tsingle L1) -
                        (FT2R a + sum_fixR (Flist_to_Rlist L1))) =
                      FT2R (sum_fixF Tsingle L1) -
                      sum_fixR (Flist_to_Rlist L1)).
             { nra. } rewrite H7. apply IHL1.
       ** apply Rle_trans with
          ((Rabs (FT2R a) + Rabs (FT2R (sum_fixF Tsingle L1))) *
            (/ 2 * / IZR (Z.pow_pos 2 23)) +
            / 2 * / IZR (Z.pow_pos 2 149) +
            (sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
             u * ((1 + u0) ^ m - 1) / u0)).
          ++ repeat apply Rplus_le_compat. apply Rmult_le_compat_r.
             nra. apply Rabs_triang. nra. nra. nra.
          ++ assert (Rabs (FT2R (sum_fixF Tsingle L1)) -
                     Rabs (sum_fixR (Flist_to_Rlist L1)) <=
                     sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                      u * ((1 + u0) ^ m - 1) / u0).
             { apply Rle_trans with (Rabs
                             (FT2R (sum_fixF Tsingle L1) -
                              sum_fixR (Flist_to_Rlist L1))).
               apply Rabs_triang_inv. nra.
             }
             assert (Rabs (FT2R (sum_fixF Tsingle L1)) <=
                          Rabs (sum_fixR (Flist_to_Rlist L1)) +
                          sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                          u * ((1 + u0) ^ m - 1) / u0).
             { nra. }
             assert (Rabs (FT2R (sum_fixF Tsingle L1)) <=
                     sum_fixR (Flist_to_Rlist_abs L1) +
                     sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                      u * ((1 + u0) ^ m - 1) / u0).
             { apply Rle_trans with
                (Rabs (sum_fixR (Flist_to_Rlist L1)) +
                   sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                   u * ((1 + u0) ^ m - 1) / u0).
               + nra.
               + repeat apply Rplus_le_compat_r. apply Rabs_list_rel.
             }
             apply Rle_trans with
             ((Rabs (FT2R a) +
               (sum_fixR (Flist_to_Rlist_abs L1) +
                     sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                     u * ((1 + u0) ^ m - 1) / u0))*
                (/ 2 * / IZR (Z.pow_pos 2 23)) +
                / 2 * / IZR (Z.pow_pos 2 149) +
                (sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                 u * ((1 + u0) ^ m - 1) / u0)).
              --- repeat apply Rplus_le_compat_r. apply Rmult_le_compat_r; nra.
              --- assert ((Rabs (FT2R a) +
                           (sum_fixR (Flist_to_Rlist_abs L1) +
                            sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                            u * ((1 + u0) ^ m - 1) / u0)) *
                          (/ 2 * / IZR (Z.pow_pos 2 23)) +
                          / 2 * / IZR (Z.pow_pos 2 149) +
                          (sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) ^ m - 1) +
                           u * ((1 + u0) ^ m - 1) / u0) =
                          (Rabs (FT2R a) * (/ 2 * / IZR (Z.pow_pos 2 23))) +
                          (sum_fixR (Flist_to_Rlist_abs L1) *
                            ((/ 2 * / IZR (Z.pow_pos 2 23)) +
                              (/ 2 * / IZR (Z.pow_pos 2 23)) * ((1 + u0) ^ m - 1)+
                              ((1 + u0) ^ m - 1)) +
                           (((/ 2 * / IZR (Z.pow_pos 2 149)) +  u * ((1 + u0) ^ m - 1) / u0) +
                             (/ 2 * / IZR (Z.pow_pos 2 23)) * (u * ((1 + u0) ^ m - 1) / u0)))).
                  { nra. } rewrite H10. clear H10.
                  assert ((Rabs (FT2R a) + sum_fixR (Flist_to_Rlist_abs L1)) *
                            ((1 + u0) * (1 + u0) ^ m - 1) +
                            u * ((1 + u0) * (1 + u0) ^ m - 1) / u0 =
                          (Rabs (FT2R a) * ((1 + u0) * (1 + u0) ^ m - 1)) +
                          (sum_fixR (Flist_to_Rlist_abs L1) * ((1 + u0) * (1 + u0) ^ m - 1) +
                           u * ((1 + u0) * (1 + u0) ^ m - 1) / u0)).
                  { nra. } rewrite H10. clear H10.
                  repeat apply Rplus_le_compat.
                  *** apply Rmult_le_compat_l.
                      apply Rabs_pos.
                      simpl in u, u0. rewrite -/u -/u0.
                      apply u_bound. unfold u0. nra.
                  *** apply Rmult_le_compat_l.
                      ---- apply sum_abs_ge_0.
                      ---- simpl in u, u0. rewrite /u /u0.  nra.
                  *** simpl in u, u0. rewrite /u /u0. nra.
Admitted.

Lemma pow_rel:
  forall (x:R) (n:nat),
  (1 + x) ^ n - 1 <= INR n * x / (1 - x).
Admitted.

Lemma prove_rndoff_n_sum :
  forall (L1 : list (ftype Tsingle)) ,
  let n:= length L1 in
  (1 <= n )%nat ->
  let u  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let u0 := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  (forall a, In a L1 -> Rabs (FT2R a) <= (@strict_overflow_bnd Tsingle ) / INR (length L1))->
  Rabs (FT2R (sum_fixF Tsingle L1) - sum_fixR (Flist_to_Rlist L1)) <=
      (INR n * u0 / (1 - u0)) * ((sum_fixR (Flist_to_Rlist_abs L1))) +
      (INR n * u / (1 - u0)).
Proof.
intros.
apply Rle_trans with
((sum_fixR (Flist_to_Rlist_abs L1)) * ((1 + u0)^n - 1) +
      u * ((1 + u0)^n - 1) / u0).
+ apply prove_rndoff_n_sum_aux. by rewrite -/n. apply H0.
+ apply Rplus_le_compat.
  - rewrite Rmult_comm. apply Rmult_le_compat_r.
    apply sum_abs_ge_0. apply pow_rel.
  - assert (u * ((1 + u0) ^ n - 1) / u0 =
            ((1 + u0) ^ n - 1) * (u / u0)).
    { nra. } rewrite H1.
    assert (INR n * u / (1 - u0)  =
            (INR n * u0 / (1 - u0)) * (u / u0)).
    { rewrite /u /u0. simpl. nra. } rewrite H2.
    apply Rmult_le_compat_r.
    * rewrite /u /u0. simpl. nra.
    * apply pow_rel.
Qed.

Lemma x_pow: forall (x:R) (n:nat),
  0 <= x ->
  0 <= x^n.
Proof.
intros.
induction n.
+ simpl. nra.
+ simpl. apply Rmult_le_pos; nra.
Qed.

Lemma x_pow_minus_1: forall (x:R) (n:nat),
  1 <= x ->
  0 <= x^n - 1.
Proof.
intros.
induction n.
+ simpl. nra.
+ simpl.
  assert (x * x ^ n - 1 = x * (x^n - 1) + (x - 1)).
  { nra. } rewrite H0.
  apply Rplus_le_le_0_compat.
  - apply Rmult_le_pos. nra. nra.
  - nra.
Qed.

Definition Flist_to_Rlist_pair {ty} (L : list ( (ftype ty) * (ftype ty))) :=
  map (fun a => (FT2R (fst a), FT2R (snd a))) L.

Definition Flist_to_Rlist_pair_abs {ty} (L : list ( (ftype ty) * (ftype ty))) :=
  map (fun a => (Rabs (FT2R (fst a)), Rabs (FT2R (snd a)))) L.

Lemma x_bound_S:
  forall (x:R) (m:nat),
  0 < x ->
  x * x + 2 * x <= (1 + x) * (1 + x) ^ (m + 1) - 1.
Proof.
intros.
induction m.
+ simpl. nra.
+ apply Rle_trans with ((1 + x) * (1 + x) ^ (m + 1) - 1).
  - apply IHm.
  - apply Rplus_le_compat_r.
    assert ((1 + x) * (1 + x) ^ (m + 1) =
             1* ((1 + x) * (1 + x) ^ (m + 1))).
    { nra. } rewrite H0.
    assert ((1 + x) * (1 + x) ^ (S m + 1) =
             (1+x) * ((1 + x) * (1 + x) ^ (m + 1))).
    { simpl. nra. } rewrite H1. apply Rmult_le_compat_r.
    nra. nra.
Qed.

Lemma sum_abs_pair_rel:
  forall (L: list ((ftype Tsingle) * (ftype Tsingle))),
  0 <= sum_fixR (prod_fixR (Flist_to_Rlist_pair_abs L)).
Proof.
intros.
induction L.
+ simpl. nra.
+ simpl.
  apply Rplus_le_le_0_compat.
  apply Rmult_le_pos; apply Rabs_pos.
  apply IHL.
Qed.

Lemma sum_abs_pair_le:
forall (L: list ((ftype Tsingle) * (ftype Tsingle))),
Rabs (dot_prodR (Flist_to_Rlist_pair L)) <=
dot_prodR (Flist_to_Rlist_pair_abs L).
Proof.
intros.
induction L.
+ simpl. unfold dot_prodR. simpl.
  rewrite Rabs_R0. nra.
+ simpl. unfold dot_prodR. simpl.
  apply Rle_trans with
  (Rabs (FT2R (fst a) * FT2R (snd a)) +
   Rabs (dot_prodR (Flist_to_Rlist_pair L))).
  - apply Rabs_triang.
  - apply Rplus_le_compat. rewrite Rabs_mult. nra.
    apply IHL.
Qed.

Lemma forward_error_dot_aux:
  forall (L: list ((ftype Tsingle) * (ftype Tsingle))),
  let ty := Tsingle in
  let n:= length L in
  let nr := INR n in
  (1 <= n)%nat ->
  let u  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let u0 := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  Rabs (FT2R (dot_prodF _ L) - dot_prodR (Flist_to_Rlist_pair L)) <=
  (dot_prodR (Flist_to_Rlist_pair_abs L)) * ((1 + u0)^(n+1) -1) +
  nr * u * (1+u0)^n + u * ((1+u0)^n -1) / u0.
Proof.
intros.
induction L.
+ simpl. unfold dot_prodR. simpl.
  rewrite Rminus_0_r.
  assert ((1 - 1) = 0). { nra. } rewrite H0.
  rewrite !Rmult_0_r. rewrite Rabs_R0.
  assert (0 * ((1 + u0) * 1 - 1) + nr * u * 1 + 0 / u0 =
          nr * u).
  { nra. } rewrite H1.
  apply Rmult_le_pos.
  - unfold nr. apply pos_INR.
  - unfold u. simpl. nra.
+ unfold dot_prodF, dot_prodR. simpl.
  remember (length L) as m.
  assert (n = (m+1)%nat). { unfold n. simpl. rewrite Heqm. lia. }
  assert (L = [:: ] \/ L <> [::]).
    { destruct L.
      + by left.
      + by right.
    } destruct H1.
    - rewrite H1. simpl.
      remember (fst a) as b1.
      remember (snd a) as b2. rewrite Rplus_0_r.
      assert ( length L = 0%nat).
      { rewrite H1. by simpl. } rewrite H2 in Heqm.
      rewrite Heqm //=.  simpl.
      pose proof (prove_rndoff (prod Tsingle b1 b2)
                  (Binary.B754_zero (fprec Tsingle) 128
                         false)).
      specialize (H3 2%nat). simpl in H3.
      assert ((1 <= 2)%nat). { lia. }
      assert ( boundsmap_denote (@bmap ty 2%nat)
                  (vmap (prod Tsingle b1 b2) (Binary.B754_zero (fprec Tsingle) 128
                         false))).
      { admit. } specialize (H3 H4 H5).
      apply Rle_trans with
      (Rabs
       (FT2R
          (sum Tsingle (prod Tsingle b1 b2) (Binary.B754_zero (fprec Tsingle) 128
                         false)) -
        (FT2R (prod Tsingle b1 b2) + 0)) +
        Rabs ((FT2R (prod Tsingle b1 b2)) - FT2R b1 * FT2R b2)).
      ++ assert ((FT2R
                   (sum Tsingle (prod Tsingle b1 b2)
                      (Binary.B754_zero (fprec Tsingle) 128
                         false)) - FT2R b1 * FT2R b2) =
                  (FT2R
                      (sum Tsingle (prod Tsingle b1 b2) (Binary.B754_zero (fprec Tsingle) 128
                         false)) -
                    (FT2R (prod Tsingle b1 b2) + 0)) +
                    (((FT2R (prod Tsingle b1 b2)) - FT2R b1 * FT2R b2))).
         { simpl. nra. } rewrite H6. apply Rabs_triang.
      ++ apply Rle_trans with
          (Rabs (FT2R (prod Tsingle b1 b2) + 0) *
           (/ 2 * / IZR (Z.pow_pos 2 23)) +
           / 2 * / IZR (Z.pow_pos 2 149) +
           Rabs (FT2R (prod Tsingle b1 b2) - FT2R b1 * FT2R b2)).
          -- by apply Rplus_le_compat_r.
          -- pose proof (prove_rndoff_prod b1 b2).
             specialize (H6 2%nat).
             assert ((1 < 2)%nat). { lia. } specialize (H6 H7).
             simpl in H6.
             assert (boundsmap_denote (@bmap_prod ty  2) (vmap b1 b2)).
             { admit. } specialize (H6 H8). rewrite Rplus_0_r.
             apply Rle_trans with
             (Rabs (FT2R (prod Tsingle b1 b2)) *
                (/ 2 * / IZR (Z.pow_pos 2 23)) +
                / 2 * / IZR (Z.pow_pos 2 149) +
              ( Rabs (FT2R b1 * FT2R b2) *
                 (/ 2 * / IZR (Z.pow_pos 2 23)) +
                 / 2 * / IZR (Z.pow_pos 2 149))).
             ** by apply Rplus_le_compat_l.
             ** assert (Rabs (FT2R (prod Tsingle b1 b2)) -
                        Rabs (FT2R b1 * FT2R b2) <=
                        Rabs (FT2R b1 * FT2R b2) *
                         (/ 2 * / IZR (Z.pow_pos 2 23)) +
                         / 2 * / IZR (Z.pow_pos 2 149)).
                { apply Rle_trans with
                  (Rabs (FT2R (prod Tsingle b1 b2) -
                            FT2R b1 * FT2R b2)).
                  apply Rabs_triang_inv. nra.
                }
                assert (Rabs (FT2R (prod Tsingle b1 b2)) <=
                        Rabs (FT2R b1 * FT2R b2) +
                        Rabs (FT2R b1 * FT2R b2) *
                         (/ 2 * / IZR (Z.pow_pos 2 23)) +
                         / 2 * / IZR (Z.pow_pos 2 149)).
                { nra. }
                apply Rle_trans with
                (( Rabs (FT2R b1 * FT2R b2) +
                  Rabs (FT2R b1 * FT2R b2) *
                  (/ 2 * / IZR (Z.pow_pos 2 23)) +
                  / 2 * / IZR (Z.pow_pos 2 149)) * (/ 2 * / IZR (Z.pow_pos 2 23)) +
                  (/ 2 * / IZR (Z.pow_pos 2 149)) +
                    (Rabs (FT2R b1 * FT2R b2) *
                       (/ 2 * / IZR (Z.pow_pos 2 23)) +
                       / 2 * / IZR (Z.pow_pos 2 149)) ).
                 +++ repeat apply Rplus_le_compat_r.
                     apply Rmult_le_compat_r. nra.
                     nra.
                 +++ rewrite -/u -/u0.
                     assert ((Rabs (FT2R b1 * FT2R b2) +
                               Rabs (FT2R b1 * FT2R b2) * u0 + u) * u0 + u +
                              (Rabs (FT2R b1 * FT2R b2) * u0 + u) =
                             Rabs (FT2R b1 * FT2R b2) * (2 * u0 + u0 * u0) + u* u0 + 2 *u).
                     { nra. } rewrite H11. rewrite Rabs_mult. rewrite Rplus_0_r.
                     assert (Rabs (FT2R b1) * Rabs (FT2R b2) *
                              ((1 + u0) * ((1 + u0) * 1) - 1) +
                              nr * u * ((1 + u0) * 1) +
                              u * ((1 + u0) * 1 - 1) / u0 =
                             Rabs (FT2R b1) * Rabs (FT2R b2) *
                              ((1 + u0) * ((1 + u0) * 1) - 1) +
                              nr * u * u0 + (nr * u + u * (u0 / u0))).
                     { nra. } rewrite H12. clear H12.
                     repeat apply Rplus_le_compat.
                     --- apply Rmult_le_compat_l.
                         *** apply Rmult_le_pos; apply Rabs_pos.
                         *** nra.
                     --- apply Rmult_le_compat_r.
                         *** unfold u0. simpl. nra.
                         *** assert (u = 1 * u). { nra. } rewrite H12.
                             assert (nr * (1 * u) = nr * u). { nra. } rewrite H13.
                             apply Rmult_le_compat_r.
                             unfold u; simpl; nra.
                             unfold nr. assert (1 = INR 1). { reflexivity. }
                             rewrite H14. by apply le_INR.
                     --- assert ( u0 / u0 = 1).
                         { apply Rinv_r. unfold u0. simpl. nra. }
                         rewrite H12.
                         assert (nr * u + u * 1 = (nr + 1) * u).
                         { nra. } rewrite H13. apply Rmult_le_compat_r.
                         unfold u; simpl; nra.
                         assert (1 <= nr -> 2 <= nr + 1). { nra. }
                         apply H14. clear H14.
                         unfold nr. assert (1 = INR 1). { reflexivity. }
                         rewrite H14. by apply le_INR.
    - simpl in IHL.
      assert ((1 <= m)%nat).
      { rewrite Heqm.
        destruct L.
        + by contradict H1.
        + simpl. lia.
      } specialize (IHL H2).
      apply Rle_trans with
      (Rabs (FT2R
               (sum Tsingle (prod Tsingle (fst a) (snd a))
                  (sum_fixF Tsingle (prod_fixF Tsingle L))) -
             (FT2R (prod Tsingle (fst a) (snd a)) +
               FT2R (sum_fixF Tsingle (prod_fixF Tsingle L)))) +
       Rabs ((FT2R (prod Tsingle (fst a) (snd a)) +
               FT2R (sum_fixF Tsingle (prod_fixF Tsingle L))) -
            (FT2R (fst a) * FT2R (snd a) +
             sum_fixR (prod_fixR (Flist_to_Rlist_pair L))))).
       * assert ((FT2R
                   (sum Tsingle (prod Tsingle (fst a) (snd a))
                      (sum_fixF Tsingle (prod_fixF Tsingle L))) -
                 (FT2R (fst a) * FT2R (snd a) +
                  sum_fixR (prod_fixR (Flist_to_Rlist_pair L)))) =
                 (FT2R
                 (sum Tsingle (prod Tsingle (fst a) (snd a))
                    (sum_fixF Tsingle (prod_fixF Tsingle L))) -
                 (FT2R (prod Tsingle (fst a) (snd a)) +
                   FT2R (sum_fixF Tsingle (prod_fixF Tsingle L)))) +
                  ((FT2R (prod Tsingle (fst a) (snd a)) +
                   FT2R (sum_fixF Tsingle (prod_fixF Tsingle L))) -
                  (FT2R (fst a) * FT2R (snd a) +
                   sum_fixR (prod_fixR (Flist_to_Rlist_pair L))))).
         { nra. } rewrite H3. clear H3.
         apply Rabs_triang.
       * pose proof (prove_rndoff_prod (prod Tsingle (fst a) (snd a))
                      (sum_fixF Tsingle (prod_fixF Tsingle L))).
         specialize (H3 (n+1)%nat).
         assert ((1 < n+1)%nat). { lia. } specialize (H3 H4).
         assert (boundsmap_denote (@bmap_prod ty (n + 1))
                  (vmap (prod Tsingle (fst a) (snd a))
                    (sum_fixF Tsingle (prod_fixF Tsingle L)))).
         { admit. } specialize (H3 H5).
         simpl in H3. rewrite -/u -/u0 in H3.
         pose proof (prove_rndoff (prod Tsingle (fst a) (snd a))
                        (sum_fixF Tsingle (prod_fixF Tsingle L))).
         specialize (H6 (m+1)%nat). simpl in H6.
         assert ((1 <= m + 1)%nat). { lia. } specialize (H6 H7).
         assert (boundsmap_denote (@bmap ty (m + 1))
                   (vmap (prod Tsingle (fst a) (snd a))
                      (sum_fixF Tsingle (prod_fixF Tsingle L)))).
         { admit. } specialize (H6 H8).
         rewrite -/u -/u0 in H6.
         apply Rle_trans with
         ((Rabs
               (FT2R (prod Tsingle (fst a) (snd a)) +
                FT2R (sum_fixF Tsingle (prod_fixF Tsingle L))) *
             u0 + u) + Rabs
            (FT2R (prod Tsingle (fst a) (snd a)) +
             FT2R (sum_fixF Tsingle (prod_fixF Tsingle L)) -
             (FT2R (fst a) * FT2R (snd a) +
              sum_fixR (prod_fixR (Flist_to_Rlist_pair L))))).
         ++ by apply Rplus_le_compat_r.
         ++ apply Rle_trans with
            ((Rabs
               (FT2R (prod Tsingle (fst a) (snd a)) +
                FT2R (sum_fixF Tsingle (prod_fixF Tsingle L))) *
             u0 + u) +
             (Rabs (FT2R (prod Tsingle (fst a) (snd a)) - (FT2R (fst a) * FT2R (snd a))) +
             Rabs (FT2R (sum_fixF Tsingle (prod_fixF Tsingle L)) -
                    sum_fixR (prod_fixR (Flist_to_Rlist_pair L))))).
             -- apply Rplus_le_compat_l.
                assert ((FT2R (prod Tsingle (fst a) (snd a)) +
                           FT2R (sum_fixF Tsingle (prod_fixF Tsingle L)) -
                           (FT2R (fst a) * FT2R (snd a) +
                            sum_fixR (prod_fixR (Flist_to_Rlist_pair L)))) =
                          (FT2R (prod Tsingle (fst a) (snd a)) - (FT2R (fst a) * FT2R (snd a))) +
                          (FT2R (sum_fixF Tsingle (prod_fixF Tsingle L)) -
                              sum_fixR (prod_fixR (Flist_to_Rlist_pair L)))).
                { nra. } rewrite H9. apply Rabs_triang.
             -- remember (fst a) as b1.
                remember (snd a) as b2.
                pose proof (prove_rndoff_prod b1 b2).
                specialize (H9 2%nat).
                assert ((1 < 2)%nat). { lia. }
                assert (boundsmap_denote (@bmap_prod ty 2) (vmap b1 b2)).
                { admit. } specialize (H9 H10 H11). simpl in H9.
                rewrite -/u -/u0 in H9.
                apply Rle_trans with
                (Rabs
                  (FT2R (prod Tsingle b1 b2) +
                   FT2R (sum_fixF Tsingle (prod_fixF Tsingle L))) *
                u0 + u +
                (Rabs (FT2R b1 * FT2R b2) * u0 + u +
                 Rabs
                   (FT2R (sum_fixF Tsingle (prod_fixF Tsingle L)) -
                    sum_fixR (prod_fixR (Flist_to_Rlist_pair L))))).
                ** by apply Rplus_le_compat_l, Rplus_le_compat_r.
                ** apply Rle_trans with
                   (Rabs
                      (FT2R (prod Tsingle b1 b2) +
                       FT2R (sum_fixF Tsingle (prod_fixF Tsingle L))) *
                    u0 + u +
                    (Rabs (FT2R b1 * FT2R b2) * u0 + u +
                     (dot_prodR (Flist_to_Rlist_pair_abs L) *
                        ((1 + u0) ^ (m + 1) - 1) +
                        INR m * u * (1 + u0) ^ m +
                        u * ((1 + u0) ^ m - 1) / u0))).
                   +++  by repeat apply Rplus_le_compat_l.
                   +++ assert (Rabs (FT2R (prod Tsingle b1 b2)) -
                               Rabs (FT2R b1 * FT2R b2) <=
                               Rabs (FT2R b1 * FT2R b2) * u0 + u).
                       { apply Rle_trans with (Rabs
                             (FT2R (prod Tsingle b1 b2) -
                              FT2R b1 * FT2R b2)).
                         + apply Rabs_triang_inv.
                         + apply H9.
                       }
                       assert (Rabs (FT2R (prod Tsingle b1 b2)) <=
                               Rabs (FT2R b1 * FT2R b2) *(1 + u0) + u).
                       { nra. }
                       assert (Rabs (FT2R (dot_prodF Tsingle L)) -
                               Rabs (dot_prodR (Flist_to_Rlist_pair L)) <=
                               dot_prodR (Flist_to_Rlist_pair_abs L) *
                                ((1 + u0) ^ (m + 1) - 1) +
                                INR m * u * (1 + u0) ^ m +
                                u * ((1 + u0) ^ m - 1) / u0).
                       { apply Rle_trans with
                         (Rabs
                            (FT2R (dot_prodF Tsingle L) -
                             dot_prodR (Flist_to_Rlist_pair L))).
                         + apply Rabs_triang_inv.
                         + nra.
                       }
                       assert (Rabs (FT2R (dot_prodF Tsingle L)) <=
                               dot_prodR (Flist_to_Rlist_pair_abs L) +
                               (dot_prodR (Flist_to_Rlist_pair_abs L) *
                                  ((1 + u0) ^ (m + 1) - 1) +
                                  INR m * u * (1 + u0) ^ m +
                                  u * ((1 + u0) ^ m - 1) / u0)).
                       { apply Rle_trans with
                         (Rabs (dot_prodR (Flist_to_Rlist_pair L)) +
                           (dot_prodR (Flist_to_Rlist_pair_abs L) *
                              ((1 + u0) ^ (m + 1) - 1) +
                              INR m * u * (1 + u0) ^ m +
                              u * ((1 + u0) ^ m - 1) / u0)).
                         + nra.
                         + apply Rplus_le_compat_r.
                           apply sum_abs_pair_le.
                       }
                       apply Rle_trans with
                       ((((Rabs (FT2R b1 * FT2R b2) * (1 + u0) + u) +
                        (dot_prodR (Flist_to_Rlist_pair_abs L) +
                          (dot_prodR (Flist_to_Rlist_pair_abs L) *
                           ((1 + u0) ^ (m + 1) - 1) +
                           INR m * u * (1 + u0) ^ m +
                           u * ((1 + u0) ^ m - 1) / u0))) *u0 + u) +
                         (Rabs (FT2R b1 * FT2R b2) * u0 + u +
                           (dot_prodR (Flist_to_Rlist_pair_abs L) *
                            ((1 + u0) ^ (m + 1) - 1) +
                            INR m * u * (1 + u0) ^ m +
                            u * ((1 + u0) ^ m - 1) / u0))).
                       --- apply Rplus_le_compat_r.
                           apply Rle_trans with
                           ((Rabs (FT2R (prod Tsingle b1 b2)) +
                            Rabs (FT2R (dot_prodF Tsingle L))) * u0 + u).
                           *** apply Rplus_le_compat_r.
                               apply Rmult_le_compat_r.
                               unfold u0; simpl;nra.
                               apply Rabs_triang.
                           *** apply Rplus_le_compat_r.
                               apply Rmult_le_compat_r.
                               unfold u0; simpl;nra.
                               apply Rplus_le_compat; nra.
                       --- rewrite !Rabs_mult.
                           assert ((Rabs (FT2R b1) * Rabs (FT2R b2) * (1 + u0) + u +
                                     (dot_prodR (Flist_to_Rlist_pair_abs L) +
                                      (dot_prodR (Flist_to_Rlist_pair_abs L) *
                                       ((1 + u0) ^ (m + 1) - 1) +
                                       INR m * u * (1 + u0) ^ m +
                                       u * ((1 + u0) ^ m - 1) / u0))) * u0 + u +
                                    (Rabs (FT2R b1) * Rabs (FT2R b2) * u0 + u +
                                     (dot_prodR (Flist_to_Rlist_pair_abs L) *
                                      ((1 + u0) ^ (m + 1) - 1) +
                                      INR m * u * (1 + u0) ^ m +
                                      u * ((1 + u0) ^ m - 1) / u0)) =
                                    (Rabs (FT2R b1) * Rabs (FT2R b2) * (u0 * u0 + 2 * u0)) +
                                    ((dot_prodR (Flist_to_Rlist_pair_abs L)) *
                                    (u0 + u0 * ((1 + u0) ^ (m + 1) - 1) + ((1 + u0) ^ (m + 1) - 1)) +
                                    ((1 + u0) * (INR m * u * (1 + u0) ^ m +
                                                  u * ((1 + u0) ^ m - 1) / u0) +
                                     u0 * u + 2 * u))).
                          { nra. } rewrite H16. clear H16.
                          unfold dot_prodR.
                          assert ((Rabs (FT2R b1) * Rabs (FT2R b2) +
                                     sum_fixR (prod_fixR (Flist_to_Rlist_pair_abs L))) *
                                    ((1 + u0) * (1 + u0) ^ (m + 1) - 1) +
                                    nr * u * ((1 + u0) * (1 + u0) ^ m) +
                                    u * ((1 + u0) * (1 + u0) ^ m - 1) / u0 =
                                   (Rabs (FT2R b1) * Rabs (FT2R b2) * ((1 + u0) * (1 + u0) ^ (m + 1) - 1)) +
                                   ((sum_fixR (prod_fixR (Flist_to_Rlist_pair_abs L))) * ((1 + u0) * (1 + u0) ^ (m + 1) - 1) +
                                    (nr * u * ((1 + u0) * (1 + u0) ^ m) +
                                    u * ((1 + u0) * (1 + u0) ^ m - 1) / u0))).
                          { nra. } rewrite H16. clear H16.
                          apply Rplus_le_compat.
                          *** repeat apply Rmult_le_compat_l.
                              ++++ repeat apply Rmult_le_pos; apply Rabs_pos.
                              ++++ apply x_bound_S. unfold u0; simpl; nra.
                          *** apply Rplus_le_compat.
                              ++++ apply Rmult_le_compat_l.
                                   apply sum_abs_pair_rel. nra.
                              ++++ assert ((1 + u0) * (INR m * u * (1 + u0) ^ m +
                                              u * ((1 + u0) ^ m - 1) / u0) + u0 * u +  2 * u =
                                            INR m * u* (1+u0) *(1+u0)^m + u * (1+u0) * ((1+u0)^m - 1) / u0 + (u0 * u + 2* u) ).
                                   { nra. } rewrite H16. clear H16. unfold nr. rewrite H0. rewrite plus_INR.
                                   simpl.
                                   assert ((INR m + 1) * u * ((1 + u0) * (1 + u0) ^ m) +
                                            u * ((1 + u0) * (1 + u0) ^ m - 1) / u0 =
                                            INR m * u * (1 + u0) * (1 + u0) ^ m +
                                            (u * ((1 + u0) * (1 + u0) ^ m - 1) / u0 +
                                            u * ((1 + u0) * (1 + u0) ^ m))).
                                   { nra. } rewrite H16.
                                   assert (INR m * u * (1 + u0) * (1 + u0) ^ m +
                                            u * (1 + u0) * ((1 + u0) ^ m - 1) / u0 +
                                            (u0 * u + 2 * u) =
                                           INR m * u * (1 + u0) * (1 + u0) ^ m +
                                            (u * (1 + u0) * ((1 + u0) ^ m - 1) / u0 +
                                            (u0 * u + 2 * u))). { nra. } rewrite H17.
                                   apply Rplus_le_compat_l.
                                   assert (u * (1 + u0) * ((1 + u0) ^ m - 1) / u0  =
                                            u * ((1 + u0) * (1 + u0) ^ m - 1) / u0  - u * (u0 / u0)).
                                   { nra. } rewrite H18.
                                   assert (u0 / u0 = 1). { apply Rinv_r. unfold u0. simpl. nra. }
                                   rewrite H19.
                                   assert (u * ((1 + u0) * (1 + u0) ^ m - 1) / u0 - u * 1 +
                                            (u0 * u + 2 * u) =
                                           u * ((1 + u0) * (1 + u0) ^ m - 1) / u0 +
                                           u * (u0 + 1)).
                                   { nra. } rewrite H20.
                                   apply Rplus_le_compat_l. apply Rmult_le_compat_l.
                                   unfold u; simpl; nra.
                                   assert (u0 <= (1 + u0) * (1 + u0) ^ m - 1 ->
                                            u0 + 1 <= (1 + u0) * (1 + u0) ^ m).
                                   { nra. } apply H21. apply u_bound. unfold u0; simpl; nra.
Admitted.

(** Using Coq's combine function to combibe two lists to get a
    list of pairs
**)
Lemma forward_error_dot_precise:
  forall (L1 L2: list (ftype Tsingle)),
  let L := combine L1 L2 in
  let ty := Tsingle in
  let n:= length L in
  let nr := INR n in
  (1 <= n)%nat ->
  let u  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let u0 := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  Rabs (FT2R (dot_prodF _ L) - dot_prodR (Flist_to_Rlist_pair L)) <=
  (dot_prodR (Flist_to_Rlist_pair_abs L)) * ((1 + u0)^(n+1) -1) +
  nr * u * (1+u0)^n + u * ((1+u0)^n -1) / u0.
Proof.
intros.
by apply forward_error_dot_aux.
Qed.

Lemma forward_error_dot:
  forall (L1 L2: list (ftype Tsingle)),
  let ty := Tsingle in
  let n:= length L1 in
  let nr := INR n in
  (1 <= n)%nat ->
  let u  := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let u0 := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  Rabs (FT2R (dot_prodF _ L1 L2) - dot_prodR (Flist_to_Rlist L1) (Flist_to_Rlist L2)) <=
  (nr * u0 * (1 + u0) / (1 - u0) + u0) * dot_prodR (Flist_to_Rlist L1) (Flist_to_Rlist L2) +
  ((nr^2 + nr) / (1 - u0) + nr) * u.
Admitted.

End WITHNANS.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e224m2e96p1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From Coq Require Import ssreflect ssrfun ssrbool.
From Mon Require Export Base.
From Mon.SRelation Require Import SRelation_Definitions SMorphisms.
From Mon.sprop Require Import SPropBase SPropMonadicStructures Monoid.

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

(***************************************************************)
(* The main useful example of a specification monad:           *)
(*    the monotone continuations monad.                        *)
(* This is especially useful because the monad laws hold       *)
(* definitionally in Coq.                                      *)
(***************************************************************)
Section MonotoneContinuationsMonad.
  Import SPropNotations.

  Context {R: Type} (Rrel : srelation R) `{PreOrder _ Rrel}.
  Notation "x ≼ y" := (Rrel x y) (at level 70).

  Definition MonoContCarrier (X: Type) : Type :=
    { f : (X -> R) -> R ≫ SProper (pointwise_srelation X Rrel s==> Rrel) f}.

  Program Definition MonoCont_ret A (a:A) : MonoContCarrier A :=
    ⦑ fun k => k a ⦒.
  Next Obligation. cbv; auto. Qed.

  Program Definition MonoCont_bind A B (m : MonoContCarrier A)
          (f : A -> MonoContCarrier B) : MonoContCarrier B :=
    ⦑ fun k => Spr1 m (fun a => Spr1 (f a) k) ⦒.
  Next Obligation.
    cbv ; intuition. apply (Spr2 m).
    intros a ; apply (Spr2 (f a)) ; assumption.
  Qed.

  Program Definition MonoContU : Monad :=
    @mkMonad MonoContCarrier MonoCont_ret MonoCont_bind _ _ _.

  Program Definition MonoCont_order A : srelation (MonoContU A) :=
    fun m1 m2 => pointwise_srelation (A -> R) Rrel (Spr1 m1) (Spr1 m2).
  Instance MonoCont_order_preorder A : PreOrder (@MonoCont_order A).
  Proof.
    constructor ; cbv ; intuition ;
      eauto using PreOrder_Transitive.
  Qed.

  Program Definition MonoCont : OrderedMonad :=
    @mkOrderedMonad MonoContU MonoCont_order _ _.
  Next Obligation.
    cbv ; intuition.
    repeat lazymatch goal with | [H : Ssig _ |- _] => destruct H end.
    match goal with
    |[|- Rrel (?X ?F) (?Y ?G)] => stransitivity (X G) ; auto
    end.
  Qed.

End MonotoneContinuationsMonad.

Section MonoContSProp.
  Definition MonoContSProp := @MonoCont SProp (SProp_op_order) _.
  Import SPropNotations.

  Global Program Instance MonoContSProp_aa A : aa (@omon_rel MonoContSProp A)
    :=
      @mkAa _ _
            (fun pre w => ⦑ fun p => pre -> Spr1 w p ⦒)
            (fun pre w => ⦑ fun p => pre s/\ Spr1 w p ⦒)
            _ _ _.
  Solve All Obligations with cbv ; intuition ; try (eapply (Spr2 w) ; eauto).

End MonoContSProp.

Section PrePostSpec.
  Import SPropNotations.

  (* Generic pre-/post-conditions for the W^Pure specification monad. *)
  Program Definition PrePostSpec {A} (P : SProp) (Q : A -> SProp) :
    MonoContSProp A :=
    ⦑ fun (Z : A -> SProp) => P s/\ forall a, Q a -> Z a ⦒.
  Next Obligation. cbv ; intuition eauto. Qed.

  Section Ran.
    Context (B C : Type) (w : MonoContSProp C)
            (pre : SProp) (post : B -> SProp).
    Context (Hpre : Spr1 w (fun _ => sUnit) -> pre).

    Definition MonoContAlongPrePost_ran : ran w (PrePostSpec pre post).
    Proof.
      unshelve econstructor.
      refine (fun b => ⦑ fun p => post b s/\ Spr1 w p ⦒).
      cbv ; intuition ; eapply (Spr2 w _) ; eauto.
      split.
      cbv. intros ; split.
      apply Hpre. eapply (Spr2 w _) ; eauto.
      cbv ; intuition. cbv ; intuition.
      cbv ; intuition.
      destruct (H a q). apply s ; assumption.
   Qed.
  End Ran.
End PrePostSpec.

Section ExceptionSpec.
  Context (E:Type).
  Import SPropNotations.

  Definition ExnSpecCarrier : Type -> Type :=
    fun X => { f : (X -> SProp) -> (E -> SProp) -> SProp
          ≫ SProper ((X ⇢ SProp_op_order) s==> (E ⇢ SProp_op_order) s==> SProp_op_order) f}.

  Program Definition ExnSpec_ret : forall A, A -> ExnSpecCarrier A :=
    fun A a => ⦑ fun p pexc => p a ⦒.
  Next Obligation. cbv ; intuition. Qed.

  Program Definition ExnSpec_bind :
    forall A B, ExnSpecCarrier A -> (A -> ExnSpecCarrier B) -> ExnSpecCarrier B :=
    fun A B m f =>
      ⦑ fun p pexc => Spr1 m (fun a => Spr1 (f a) p pexc) pexc ⦒.
  Next Obligation.
    move=> ? ? ? ? ? ?.
    eapply (Spr2 m) ; try eassumption.
    move=> /= ? ; apply (Spr2 (f _)) ; assumption.
  Qed.

  Program Definition ExnSpecU : Monad :=
    @mkMonad ExnSpecCarrier ExnSpec_ret ExnSpec_bind _ _ _.

  Definition ExnSpec_rel A : srelation (ExnSpecU A) :=
    fun m1 m2 => ((A -> SProp) ⇢ ((E -> SProp) ⇢ SProp_op_order)) (Spr1 m1) (Spr1 m2).

  Instance ExnSpec_order A : PreOrder (@ExnSpec_rel A).
  Proof. constructor ; cbv ; intuition. Qed.

  Program Definition ExnSpec : OrderedMonad :=
    @mkOrderedMonad ExnSpecU ExnSpec_rel _ _.
  Next Obligation.
    cbv; move=> ? y H ? ? ? ? ? H1 ; apply H.
    move: H1 ; apply (Spr2 y) ; cbv ; intuition.
  Qed.
End ExceptionSpec.

(***************************************************************)
(* A variation on continuations for update monads              *)
(***************************************************************)

Section UpdateSpecMonad.
  Context (M : monoid) (X : monoid_action M).

  Definition dom_rel A : srelation (A -> M -> SProp) :=
    pointwise_srelation A (pointwise_srelation M SProp_op_order).
  Definition cod_rel : srelation (X -> SProp) :=
    pointwise_srelation X SProp_op_order.

  Instance dom_rel_ord A : PreOrder (@dom_rel A).
  Proof. constructor ; cbv ; intuition. Qed.
  Instance cod_rel_ord : PreOrder cod_rel.
  Proof. constructor ; cbv ; intuition. Qed.

  Import SPropNotations.

  Definition WUpd A :=
    { f : (A -> M -> SProp) -> X -> SProp ≫
      SProper (@dom_rel A s==> cod_rel) f}.
  Program Definition retWUpd A (a : A) : WUpd A :=
    ⦑ fun p xx => p a (e M) ⦒.
  Next Obligation. move=> ? ? H ? ; apply H. Qed.

  Program Definition bindWUpd A1 A2
          (wm : WUpd A1) (wf : A1 -> WUpd A2)
    : WUpd A2 :=
    ⦑ fun p x => Spr1 wm (fun a m => Spr1 (wf a)
                                       (fun a m' => p a (m'⋅m))
                                       (m ⧕  x)) x ⦒.
  Next Obligation.
    move=> ? ? H ? ; apply (Spr2 wm)=> a m ; apply (Spr2 (wf a))=> ? ? ; apply H.
  Qed.

  Definition WUpd_rel A : srelation (WUpd A) :=
    fun m1 m2 => forall p, cod_rel (Spr1 m1 p) (Spr1 m2 p).
  Instance WUpd_ord A : PreOrder (@WUpd_rel A).
  Proof. constructor ; cbv ; intuition. Qed.

  (* We do not prove the monadic laws since they would
   rely on funext. Instead we let them be proved on a case
   by case basis, which should be trivial when both the monoid
   and action laws hold definitionally *)
  Program Definition UpdSpecFromLaws pf1 pf2 pf3 : OrderedMonad :=
    let upd_spec_monad := @mkMonad WUpd retWUpd bindWUpd pf1 pf2 pf3 in
    @mkOrderedMonad upd_spec_monad WUpd_rel WUpd_ord _.
  Next Obligation.
    cbv ; move=> x ? Hm ? ? Hf ? ? H. move: (Hm _ _ H).
    apply (Spr2 x) => ? ? ; apply Hf.
  Qed.

  Import FunctionalExtensionality.

  Program Definition UpdSpec := UpdSpecFromLaws _ _ _.
  Next Obligation.
    apply Ssig_eq. extensionality p0 ; extensionality x.
    cbv. f_equal.
    extensionality a0 ; extensionality m' ; rewrite !monoid_law2 //.
    rewrite !monact_unit //.
  Qed.

  Next Obligation.
    apply Ssig_eq. extensionality p.
    cbv. extensionality a ; f_equal. extensionality a0 ; extensionality m'.
    rewrite !monoid_law1 //.
  Qed.

  Next Obligation.
    apply Ssig_eq; extensionality p ; extensionality x.
    cbv.
    let t :=
        f_equal ; [let Hab := fresh "ab" in
        let Hmm := fresh "mm" in
        extensionality Hab ; extensionality Hmm |..] in
    do 3 t.
    rewrite !monoid_law3 //.
    rewrite !monact_mult //.
  Qed.

  Section AssertAssume.
    Context pf1 pf2 pf3 (UpdSpec := UpdSpecFromLaws pf1 pf2 pf3).
    Global Program Instance UpdSpecFromLaws_aa A : aa (@omon_rel UpdSpec A)
      :=
        @mkAa _ _
              (fun pre w => ⦑ fun p x => pre -> Spr1 w p x ⦒)
              (fun pre w => ⦑ fun p x => pre s/\ Spr1 w p x ⦒)
              _ _ _.
    Solve All Obligations with cbv ; intuition ; eapply (Spr2 w) ; eauto.

  End AssertAssume.

  Global Instance UpdSpec_aa A : aa (@omon_rel UpdSpec A).
  Proof. eapply UpdSpecFromLaws_aa. Defined.

End UpdateSpecMonad.

(*****************************************************************)
(* Some less useful specification monads, covered in Section 4.1 *)
(*****************************************************************)

(* Fat monotone relation-based specification monad *)
Section MonotonicRelations.
  Import SPropNotations.
  Import SPropAxioms.

  Definition SPropAssuming (pre : SProp) :=
    { q : SProp ≫ q s<-> (pre -> q) }.

  Definition MR_base X :=
    forall (pre:SProp), (X -> SPropAssuming pre) -> SPropAssuming pre.

  Definition MR_base_rel X : srelation (MR_base X) :=
    fun r1 r2 =>
    forall (pre1 pre2:SProp) (Hpre : pre1 -> pre2) (post1 : X -> SPropAssuming pre1)
      (post2 : X -> SPropAssuming pre2)
      (Hpost : forall x, Spr1 (post2 x) -> Spr1 (post1 x)), Spr1 (r2 pre2 post2) -> Spr1 (r1 pre1 post1).

  Definition MR X := { r : MR_base X ≫ SProper (@MR_base_rel X) r }.

  Program Definition retMR A a : MR A :=
    ⦑ fun pre post => ⦑ pre -> Spr1 (post a) ⦒ ⦒.
  Next Obligation. cbv ; intuition. Qed.
  Next Obligation. cbv ; intuition. Qed.

  Program Definition bindMR A B (m:MR A) (f: A -> MR B) : MR B :=
    ⦑ fun pre post => ⦑ Spr1 (Spr1 m pre (fun a => ⦑ Spr1 (Spr1 (f a) pre post) ⦒)) ⦒ ⦒.
  Next Obligation.
    split ; move=> ? //=.
    match goal with | [|- _ ?X] => apply (Spr2 X) ;assumption end.
  Qed.
  Next Obligation.
    cbv ; intuition.
    match goal with | [|- ?X ?Y] => apply (Spr2 Y) ; assumption end.
  Qed.
  Next Obligation.
    cbv ; intuition.
    simple refine (Spr2 m _ _ _ _ _ _ H).
    assumption.
    cbv ; move=> a. apply (Spr2 (f a)). assumption. auto.
  Qed.

  Import FunctionalExtensionality.

  Program Definition MR_monad : Monad :=
    @mkMonad MR retMR bindMR _ _ _.
  Next Obligation.
    apply Ssig_eq ; extensionality pre ; extensionality post ; apply Ssig_eq ; apply sprop_ext.
    do 2 split ; cbv.
    move=> ?; match goal with
               | [|- _ ?X] => apply (Spr2 X) ; assumption
              end.
    move=> ? ? //=.
  Qed.
  Next Obligation.
    apply Ssig_eq ; extensionality pre ; extensionality post ; apply Ssig_eq ; apply sprop_ext.
    do 2 split ; cbv.
    apply (Spr2 c) => //=.
    move=> ? ? ; apply (Spr2 (post _)) ; assumption.
    apply (Spr2 c) => //=.
  Qed.

  Definition MR_rel X : srelation (MR X) :=
    fun w1 w2 => forall pre post, Spr1 (Spr1 w2 pre post) -> Spr1 (Spr1 w1 pre post).

  Instance MR_preorder X : PreOrder (@MR_rel X).
  Proof.
    constructor ; cbv ; intuition.
  Qed.

  Program Definition MRSpec : OrderedMonad :=
    @mkOrderedMonad MR_monad MR_rel _ _.
  Next Obligation.
    cbv ; intuition.
    simple refine (H _ _ _).
    move:H1 ; apply (Spr2 y); auto.
  Qed.

End MonotonicRelations.

From Coq Require FunctionalExtensionality.

Section Pred.
  Import SPropNotations.
  Import SPropAxioms.
  Import FunctionalExtensionality.

  Definition Pred X := X -> SProp.
  Definition Pred_ret : forall A, A -> Pred A := fun _ x y => y ≡ x.
  Definition Pred_bind
    : forall A B, Pred A -> (A -> Pred B) -> Pred B :=
    fun A B m f y => s∃ x, m x s/\ (f x) y.

  Program Definition PredM : Monad :=
    @mkMonad Pred Pred_ret Pred_bind _ _ _.
  Next Obligation.
    cbv ; extensionality y ; apply sprop_ext ; do 2 constructor.
    move=> [? [H ?]] ; induction H=> //.
    move=> ? ; eexists ; split=> //.
  Qed.
  Next Obligation.
    cbv ; extensionality y ; apply sprop_ext ; do 2 constructor.
    move=> [? [? H]] ; induction H=> //.
    move=> ? ; eexists ; split=> // ; by [].
  Qed.
  Next Obligation.
    cbv ; extensionality y ; apply sprop_ext ; do 2 constructor.
    move=> [? [[? [? ?]] ?]] ; eexists ; split ; [|eexists; split] ; eassumption.
    move=> [? [? [? [? ?]]]] ; eexists ; split ; [eexists; split|] ; eassumption.
  Qed.

  Program Definition PredOM : OrderedMonad :=
    @mkOrderedMonad PredM (fun X => X ⇢ SProp_order) _ _.
  Next Obligation.
    cbv=> ? ? ? ? ? ? ? [a [? ?]]; exists a ; split ; auto.
  Qed.
End Pred.

Module PrePost.
  Import SPropNotations.
  Import SPropAxioms.
  Import FunctionalExtensionality.

  Definition PP X := SProp × (X -> SProp).

  Definition PP_ret : forall A, A -> PP A := fun _ x => ⟨ sUnit, fun y => y ≡ x ⟩.

  Definition PP_bind
    : forall A B, PP A -> (A -> PP B) -> PP B :=
    fun A B m f =>
      ⟨ (nfst m s/\ forall x, nsnd m x -> nfst (f x)),
        fun y => s∃ x, nsnd m x s/\ nsnd (f x) y ⟩.

  Program Definition PP_monad : Monad :=
    @mkMonad PP PP_ret PP_bind _ _ _.

  Next Obligation.
    apply nprod_eq =>//= ; [|extensionality y] ; apply sprop_ext => //=.
    dintuition ; subst_sEq ; assumption.
    do 2 split.
    intros [? []]; subst_sEq ; assumption.
    eexists ; split ; [| eassumption] ; reflexivity.
  Qed.

  Next Obligation.
    apply nprod_eq =>//= ; [|extensionality y] ;
      apply sprop_ext => //= ; try by dintuition.
    do 2 split.
    move=> [? [? ?]] ; subst_sEq ; eassumption.
    move=> ? ; eexists ; split. eassumption. reflexivity.
  Qed.

  Next Obligation.
    apply nprod_eq =>//= ; [|extensionality y] ; apply sprop_ext => //=.
    - dintuition. eapply q ; eexists ; split ; eassumption.
      destruct (q x H) ; assumption.
      destruct H as [?[n ?]]. destruct (q _ n) ; auto.
    - do 2 split.
    intros [? [[? []]]] ; eexists ; split ; [|eexists;split] ;eassumption.
    intros [? [? [? []]]] ; eexists ; split ; [eexists; split|] ; eassumption.
  Qed.

  Program Definition PP_rel A : srelation (PP A) :=
    fun m1 m2 => (nfst m2 -> nfst m1) s/\ forall x, nsnd m1 x -> nsnd m2 x.
  Instance PP_rel_preorder A : PreOrder (@PP_rel A).
  Proof. constructor ; cbv ; dintuition. Qed.

  Program Definition PPSpecMonad : OrderedMonad :=
    @mkOrderedMonad PP_monad PP_rel _ _.
  Next Obligation.
    cbv ; dintuition. destruct (H x0) ; auto.
    destruct H0 as [x1 []]. destruct (H x1) ; eexists ; split ; auto.
    auto.
  Qed.

  Section RightKanExtension.
    Context A B (w : PPSpecMonad A) (w' : PPSpecMonad B).

    (*    1 -- w --> A
          |         /
          w' <=   /
          |     /  Ran_w w'
          v   /
          B <
   *)

    Context (Hpre : nfst w' -> nfst w).

    Local Definition PPSpec_ran : A -> PPSpecMonad B :=
      fun (a:A) => ⟨nsnd w a s/\ nfst w', fun b => nsnd w a -> nsnd w' b⟩.

    Lemma PPSpec_ran_valid : bind w PPSpec_ran ≤[PPSpecMonad] w'.
    Proof.
      cbv ; split.
      intuition.
      move=> b [a [? ?]] ; intuition.
    Qed.

    Lemma PPSpec_ran_universal : forall (w'' : A -> PPSpecMonad B),
        bind w w'' ≤[PPSpecMonad] w' -> forall a, w'' a ≤[PPSpecMonad] PPSpec_ran a.
    Proof.
      cbv. move=> ? [? H] a ; intuition.
      apply H. exists a ; intuition.
    Qed.

    Program Definition PPSpecRan : ran w' w :=
      ⦑ PPSpec_ran ⦒.
    Next Obligation.
      split ; [exact PPSpec_ran_valid | exact PPSpec_ran_universal].
    Qed.
  End RightKanExtension.

  Global Program Instance PP_aa A : aa (@omon_rel PPSpecMonad A)
    :=
      @mkAa _ _
            (fun pre w => ⟨pre -> nfst w, nsnd w⟩)
            (fun pre w => ⟨pre s/\ nfst w, nsnd w⟩)
            _ _ _.
  Solve All Obligations with cbv ; intuition.

End PrePost.

Module StrongestPostcondition.
  Import SPropNotations.
  Import SPropAxioms.
  Import FunctionalExtensionality.

  Record SPropOver (p:SProp) := mkOver { base :> SProp ; over : base -> p }.

  Definition SP X := { f : forall p:SProp, X -> SPropOver p ≫
                       forall (p1 p2 : SProp) x, (p1 -> p2) -> f p1 x -> f p2 x}.

  Program Definition SP_ret A (a:A) : SP A :=
    ⦑ fun p y => @mkOver _ (p s/\ a ≡ y) _ ⦒.
  Next Obligation. destruct H ; assumption. Qed.
  Next Obligation. destruct H0 ; split ; auto. Qed.

  Program Definition SP_bind A B (m:SP A) (f : A -> SP B) : SP B :=
    ⦑ fun p y => @mkOver _ (s∃ x, Spr1 (f x) (Spr1 m p x) y) _ ⦒.
  Next Obligation.
    destruct H as [x0 H0].
    exact (@over _ (Spr1 m p x0) (@over _ (Spr1 (f _) _ _) H0)).
  Qed.

  Next Obligation.
    destruct H0 as [x0 H1].
    exists x0 ; apply (Spr2 (f x0) _ _ _ (Spr2 m _ _ x0 H)) ; assumption.
  Qed.

  Lemma trivial_eq (p:SProp) {A} (x:A) : p = (p s/\ x ≡ x).
  Proof. apply sprop_ext ; split ; dintuition. Qed.

  Lemma SPropOver_eq p (q1 q2 : SPropOver p) :
    (base q1 s<-> base q2) -> q1 = q2.
  Proof.
    intros .
    assert (H0 : base q1 = base q2) by (apply sprop_ext ; constructor ; assumption).
    destruct q1 ; destruct q2 ; simpl in *.
    induction H0.
    reflexivity.
  Qed.

  Program Definition SP_monad : Monad := @mkMonad SP SP_ret SP_bind _ _ _.

  Next Obligation.
    apply Ssig_eq ; extensionality p ; extensionality y ; apply SPropOver_eq ;
      simpl ; split.
    intros [x H] ; move: (over H) => [_?] ; subst_sEq ;
      move: H ; apply (Spr2 (f a)) ; intuition.
    intros H ; exists a; rewrite <- trivial_eq ; assumption.
  Qed.

  Next Obligation.
    apply Ssig_eq ; extensionality p ; extensionality y ; apply SPropOver_eq ;  simpl ; split.
    intros [? []] ; subst_sEq ; assumption.
    intros H ; eexists ; intuition ; eassumption.
  Qed.

  Next Obligation.
    apply Ssig_eq ; extensionality p ; extensionality y ; apply SPropOver_eq ;  simpl ; split.

    intros [x0 H].
    move: (over H) => [x1 H1]; exists x1 ; exists x0; move: H.
    apply (Spr2 (g x0)) => ? //=.

    intros [x0 [x1 H]] ; exists x1 ; move: H ; apply (Spr2 (g x1)) => ?.
    exists x0 ; assumption.
  Qed.

  Definition SP_rel A : srelation (SP A) :=
    fun m1 m2 => forall p x, Spr1 m1 p x -> Spr1 m2 p x.
  Instance SP_rel_preorder A : PreOrder (@SP_rel A).
  Proof. constructor ; cbv ; intuition. Qed.

  Program Definition ForwardPredTransformer : OrderedMonad :=
    @mkOrderedMonad SP_monad SP_rel _ _.
  Next Obligation.
    cbv; move=> ? ? ? ? f H ? ? [x H0].
    exists x. move : (H _ _ _ H0) ; eapply (Spr2 (f x)) ; auto.
  Qed.

End StrongestPostcondition.

Section Adjunctions.
  Import PrePost.
  Import SPropNotations.

  Definition pred2pp A (post:PredOM A) : PPSpecMonad A :=
    ⟨sUnit, post⟩.
  Definition pp2pred A (pp:PPSpecMonad A) : PredOM A :=
    fun a => nsnd pp a.

  Lemma pred_pp_adjunction : forall A post (pp : PPSpecMonad A),
   pred2pp post ≤[PPSpecMonad] pp s<-> post ≤[PredOM] pp2pred pp.
  Proof.
    move=> A post pp ; cbv ; split ; intuition.
  Qed.

  Let MonoCont := MonoContSProp.

  Definition wp2pp A (w : MonoCont A) : PPSpecMonad A :=
    ⟨Spr1 w (fun _ => sUnit), fun x =>  forall p, Spr1 w p -> p x⟩.
  Program Definition pp2wp A (pp : PPSpecMonad A) : MonoCont A :=
    ⦑ fun post => nfst pp s/\ (forall x, nsnd pp x -> post x) ⦒.
  Next Obligation. cbv ; intuition. Qed.

  Lemma wp_pp_adjunction : forall A pp (w : MonoCont A),
   pp ≤[PPSpecMonad] wp2pp w s<-> pp2wp pp ≤[MonoCont] w.
  Proof.
    intros A pp w ; cbv ; split.
    - move=> [Hpre Hpost] a H1 ; split.
      apply Hpre. move:H1. apply (Spr2 w). cbv ; dintuition.
      intros ; apply Hpost ; assumption.
    - intros Hpp ; split.
      move=> H1 ; move: (Hpp _ H1) ; dintuition.
      intros x Hp post Hpost ; move: (Hpp _ Hpost) ; move=> [_ H1].
      apply H1 ; assumption.
  Qed.

  Program Definition wp2mr A (w : MonoCont A) : MRSpec A :=
    ⦑ fun pre post => ⦑ pre -> Spr1 w (fun a => Spr1 (post a)) ⦒ ⦒.
  Next Obligation. cbv ; intuition. Qed.
  Next Obligation.
    cbv ; intuition.
    move: H2 ; apply (Spr2 w). cbv ; auto.
  Qed.

  Program Definition assuming (pre : SProp) A (post : A -> SProp) (x:A) :
    SPropAssuming pre :=
    ⦑ pre -> post x ⦒.
  Next Obligation. cbv ; intuition. Qed.

  Program Definition mr2wp A (mr:MRSpec A) : MonoCont A :=
    ⦑ fun p => s∃ (pre:SProp), Spr1 (Spr1 mr pre (assuming pre p)) s/\ pre ⦒.
  Next Obligation.
    cbv ; intuition.
    move: H0 => [pre [Hmr ?]] ; exists pre ; intuition.
    move: Hmr ; apply (Spr2 mr) ; cbv ; auto.
  Qed.

  Lemma wp_mr_adjunction : forall A (w : MonoCont A) r,
   w ≤ mr2wp r s<-> wp2mr w ≤ r.
  Proof.
   cbv ; intuition.
   apply H. exists pre ; intuition.
   move: H0 ; apply (Spr2 r) ; auto.

   move: H0 => [pre [Hr Hpre]].
   move: (H _ _ Hr Hpre). apply (Spr2 w). auto.
  Qed.

  Import StrongestPostcondition.

  Definition sp2pp A (sp:ForwardPredTransformer A) : PPSpecMonad A :=
    let post := fun x => forall (pre : SProp), pre -> Spr1 sp pre x in
    let pre := s∃ pre, (forall x, post x -> Spr1 sp pre x) s/\ pre in
    ⟨pre, post⟩.

  Program Definition pp2sp0 A (pp : PPSpecMonad A) : ForwardPredTransformer A :=
    let sp pre x := pre s/\ (nfst pp -> nsnd pp x) in
    ⦑ fun pre x => @mkOver _ (sp pre x) _ ⦒.
  Next Obligation. destruct H ; assumption. Qed.
  Next Obligation. move: H0 => [Hpre Hpost] ; split ; auto. Qed.

  Program Definition pp2sp A (pp : PPSpecMonad A) : ForwardPredTransformer A :=
    let sp pre x : SProp :=
        forall (sp: ForwardPredTransformer A),
          (forall x pre', pre' s/\ nsnd pp x -> Spr1 sp pre' x) ->
              Spr1 sp pre x in
    ⦑ fun pre x => @mkOver _ (sp pre x) _ ⦒.
  Next Obligation.
    move: (H (pp2sp0 pp)) => H0.
    apply (fun f => over (H0 f)).
    cbv ; intuition.
  Qed.
  Next Obligation.
    move: (H0 sp H1). apply (Spr2 sp). assumption.
  Qed.

  Lemma pp2sp01 A (pp:PPSpecMonad A) :
    pp2sp pp ≤[ForwardPredTransformer] pp2sp0 pp.
  Proof.
    cbv.
    move=> p x H.
    move: (H (pp2sp0 pp)) => H0.
    apply H0.
    cbv ; intuition.
  Qed.

  Lemma sp2pp_pp2sp_loop A (pp:PPSpecMonad A) :
    sp2pp (pp2sp pp) ≤[PPSpecMonad] pp.
  Proof.
    cbv.
    split.
    - move=> ?; exists sUnit;split.
      move=> ? H ? ?; apply H.
      all:intuition.
    - move=> x H.
      simple refine (_ (H sUnit stt (pp2sp0 ⟨sUnit, nsnd pp⟩) _)); cbv ; intuition.
  Qed.

  Lemma pp2sp_sp2pp_loop A (sp:ForwardPredTransformer A) :
    sp ≤[ForwardPredTransformer] pp2sp (sp2pp sp).
  Proof.
    cbv.
    intuition.
    specialize (H0 x).
    apply H0.
    split. exact (over H).
    intros ; move: H ; apply (Spr2 sp) ; intuition.
  Qed.

  Lemma sp_pp_adjunction A pp (sp : ForwardPredTransformer A) :
    sp2pp sp ≤[PPSpecMonad] pp s<-> sp ≤[ForwardPredTransformer] pp2sp pp.
  Proof.
    cbv ; split.
    - dintuition. apply H0.
      split. exact (over H).
      apply q. intros ; move:H ; apply (Spr2 sp) ; intuition.
    - dintuition.
      exists sUnit. split ; intuition.
      apply H1 ; constructor.
      simple refine (_ (H sUnit x (H0 sUnit stt)(pp2sp0 ⟨sUnit, nsnd pp⟩) _)); cbv ; intuition.
  Qed.

  Program Definition sp2mr A (sp : ForwardPredTransformer A)
    : MRSpec A :=
    ⦑ fun pre post => ⦑ forall a, Spr1 sp pre a -> Spr1 (post a) ⦒ ⦒.
  Next Obligation.
    cbv ; intuition.
    apply (Spr2 (post a)).
    auto.
  Qed.
  Next Obligation.
    cbv ; intuition.
    apply Hpost. apply H. move: H0 ; apply (Spr2 sp) ; auto.
  Qed.

  Program Definition mr2sp A (mr : MRSpec A)
    : ForwardPredTransformer A :=
    ⦑ fun pre a => @mkOver _ (pre s/\ forall post, Spr1 (Spr1 mr pre post) -> Spr1 (post a)) _ ⦒.
  Next Obligation. destruct H ; assumption. Qed.
  Next Obligation.
    move: H0 => [Hpre Hmr] ; split ; [auto|].
    move=> post Hpost. simple refine (Hmr (fun a => ⦑ Spr1 (post a) ⦒) _). cbv ; intuition.
    move: Hpost ; apply (Spr2 mr) ; cbv ; intuition.
  Qed.

  Lemma sp_mr_adjunction A (sp : ForwardPredTransformer A) (mr:MRSpec A) :
     sp2mr sp ≤ mr s<-> sp  ≤ mr2sp mr.
  Proof.
    cbv ; intuition.
    exact (over H0).
    move: (H _ _ H1) => [? Hpost].
    apply Hpost ; assumption.
  Qed.

End Adjunctions.

Section WpSpRightKanExtension.
  Let MonoCont := @MonoCont SProp (SProp_op_order) _.
  Import PrePost.
  Import StrongestPostcondition.
  Import SPropNotations.

  Definition ppwp_pairing A (pp : PPSpecMonad A) (w : MonoCont A) : SProp :=
    nfst pp -> Spr1 w (nsnd pp).

  Definition ppsp_pairing A (pp : PPSpecMonad A) (sp : ForwardPredTransformer A) : SProp :=
    forall a, Spr1 sp (nfst pp) a -> nsnd pp a.

  Definition wpsp_pairing A (wp: MonoCont A) (sp:ForwardPredTransformer A) : SProp :=
    (forall pre post, let pp := ⟨pre, post⟩ in ppwp_pairing pp wp -> ppsp_pairing pp sp) s/\
    (forall pre post, let pp := ⟨pre, post⟩ in ppsp_pairing pp sp -> ppwp_pairing pp wp).

  Context (M : Monad) (θwp : MonadMorphism M MonoCont)
          (θsp : MonadMorphism M ForwardPredTransformer).
  Context (Hadj : forall A m, wpsp_pairing (θwp A m) (θsp A m)).

  Program Definition wp_ran A B (w: MonoCont B) (m: M A) : ran w (θwp A m) :=
    ⦑ fun a => ⦑ fun p => Spr1 (θsp A m) (Spr1 w p) a ⦒ ⦒.
  Next Obligation.
    cbv. move=> ? ? H ; apply (Spr2 (θsp A m)) ; apply (Spr2 w)=> //=.
  Qed.
  Next Obligation.
    move: (Hadj m) ; move => [H1 H2]; cbv ; split.
    - move=> p ; apply H2 => //=.
    - move=> w' Hw' a p.
      refine (H1 _ (fun a => Spr1 (w' a) p) _ a).
      cbv ; apply Hw'.
   Qed.

End WpSpRightKanExtension.


Require Export LL.SL.FLL.Specifications.OL2FLLResults.
Require Import LL.SL.FLL.Reasoning.
Export ListNotations.
Export LLNotations.

Set Implicit Arguments.

(** ⊗ Rules of the encoded proof system *)
Section OLPOSNEG.
Context `{OLS : OLSyntax}.

 (** Allowing contraction and weakening on the left side of the sequent *)
  Definition POS F := (perp (down F)) ⊗ (? (atom (down F))).
  (** Allowing contraction and weakening on the right side of the sequent *)
  Definition NEG F := (perp (up F)) ⊗ (? atom (up F)).

Definition hasPos th:= (forall OO: uexp, isOLFormula OO -> th (POS OO)).
Definition hasNeg th:= (forall OO: uexp, isOLFormula OO -> th (NEG OO)).

Lemma PosF : forall (th : oo -> Prop) F D M ,
isOLFormula F -> hasPos th ->
flls th (D++[(atom (down F))] ) (M) (UP []) ->
flls th D ((atom (down F)) :: M) (UP []).
Proof with sauto.
  intros.
  TFocus (POS F ).
  inversion H1...
  FLLsplit [(atom (down F))] M.
Qed.

Lemma PosFN : forall n (th : oo -> Prop) F D M ,
isOLFormula F -> hasPos th ->
flln th n ((atom (down F))::D ) (M) (UP []) ->
flln th (S (S (S (S n)))) D ((atom (down F)) :: M) (UP []).
Proof with sauto.
  intros.
  TFocus (POS F ).
  inversion H1...
  FLLsplit [(atom (down F))] M.
Qed.

Lemma NegF : forall (th : oo -> Prop) F D M,
isOLFormula F -> hasNeg th ->
flls th (D ++ [(atom (up F))]) M (UP []) ->
flls th D ((atom (up F)) :: M) (UP []).
Proof with sauto.
  intros.
  TFocus (NEG F ).
  inversion H1.
  FLLsplit [(atom (up F))] M.
Qed.

Lemma NegFN : forall n (th : oo -> Prop) F D M ,
isOLFormula F -> hasNeg th ->
flln th n ((atom (up F))::D ) (M) (UP []) ->
flln th (S (S (S (S n)))) D ((atom (up F)) :: M) (UP []).
Proof with sauto.
  intros.
  TFocus (NEG F ).
  inversion H1...
  FLLsplit [(atom (up F))] M.
Qed.

Lemma PosSetP L : forall (th : oo -> Prop) D M,
isOLFormulaL L -> hasPos th ->
flls th (LEncode L++D ) M (UP []) ->
flls th D (M++LEncode L) (UP []).
Proof with sauto.
  induction L;intros...
  simpl in *...
  inversion H...
  simpl in *...

  TFocus (POS a)...
  inversion H1.
  FLLsplit [(atom (down a))] (M ++ LEncode L)...
  solveLL.
  eapply IHL...
  LLExact H0.
Qed.

Lemma NegSetP L : forall (th : oo -> Prop) D M,
isOLFormulaL L -> hasNeg th ->
flls th ((REncode L)++D ) M (UP []) ->
flls th D (M++REncode L) (UP []).
Proof with sauto.
  induction L;intros...
  simpl in *...
  inversion H...
  simpl in *...

  TFocus (NEG a)...
  inversion H1.
  FLLsplit [(atom (up a))] (M ++ REncode L)...
  solveLL.
  eapply IHL...
  LLExact H0.
Qed.

Theorem PosNegSetT : forall (th:oo->Prop) D L1 L2,
isOLFormulaL L1 -> isOLFormulaL L2 ->
hasNeg th ->
hasPos th ->
flls th (D ++  (LEncode L1) ++ (REncode L2)) [] (UP []) ->
flls th D (LEncode L1++REncode L2) (UP []).
Proof with sauto.
  intros.
  apply NegSetP...
  rewrite <- (app_nil_l (LEncode L1)).
  apply PosSetP...
  LLExact H1.
Qed.

Lemma PosNegSetT' : forall (th:oo->Prop) D L1 L2,
hasNeg th -> hasPos th ->
IsPositiveAtomFormulaL L1 -> IsPositiveAtomFormulaL L2 ->
flls th (L1++L2 ++D) [] (UP []) ->
flls th D (L1++L2) (UP []).
Proof with sauto.
  intros.
  assert(IsPositiveAtomFormulaL L1) by auto.
  assert(IsPositiveAtomFormulaL L2) by auto.
  apply posDestruct' in H2.
  apply posDestruct' in H3...
  assert(isOLFormulaL x1).
  apply PositiveAtomLEOLFormula.
  OLSolve.
  assert(isOLFormulaL x).
  apply PositiveAtomLEOLFormula.
  OLSolve.
  assert(isOLFormulaL x2).
  apply PositiveAtomREOLFormula.
  OLSolve.
  assert(isOLFormulaL x0).
  apply PositiveAtomREOLFormula.
  OLSolve.

  rewrite H2.

  LLPerm((L2++LEncode x1) ++ REncode x2).
  apply NegSetP...
  apply PosSetP...

  rewrite H3.
  apply NegSetP...
  rewrite <- (app_nil_l (LEncode x)).
  apply PosSetP...
  eapply exchangeCC.
  2:{ exact H1. }
  rewrite H2.
  rewrite H3.
  rewrite !app_assoc. perm.
Qed.

Lemma ContractionLinear: forall (th:oo->Prop) D M N,
hasPos th -> hasNeg th ->
IsPositiveAtomFormulaL N ->
flls th D (M++N++N) (UP []) ->
flls th D (M++N) (UP []).
Proof with sauto.
  intros.
  assert(IsPositiveAtomFormulaL N) by auto.
  apply posDestruct' in H1...
  assert(isOLFormulaL x).
  apply PositiveAtomLEOLFormula.
  OLSolve.
  assert(isOLFormulaL x0).
  apply PositiveAtomREOLFormula.
  OLSolve.

  rewrite H1.
  rewrite app_assoc.
  apply NegSetP...
  apply PosSetP...
  rewrite app_assoc.

  apply AbsorptionCSet'.
  apply AbsorptionLSet'.
  rewrite <- H1...
  rewrite app_assoc_reverse...
  Qed.

Lemma ContractionLinearPos: forall (th:oo->Prop) D M N,
hasPos th -> isOLFormulaL N ->
flls th D (M++LEncode N++LEncode N) (UP []) ->
flls th D (M++LEncode N) (UP []).
Proof with sauto.
  intros.
  apply PosSetP...

  apply AbsorptionCSet'.
  apply AbsorptionLSet'.
  rewrite app_assoc_reverse...
  Qed.

Lemma WeakeningLinear: forall (th:oo->Prop) D M N,
hasPos th -> hasNeg th ->
IsPositiveAtomFormulaL N ->
flls th D M (UP []) ->
flls th D (M++N) (UP []).
Proof with sauto.
  intros.
  assert(IsPositiveAtomFormulaL N) by auto.
  apply posDestruct' in H1...
  assert(isOLFormulaL x).
  apply PositiveAtomLEOLFormula.
  OLSolve.
  assert(isOLFormulaL x0).
  apply PositiveAtomREOLFormula.
  OLSolve.

  rewrite H1.
  rewrite app_assoc.
  apply NegSetP...
  apply PosSetP...
  rewrite app_assoc.
  apply weakeningGen...
Qed.

Lemma WeakeningLinearPos: forall (th:oo->Prop) D M N,
hasPos th ->
isOLFormulaL N ->
flls th D M (UP []) ->
flls th D (M++LEncode N) (UP []).
Proof with sauto.
  intros.
  apply PosSetP...
  apply weakeningGen...
Qed.

Lemma LinearToClassic: forall (th:oo->Prop) D L,
hasPos th -> hasNeg th ->
IsPositiveAtomFormulaL L ->
flls th (L++D) [] (UP []) ->
flls th D (L) (UP []).
Proof with sauto.
  intros.
  assert(IsPositiveAtomFormulaL L) by auto.
  apply posDestruct' in H1...
  assert(isOLFormulaL x).
  apply PositiveAtomLEOLFormula.
  OLSolve.
  assert(isOLFormulaL x0).
  apply PositiveAtomREOLFormula.
  OLSolve.

  rewrite H1.
  apply PosNegSetT'...
  OLSolve.
  OLSolve.
  eapply exchangeCC.
  2:{ exact H0. }
  rewrite H1.
  perm.
Qed.

End OLPOSNEG.

Tactic Notation "PosNeg" :=
  match goal with
     | [ |- flls _ _  ((atom (up _)) :: _) _ ] =>  eapply NegF;auto
     | [ |- flls _ _  ((atom (down _)) :: _) _ ] =>  eapply PosF;auto
end.

Tactic Notation "PosNegAll"  :=
  match goal with
     | [ |- flls _ _ _ _ ] =>  eapply LinearToClassic;auto
end.

Tactic Notation "PosNegAllE" :=
  match goal with
     | [ |- flls _ _ _ _ ] =>  eapply PosNegSetT ;auto
end.


(*********************************************************************************************************************************)
(* ProgrammingLanguageCategory                                                                                *)
(*                                                                                *)
(*   The category Types(L)                                                                                *)
(*                                                                                *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import Categories_ch1_3.
Require Import InitialTerminal_ch2_2.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import ProductCategories_ch1_6_1.
Require Import OppositeCategories_ch1_6_2.
Require Import Enrichment_ch2_8.
Require Import Subcategories_ch7_1.
Require Import NaturalTransformations_ch7_4.
Require Import NaturalIsomorphisms_ch7_5.
Require Import BinoidalCategories.
Require Import PreMonoidalCategories.
Require Import MonoidalCategories_ch7_8.
Require Import Coherence_ch7_8.
Require Import Enrichment_ch2_8.
Require Import RepresentableStructure_ch7_2.
Require Import FunctorCategories_ch7_7.

Require Import NaturalDeduction.
Require Import ProgrammingLanguage.
        Export ProgrammingLanguage.

Require Import NaturalDeductionCategory.

Open Scope nd_scope.
(* I am at a loss to explain why "auto" can't handle this *)
Ltac ndpc_tac :=
  match goal with
    | [ |- NDPredicateClosure ?P (?A ;; ?B) ] => apply ndpc_comp; ndpc_tac
    | [ |- NDPredicateClosure ?P (?A ** ?B) ] => apply ndpc_prod; ndpc_tac
    | _                                       => auto
  end.

(* this tactical searches the environment; setoid_rewrite doesn't seem to be able to do that properly sometimes *)
Ltac nd_swap_ltac P EQV :=
  match goal with
    [ |- context [ (?F ** nd_id _) ;; (nd_id _ ** ?G) ] ] =>
      set (@nd_swap _ _ EQV _ _ _ _ F G) as P
  end.

(* I still wish I knew why "Hint Constructors" doesn't work *)
Hint Extern 5 => apply snd_inert_initial.
Hint Extern 5 => apply snd_inert_cut.
Hint Extern 5 => apply snd_inert_structural.
Hint Extern 5 => apply cnd_inert_initial.
Hint Extern 5 => apply cnd_inert_cut.
Hint Extern 5 => apply cnd_inert_structural.
Hint Extern 5 => apply cnd_inert_cnd_ant_assoc.
Hint Extern 5 => apply cnd_inert_cnd_ant_cossa.
Hint Extern 5 => apply cnd_inert_cnd_ant_cancell.
Hint Extern 5 => apply cnd_inert_cnd_ant_cancelr.
Hint Extern 5 => apply cnd_inert_cnd_ant_llecnac.
Hint Extern 5 => apply cnd_inert_cnd_ant_rlecnac.
Hint Extern 5 => apply cnd_inert_se_expand_left.
Hint Extern 5 => apply cnd_inert_se_expand_right.

Hint Extern 2 (@Structural _ _ _ _ (@nd_id _ _ []   )) => simpl; auto.
Hint Extern 2 (@Structural _ _ _ _ (@nd_id _ _ [ _ ])) => simpl; auto.

Section ProgrammingLanguageCategory.

  Context {T    : Type}.               (* types of the language *)

  Context {Rule : Tree ??(@PLJudg T) -> Tree ??(@PLJudg T) -> Type}.
     Notation "cs |= ss" := (@sequent T cs ss) : pl_scope.

  Notation "H /⋯⋯/ C" := (ND Rule H C) : pl_scope.

  Open Scope pf_scope.
  Open Scope nd_scope.
  Open Scope pl_scope.

  Context (PL:@ProgrammingLanguage T Rule).

  (* category of judgments in a fixed type/coercion context *)
  Definition Judgments_cartesian := @Judgments_Category_CartesianCat _ Rule pl_eqv.

  Definition JudgmentsL          := Judgments_cartesian.

  Definition identityProof t : [] ~~{JudgmentsL}~~> [t |= t].
    unfold hom; simpl.
    apply snd_initial.
    Defined.

  Definition cutProof a b c : [a |= b],,[b |= c] ~~{JudgmentsL}~~> [a |= c].
    unfold hom; simpl.
    apply snd_cut.
    Defined.

  Instance TypesL : ECategory JudgmentsL (Tree ??T) (fun x y => [x|=y]) :=
  { eid   := identityProof
  ; ecomp := cutProof
  }.
    intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
    intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
    abstract (intros; unfold identityProof; unfold cutProof; simpl; eapply cndr_inert; auto; apply PL).
    abstract (intros; unfold identityProof; unfold cutProof; simpl; eapply cndr_inert; auto; apply PL).
    abstract (intros; unfold identityProof; unfold cutProof; simpl; eapply cndr_inert;
                [ apply PL | idtac | idtac ]; apply ndpc_comp; auto).
    Defined.

  Instance Types_first c : EFunctor TypesL TypesL (fun x => x,,c ) :=
    { efunc := fun x y => cnd_expand_right(ContextND:=pl_cnd) x y c }.
    intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
    abstract (intros; simpl; apply (cndr_inert pl_cnd); auto).
    abstract (intros; unfold ehom; unfold comp; simpl; unfold cutProof;
              rewrite <- (@ndr_prod_preserves_comp _ _ PL _ _ (cnd_expand_right _ _ c) _ _ (nd_id1 (b|=c0))
                          _ (nd_id1 (a,,c |= b,,c))  _ (cnd_expand_right _ _ c));
              setoid_rewrite (@ndr_comp_right_identity _ _ PL _ [a,, c |= b,, c]);
              setoid_rewrite (@ndr_comp_left_identity  _ _ PL [b |= c0]);
              simpl; eapply cndr_inert; [ apply PL | auto | auto ]).
    Defined.

  Instance Types_second c : EFunctor TypesL TypesL (fun x => c,,x) :=
    { efunc := fun x y => ((@cnd_expand_left _ _ _ _ _ _ x y c)) }.
    intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
    abstract (intros; simpl; apply (cndr_inert pl_cnd); auto).
    intros; unfold ehom; unfold comp; simpl; unfold cutProof;
    abstract (rewrite <- (@ndr_prod_preserves_comp _ _ PL _ _ (cnd_expand_left _ _ c) _ _ (nd_id1 (b|=c0))
                          _ (nd_id1 (c,,a |= c,,b))  _ (cnd_expand_left _ _ c));
              setoid_rewrite (@ndr_comp_right_identity _ _ PL _ [c,,a |= c,,b]);
              setoid_rewrite (@ndr_comp_left_identity  _ _ PL [b |= c0]);
              simpl; eapply cndr_inert; [ apply PL | auto | auto ]).
    Defined.

  Instance Types_binoidal : EBinoidalCat TypesL (@T_Branch _) :=
  { ebc_first  := Types_first
  ; ebc_second := Types_second
  }.

  Instance Types_assoc_iso a b c : Isomorphic(C:=TypesL) ((a,,b),,c) (a,,(b,,c)) :=
  { iso_forward  := snd_initial _ ;; cnd_ant_cossa _ a b c
  ; iso_backward := snd_initial _ ;; cnd_ant_assoc _ a b c
  }.
    abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
    abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
    Defined.

  Instance Types_cancelr_iso a : Isomorphic(C:=TypesL) (a,,[]) a :=
  { iso_forward  := snd_initial _ ;; cnd_ant_rlecnac _ a
  ; iso_backward := snd_initial _ ;; cnd_ant_cancelr _ a
  }.
    abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
    abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
    Defined.

  Instance Types_cancell_iso a : Isomorphic(C:=TypesL) ([],,a) a :=
    { iso_forward  := snd_initial _ ;; cnd_ant_llecnac _ a
    ; iso_backward := snd_initial _ ;; cnd_ant_cancell _ a
    }.
    abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
    abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
    Defined.

  Lemma coincide' : nd_llecnac === nd_rlecnac.
    set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
    set (isos_forward_equal_then_backward_equal _ _ q') as qq.
    apply qq.
    Qed.

  Lemma Types_assoc_lemma : ∀a b X Y : TypesL,
      ∀f : X ~~{ TypesL }~~> Y,
      #(Types_assoc_iso a X b) >>> (Types_first b >>>> Types_second a) \ f ~~
      (Types_second a >>>> Types_first b) \ f >>> #(Types_assoc_iso a Y b).
    intros.
    Opaque nd_id.
      simpl.
      Transparent nd_id.
    unfold ehom.

    nd_swap_ltac p PL.
      setoid_rewrite p.
      clear p.

    repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).

    setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
    setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
    setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
    setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).

    setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

    set (ni_commutes' (jud_mon_cancelr PL) f) as q.
      simpl in q.
      setoid_rewrite <- q.
      clear q.

    set (ni_commutes' (jud_mon_cancell PL) f) as q.
      simpl in q.
      setoid_rewrite coincide' in q.
      setoid_rewrite <- q.
      clear q.

    setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      apply ndr_comp_respects; try reflexivity.

    apply (cndr_inert pl_cnd); auto; ndpc_tac; auto.
    Qed.

  Instance Types_assoc a b : Types_second a >>>> Types_first b <~~~> Types_first b >>>> Types_second a :=
    { ni_iso := fun c => Types_assoc_iso a c b }.
    apply Types_assoc_lemma.
    Defined.

  Lemma Types_assoc_ll_lemma :
    ∀a b X Y : TypesL,
    ∀f : X ~~{ TypesL }~~> Y,
    #(Types_assoc_iso a b X) >>> (Types_second b >>>> Types_second a) \ f ~~
    Types_second (a,, b) \ f >>> #(Types_assoc_iso a b Y).

    intros.
    Opaque nd_id.
    simpl.
    Transparent nd_id.
    unfold ehom.
    nd_swap_ltac p PL.
    setoid_rewrite p.
    clear p.

    setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
    setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
    setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).

    repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

    set (ni_commutes' (jud_mon_cancelr PL) f) as q.
    Opaque nd_id.
    simpl in q.
    setoid_rewrite <- q.

    clear q.
    set (ni_commutes' (jud_mon_cancell PL) f) as q.
    simpl in q.
    set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
    set (isos_forward_equal_then_backward_equal _ _ q') as qq.
    simpl in qq.
    setoid_rewrite qq in q.
    clear q' qq.
    setoid_rewrite <- q.

    setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    apply ndr_comp_respects; try reflexivity.

    Transparent nd_id.
    apply (cndr_inert pl_cnd); auto; ndpc_tac.
    Qed.

  Instance Types_assoc_ll a b : Types_second (a,,b) <~~~> Types_second b >>>> Types_second a :=
    { ni_iso := fun c => Types_assoc_iso a b c }.
    apply Types_assoc_ll_lemma.
    Defined.

  Lemma Types_assoc_rr_lemma :
    ∀a b A B : TypesL,
    ∀f : A ~~{ TypesL }~~> B,
    #(Types_assoc_iso A a b) ⁻¹ >>> (Types_first a >>>> Types_first b) \ f ~~
    Types_first (a,, b) \ f >>> #(Types_assoc_iso B a b) ⁻¹.
    intros.
    Opaque nd_id.
    simpl.
    Transparent nd_id.

    rename A into X.
    rename B into Y.
    unfold ehom.
    nd_swap_ltac p PL.
    setoid_rewrite p.
    clear p.

    setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
    setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
    setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).

    repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

    set (ni_commutes' (jud_mon_cancelr PL) f) as q.
    Opaque nd_id.
    simpl in q.
    setoid_rewrite <- q.

    clear q.
    set (ni_commutes' (jud_mon_cancell PL) f) as q.
    simpl in q.
    set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
    set (isos_forward_equal_then_backward_equal _ _ q') as qq.
    simpl in qq.
    setoid_rewrite qq in q.
    clear q' qq.
    setoid_rewrite <- q.

    setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    apply ndr_comp_respects; try reflexivity.

    Transparent nd_id.
    apply (cndr_inert pl_cnd); auto; ndpc_tac.
    Qed.

  Instance Types_assoc_rr a b : Types_first (a,,b) <~~~> Types_first a >>>> Types_first b :=
    { ni_iso := fun c => iso_inv _ _ (Types_assoc_iso c a b) }.
    apply Types_assoc_rr_lemma.
    Defined.

  Lemma Types_cancelr_lemma :
    ∀A B : TypesL,
    ∀f : A ~~{ TypesL }~~> B,
    #(Types_cancelr_iso A) >>> functor_id TypesL \ f ~~
    Types_first [] \ f >>> #(Types_cancelr_iso B).
    intros.
    Opaque nd_id.
    simpl.
    unfold ehom.
    nd_swap_ltac p PL.
    setoid_rewrite p.
    setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
    repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

    set (ni_commutes' (jud_mon_cancelr PL) f) as q.
    Opaque nd_id.
    simpl in q.
    setoid_rewrite <- q.
    clear q.

    set (ni_commutes' (jud_mon_cancell PL) f) as q.
    simpl in q.
    set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
    set (isos_forward_equal_then_backward_equal _ _ q') as qq.
    simpl in qq.
    setoid_rewrite qq in q.
    clear q' qq.
    setoid_rewrite <- q.

    setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    apply ndr_comp_respects; try reflexivity.
    Transparent nd_id.
    simpl.
    apply (cndr_inert pl_cnd); auto; ndpc_tac.
    Qed.

  Instance Types_cancelr   : Types_first [] <~~~> functor_id _ :=
    { ni_iso := Types_cancelr_iso }.
    apply Types_cancelr_lemma.
    Defined.

  Lemma Types_cancell_lemma :
    ∀A B : TypesL,
    ∀f : A ~~{ TypesL }~~> B,
    #(Types_cancell_iso A) >>> functor_id TypesL \ f ~~
    Types_second [] \ f >>> #(Types_cancell_iso B).
    intros.
    Opaque nd_id.
    simpl.
    unfold ehom.
    nd_swap_ltac p PL.
    setoid_rewrite p.
    setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
    repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
    setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

    set (ni_commutes' (jud_mon_cancelr PL) f) as q.
    Opaque nd_id.
    simpl in q.
    setoid_rewrite <- q.
    clear q.

    set (ni_commutes' (jud_mon_cancell PL) f) as q.
    simpl in q.
    set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
    set (isos_forward_equal_then_backward_equal _ _ q') as qq.
    simpl in qq.
    setoid_rewrite qq in q.
    clear q' qq.
    setoid_rewrite <- q.
    setoid_rewrite (@ndr_comp_associativity _ Rule PL).

    apply ndr_comp_respects; try reflexivity.
    Transparent nd_id.
    simpl.
    apply (cndr_inert pl_cnd); auto; ndpc_tac.
    Qed.

  Instance Types_cancell   : Types_second [] <~~~> functor_id _ :=
    { ni_iso := Types_cancell_iso }.
    apply Types_cancell_lemma.
    Defined.

  Lemma TypesL_assoc_central a b c : CentralMorphism(H:=Types_binoidal) #((Types_assoc a b) c).
    intros.
      apply Build_CentralMorphism.
      intros.
      unfold bin_obj.
      unfold ebc_bobj.
      Opaque nd_id.
      simpl.
      unfold ehom.
      nd_swap_ltac p PL.
      setoid_rewrite p.
      clear p.
      setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
      setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
      repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

      set (ni_commutes' (jud_mon_cancelr PL) g) as q.
      Opaque nd_id.
      simpl in q.
      setoid_rewrite <- q.
      clear q.

      set (ni_commutes' (jud_mon_cancell PL) g) as q.
      simpl in q.
      set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
      set (isos_forward_equal_then_backward_equal _ _ q') as qq.
      simpl in qq.
      setoid_rewrite qq in q.
      clear q' qq.
      setoid_rewrite <- q.

      setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      apply ndr_comp_respects.
      reflexivity.

      Transparent nd_id.
      apply (cndr_inert pl_cnd); auto; ndpc_tac.

      Opaque nd_id.
      intros.
      unfold bin_obj.
      unfold ebc_bobj.
      simpl.
      unfold ehom.
      symmetry.
      nd_swap_ltac p PL.
      setoid_rewrite p.
      clear p.
      setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
      setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
      repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

      set (ni_commutes' (jud_mon_cancelr PL) g) as q.
      Opaque nd_id.
      simpl in q.
      setoid_rewrite <- q.
      clear q.

      set (ni_commutes' (jud_mon_cancell PL) g) as q.
      simpl in q.
      set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
      set (isos_forward_equal_then_backward_equal _ _ q') as qq.
      simpl in qq.
      setoid_rewrite qq in q.
      clear q' qq.
      setoid_rewrite <- q.

      setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      apply ndr_comp_respects.
      reflexivity.

      Transparent nd_id.
      apply (cndr_inert pl_cnd); auto; ndpc_tac.
      Qed.

  Lemma TypesL_cancell_central a : CentralMorphism(H:=Types_binoidal) #(Types_cancell a).
    intros.
      apply Build_CentralMorphism.
      Opaque nd_id.
      intros.
      unfold bin_obj.
      unfold ebc_bobj.
      simpl.
      unfold ehom.
      nd_swap_ltac p PL.
      setoid_rewrite p.
      clear p.
      setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
      setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
      repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

      set (ni_commutes' (jud_mon_cancelr PL) g) as q.
      Opaque nd_id.
      simpl in q.
      setoid_rewrite <- q.
      clear q.

      set (ni_commutes' (jud_mon_cancell PL) g) as q.
      simpl in q.
      set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
      set (isos_forward_equal_then_backward_equal _ _ q') as qq.
      simpl in qq.
      setoid_rewrite qq in q.
      clear q' qq.
      setoid_rewrite <- q.

      setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      apply ndr_comp_respects.
      reflexivity.

      Transparent nd_id.
      apply (cndr_inert pl_cnd); auto; ndpc_tac.

      Opaque nd_id.
      intros.
      unfold bin_obj.
      unfold ebc_bobj.
      simpl.
      unfold ehom.
      symmetry.
      nd_swap_ltac p PL.
      setoid_rewrite p.
      clear p.
      setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
      setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
      repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

      set (ni_commutes' (jud_mon_cancelr PL) g) as q.
      Opaque nd_id.
      simpl in q.
      setoid_rewrite <- q.
      clear q.

      set (ni_commutes' (jud_mon_cancell PL) g) as q.
      simpl in q.
      set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
      set (isos_forward_equal_then_backward_equal _ _ q') as qq.
      simpl in qq.
      setoid_rewrite qq in q.
      clear q' qq.
      setoid_rewrite <- q.

      setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      apply ndr_comp_respects.
      reflexivity.

      Transparent nd_id.
      apply (cndr_inert pl_cnd); auto; ndpc_tac.
      Qed.

  Lemma TypesL_cancelr_central a : CentralMorphism(H:=Types_binoidal) #(Types_cancelr a).
    intros.
      apply Build_CentralMorphism.
      Opaque nd_id.
      intros.
      unfold bin_obj.
      unfold ebc_bobj.
      simpl.
      unfold ehom.
      nd_swap_ltac p PL.
      setoid_rewrite p.
      clear p.
      setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
      setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
      repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

      set (ni_commutes' (jud_mon_cancelr PL) g) as q.
      Opaque nd_id.
      simpl in q.
      setoid_rewrite <- q.
      clear q.

      set (ni_commutes' (jud_mon_cancell PL) g) as q.
      simpl in q.
      set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
      set (isos_forward_equal_then_backward_equal _ _ q') as qq.
      simpl in qq.
      setoid_rewrite qq in q.
      clear q' qq.
      setoid_rewrite <- q.

      setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      apply ndr_comp_respects.
      reflexivity.

      Transparent nd_id.
      apply (cndr_inert pl_cnd); auto; ndpc_tac.

      Opaque nd_id.
      intros.
      unfold bin_obj.
      unfold ebc_bobj.
      simpl.
      unfold ehom.
      symmetry.
      nd_swap_ltac p PL.
      setoid_rewrite p.
      clear p.
      setoid_rewrite (@nd_prod_split_left  _ Rule PL _ _ _ []).
      setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
      repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).

      set (ni_commutes' (jud_mon_cancelr PL) g) as q.
      Opaque nd_id.
      simpl in q.
      setoid_rewrite <- q.
      clear q.

      set (ni_commutes' (jud_mon_cancell PL) g) as q.
      simpl in q.
      set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
      set (isos_forward_equal_then_backward_equal _ _ q') as qq.
      simpl in qq.
      setoid_rewrite qq in q.
      clear q' qq.
      setoid_rewrite <- q.

      setoid_rewrite (@ndr_comp_associativity _ Rule PL).
      apply ndr_comp_respects.
      reflexivity.

      Transparent nd_id.
      apply (cndr_inert pl_cnd); auto; ndpc_tac.
      Qed.

  Instance TypesL_PreMonoidal : PreMonoidalCat Types_binoidal [] :=
    { pmon_assoc    := Types_assoc
    ; pmon_cancell  := Types_cancell
    ; pmon_cancelr  := Types_cancelr
    ; pmon_assoc_rr := Types_assoc_rr
    ; pmon_assoc_ll := Types_assoc_ll
    }.
    abstract (apply Build_Pentagon; intros; simpl; eapply cndr_inert; try apply PL; ndpc_tac).
    abstract (apply Build_Triangle; intros; simpl; eapply cndr_inert; try apply PL; ndpc_tac).
    intros; simpl; reflexivity.
    intros; simpl; reflexivity.
    apply TypesL_assoc_central.
    apply TypesL_cancelr_central.
    apply TypesL_cancell_central.
    Defined.

End ProgrammingLanguageCategory.