(* Puiseux_base.v *)

(* Most of notations are Robert Walker's ones *)

Require Import Utf8 QArith Sorting.

Require Import ConvexHull.
Require Import ConvexHullMisc.
Require Import Misc.
Require Import NbarM.
Require Import QbarM.
Require Import Newton.
Require Import Field2.
Require Import Fpolynomial.
Require Import Power_series.
Require Import Puiseux_series.
Require Import Ps_add.
Require Import Ps_add_compat.
Require Import Ps_mul.
Require Import Ps_div.

Set Implicit Arguments.

Definition order {α} {r : ring α} {K : field r} ps :=
  match series_order (ps_terms ps) 0 with
  | fin v => qfin (ps_ordnum ps + Z.of_nat v # ps_polydo ps)
  | ∞ => qinf
  end.

Arguments order _ _ _ ps%ps_scope.

Definition order_coeff α {R : ring α} {K : field R} ps :=
  match series_order (ps_terms ps) 0 with
  | fin v => (ps_terms ps) .[v]
  | ∞ => (0)%K
  end.

Fixpoint power_list α pow (psl : list α) :=
  match psl with
  | [] => []
  | [ps₁ … psl₁] => [(pow, ps₁) … power_list (S pow) psl₁]
  end.

Definition qpower_list α pow (psl : list (puiseux_series α)) :=
  List.map (pair_rec (λ pow ps, (Qnat pow, ps))) (power_list pow psl).

Fixpoint filter_finite_ord α (r : ring α) {K : field r}
    (dpl : list (Q * puiseux_series α)) :=
  match dpl with
  | [(pow, ps) … dpl₁] =>
      match order ps with
      | qfin v => [(pow, v) … filter_finite_ord dpl₁]
      | qinf => filter_finite_ord dpl₁
      end
  | [] =>
      []
  end.

Definition points_of_ps_lap_gen α {r} {K : field r} pow
    (cl : list (puiseux_series α)) :=
  filter_finite_ord (qpower_list pow cl).

Definition points_of_ps_lap α {R : ring α} {K : field R} lps :=
  points_of_ps_lap_gen 0 lps.

Definition points_of_ps_polynom α {R : ring α} {K : field R} pol :=
  points_of_ps_lap (al pol).

Definition newton_segments α {R : ring α} {K : field R} pol :=
  let gdpl := points_of_ps_polynom pol in
  lower_convex_hull_points gdpl.

Definition puis_ser_pol α := polynomial (puiseux_series α).

(* *)

Section theorems.

Variable α : Type.
Variable r : ring α.
Variable K : field r.

Theorem fold_qpower_list : ∀ pow (psl : list (puiseux_series α)),
  List.map (pair_rec (λ pow ps, (Qnat pow, ps))) (power_list pow psl) =
  qpower_list pow psl.
Proof. reflexivity. Qed.

Theorem order_inf : ∀ x, order x = qinf ↔ (x = 0)%ps.
Proof.
intros x.
split; intros H.
 apply ps_series_order_inf_iff.
 unfold order in H.
 remember (series_order (ps_terms x) 0) as n eqn:Hn .
 symmetry in Hn.
 destruct n as [n| ]; [ discriminate H | reflexivity ].

 apply ps_series_order_inf_iff in H.
 unfold order.
 rewrite H; reflexivity.
Qed.

Theorem order_fin : ∀ x, order x ≠ qinf ↔ (x ≠ 0)%ps.
Proof.
intros x.
split; intros H I; apply H, order_inf; assumption.
Qed.

Theorem order_0 : order 0%ps = QbarM.qinf.
Proof.
unfold order; simpl.
rewrite series_order_series_0; reflexivity.
Qed.

Theorem ps_zerop : ∀ a, {(a = 0)%ps} + {(a ≠ 0)%ps}.
Proof.
intros a.
destruct (Qbar.eq_dec (order a) QbarM.qinf) as [H| H].
 left.
 apply order_inf.
 unfold Qbar.qeq in H.
 destruct (order a); [ contradiction | reflexivity ].

 right.
 intros HH; apply H.
 apply order_inf in HH.
 rewrite HH; reflexivity.
Qed.

Theorem points_of_polyn_sorted : ∀ deg (cl : list (puiseux_series α)) pts,
  pts = points_of_ps_lap_gen deg cl
  → Sorted fst_lt pts.
Proof.
intros deg cl pts Hpts.
destruct cl as [| c₁]; [ subst pts; constructor | idtac ].
revert deg c₁ pts Hpts.
induction cl as [| c]; intros.
 unfold points_of_ps_lap_gen in Hpts; simpl in Hpts.
 destruct (order c₁); subst pts; constructor; constructor.

 unfold points_of_ps_lap_gen in Hpts.
 remember [c … cl] as ccl; simpl in Hpts; subst ccl.
 destruct (order c₁) as [q | ]; [ idtac | eapply IHcl; eassumption ].
 remember (points_of_ps_lap_gen (S deg) [c … cl]) as pts₁.
 subst pts; rename pts₁ into pts; rename Heqpts₁ into Hpts.
 clear IHcl.
 clear c₁.
 revert deg c q pts Hpts.
 induction cl as [| c₂]; intros.
  simpl.
  unfold points_of_ps_lap_gen in Hpts; simpl in Hpts.
  destruct (order c).
   constructor; constructor; [ constructor | constructor | idtac ].
   apply Qnat_lt, lt_n_Sn.

   constructor; constructor.

  unfold points_of_ps_lap_gen in Hpts.
  remember [c₂ … cl] as ccl; simpl in Hpts; simpl; subst ccl.
  destruct (order c) as [v₂| ].
   subst pts.
   apply Sorted_LocallySorted_iff.
   constructor; [ idtac | apply Qnat_lt, lt_n_Sn ].
   apply Sorted_LocallySorted_iff.
   eapply IHcl; reflexivity.

   eapply IHcl with (q := q) in Hpts.
   apply Sorted_minus_2nd with (x₂ := (Qnat (S deg), q)).
    unfold fst_lt.
    intros x y z; apply Qlt_trans.

    constructor; [ assumption | constructor; apply Qnat_lt, lt_n_Sn ].
Qed.

End theorems.

Theorem div_gcd_gcd_0_r : ∀ a b c d e f,
  (b / Z.gcd (Z.gcd a b) c)%Z = (e / Z.gcd (Z.gcd d e) f)%Z
  → e = 0%Z
    → (a * e)%Z = (d * b)%Z.
Proof.
intros a b c d e f Hb He.
subst e.
rewrite Z.mul_0_r.
rewrite Z.gcd_0_r in Hb.
destruct (Z_zerop d) as [Hd| Hd].
 subst d; rewrite Z.mul_0_l; reflexivity.

 rewrite Z.div_0_l in Hb.
  rewrite Z.gcd_comm, Z.gcd_assoc in Hb.
  pose proof (Z.gcd_divide_l b (Z.gcd c a)) as H.
  destruct H as (e, H).
  rewrite Z.gcd_comm in H.
  remember (Z.gcd (Z.gcd c a) b) as g.
  rewrite H in Hb.
  destruct (Z_zerop g) as [Hg| Hg].
   move Hg at top; subst g.
   rewrite Z.mul_0_r in H; subst b.
   rewrite Z.mul_0_r; reflexivity.

   rewrite Z.div_mul in Hb; [ idtac | assumption ].
   subst e b.
   rewrite Z.mul_0_l, Z.mul_0_r; reflexivity.

  intros H.
  apply Z.gcd_eq_0_l in H.
  apply Hd.
  apply Z.abs_0_iff; assumption.
Qed.

Theorem div_gcd_gcd_mul_compat : ∀ a b c d e f,
  (a / Z.gcd (Z.gcd a b) c)%Z = (d / Z.gcd (Z.gcd d e) f)%Z
  → (b / Z.gcd (Z.gcd a b) c)%Z = (e / Z.gcd (Z.gcd d e) f)%Z
    → (a * e)%Z = (d * b)%Z.
Proof.
intros a b c d e f Ha Hb.
destruct (Z_zerop e) as [He| He].
 eapply div_gcd_gcd_0_r; eassumption.

 destruct (Z_zerop d) as [Hd| Hd].
  rewrite Z.mul_comm; symmetry.
  rewrite Z.mul_comm; symmetry.
  symmetry.
  apply div_gcd_gcd_0_r with (c := c) (f := f); [ idtac | assumption ].
  replace (Z.gcd b a) with (Z.gcd a b) by apply Z.gcd_comm.
  replace (Z.gcd e d) with (Z.gcd d e) by apply Z.gcd_comm.
  assumption.

  apply Z.mul_cancel_r with (p := e) in Ha; [ idtac | assumption ].
  rewrite Z_div_mul_swap in Ha.
   rewrite Z_div_mul_swap in Ha.
    apply Z.mul_cancel_l with (p := d) in Hb; [ idtac | assumption ].
    rewrite Z.mul_comm in Hb.
    rewrite Z_div_mul_swap in Hb.
     symmetry in Hb.
     rewrite Z.mul_comm in Hb.
     rewrite Z_div_mul_swap in Hb.
      rewrite Z.mul_comm in Hb.
      rewrite Hb in Ha.
      apply Z_div_reg_r in Ha.
       rewrite Ha; apply Z.mul_comm.

       apply Z.divide_mul_l.
       rewrite <- Z.gcd_assoc.
       apply Z.gcd_divide_l.

       apply Z.divide_mul_l.
       rewrite Z.gcd_comm, Z.gcd_assoc.
       apply Z.gcd_divide_r.

      rewrite Z.gcd_comm, Z.gcd_assoc.
      apply Z.gcd_divide_r.

     rewrite Z.gcd_comm, Z.gcd_assoc.
     apply Z.gcd_divide_r.

    rewrite <- Z.gcd_assoc.
    apply Z.gcd_divide_l.

   rewrite <- Z.gcd_assoc.
   apply Z.gcd_divide_l.
Qed.

Add Parametric Morphism α (R : ring α) (K : field R) : (@order α R K)
  with signature eq_ps ==> Qbar.qeq
  as order_morph.
Proof.
intros a b Hab.
inversion Hab; subst.
unfold normalise_ps in H; simpl in H.
unfold order.
remember (series_order (ps_terms a) 0) as na eqn:Hna .
remember (series_order (ps_terms b) 0) as nb eqn:Hnb .
symmetry in Hna, Hnb.
destruct na as [na| ].
 destruct nb as [nb| ].
  inversion_clear H.
  simpl in H0, H1, H2.
  unfold Qbar.qeq, Qeq; simpl.
  unfold normalise_series in H2.
  remember (greatest_series_x_power K (ps_terms a) na) as apn.
  remember (greatest_series_x_power K (ps_terms b) nb) as bpn.
  assert (0 < gcd_ps na apn a)%Z as Hpga by apply gcd_ps_is_pos.
  assert (0 < gcd_ps nb bpn b)%Z as Hpgb by apply gcd_ps_is_pos.
  unfold gcd_ps in H0, H1, H2, Hpga, Hpgb.
  remember (ps_ordnum a + Z.of_nat na)%Z as ao eqn:Hao .
  remember (ps_ordnum b + Z.of_nat nb)%Z as bo eqn:Hbo .
  remember (Z.of_nat apn) as ap eqn:Hap ; subst apn.
  remember (Z.of_nat bpn) as bp eqn:Hbp ; subst bpn.
  remember (Zpos (ps_polydo a))%Z as oa eqn:Hoa .
  remember (Zpos (ps_polydo b))%Z as ob eqn:Hob .
  apply Z2Pos.inj in H1.
   eapply div_gcd_gcd_mul_compat; eassumption.

   apply Z.div_str_pos.
   split; [ assumption | idtac ].
   rewrite Z.gcd_comm, Z.gcd_assoc, Hoa.
   apply Z_gcd_pos_r_le.

   apply Z.div_str_pos.
   split; [ assumption | idtac ].
   rewrite Z.gcd_comm, Z.gcd_assoc, Hob.
   apply Z_gcd_pos_r_le.

  apply ps_series_order_inf_iff in Hnb.
  rewrite Hnb in Hab.
  apply ps_series_order_inf_iff in Hab.
  rewrite Hab in Hna; discriminate Hna.

 apply ps_series_order_inf_iff in Hna.
 rewrite Hna in Hab.
 symmetry in Hab.
 apply ps_series_order_inf_iff in Hab.
 rewrite Hab in Hnb.
 subst nb; reflexivity.
Qed.

Definition ps_field α {R : ring α} {K : field R} : field (ps_ring K) :=
  {| fld_inv := ps_inv;
     fld_mul_inv_l := ps_mul_inv_l (f := K);
     fld_zerop := ps_zerop K |}.

Canonical Structure ps_field.


Definition and_bool (b1 b2 : bool) : bool :=
  match b1 , b2 with
  | true  , b2 => b2
  | false , b2 => false
  end.

Lemma and_false_left : forall b, and_bool false b = false.
Proof.
  intro Hb.
  simpl.
  reflexivity.
Qed.


(* generated by Ott 0.25, locally-nameless lngen from: f.ott *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition a := var. (*r type variables *)
Definition x := var. (*r variables *)
Definition i := nat. (*r integer literals *)

Inductive t : Set :=  (*r types *)
 | t_var_b (_:nat)
 | t_var_f (a5:a)
 | t_int : t
 | t_arr (t1:t) (t2:t)
 | t_all (t5:t)
 | t_prod (t1:t) (t2:t).

Inductive p : Set :=  (*r primitives *)
 | p_plus : p
 | p_minus : p.

Definition D : Set := list a.

Inductive u : Set :=  (*r terms *)
 | u_var_b (_:nat)
 | u_var_f (x5:x)
 | u_int (i5:i)
 | u_fix (t1:t) (t2:t) (e:u)
 | u_lam (t1:t) (e:u)
 | u_app (e1:u) (e2:u)
 | u_tlam (e:u)
 | u_tapp (e:u) (t5:t)
 | u_pair (e1:u) (e2:u)
 | u_prl (e:u)
 | u_prr (e:u)
 | u_prim (e1:u) (p5:p) (e2:u)
 | u_if0 (e1:u) (e2:u) (e3:u)
 | u_ann (u5:u) (t5:t) (*r annotated terms *).

Definition G : Set := list (x * t).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_t_wrt_t_rec (k:nat) (t_6:t) (t__7:t) {struct t__7}: t :=
  match t__7 with
  | (t_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => t_var_b nat
        | inleft (right _) => t_6
        | inright _ => t_var_b (nat - 1)
      end
  | (t_var_f a5) => t_var_f a5
  | t_int => t_int
  | (t_arr t1 t2) => t_arr (open_t_wrt_t_rec k t_6 t1) (open_t_wrt_t_rec k t_6 t2)
  | (t_all t5) => t_all (open_t_wrt_t_rec (S k) t_6 t5)
  | (t_prod t1 t2) => t_prod (open_t_wrt_t_rec k t_6 t1) (open_t_wrt_t_rec k t_6 t2)
end.

Fixpoint open_u_wrt_u_rec (k:nat) (e_5:u) (e__6:u) {struct e__6}: u :=
  match e__6 with
  | (u_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => u_var_b nat
        | inleft (right _) => e_5
        | inright _ => u_var_b (nat - 1)
      end
  | (u_var_f x5) => u_var_f x5
  | (u_int i5) => u_int i5
  | (u_fix t1 t2 e) => u_fix t1 t2 (open_u_wrt_u_rec (S k) e_5 e)
  | (u_lam t1 e) => u_lam t1 (open_u_wrt_u_rec (S k) e_5 e)
  | (u_app e1 e2) => u_app (open_u_wrt_u_rec k e_5 e1) (open_u_wrt_u_rec k e_5 e2)
  | (u_tlam e) => u_tlam (open_u_wrt_u_rec k e_5 e)
  | (u_tapp e t5) => u_tapp (open_u_wrt_u_rec k e_5 e) t5
  | (u_pair e1 e2) => u_pair (open_u_wrt_u_rec k e_5 e1) (open_u_wrt_u_rec k e_5 e2)
  | (u_prl e) => u_prl (open_u_wrt_u_rec k e_5 e)
  | (u_prr e) => u_prr (open_u_wrt_u_rec k e_5 e)
  | (u_prim e1 p5 e2) => u_prim (open_u_wrt_u_rec k e_5 e1) p5 (open_u_wrt_u_rec k e_5 e2)
  | (u_if0 e1 e2 e3) => u_if0 (open_u_wrt_u_rec k e_5 e1) (open_u_wrt_u_rec k e_5 e2) (open_u_wrt_u_rec k e_5 e3)
  | (u_ann u5 t5) => u_ann (open_u_wrt_u_rec k e_5 u5) t5
end.

Fixpoint open_u_wrt_t_rec (k:nat) (t_6:t) (e_5:u) {struct e_5}: u :=
  match e_5 with
  | (u_var_b nat) => u_var_b nat
  | (u_var_f x5) => u_var_f x5
  | (u_int i5) => u_int i5
  | (u_fix t1 t2 e) => u_fix (open_t_wrt_t_rec k t_6 t1) (open_t_wrt_t_rec k t_6 t2) (open_u_wrt_t_rec k t_6 e)
  | (u_lam t1 e) => u_lam (open_t_wrt_t_rec k t_6 t1) (open_u_wrt_t_rec k t_6 e)
  | (u_app e1 e2) => u_app (open_u_wrt_t_rec k t_6 e1) (open_u_wrt_t_rec k t_6 e2)
  | (u_tlam e) => u_tlam (open_u_wrt_t_rec (S k) t_6 e)
  | (u_tapp e t5) => u_tapp (open_u_wrt_t_rec k t_6 e) (open_t_wrt_t_rec k t_6 t5)
  | (u_pair e1 e2) => u_pair (open_u_wrt_t_rec k t_6 e1) (open_u_wrt_t_rec k t_6 e2)
  | (u_prl e) => u_prl (open_u_wrt_t_rec k t_6 e)
  | (u_prr e) => u_prr (open_u_wrt_t_rec k t_6 e)
  | (u_prim e1 p5 e2) => u_prim (open_u_wrt_t_rec k t_6 e1) p5 (open_u_wrt_t_rec k t_6 e2)
  | (u_if0 e1 e2 e3) => u_if0 (open_u_wrt_t_rec k t_6 e1) (open_u_wrt_t_rec k t_6 e2) (open_u_wrt_t_rec k t_6 e3)
  | (u_ann u5 t5) => u_ann (open_u_wrt_t_rec k t_6 u5) (open_t_wrt_t_rec k t_6 t5)
end.

Definition open_u_wrt_u e_5 e__6 := open_u_wrt_u_rec 0 e__6 e_5.

Definition open_u_wrt_t t_6 e_5 := open_u_wrt_t_rec 0 e_5 t_6.

Definition open_t_wrt_t t_6 t__7 := open_t_wrt_t_rec 0 t__7 t_6.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_t *)
Inductive lc_t : t -> Prop :=    (* defn lc_t *)
 | lc_t_var_f : forall (a5:a),
     (lc_t (t_var_f a5))
 | lc_t_int :
     (lc_t t_int)
 | lc_t_arr : forall (t1 t2:t),
     (lc_t t1) ->
     (lc_t t2) ->
     (lc_t (t_arr t1 t2))
 | lc_t_all : forall (t5:t),
      ( forall a5 , lc_t  ( open_t_wrt_t t5 (t_var_f a5) )  )  ->
     (lc_t (t_all t5))
 | lc_t_prod : forall (t1 t2:t),
     (lc_t t1) ->
     (lc_t t2) ->
     (lc_t (t_prod t1 t2)).

(* defns LC_u *)
Inductive lc_u : u -> Prop :=    (* defn lc_u *)
 | lc_u_var_f : forall (x5:x),
     (lc_u (u_var_f x5))
 | lc_u_int : forall (i5:i),
     (lc_u (u_int i5))
 | lc_u_fix : forall (t1 t2:t) (e:u),
     (lc_t t1) ->
     (lc_t t2) ->
      ( forall x5 , lc_u  ( open_u_wrt_u e (u_var_f x5) )  )  ->
     (lc_u (u_fix t1 t2 e))
 | lc_u_lam : forall (t1:t) (e:u),
     (lc_t t1) ->
      ( forall x1 , lc_u  ( open_u_wrt_u e (u_var_f x1) )  )  ->
     (lc_u (u_lam t1 e))
 | lc_u_app : forall (e1 e2:u),
     (lc_u e1) ->
     (lc_u e2) ->
     (lc_u (u_app e1 e2))
 | lc_u_tlam : forall (e:u),
      ( forall a5 , lc_u  ( open_u_wrt_t e (t_var_f a5) )  )  ->
     (lc_u (u_tlam e))
 | lc_u_tapp : forall (e:u) (t5:t),
     (lc_u e) ->
     (lc_t t5) ->
     (lc_u (u_tapp e t5))
 | lc_u_pair : forall (e1 e2:u),
     (lc_u e1) ->
     (lc_u e2) ->
     (lc_u (u_pair e1 e2))
 | lc_u_prl : forall (e:u),
     (lc_u e) ->
     (lc_u (u_prl e))
 | lc_u_prr : forall (e:u),
     (lc_u e) ->
     (lc_u (u_prr e))
 | lc_u_prim : forall (e1:u) (p5:p) (e2:u),
     (lc_u e1) ->
     (lc_u e2) ->
     (lc_u (u_prim e1 p5 e2))
 | lc_u_if0 : forall (e1 e2 e3:u),
     (lc_u e1) ->
     (lc_u e2) ->
     (lc_u e3) ->
     (lc_u (u_if0 e1 e2 e3))
 | lc_u_ann : forall (u5:u) (t5:t),
     (lc_u u5) ->
     (lc_t t5) ->
     (lc_u (u_ann u5 t5)).
(** free variables *)
Fixpoint tt_fv_t (t_6:t) : vars :=
  match t_6 with
  | (t_var_b nat) => {}
  | (t_var_f a5) => {{a5}}
  | t_int => {}
  | (t_arr t1 t2) => (tt_fv_t t1) \u (tt_fv_t t2)
  | (t_all t5) => (tt_fv_t t5)
  | (t_prod t1 t2) => (tt_fv_t t1) \u (tt_fv_t t2)
end.

Fixpoint tt_fv_u (e_5:u) : vars :=
  match e_5 with
  | (u_var_b nat) => {}
  | (u_var_f x5) => {}
  | (u_int i5) => {}
  | (u_fix t1 t2 e) => (tt_fv_t t1) \u (tt_fv_t t2) \u (tt_fv_u e)
  | (u_lam t1 e) => (tt_fv_t t1) \u (tt_fv_u e)
  | (u_app e1 e2) => (tt_fv_u e1) \u (tt_fv_u e2)
  | (u_tlam e) => (tt_fv_u e)
  | (u_tapp e t5) => (tt_fv_u e) \u (tt_fv_t t5)
  | (u_pair e1 e2) => (tt_fv_u e1) \u (tt_fv_u e2)
  | (u_prl e) => (tt_fv_u e)
  | (u_prr e) => (tt_fv_u e)
  | (u_prim e1 p5 e2) => (tt_fv_u e1) \u (tt_fv_u e2)
  | (u_if0 e1 e2 e3) => (tt_fv_u e1) \u (tt_fv_u e2) \u (tt_fv_u e3)
  | (u_ann u5 t5) => (tt_fv_u u5) \u (tt_fv_t t5)
end.

Fixpoint e_fv_u (e_5:u) : vars :=
  match e_5 with
  | (u_var_b nat) => {}
  | (u_var_f x5) => {{x5}}
  | (u_int i5) => {}
  | (u_fix t1 t2 e) => (e_fv_u e)
  | (u_lam t1 e) => (e_fv_u e)
  | (u_app e1 e2) => (e_fv_u e1) \u (e_fv_u e2)
  | (u_tlam e) => (e_fv_u e)
  | (u_tapp e t5) => (e_fv_u e)
  | (u_pair e1 e2) => (e_fv_u e1) \u (e_fv_u e2)
  | (u_prl e) => (e_fv_u e)
  | (u_prr e) => (e_fv_u e)
  | (u_prim e1 p5 e2) => (e_fv_u e1) \u (e_fv_u e2)
  | (u_if0 e1 e2 e3) => (e_fv_u e1) \u (e_fv_u e2) \u (e_fv_u e3)
  | (u_ann u5 t5) => (e_fv_u u5)
end.

(** substitutions *)
Fixpoint t_subst_t (t_6:t) (a_6:a) (t__7:t) {struct t__7} : t :=
  match t__7 with
  | (t_var_b nat) => t_var_b nat
  | (t_var_f a5) => (if eq_var a5 a_6 then t_6 else (t_var_f a5))
  | t_int => t_int
  | (t_arr t1 t2) => t_arr (t_subst_t t_6 a_6 t1) (t_subst_t t_6 a_6 t2)
  | (t_all t5) => t_all (t_subst_t t_6 a_6 t5)
  | (t_prod t1 t2) => t_prod (t_subst_t t_6 a_6 t1) (t_subst_t t_6 a_6 t2)
end.

Fixpoint e_subst_u (e_5:u) (x_6:x) (e__6:u) {struct e__6} : u :=
  match e__6 with
  | (u_var_b nat) => u_var_b nat
  | (u_var_f x5) => (if eq_var x5 x_6 then e_5 else (u_var_f x5))
  | (u_int i5) => u_int i5
  | (u_fix t1 t2 e) => u_fix t1 t2 (e_subst_u e_5 x_6 e)
  | (u_lam t1 e) => u_lam t1 (e_subst_u e_5 x_6 e)
  | (u_app e1 e2) => u_app (e_subst_u e_5 x_6 e1) (e_subst_u e_5 x_6 e2)
  | (u_tlam e) => u_tlam (e_subst_u e_5 x_6 e)
  | (u_tapp e t5) => u_tapp (e_subst_u e_5 x_6 e) t5
  | (u_pair e1 e2) => u_pair (e_subst_u e_5 x_6 e1) (e_subst_u e_5 x_6 e2)
  | (u_prl e) => u_prl (e_subst_u e_5 x_6 e)
  | (u_prr e) => u_prr (e_subst_u e_5 x_6 e)
  | (u_prim e1 p5 e2) => u_prim (e_subst_u e_5 x_6 e1) p5 (e_subst_u e_5 x_6 e2)
  | (u_if0 e1 e2 e3) => u_if0 (e_subst_u e_5 x_6 e1) (e_subst_u e_5 x_6 e2) (e_subst_u e_5 x_6 e3)
  | (u_ann u5 t5) => u_ann (e_subst_u e_5 x_6 u5) t5
end.

Fixpoint t_subst_u (t_6:t) (a_6:a) (e_5:u) {struct e_5} : u :=
  match e_5 with
  | (u_var_b nat) => u_var_b nat
  | (u_var_f x5) => u_var_f x5
  | (u_int i5) => u_int i5
  | (u_fix t1 t2 e) => u_fix (t_subst_t t_6 a_6 t1) (t_subst_t t_6 a_6 t2) (t_subst_u t_6 a_6 e)
  | (u_lam t1 e) => u_lam (t_subst_t t_6 a_6 t1) (t_subst_u t_6 a_6 e)
  | (u_app e1 e2) => u_app (t_subst_u t_6 a_6 e1) (t_subst_u t_6 a_6 e2)
  | (u_tlam e) => u_tlam (t_subst_u t_6 a_6 e)
  | (u_tapp e t5) => u_tapp (t_subst_u t_6 a_6 e) (t_subst_t t_6 a_6 t5)
  | (u_pair e1 e2) => u_pair (t_subst_u t_6 a_6 e1) (t_subst_u t_6 a_6 e2)
  | (u_prl e) => u_prl (t_subst_u t_6 a_6 e)
  | (u_prr e) => u_prr (t_subst_u t_6 a_6 e)
  | (u_prim e1 p5 e2) => u_prim (t_subst_u t_6 a_6 e1) p5 (t_subst_u t_6 a_6 e2)
  | (u_if0 e1 e2 e3) => u_if0 (t_subst_u t_6 a_6 e1) (t_subst_u t_6 a_6 e2) (t_subst_u t_6 a_6 e3)
  | (u_ann u5 t5) => u_ann (t_subst_u t_6 a_6 u5) (t_subst_t t_6 a_6 t5)
end.

(** definitions *)

(* defns Jtype *)
Inductive type : D -> t -> Prop :=    (* defn type *)
 | type_var : forall (D5:D) (a5:a),
      In  a5   D5  ->
     type D5 (t_var_f a5)
 | type_int : forall (D5:D),
     type D5 t_int
 | type_arr : forall (D5:D) (t1 t2:t),
     type D5 t1 ->
     type D5 t2 ->
     type D5 (t_arr t1 t2)
 | type_all : forall (L:vars) (D5:D) (t5:t),
      ( forall a5 , a5 \notin  L  -> type  ( a5  ::  D5 )   ( open_t_wrt_t t5 (t_var_f a5) )  )  ->
     type D5 (t_all t5).

(* defns Jterm *)
Inductive term : D -> G -> u -> t -> Prop :=    (* defn term *)
 | term_ann : forall (D5:D) (G5:G) (u5:u) (t5:t),
     term D5 G5 u5 t5 ->
     term D5 G5 (u_ann u5 t5) t5
 | term_var : forall (D5:D) (G5:G) (x5:x) (t5:t),
     type D5 t5 ->
      In ( x5 ,  t5 )  G5  ->
     term D5 G5 (u_var_f x5) t5
 | term_int : forall (D5:D) (G5:G) (i5:i),
     term D5 G5 (u_int i5) t_int
 | term_lam : forall (L:vars) (D5:D) (G5:G) (t1:t) (u5:u) (t2:t),
     type D5 t1 ->
      ( forall x1 , x1 \notin  L  -> term D5  (( x1 ,  t1 ) ::  G5 )   ( open_u_wrt_u u5 (u_var_f x1) )  t2 )  ->
     term D5 G5 (u_lam t1 u5) (t_arr t1 t2)
 | term_fix : forall (L:vars) (D5:D) (G5:G) (t1 t2:t) (u5:u),
     type D5 t1 ->
     type D5 t2 ->
      ( forall x5 , x5 \notin  L  -> term D5  (( x5 ,  (t_arr t1 t2) ) ::  G5 )   ( open_u_wrt_u u5 (u_var_f x5) )  (t_arr t1 t2) )  ->
     term D5 G5 (u_fix t1 t2 u5) (t_arr t1 t2)
 | term_app : forall (D5:D) (G5:G) (e1 e2:u) (t2 t1:t),
     term D5 G5 e1 (t_arr t1 t2) ->
     term D5 G5 e2 t1 ->
     term D5 G5 (u_app e1 e2) t2
 | term_tlam : forall (L:vars) (D5:D) (G5:G) (e:u) (t5:t),
      ( forall a5 , a5 \notin  L  -> term  ( a5  ::  D5 )  G5  ( open_u_wrt_t e (t_var_f a5) )   ( open_t_wrt_t t5 (t_var_f a5) )  )  ->
     term D5 G5 (u_tlam e) (t_all t5)
 | term_tapp : forall (D5:D) (G5:G) (e:u) (t5 t':t),
     type D5 t5 ->
     term D5 G5 e (t_all t') ->
     term D5 G5 (u_tapp e t5)  (open_t_wrt_t  t' t5 )
 | term_pair : forall (D5:D) (G5:G) (e1 e2:u) (t1 t2:t),
     term D5 G5 e1 t1 ->
     term D5 G5 e2 t2 ->
     term D5 G5 (u_pair e1 e2) (t_prod t1 t2)
 | term_prl : forall (D5:D) (G5:G) (e:u) (t1 t2:t),
     term D5 G5 e (t_prod t1 t2) ->
     term D5 G5 (u_prl e) t1
 | term_prr : forall (D5:D) (G5:G) (e:u) (t2 t1:t),
     term D5 G5 e (t_prod t1 t2) ->
     term D5 G5 (u_prr e) t2
 | term_prim : forall (D5:D) (G5:G) (e1:u) (p5:p) (e2:u),
     term D5 G5 e1 t_int ->
     term D5 G5 e2 t_int ->
     term D5 G5 (u_prim e1 p5 e2) t_int
 | term_if0 : forall (D5:D) (G5:G) (e1 e2 e3:u) (t5:t),
     term D5 G5 e1 t_int ->
     term D5 G5 e2 t5 ->
     term D5 G5 e3 t5 ->
     term D5 G5 (u_if0 e1 e2 e3) t5.

(** infrastructure *)
Hint Constructors type term lc_t lc_u.


Section MonotonicityBelief.

Require Import Syntax.
Require Import ProofSystem.
Require Import Belief.
Require Import TechnicalLemmasBelief.
Require Import Setoid.

Theorem B_lt_monotonic : forall (phi : formula)(B : belief_model) (w : B_W B)
                              (v : var -> D (B_s B w)) ,
  B_models B w v phi -> forall (w' : B_W B) (l : B_lt B w w'),
                          B_models B w' (B_extend_v B w w' l v) phi.
Proof.
  induction phi.
  (* Case FocaleTrue *)
    simpl. trivial.
  (* Case FocaleFalse *)
    intros. simpl in H. inversion H.
  (* Case Rel_f *)
    intros; destruct r; simpl.
    assert (equiv_listD (B_s B w') (map (B_extend_d_lt B w w' l0)
             (map (fun x : term => B_mu B w v x) l))
             (map (fun x : term => B_mu B w' (B_extend_v B w w' l0 v) x) l)).
      apply B_equiv_list_ext.
    simpl in H.
    rewrite <- ind_R with (ds := map (B_extend_d_lt B w w' l0)
                                     (map (fun x : term => B_mu B w v x) l)).
    apply B_r_subset_lt. exact H. exact H0.
  (* Case Eq *)
    intros; simpl.
    assert (d_Eq (B_s B w') (B_mu B w' (B_extend_v B w w' l v) t)
                          (B_extend_d_lt B w w' l (B_mu B w v t))).
      symmetry; apply B_mu_same.
    assert (d_Eq (B_s B w') (B_mu B w' (B_extend_v B w w' l v) t0)
                          (B_extend_d_lt B w w' l (B_mu B w v t0))).
      symmetry; apply B_mu_same.
    transitivity (B_extend_d_lt B w w' l (B_mu B w v t)). exact H0.
    symmetry;
    transitivity (B_extend_d_lt B w w' l (B_mu B w v t0)). exact H1.
    simpl in H. apply B_eq_subset_lt. symmetry in H; exact H.
  (* Case And *)
    intros; simpl; simpl in H; split.
    apply IHphi1; apply H. apply IHphi2; apply H.
  (*Case Or *)
    intros. simpl; simpl in H. destruct H.
    left; apply IHphi1; exact H.
    right; apply IHphi2; exact H.
  (* Case Implies *)
    intros; simpl; simpl in H; intros.
    assert (B_lt B w w'0). apply B_lt_trans with (w' := w'); assumption.
    apply B_models_v_same with (v := B_extend_v B w w'0 H1 v).
    intro; rewrite B_extend_v_idempotent with (l'' := H1). reflexivity.
    apply H. apply B_models_v_same with (v := B_extend_v B w' w'0 l0
                                               (B_extend_v B w w' l v)).
    intro; rewrite B_extend_v_idempotent with (l'' := H1). reflexivity.
    exact H0.
  (* Case Not *)
    intros. simpl in H. simpl.
    intros w'' l'.
    assert (B_lt B w w'').
      apply B_lt_trans with (w' := w'); [auto | auto].
    assert (forall v1 : var, (B_extend_v B w' w'' l' (B_extend_v B w w' l v)) v1 = (B_extend_v B w w'' H0 v) v1).
      apply B_extend_v_idempotent.
    rewrite B_model_v_same with (v' := B_extend_v B w w'' H0 v). apply H.
    assumption; assumption.
  (* Case Forall*)
    intros.  simpl.
    intros w'' d l'.
    assert (B_lt B w w'').
      apply B_lt_trans with (w' := w'); assumption.
    assert (forall d : D (B_s B w''), B_subst_map B w'' (B_extend_v B w' w'' l' (B_extend_v B w w' l v0)) v d = B_subst_map B w'' (B_extend_v B w w'' H0 v0) v d).
      assert (forall v1 : var, B_extend_v B w' w'' l' (B_extend_v B w w' l v0) v1 = B_extend_v B w w'' H0 v0 v1). apply  B_extend_v_idempotent.
      assert (B_extend_v B w' w'' l' (B_extend_v B w w' l v0) = B_extend_v B w w'' H0 v0).
        apply function_same. assumption.
      rewrite H2. trivial.
    rewrite H1.
    apply H.
  (* Case Exists *)
    intros. simpl.
    simpl in H. induction H.
    exists (B_extend_d_lt B w w' l x).
    assert (forall v1 : var, B_extend_v B w w' l (B_subst_map B w v0 v x) v1 = B_subst_map B w' (B_extend_v B w w' l v0) v (B_extend_d_lt B w w' l x) v1).
      unfold B_extend_v. unfold B_subst_map. intros.
      induction (var_dec v1 v).
      trivial. trivial.
    assert (B_extend_v B w w' l (B_subst_map B w v0 v x) = B_subst_map B w' (B_extend_v B w w' l v0) v (B_extend_d_lt B w w' l x)). apply function_same. assumption.
    rewrite <- H1.
    apply IHphi with (v := B_subst_map B w v0 v x). assumption.
  (* Case Says *)
    intros. simpl; simpl in H.
    apply B_worldview_respects with (p := B_coerce_d_to_p B w (B_mu B w v t)).
    apply B_mu_pi_same.
    apply B_worldview_monotonic with (w := w). exact H.
  (* Case Speaksfor *)
    simpl; intros.
    apply B_worldview_respects with (p := B_coerce_d_to_p B w (B_mu B w v t0)).
      apply B_mu_pi_same.
    assert (B_lt B w w'0).
      apply B_lt_trans with (w' := w'); [exact l | exact l0].
    assert ((B_extend_v B w' w'0 l0 (B_extend_v B w w' l v))
           = B_extend_v B w w'0 H1 v).
      assert (forall v1 : var,
            B_extend_v B w' w'0 l0 (B_extend_v B w w' l v) v1
           = B_extend_v B w w'0 H1 v v1).
      apply B_extend_v_idempotent. apply function_same. exact H2.
    rewrite H2.
    apply H. rewrite <- H2.
    apply B_worldview_respects with (p := B_coerce_d_to_p B w'
                                           (B_mu B w'
                                             (B_extend_v B w w' l v)
                                           t)).
    apply B_p_eq_symm. apply B_mu_pi_same.
    exact H0.
Qed.

Theorem B_lt_monotonic_all : forall (B : belief_model) (w : B_W B)
                              (v : var -> D (B_s B w)) (Gamma : list formula),
  B_modelsAll B w v Gamma -> forall (w' : B_W B) (l : B_lt B w w'),
                               B_modelsAll B w' (B_extend_v B w w' l v) Gamma.
Proof.
  intros. induction Gamma as [| phi' Gamma'].
  simpl; trivial.
  simpl; split. simpl in H; apply B_lt_monotonic; apply H.
  simpl in H; apply IHGamma'. apply H.
Qed.

End MonotonicityBelief.


(* begin hide *)
Require Import Paco.paco.
From Coq Require Import Morphisms.
From ITree Require Import
     ITree
     Eq.Eqit
     Basics.HeterogeneousRelations
     Interp.TranslateFacts.
Set Implicit Arguments.
Set Strict Implicit.
(* end hide *)

(** * Unary interpretation for [eutt]: a traditional program logic.

  The weak bisimulation supported by [itree]s and the notions of
  refinements we build upon it in the various monads we interpret into
  give us reasoning principles to establish the equivalence or refinement
  of computations.
  In particular, it can be seen as a relational program logic.

  We develop here some theory for a unary program logic over itree-based computations.
  It is defined in terms of [eutt], simply taking its diagonal.
  We prove that it respects the expected elemntary proof rules w.r.t. to logical
  connectors.
  Most importantly, we derive a proof rule to leverage such unary facts during a
  relational refinement proof: see [eutt_post_bind] and [eutt_post_bind_gen].

*)

(* The main predicate: an itree-computation [t] admits [Q] for a postcondition.
  Defined as the diagonal of [eutt].
*)
Definition has_post {E X} (t : itree E X) (Q : X -> Prop) : Prop :=
  eutt (fun 'x _ => Q x) t t.

(* Note: the following formulation is equivalent. *)
Definition has_post_strong {E X} (t : itree E X) (Q : X -> Prop) : Prop :=
  eutt (fun 'x y => x = y /\ Q x) t t.

Lemma has_post_post_strong : forall {E X} (t : itree E X) Q,
    has_post t Q <-> has_post_strong t Q.
Proof.
  intros; split; intros HP.
  - apply eutt_conj; [reflexivity | auto].
  - eapply eqit_mon; eauto.
    intros * H; apply H.
Qed.

Notation "t ⤳ Q" := (has_post t Q) (at level 50).

(** [has_post] logical primitives.
    Post-conditions can be established by usual elementary logical connectives
 *)

#[global] Instance has_post_eutt {E X} : Proper (eutt eq ==> equiv_pred ==> iff) (@has_post E X).
Proof.
  repeat red; unfold has_post; intros * EUTT * EQ *; split; intros HP.
  - rewrite <- EUTT; eapply eutt_equiv; eauto.
    split; red; intros; apply EQ; auto.
  - rewrite EUTT; eapply eutt_equiv; eauto.
    split; red; intros; apply EQ; auto.
Qed.

#[global] Instance has_post_eq_itree {E X} : Proper (eq_itree eq ==> eq ==> iff) (@has_post E X).
Proof.
  repeat red; unfold has_post; intros * EUTT * EQ *; split; intros HP.
  - rewrite <- EUTT; eapply eutt_equiv; eauto.
    subst; split; red; intros; auto.
  - rewrite EUTT; eapply eutt_equiv; eauto.
    subst; split; red; intros; auto.
Qed.

Lemma has_post_conj : forall {E X} (t : itree E X) P Q,
    t ⤳ P ->
    t ⤳ Q ->
    t ⤳ (P /1\ Q).
Proof.
  intros * HP HQ.
  pose proof eutt_conj _ _ HP HQ.
  auto.
Qed.

Lemma has_post_disj_l : forall {E X} (t : itree E X) P Q,
    t ⤳ P ->
    t ⤳ (P \1/ Q).
Proof.
  intros * HP.
  epose proof eutt_disj_l _ _ HP as H.
  apply H.
Qed.

Lemma has_post_disj_r : forall {E X} (t : itree E X) P Q,
    t ⤳ Q ->
    t ⤳ (P \1/ Q).
Proof.
  intros * HQ.
  epose proof eutt_disj_r _ _ HQ as H.
  apply H.
Qed.

Lemma has_post_weaken : forall {E X} (t : itree E X) P Q,
    t ⤳ P ->
    P <1= Q ->
    t ⤳ Q.
Proof.
  intros * HP INCL.
  eapply eqit_mon; eauto.
  intros; apply INCL; auto.
Qed.

Lemma has_post_True : forall {E X} (t : itree E X),
    t ⤳ fun _ => True.
Proof.
  intros *.
  eapply eqit_mon; eauto.
  reflexivity.
Qed.

(** [has_post] structural constructs *)

Lemma has_post_bind : forall {E X Y} (t : itree E X) (k : X -> itree E Y) Q,
    (forall x, k x ⤳ Q) ->
    ITree.bind t k ⤳ Q.
Proof.
  intros * POST.
  apply eutt_eq_bind; intros ?; apply POST.
Qed.

Lemma has_post_bind_strong : forall {E X Y} (t : itree E X) (k : X -> itree E Y) S Q,
    t ⤳ S ->
    (forall x, S x -> k x ⤳ Q) ->
    ITree.bind t k ⤳ Q.
Proof.
  intros * POST1 POST2.
  apply eutt_clo_bind with (UU := fun x y => x = y /\ S x) ; [apply has_post_post_strong; exact POST1 |].
  intros ? ? [<- ?]; eapply POST2; eauto.
Qed.

Lemma has_post_iter_strong :
  forall {E R I} (body : I -> itree E (I + R)) (entry : I) (Inv : I -> Prop) (Q : R -> Prop),
    (forall i, Inv i -> body i ⤳ sum_pred Inv Q) ->
    Inv entry ->
    ITree.iter body entry ⤳ Q.
Proof.
  intros * IND INIT.
  eapply (@KTreeFacts.eutt_iter_gen _ _ _ (fun x y => x = y /\ Inv x)); eauto.
  intros i ? [<- ?].
  specialize (IND i); apply has_post_post_strong in IND; auto.
  unfold has_post_strong in IND.
  eapply eqit_mon; try apply IND; auto.
  intros [] ? [<- ?]; eauto.
Qed.

Lemma has_post_translate : forall {E F X} (t : itree E X) Q (h : E ~> F),
    t ⤳ Q ->
    translate h t ⤳ Q.
Proof.
  unfold has_post; intros * POST.
  apply eutt_translate_gen; auto.
Qed.

(** Relationship between [has_post] and [eutt]
    The main benefit of the approach: post-conditions can be leveraged when performing a cut
    during relational proofs.
 *)
Lemma eutt_post_bind : forall E R1 R2 RR U Q (t: itree E U) (k1: U -> itree E R1) (k2: U -> itree E R2),
    t ⤳ Q ->
    (forall u, Q u -> eutt RR (k1 u) (k2 u)) ->
    eutt RR (ITree.bind t k1) (ITree.bind t k2).
Proof.
  intros * POST ?.
  apply eutt_clo_bind with (UU := fun x y => x = y /\ Q x); [apply has_post_post_strong; exact POST |].
  intros ? ? [-> ?]; auto.
Qed.

Lemma eutt_post_bind_gen :
  forall E R1 R2 RR S1 S2 SS Q1 Q2
    (t1 : itree E S1) (k1: S1 -> itree E R1) (t2 : itree E S2) (k2 : S2 -> itree E R2),
    t1 ⤳ Q1 ->
    t2 ⤳ Q2 ->
    eutt SS t1 t2 ->
    (forall u1 u2, SS u1 u2 -> Q1 u1 -> Q2 u2 -> eutt RR (k1 u1) (k2 u2)) ->
    eutt RR (ITree.bind t1 k1) (ITree.bind t2 k2).
Proof.
  intros * POST1 POST2 EQ KEQ.
  apply eutt_clo_bind with (UU := fun x y => SS x y /\ Q1 x /\ Q2 y).
  2: intros ? ? (? & ? & ?); apply KEQ; auto.
  clear KEQ.
  apply has_post_post_strong in POST1.
  apply has_post_post_strong in POST2.
  pose proof eqit_trans _ _ _ _ _ _ _ POST1 EQ as EQ1.
  pose proof eqit_trans _ _ _ _ _ _ _ EQ1 POST2 as EQ2.
  clear -EQ2.
  eapply eutt_equiv; eauto.
  split.
  - intros ? ? (? & ? & ?); do 2 econstructor; eauto.
  - intros ? ? ?. inversion H. inversion REL1.
    destruct REL2 as [-> ?], REL0 as [<- ?]; eauto.
Qed.

(* A little oddity that can be useful when building bisimulations manually:
   an [eutt] hypothesis between a tree and itself can be refined into an [eq_itree] one.
 *)
Lemma has_post_has_eq_itree_aux : forall {E X} (t : itree E X) (Q : X -> Prop),
    has_post_strong t Q ->
    eq_itree (fun 'x y => x = y /\ Q x) t t.
Proof.
  intros.
  unfold has_post_strong in *.
  rewrite itree_eta in *.
  genobs t ot.
  revert t ot H Heqot.
  ginit.
  gcofix CIH.
  intros.
  pose proof H0 as EQ.
  punfold H0.
  red in H0. cbn in H0.
  subst ot.
  induction H0.
  - gstep; constructor; intuition; subst; auto.
  - gstep; constructor.
    rewrite itree_eta.
    gbase.
    eapply CIH; eauto.
    rewrite <- tau_eutt at 1 2.
    rewrite (itree_eta m2) in EQ.
    apply EQ.
  - gstep. constructor.
    intros; red.
    rewrite (itree_eta (k2 v)).
    gbase.
    eapply CIH; eauto.
    pose proof eqit_inv_Vis _ _ _ _ _ _ _ EQ v.
    rewrite (itree_eta (k2 v)) in H.
    apply H.
  - apply IHeqitF; auto.
  - gstep; constructor.
    rewrite itree_eta.
    gbase.
    eapply CIH; eauto.
    rewrite <- tau_eutt at 1 2.
    rewrite (itree_eta t2) in EQ.
    apply EQ.
Qed.

Lemma has_post_has_eq_itree : forall {E X} (t : itree E X) (Q : X -> Prop),
    has_post t Q ->
    eq_itree (fun 'x y => x = y /\ Q x) t t.
Proof.
  intros; apply has_post_post_strong in H; apply has_post_has_eq_itree_aux; auto.
Qed.


Require Import Verse.

Module Type CONFIG.

  (** The basic word of the hash. For blake2b it is [Word64] where as
      for blake2s it is [Word32]
   *)
  Parameter Word : type direct.

  (** The number of rounds that is involved in hashing. *)
  Parameters ROUNDS : nat.

  (** The round constants for the hash *)
  Parameter IVVec : Vector.t (constant Word) 8.

  (** The rotation constants used by the G function *)
  Parameter R0 R1 R2 R3 : nat.

End CONFIG.

(**

A single block of both sha512 and sha256 are 16-words in big endian
and the hash value is 8-words long.

*)

Definition HASH_SIZE : nat := 8.
Definition BLOCK_SIZE : nat := 16.


Require Import Coq.Strings.Ascii Coq.Strings.String.
Require Import Coq.Numbers.BinNums.
Require Import Crypto.Util.Strings.Equality.
Import BinPosDef.

Module Import DecimalHelpers. (* mostly from the decimal plugin, see https://github.com/coq/coq/pull/6599/files *)
  Inductive uint :=
  | Nil
  | D0 (_:uint)
  | D1 (_:uint)
  | D2 (_:uint)
  | D3 (_:uint)
  | D4 (_:uint)
  | D5 (_:uint)
  | D6 (_:uint)
  | D7 (_:uint)
  | D8 (_:uint)
  | D9 (_:uint).

  Notation zero := (D0 Nil).

  (** For conversions with binary numbers, it is easier to operate
    on little-endian numbers. *)

  Fixpoint revapp (d d' : uint) :=
    match d with
    | Nil => d'
    | D0 d => revapp d (D0 d')
    | D1 d => revapp d (D1 d')
    | D2 d => revapp d (D2 d')
    | D3 d => revapp d (D3 d')
    | D4 d => revapp d (D4 d')
    | D5 d => revapp d (D5 d')
    | D6 d => revapp d (D6 d')
    | D7 d => revapp d (D7 d')
    | D8 d => revapp d (D8 d')
    | D9 d => revapp d (D9 d')
    end.

  Definition rev d := revapp d Nil.

  Module Little.
    (** Successor of little-endian numbers *)
    Fixpoint succ d :=
      match d with
      | Nil => D1 Nil
      | D0 d => D1 d
      | D1 d => D2 d
      | D2 d => D3 d
      | D3 d => D4 d
      | D4 d => D5 d
      | D5 d => D6 d
      | D6 d => D7 d
      | D7 d => D8 d
      | D8 d => D9 d
      | D9 d => D0 (succ d)
      end.

    Fixpoint double d :=
      match d with
      | Nil => Nil
      | D0 d => D0 (double d)
      | D1 d => D2 (double d)
      | D2 d => D4 (double d)
      | D3 d => D6 (double d)
      | D4 d => D8 (double d)
      | D5 d => D0 (succ_double d)
      | D6 d => D2 (succ_double d)
      | D7 d => D4 (succ_double d)
      | D8 d => D6 (succ_double d)
      | D9 d => D8 (succ_double d)
      end

    with succ_double d :=
           match d with
           | Nil => D1 Nil
           | D0 d => D1 (double d)
           | D1 d => D3 (double d)
           | D2 d => D5 (double d)
           | D3 d => D7 (double d)
           | D4 d => D9 (double d)
           | D5 d => D1 (succ_double d)
           | D6 d => D3 (succ_double d)
           | D7 d => D5 (succ_double d)
           | D8 d => D7 (succ_double d)
           | D9 d => D9 (succ_double d)
           end.
  End Little.

  Module Pos.
    Local Open Scope positive_scope.
    Fixpoint to_little_uint p :=
      match p with
      | 1 => D1 Nil
      | p~1 => Little.succ_double (to_little_uint p)
      | p~0 => Little.double (to_little_uint p)
      end.

    Definition to_uint p := rev (to_little_uint p).

    Local Notation ten := 1~0~1~0.

    Fixpoint of_uint_acc (d:uint)(acc:positive) :=
      match d with
      | Nil => acc
      | D0 l => of_uint_acc l (Pos.mul ten acc)
      | D1 l => of_uint_acc l (Pos.add 1 (Pos.mul ten acc))
      | D2 l => of_uint_acc l (Pos.add 1~0 (Pos.mul ten acc))
      | D3 l => of_uint_acc l (Pos.add 1~1 (Pos.mul ten acc))
      | D4 l => of_uint_acc l (Pos.add 1~0~0 (Pos.mul ten acc))
      | D5 l => of_uint_acc l (Pos.add 1~0~1 (Pos.mul ten acc))
      | D6 l => of_uint_acc l (Pos.add 1~1~0 (Pos.mul ten acc))
      | D7 l => of_uint_acc l (Pos.add 1~1~1 (Pos.mul ten acc))
      | D8 l => of_uint_acc l (Pos.add 1~0~0~0 (Pos.mul ten acc))
      | D9 l => of_uint_acc l (Pos.add 1~0~0~1 (Pos.mul ten acc))
      end.
  End Pos.

  Module N.
    Fixpoint of_uint (d:uint) : N :=
      match d with
      | Nil => N0
      | D0 l => of_uint l
      | D1 l => Npos (Pos.of_uint_acc l 1)
      | D2 l => Npos (Pos.of_uint_acc l 1~0)
      | D3 l => Npos (Pos.of_uint_acc l 1~1)
      | D4 l => Npos (Pos.of_uint_acc l 1~0~0)
      | D5 l => Npos (Pos.of_uint_acc l 1~0~1)
      | D6 l => Npos (Pos.of_uint_acc l 1~1~0)
      | D7 l => Npos (Pos.of_uint_acc l 1~1~1)
      | D8 l => Npos (Pos.of_uint_acc l 1~0~0~0)
      | D9 l => Npos (Pos.of_uint_acc l 1~0~0~1)
      end.
  End N.

  Module String.
    Local Open Scope string_scope.
    Fixpoint of_uint (v : uint) : string
      := match v with
         | Nil => ""
         | D0 x => String "0" (of_uint x)
         | D1 x => String "1" (of_uint x)
         | D2 x => String "2" (of_uint x)
         | D3 x => String "3" (of_uint x)
         | D4 x => String "4" (of_uint x)
         | D5 x => String "5" (of_uint x)
         | D6 x => String "6" (of_uint x)
         | D7 x => String "7" (of_uint x)
         | D8 x => String "8" (of_uint x)
         | D9 x => String "9" (of_uint x)
         end.

    Fixpoint to_uint (v : string) : uint
      := match v with
         | EmptyString => Nil
         | String ch v
           => let rest := to_uint v in
              (if ascii_beq ch "0"
               then D0 rest
               else if ascii_beq ch "1"
               then D1 rest
               else if ascii_beq ch "2"
               then D2 rest
               else if ascii_beq ch "3"
               then D3 rest
               else if ascii_beq ch "4"
               then D4 rest
               else if ascii_beq ch "5"
               then D5 rest
               else if ascii_beq ch "6"
               then D6 rest
               else if ascii_beq ch "7"
               then D7 rest
               else if ascii_beq ch "8"
               then D8 rest
               else if ascii_beq ch "9"
               then D9 rest
               else Nil)
         end.

    Lemma to_of v : String.to_uint (String.of_uint v) = v.
    Proof. induction v; cbn; f_equal; trivial. Qed.
  End String.
End DecimalHelpers.

Local Open Scope positive_scope.
Local Open Scope string_scope.

Definition decimal_string_of_pos (p : positive) : string
  := String.of_uint (Pos.to_uint p).

Definition pos_of_decimal_string (s : string) : positive
  := match N.of_uint (String.to_uint s) with
     | N0 => 1
     | Npos p => p
     end.

(*Lemma pos_of_decimal_string_of_pos (p : positive)
  : pos_of_decimal_string (decimal_string_of_pos p) = p.
Proof.
  cbv [pos_of_decimal_string decimal_string_of_pos].
  rewrite String.to_of.
 ...
Qed.*)

Example decimal_string_of_pos_1 : decimal_string_of_pos 1 = "1" := eq_refl.
Example decimal_string_of_pos_2 : decimal_string_of_pos 2 = "2" := eq_refl.
Example decimal_string_of_pos_3 : decimal_string_of_pos 3 = "3" := eq_refl.
Example decimal_string_of_pos_7 : decimal_string_of_pos 7 = "7" := eq_refl.
Example decimal_string_of_pos_8 : decimal_string_of_pos 8 = "8" := eq_refl.
Example decimal_string_of_pos_9 : decimal_string_of_pos 9 = "9" := eq_refl.
Example decimal_string_of_pos_10 : decimal_string_of_pos 10 = "10" := eq_refl.
Example decimal_string_of_pos_11 : decimal_string_of_pos 11 = "11" := eq_refl.
Example decimal_string_of_pos_12 : decimal_string_of_pos 12 = "12" := eq_refl.
Example decimal_string_of_pos_13 : decimal_string_of_pos 13 = "13" := eq_refl.
Example decimal_string_of_pos_14 : decimal_string_of_pos 14 = "14" := eq_refl.
Example decimal_string_of_pos_15 : decimal_string_of_pos 15 = "15" := eq_refl.
Example decimal_string_of_pos_16 : decimal_string_of_pos 16 = "16" := eq_refl.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.SHA256.
Require Import sha.pure_lemmas.
Require Import sha.functional_prog.

(* Lemma 1: M = Prefix(Pad(M)) *)

(* TODO: replace InWords with InBlocks 4? *)
Inductive InWords : list Z -> Prop :=
  | words_nil : InWords []
  | words_word : forall (a b c d : Z) (msg : list Z),
                   InWords msg -> InWords (a :: b :: c :: d :: msg).

(* *** New definition for this lemma. *)
Definition pad (msg : list Z) : list Z :=
  let n := Zlength msg in
  msg ++ [128%Z]
      ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
      ++ intlist_to_Zlist (([Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)])%list).

Definition generate_and_pad' (msg : list Z) : list int :=
  Zlist_to_intlist (pad msg).

(* ----------------- ^ Definitions *)

Lemma fstpad_len :
  forall (msg : list Z),
    Datatypes.length (msg ++ [128]
                 ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0)
= (Datatypes.length msg + (S (Z.to_nat (- (Zlength msg + 9) mod 64))))%nat.
Proof.
  intros msg.
  simpl.
  rewrite -> app_length.
  simpl.
  rewrite -> length_list_repeat.
  reflexivity.
Qed.

Lemma InWords_len4 : forall (l : list Z),
                       Nat.divide (Z.to_nat WORD) (length l) -> InWords l.
Proof.
  intros l [x H].
  revert l H.
  induction x.
  intros l H. simpl in H.
  destruct l.
    apply words_nil.
    simpl in H. inversion H.
  intros l H.
  destruct l as [ | a [ | b [ | c [ | d ? ]]]].
    inversion H.
    inversion H.
    inversion H.
    inversion H.
    specialize (IHx l).
      apply words_word.
      apply IHx.
      simpl in H. inversion H.
      simpl. apply H1.
Qed.

(* TODO: clear out the SearchAbouts / clean up proof *)
Lemma pad_len_64_mod : forall (msg : list Z),
                           (Zlength (pad msg)) mod 64 = 0.
Proof.
  intros msg.
  unfold pad.
  rewrite -> Zlength_correct.
  repeat rewrite -> app_length.
  simpl.
  assert (succ: forall (n : nat), S n = (n + 1)%nat).
    intros. induction n. reflexivity. omega.
  rewrite -> succ.
  assert ((length msg +
      (length (list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0%Z) + 8 +
       1))%nat = (length msg +
      (length (list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0%Z) + 9))%nat) by omega.
  rewrite -> H. clear H.

  rewrite -> Zlength_correct.
  rewrite -> length_list_repeat.

  repeat rewrite -> Nat2Z.inj_add.
  rewrite -> Z2Nat.id.

  assert (move : forall (a b c : Z), a + (b + c) = (a + c) + b).
  intros. omega.

  rewrite -> move.
  rewrite -> Zplus_mod_idemp_r.

  assert (Z_9 : 9 = Z.of_nat (9%nat)). reflexivity.
  rewrite -> Z_9.

  repeat rewrite <- Nat2Z.inj_add.

  assert (forall (x : Z), x + (-x) = 0). intros. omega.

  rewrite -> H.
  reflexivity.

  * apply Z.mod_pos_bound.
    omega.
Qed.

(* more usable versions *)
Lemma pad_len_64 : forall (msg : list Z), exists (n : Z),
                           Zlength (pad msg) = 64 * n /\ n >= 0.
Proof.
  intros msg.
  pose proof pad_len_64_mod msg as pad_len_mod.
  rewrite -> Zmod_divides in *. 2: omega.

  destruct pad_len_mod.
  exists x.
  split.
  apply H.
  specialize (Zlength_nonneg (pad msg)); intros. omega.
Qed.

Lemma pad_len_64_nat : forall (msg : list Z), exists (n : nat),
                           (length (pad msg))%nat = (64 * n)%nat.
Proof.
  intros msg.
  pose proof pad_len_64 msg as pad_len_64.

  rewrite -> Zlength_correct in *.
  destruct pad_len_64.
  exists (Z.to_nat x).
  destruct H.

  assert (app_each : Z.to_nat (Z.of_nat (length (pad msg))) = Z.to_nat (64 * x)).
    rewrite -> H. reflexivity.

  rewrite -> Nat2Z.id in app_each.

  rewrite -> app_each.
(*  SearchAbout (Z.to_nat (_ * _)).*)
  rewrite -> Z2Nat.inj_mul.
  assert (n_64 : Z.to_nat 64 = 64%nat). reflexivity.

  rewrite -> n_64.
  reflexivity.

  * omega.
  * omega.
Qed.

Lemma total_pad_len_Zlist : forall (msg : list Z), exists (n : nat),
     length
       (msg ++ [128] ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0)
     =  (n * Z.to_nat WORD (* 4 *))%nat.
Proof.
  intros msg.
  pose proof pad_len_64_nat msg as pad_len_64_nat.

  unfold pad in *.
  repeat rewrite -> app_length in *.
  destruct pad_len_64_nat.
  assert (sym: (64 * x)%nat = (x * 64)%nat) by omega.
  rewrite -> sym in *. clear sym.

  simpl in *.
  assert (Pos.to_nat 4 = 4%nat) by reflexivity.
  (*rewrite -> H0. clear H0.*)

  rewrite -> length_list_repeat in *.

  assert (add_both: (length msg + S (Z.to_nat (- (Zlength msg + 9) mod 64) ))%nat =
      (x * 64 - 8)%nat) by omega. clear H.

  rewrite -> add_both.
  assert ((x * 64 - 8)%nat = (4 * (16 * x - 2))%nat) by omega.

  rewrite -> H.
  exists (16 * x - 2)%nat.
  omega.
Qed.

Lemma pad_inwords :
  forall (msg : list Z),
    InWords (msg ++ [128]
                 ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0).
Proof.
  intros msg.
  apply InWords_len4.
  pose proof total_pad_len_Zlist.
  specialize (H msg).
  unfold Nat.divide.
  apply H.
Qed.

Definition fulllen (len : Z) :=
  len + 1%Z + (- (len + 9) mod 64).

Lemma app_left : forall (a b c d : list Z),
   a ++ b ++ c ++ d = (a ++ b ++ c) ++ d.
(* a ++ (b ++ (c ++ d)) = (a ++ (b ++ c)) ++ d *)
Proof.
   intros a b c d.
   assert (b ++ (c ++ d) = (b ++ c) ++ d) as assert1.
     rewrite -> app_assoc. reflexivity.
   rewrite -> assert1.
   rewrite -> app_assoc.
   reflexivity.
Qed.

(* can use extensionality *)
Theorem pad_compose_equal : forall (msg : list Z),
                              generate_and_pad' msg = generate_and_pad msg.
Proof.
  intros msg.
  unfold generate_and_pad'.
  unfold pad.
  unfold generate_and_pad.
  (* need il => ZIL (IZL il), and
     ZIL a ++ Zil b = ZIL (a ++ b) (with length a being a multiple of 4)
   *)
  pose proof pad_inwords as pad_inwords.
  specialize (pad_inwords msg).
  rewrite -> app_left.
  induction pad_inwords.
  (* case none *)
    assert (forall l : list Z, [] ++ l = l) as Happend. reflexivity.
    specialize (Happend (intlist_to_Zlist
        [Int.repr (Zlength msg * 8 / Int.modulus);
        Int.repr (Zlength msg * 8)])).
    rewrite -> Happend.
    rewrite -> intlist_to_Zlist_to_intlist.
    reflexivity.
  (* case a :: b :: c :: d :: msg0 *)
    Opaque intlist_to_Zlist.
    simpl.
    apply f_equal.
    apply IHpad_inwords.
Qed.

(* ------------------------------------------------ *)

(* Lemma 2: |M1| = |M2| -> |Pad(M1)| = |Pad(M2)| *)

Theorem length_equal_pad_length : forall (msg1 : list Z) (msg2 : list Z),
     Zlength msg1  = Zlength msg2 ->
     Zlength (generate_and_pad msg1) = Zlength (generate_and_pad msg2).
Proof.
  intros m1 m2 H.
  repeat rewrite -> functional_prog.length_generate_and_pad.
  rewrite -> H.
  reflexivity.
Qed.

(* ------------------------------------------------ *)

(* Lemma 3: |M1| =/= |M2| ->
last block of Pad(M1) =/= last block of Pad(M2)

or, if one-to-one property is desired (for HMAC), only need to prove that
the padded messages differ
*)


Require Export Defs.
Require Export DList.
Require Export Bvector.
Require Export GenericState.

Open Scope type_scope.

Module Type IDvmStateType.

Parameter n:nat.

Definition securityVectorType : Type := Bvector n.

Definition plusSecurityVectors := BVor n.

Definition nullSecurityVector :=

Inductive ObjectVectorType : Type :=
  | topObjVect : securityVectorType -> ObjectVectorType
  | obj : ClassLocation -> ClassLocation -> list (FieldLocation * securityVectorType) -> ObjectVectorType
  | dobjVect : securityVectorType -> ObjectVectorType.

Inductive ArrayVectorType : Type :=
  | arr : nat -> list securityVectorType -> ArrayVectorType.

Inductive arrOrObj' : Type :=
  | ar : ArrayVectorType -> arrOrObj'
  | dob : ObjectVectorType -> arrOrObj'.

Declare Module IDvmStateModule : GenericStateType with Definition Val' := securityVectorType with Definition arrOrObj' := arrOrObj.
Export IDvmStateModule.

End IDvmStateType.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.CCC.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import Basic_Cons.Exponential.
From Categories Require Import PreSheaf.PreSheaf PreSheaf.Product.
From Categories Require Import Yoneda.Yoneda.

Section Exponential.
  Context (C : Category) (F G : PShCat C).

  Local Obligation Tactic := idtac.

  (** The exponential in category of presheaves is the presheaf that maps each
      object c of C to the set of natural transformations (Y(c) × F –≻ G).
      Where Y is the Yoneda embedding, and × is the product of presheaves.

      This presheaf, maps an arrow h : c –≻ c' in C to the natural
      transformation ( morphisms in category of presheaves are natural
      transformations) that maps a natural transformation u to the natural
      transformation that maps an objet x of C to the function that given
      v : ((c' –≻ x : Cᵒᵖ) * F(x)) gives
      (Trans u x (((fst v) ∘ f)%morphism, (snd v)))
 *)
  Program Definition funspace_psh : Functor (C^op) Type_Cat :=
    {|
      FO :=
        fun x =>
          NatTrans
            (pointwise_product_psh _ ((Yoneda C _o) x)%object F)
            G;
      FA :=
        fun _ _ f u =>
          {|
            Trans :=
              fun x v => Trans u x (((fst v) ∘ f)%morphism, (snd v))
          |}
    |}.

  Next Obligation.
  Proof.
    basic_simpl.
    extensionality v.
    simpl_ids.
    set (W := equal_f (Trans_com u h) (f ∘ (fst v), snd v)%morphism).
    cbn in W.
    simpl_ids in W.
    rewrite assoc_sym.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply funspace_psh_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    intros x.
    FunExt.
    apply NatTrans_eq_simplify; cbn; auto.
  Qed.

  Next Obligation.
  Proof.
    intros a b c f g.
    FunExt.
    apply NatTrans_eq_simplify; cbn.
    FunExt.
    rewrite assoc.
    trivial.
  Qed.

  (** The evaluation morphism (natural transformation) for exponentials of
      presheaves. *)
  Program Definition PSh_Exponential_Eval :
    (pointwise_product_psh C funspace_psh F –≻ G)%nattrans
    :=
      {|
        Trans := fun x u => Trans (fst u) x (id, snd u)
      |}.

  Next Obligation.
  Proof.
    basic_simpl.
    extensionality u.
    set (W := equal_f (Trans_com (fst u) h) (id, snd u)).
    cbn in W.
    auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply PSh_Exponential_Eval_obligation_1.
  Qed.

  (** The currying morphism (natural transformation) for exponentials of
      presheaves. *)
  Program Definition PSh_Exponential_Curry
          (x : (C ^op –≻ Type_Cat)%functor)
          (u : (pointwise_product_psh C x F –≻ G)%nattrans)
    :
      (x –≻ funspace_psh)%nattrans
  :=
    {|
      Trans :=
        fun v m =>
          {|
            Trans :=
              fun p q =>
                Trans u p (x _a (fst q) m, snd q)%morphism
          |}
    |}.

  Next Obligation.
  Proof.
    intros x u v m c c' h.
    cbn in *.
    extensionality p.
    simpl_ids.
    cbn_rewrite (F_compose x (fst p) h).
    set (W := equal_f (Trans_com u h) ((x _a (fst p) m)%morphism, snd p)).
    cbn in W.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry; simpl.
    apply PSh_Exponential_Curry_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    intros x u c c' h.
    cbn in *.
    extensionality v.
    apply NatTrans_eq_simplify.
    extensionality z; extensionality y.
    cbn in *.
    cbn_rewrite (F_compose x h (fst y)).
    trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry; simpl.
    apply PSh_Exponential_Curry_obligation_3.
  Qed.

  (** Exponentials of presheaves. *)
  Program Definition PSh_Exponential : (F ⇑ G)%object :=
    {|
      exponential := funspace_psh;
      eval := PSh_Exponential_Eval;
      Exp_morph_ex := PSh_Exponential_Curry
    |}.

  Next Obligation.
  Proof.
    intros z f.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y.
    cbn in *.
    rewrite (F_id z).
    trivial.
  Qed.

  Next Obligation.
  Proof.
    intros z f u u' H1 H2.
    rewrite H2 in H1; clear H2.
    assert (H1' := f_equal Trans H1); clear H1.
    symmetry in H1'.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y.
    apply NatTrans_eq_simplify.
    extensionality p.
    extensionality q.
    cbn in *.
    assert (H1 := f_equal (fun w => w p (z _a (fst q) y, snd q)%morphism) H1');
      clear H1'.
    cbn in H1.
    cbn_rewrite (equal_f (Trans_com u (fst q)) y) in H1.
    cbn_rewrite (equal_f (Trans_com u' (fst q)) y) in H1.
    cbn in H1.
    auto.
  Qed.

End Exponential.

Instance PSh_Has_Exponentials (C : Category) : Has_Exponentials (PShCat C) :=
  PSh_Exponential C.


Set Implicit Arguments.

Require Import expec.
Require Import monoid_monad_trans.
Require Import monoid_tree_monad.
Require Import Rdefinitions.
Require Import monads.
Require Import util.
Require Import Bool.
Require Import sums_and_averages.
Require Import List.
Require Import list_utils.
Require Import Rbase.
Require ne_tree_monad.

Arguments fst {A B}.

Definition map_fst (A B C: Set) (f: A -> B) (p: A * C): B * C := (f (fst p), snd p).

Section contents.

  Variables (m: Monoid) (ms: m -> nat).

  Definition monoid_expec {A: Set}:
    MonoidMonadTrans.M m ne_tree_monad.ext A -> R
      := expec (ms ∘ (fst (B:=_:Set))).

  Lemma monoid_expec_bind_leaf (X Y: Set) (f: X -> MonoidMonadTrans.M m ne_tree_monad.ext Y)
    (n: prod m X):
    monoid_expec (@bind (MonoidMonadTrans.M m ne_tree_monad.ext) _ _ (ne_tree.Leaf n) f) =
    expec (ms ∘ monoid_mult m (fst n) ∘ (fst (B:=_:Set))) (f (snd n)).
  Proof.
    intros.
    unfold monoid_expec.
    rewrite MonoidMonadTrans.bind_toLower'.
    rewrite ne_tree_monad.bind_Leaf.
    simpl @ret.
    simpl mon.
    rewrite expec_bind_leaf.
    reflexivity.
  Qed.

  Hypothesis mh: monoidHomo m NatAddMonoid ms.

  Definition monoid_expec_sum (T U: Set)
  (g: T -> MonoidMonadTrans.M m ne_tree_monad.ext U): list T -> R
    := Rsum ∘ map (monoid_expec ∘ g).

  Lemma monoid_expec_sum_ext (T U: Set)
    (f g: T -> MonoidMonadTrans.M m ne_tree_monad.ext U):
      ext_eq f g ->
      ext_eq (monoid_expec_sum f) (monoid_expec_sum g).
  Proof with auto.
    unfold monoid_expec_sum.
    intros.
    intro.
    unfold compose.
    f_equal.
    apply map_ext.
    intro.
    f_equal.
    apply H.
  Qed.

  Lemma monoid_expec_Node_map (A B: Set) (f: A -> MonoidMonadTrans.M m ne_tree_monad.ext B) (l: ne_list.L A):
    monoid_expec (ne_tree.Node (ne_list.map f l)) =
    monoid_expec_sum f l / INR (length l).
  Proof with auto.
    unfold monoid_expec, monoid_expec_sum.
    intros.
    rewrite expec_Node.
    rewrite ne_list.map_map.
    unfold Ravg.
    rewrite ne_list.map_length.
    unfold monoid_expec.
    rewrite ne_list.plain_map...
  Qed.

  Lemma monoid_expec_ret (A: Set) (a: A): monoid_expec (ret a) = 0.
  Proof with auto.
    intros.
    simpl.
    unfold monoid_expec.
    unfold expec, compose.
    simpl.
    rewrite (monoidHomo_zero mh)...
  Qed.

  Lemma monoid_expec_bind_leaf_plus (X Y: Set) (f: X -> MonoidMonadTrans.M m ne_tree_monad.ext Y)
    (n: prod m X):
    monoid_expec (@bind (MonoidMonadTrans.M m ne_tree_monad.ext) _ _ (ne_tree.Leaf n) f) =
       INR (ms (fst n)) + monoid_expec (f (snd n)).
  Proof with auto.
    intros.
    rewrite monoid_expec_bind_leaf.
    unfold monoid_expec.
    rewrite (@expec_ext _ (ms ∘ monoid_mult m (fst n) ∘ fst (A:=m) (B:=Y)) (plus (ms (fst n)) ∘ ms ∘ fst)).
      rewrite <- comp_ass.
      rewrite (ext_eq_rw (expec_plus_c (ms ∘ fst (A:=m) (B:=Y)) (ms (fst n)))).
      reflexivity.
    intro.
    repeat rewrite comp_apply.
    apply (monoidHomo_mult mh).
  Qed.

  Lemma monoid_expec_bind_det (X: Set) (v: prod m X) (x: MonoidMonadTrans.M m ne_tree_monad.ext X):
    ne_tree_monad.deterministic x v -> forall (Y: Set) (f: X -> MonoidMonadTrans.M m ne_tree_monad.ext Y), monoid_expec (x >>= f) = monoid_expec x + monoid_expec (f (snd v)).
  Proof with auto with real.
    intros.
    rewrite H.
    rewrite monoid_expec_bind_leaf_plus.
    unfold monoid_expec.
    rewrite expec_Leaf.
    reflexivity.
  Qed.

  Hint Resolve ne_tree.In_head.

  Lemma monoid_expec_plus (A B: Set)
    (f: MonoidMonadTrans.M m ne_tree_monad.ext A)
    (g: A -> MonoidMonadTrans.M m ne_tree_monad.ext B) :
    forall (gc: forall x y, ne_tree.In x f -> ne_tree.In y f ->
     monoid_expec (g (snd x)) = monoid_expec (g (snd y))),
      monoid_expec (f >>= g) = monoid_expec f + monoid_expec (g (snd (ne_tree.head f))).
  Proof with auto with real.
    revert f.
    induction f.
        rewrite (@monoid_expec_bind_det _ n)...
        unfold ne_tree_monad.deterministic...
      unfold monoid_expec in *.
      rewrite MonoidMonadTrans.bind_toLower in *.
      rewrite ne_tree_monad.bind_Node_one.
      repeat rewrite expec_Node_one.
      intros.
      rewrite IHf...
    unfold monoid_expec in *.
    rewrite MonoidMonadTrans.bind_toLower in *.
    rewrite expec_Node_cons.
    rewrite expec_bind_cons.
    intros.
    rewrite IHf...
    rewrite IHf0.
      simpl ne_tree.head.
      repeat rewrite S_INR.
      rewrite (gc (ne_tree.head (ne_list.head l)) (ne_tree.head f))...
        simpl.
        unfold ne_tree_monad.C.
        field...
      apply ne_tree.InNode. apply ne_tree.InTail.
      destruct l...
    intros.
    inversion_clear H. inversion_clear H0.
    apply gc...
  Qed.

  Lemma monoid_expec_map_fst_monoid_mult (A: Set) (g: m) (t: MonoidMonadTrans.M m ne_tree_monad.ext A):
    monoid_expec (ne_tree.map (map_fst (monoid_mult m g)) t) =
    INR (ms g) + monoid_expec t.
  Proof with auto.
    intros.
    unfold monoid_expec.
    unfold expec.
    rewrite comp_apply.
    rewrite ne_tree.map_map.
    assert (ext_eq
      (INR ∘ (ms ∘ fst (A:=m) (B:=A)) ∘ map_fst (C:=A) (monoid_mult m g))
      (INR ∘ plus (ms g) ∘ mult 1 ∘ (ms ∘ fst (A:=m) (B:=A)))).
      intro.
      unfold compose.
      simpl.
      rewrite (monoidHomo_mult mh).
      simpl.
      rewrite plus_0_r...
    rewrite (ne_tree.map_ext H).
    rewrite <- ne_tree.map_map.
    cset (lin_nat 1 (ms g) (ne_tree.map (ms ∘ fst (A:=m) (B:=A)) t)).
    rewrite comp_apply in H0.
    rewrite H0.
    repeat rewrite comp_apply.
    simpl INR.
    rewrite Rmult_1_l.
    rewrite ne_tree.map_map...
  Qed.

  Lemma monoid_expec_bind_0_r (A B: Set)
    (g: A -> MonoidMonadTrans.M m ne_tree_monad.ext B)
    (gc: forall x, monoid_expec (g x) = 0)
    (f: MonoidMonadTrans.M m ne_tree_monad.ext A):
      monoid_expec (f >>= g) = monoid_expec f.
  Proof with auto with real.
    intros.
    rewrite monoid_expec_plus.
      rewrite gc.
      apply Rplus_0_r.
    intros.
    do 2 rewrite gc...
  Qed.

End contents.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A X C D U V : Universe, ((wd_ U X /\ (wd_ X V /\ (wd_ U A /\ (wd_ A V /\ (wd_ U V /\ (wd_ C D /\ (wd_ X A /\ (col_ U A V /\ col_ U X V)))))))) -> col_ A X V)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

(** Properties of real functions sequences. *)

Require Import Rsequence_def.
Require Import Rinterval Ranalysis_def.
Require Import Rsequence_cv_facts.
Require Import Rsequence_tactics.
Require Import MyRIneq.
Require Import Cfunctions.
Require Import Csequence.
Require Import Csequence_facts.
Require Import CFsequence.
Require Import Cnorm.
Require Import Cprop_base.
Require Import Ctacfield.
Require Import Lra.
Require Import Max.
Require Import Cmet.
Require Import Canalysis_def.
Require Import Canalysis_deriv.

Open Scope C_scope.

Lemma CFseq_cvu_derivable : forall (fn fn' : nat -> C -> C) (f g : C -> C) (z c : C) (r : posreal)
      (z_in : Boule c r z),
      (forall (x:C) (n:nat), Boule c r x -> derivable_pt_lim (fn n) x (fn' n x)) ->
      (CFseq_cv_boule fn f c r) ->
      (CFseq_cvu fn' g c r) ->
      (forall (x:C), Boule c r x -> continuity_pt g x) ->
      derivable_pt_lim f z (g z).
Proof.
intros fn fn' f g z c r z_in Dfn_eq_fn' fn_cv_f fn'_cvu_g g_cont eps eps_pos.
 assert (eps_8_pos : 0 < eps / 8) by lra.
 destruct (g_cont z z_in (eps/8)%R eps_8_pos) as [delta1 H] ; clear g_cont ; destruct H as [delta1_pos g_cont].
 assert (delta_pos : 0 < Rmin ((r - (Cnorm (z - c))) / 2) delta1).
  apply Rmin_pos_lt ; [| assumption].
  unfold middle, Rdiv ; apply Rlt_mult_inv_pos ; [| lra].
  apply Rlt_Rminus ; rewrite Cnorm_minus_sym ; apply z_in.

 pose (delta := mkposreal (Rmin ((r - (Cnorm (z - c))) / 2) delta1) (delta_pos)).
 exists delta ; intros h h_neq h_ub.
 pose (eps' :=  ((Cnorm h) * eps / 4)%R).
 assert (eps'_pos : 0 < eps').
  unfold eps', Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat ;
  [apply Cnorm_pos_lt ; assumption | lra].
 destruct (fn_cv_f z z_in eps' eps'_pos) as [Nz fnz_cv_fz].

assert (zh_in : Boule c r (z + h)).
 unfold Boule ; simpl ; unfold C_dist.
  unfold Cminus ; rewrite Copp_add_distr ; unfold Cminus ; rewrite <- Cadd_assoc ;
  apply Rle_lt_trans with (Cnorm (c - z) + Cnorm (-h))%R.
  apply Cnorm_triang.
  rewrite Cnorm_opp, Cnorm_minus_sym.
  apply Rlt_le_trans with (Cnorm (z - c) + delta)%R.
  apply Rplus_lt_compat_l ; assumption.
  apply Rle_trans with (Cnorm (z - c) + ((r - (Cnorm (z - c))) / 2))%R.
  apply Rplus_le_compat_l ; unfold delta ; apply Rmin_l.
  apply Rle_trans with ((Cnorm (z - c) + r) / 2)%R.
  right ; field.
  apply Rle_trans with ((r + r) / 2)%R.
  unfold Rdiv ; apply Rmult_le_compat_r ; [lra |] ; apply Rplus_le_compat_r ;
  rewrite Cnorm_minus_sym ; left ; apply z_in.
  right ; field.

 destruct (fn_cv_f (z + h) zh_in eps' eps'_pos) as [Nzh fnzh_cv_fzh] ; clear fn_cv_f.

 destruct (fn'_cvu_g (eps/8)%R eps_8_pos) as [Ng fn'c_cvu_gc] ; clear fn'_cvu_g.

 pose (N := max (max Nz Nzh) Ng).
 assert (Main : Cnorm ((f (z+h) - fn N (z+h)) - (f z - fn N z) + (fn N (z+h) - fn N z - h * (g z))) < (Cnorm h)*eps).
 apply Rle_lt_trans with (Rplus (Cnorm (f (z + h) - fn N (z + h) - (f z - fn N z))) (Cnorm ((fn N (z + h) - fn N z - h * g z)))).
 apply Cnorm_triang.
 apply Rle_lt_trans with (Rplus (Rplus (Cnorm (f (z + h) - fn N (z + h))) (Cnorm (- (f z - fn N z))))
                                                            (Cnorm (fn N (z + h) - fn N z - h * g z))).
 apply Rplus_le_compat_r ; apply Cnorm_triang.
 rewrite Cnorm_opp.

apply Rlt_le_trans with (Rplus (Rplus eps' (Cnorm (f z - fn N z)))  (Cnorm (fn N (z + h) - fn N z - h * g z))).
 do 2 apply Rplus_lt_compat_r ; rewrite Cnorm_minus_sym ; apply fnzh_cv_fzh.
 unfold ge ; apply le_trans with (max Nz Nzh)%nat ; [apply le_max_r | apply le_max_l].

apply Rle_trans with (Rplus (Rplus eps' eps') (Cnorm (fn N (z + h) - fn N z - h * g z))).
 apply Rplus_le_compat_r ; apply Rplus_le_compat_l ; left ; rewrite Cnorm_minus_sym ;
 apply fnz_cv_fz ; unfold ge ; apply le_trans with (max Nz Nzh)%nat ; apply le_max_l.

apply Rle_trans with (Cnorm h * eps / 2 + Cnorm h * eps / 2)%R.
 apply Rle_trans with (Cnorm h * eps / 4 + Cnorm h * eps / 4 + Cnorm h * eps / 2)%R.
 apply Rplus_le_compat_l.

 assert (Interval_to_boule : forall (t: R), interval 0 1 t -> Boule c r (z + t * h)).
  intros t t_in ; unfold Boule ; simpl ; unfold C_dist.
  replace (c - (z + t * h)) with ((c - z) + - (t*h)).
  apply Rle_lt_trans with (Rplus (Cnorm (c - z)) (Cnorm (- (t*h)))) ;
  [apply Cnorm_triang | rewrite Cnorm_opp, Cnorm_Cmult].
  apply Rle_lt_trans with (Rplus (Cnorm (c - z)) (Cnorm h)).
  apply Rplus_le_compat_l ; rewrite <- Rmult_1_l ; apply Rmult_le_compat_r ;
  [apply Cnorm_pos | rewrite Cnorm_IRC_Rabs].
  clear -t_in ; destruct t_in as [t_lb [t_eq | t_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; lra.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  apply Rlt_le_trans with (Rplus (Cnorm (c - z)) delta) ;
  [apply Rplus_lt_compat_l ; assumption |].
  apply Rle_trans with (Rplus (Cnorm (c - z)) ((r - Cnorm (z - c)) / 2)) ;
  [apply Rplus_le_compat_l ; unfold delta ; apply Rmin_l |].
  rewrite Cnorm_minus_sym.
  field_simplify ; unfold Rdiv; try rewrite Rinv_1, Rmult_1_r.
  unfold Boule in z_in ; simpl in z_in ; unfold C_dist in z_in ;
  left ; rewrite Cnorm_minus_sym ;
 apply (proj2 (middle_is_in_the_middle _ _ z_in)).
 unfold Cminus ; rewrite Copp_add_distr ;
 rewrite Cadd_assoc ; reflexivity.

 assert (fn_deriv : forall t : R, interval 0 1 t -> derivable_pt (fn N) (z + t * h)).
  intros ; exists (fn' N (z + t * h)) ; apply Dfn_eq_fn'.
  apply Interval_to_boule ; assumption.

 destruct (MVT_Cre (fn N) z h fn_deriv h_neq) as [u [u_in_I Hu_bd]].
 destruct (MVT_Cim (fn N) z h fn_deriv h_neq) as [v [v_in_I Hv_bd]].

 apply Rle_trans with (Rmult (Cnorm h) (Rmult (Cnorm (fn N (z + h) - fn N z - h * g z)) (/ Cnorm h))).
 right ; field ; apply Cnorm_no_R0 ; assumption.

 unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_le_compat_l ;
 [apply Cnorm_pos |] ; rewrite <- Cnorm_inv, <- Cnorm_Cmult ; [| assumption].
 rewrite Cmult_minus_distr_r ; replace (h * g z * / h) with (g z) ; [| field ; assumption].
 rewrite <- Cproj_right with ((fn N (z + h) - fn N z) * / h), <- Cproj_right with (g z).
 apply Rle_trans with (Cnorm (Rminus (Cre ((fn N (z + h) - fn N z) * / h))  (Cre (g z)),
                                                    Rminus (Cim ((fn N (z + h) - fn N z) * / h)) (Cim (g z)))).
  right ; apply Cnorm_eq_compat ; CusingR.

apply Rle_trans with (Rplus (Cnorm ((Cre ((fn N (z + h)%C - fn N z) * / h) - Cre (g z))%R, R0))
        (Cnorm ((R0 , (Cim ((fn N (z + h)%C - fn N z) * / h) - Cim (g z))%R)))).
 apply Rle_trans with (Cnorm (((Cre ((fn N (z + h)%C - fn N z) * / h) - Cre (g z))%R, R0)
   + (R0, (Cim ((fn N (z + h)%C - fn N z) * / h) - Cim (g z))%R))).
  right ; apply Cnorm_eq_compat ; CusingR.
  apply Cnorm_triang.
 rewrite Cnorm_Cre_simpl, Cnorm_Cim_simpl.
 unfold Cdiv in Hu_bd, Hv_bd ; rewrite Hu_bd, Hv_bd.

apply Rle_trans with (eps/4 + Rabs (Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g z)))%R.
apply Rplus_le_compat_r.
apply Rle_trans with (Rabs ((Cre (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I)) - Cre (g (z + u * h)))
                                                      +  (Cre (g (z + u * h)) - Cre (g z)))).
 right ; apply Rabs_eq_compat ; ring.
 apply Rle_trans with (Rplus (Rabs (Cre (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I)) - Cre (g (z + u * h))))
                                (Rabs (Cre (g (z + u * h)) - Cre (g z)))) ; [apply Rabs_triang |].
 do 2 rewrite Cre_minus_compat.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I) - g (z + u * h)))
                                (Rabs (Cre (g (z + u * h) - g z)))).
 apply Rplus_le_compat_r ; apply Cre_le_Cnorm.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I) - g (z + u * h)))
                                (Cnorm (g (z + u * h) - g z))).
 apply Rplus_le_compat_l ; apply Cre_le_Cnorm.

apply Rle_trans with (Rplus (eps / 8) (Cnorm (g (z + u * h) - g z))).
apply Rplus_le_compat_r.

assert (zuh_in : Boule c r (z + u *h)).
 apply Interval_to_boule ; assumption.
 rewrite (derive_pt_eq_0 _ _ _ (fn_deriv u u_in_I) (Dfn_eq_fn' _ N zuh_in)).
 unfold C_dist in fn'c_cvu_gc ; left ; apply fn'c_cvu_gc ;
 [unfold N ; apply le_max_r |] ; assumption.

apply Rle_trans with (eps / 8 + eps / 8)%R ; [apply Rplus_le_compat_l | right ; field].

destruct (proj1 u_in_I) as [u_neq | u_eq].

left ; simpl in g_cont ; unfold C_dist in g_cont ; apply g_cont ; split.
unfold Cderiv.D_x, no_cond ; split ; [trivial |].
 clear - u_neq h_neq.
 intro Hf ; symmetry in Hf ; generalize Hf ; clear Hf ; apply Cadd_neq_compat_l.
 apply  Cmult_integral_contrapositive_currified ;
 [apply IRC_neq_compat ; apply Rgt_not_eq |] ; assumption.

 replace (z + u * h - z) with (u * h).
 rewrite Cnorm_Cmult ; apply Rlt_le_trans with (1 * delta)%R.
 apply Rlt_le_trans with (Cnorm u * delta)%R.
 apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; apply IRC_neq_compat ;
 apply Rgt_not_eq |] ; assumption.
 apply Rmult_le_compat_r ; [left ; assumption |].
 rewrite Cnorm_IRC_Rabs.
  clear -u_in_I ; destruct u_in_I as [u_lb [u_eq | u_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; lra.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  rewrite Rmult_1_l ; unfold delta ; apply Rmin_r.

 ring.

subst ; rewrite Cmult_0_l, Cadd_0_r ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ;
 left ; assumption.

apply Rle_trans with (eps / 4 +  eps/4)%R ; [apply Rplus_le_compat_l | right ; field].

apply Rle_trans with (Rabs ((Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g (z + v * h)))
                                                      +  (Cim (g (z + v * h)) - Cim (g z)))).
 right ; apply Rabs_eq_compat ; ring.
 apply Rle_trans with (Rplus (Rabs (Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g (z + v * h))))
                                (Rabs (Cim (g (z + v * h)) - Cim (g z)))) ; [apply Rabs_triang |].
 do 2 rewrite Cim_minus_compat.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I) - g (z + v * h)))
                                (Rabs (Cim (g (z + v * h) - g z)))).
 apply Rplus_le_compat_r ; apply Cim_le_Cnorm.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I) - g (z + v * h)))
                                (Cnorm (g (z + v * h) - g z))).
 apply Rplus_le_compat_l ; apply Cim_le_Cnorm.

apply Rle_trans with (Rplus (eps / 8) (Cnorm (g (z + v * h) - g z))).
apply Rplus_le_compat_r.

assert (zvh_in : Boule c r (z + v *h)).
 apply Interval_to_boule ; assumption.
 rewrite (derive_pt_eq_0 _ _ _ (fn_deriv v v_in_I) (Dfn_eq_fn' _ N zvh_in)).
 unfold C_dist in fn'c_cvu_gc ; left ; apply fn'c_cvu_gc ;
 [unfold N ; apply le_max_r |] ; assumption.

apply Rle_trans with (eps / 8 + eps / 8)%R ; [apply Rplus_le_compat_l | right ; field].

destruct (proj1 v_in_I) as [v_neq | v_eq].

left ; simpl in g_cont ; unfold C_dist in g_cont ; apply g_cont ; split.
unfold Cderiv.D_x, no_cond ; split ; [trivial |].
 clear - v_neq h_neq.
 intro Hf ; symmetry in Hf ; generalize Hf ; clear Hf ; apply Cadd_neq_compat_l.
 apply  Cmult_integral_contrapositive_currified ;
 [apply IRC_neq_compat ; apply Rgt_not_eq |] ; assumption.

 replace (z + v * h - z) with (v * h).
 rewrite Cnorm_Cmult ; apply Rlt_le_trans with (1 * delta)%R.
 apply Rlt_le_trans with (Cnorm v * delta)%R.
 apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; apply IRC_neq_compat ;
 apply Rgt_not_eq |] ; assumption.
 apply Rmult_le_compat_r ; [left ; assumption |].
 rewrite Cnorm_IRC_Rabs.
  clear -v_in_I ; destruct v_in_I as [v_lb [v_eq | v_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; lra.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  rewrite Rmult_1_l ; unfold delta ; apply Rmin_r.

 ring.

subst ; rewrite Cmult_0_l, Cadd_0_r ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ;
 left ; assumption.

right ; field.
right ; field.

apply Rle_lt_trans with (Rmult (Cnorm ((f (z + h)  - f z) - h * g z)) (/ Cnorm h)).
rewrite <- Cnorm_inv, <- Cnorm_Cmult ; [| assumption] ; right ; apply Cnorm_eq_compat ;
 field ; assumption.

apply Rle_lt_trans with (Rmult (Cnorm (f (z + h) - fn N (z + h) - (f z - fn N z) +
          (fn N (z + h) - fn N z - h * g z))) (/ Cnorm h)).
right ; apply Rmult_eq_compat_r ; apply Cnorm_eq_compat ; ring.

apply Rlt_le_trans with ((Cnorm h * eps) * / Cnorm h)%R.
apply Rmult_lt_compat_r ; [rewrite <- Cnorm_inv ; [apply Cnorm_pos_lt ;
 apply Cinv_neq_0_compat |] |] ; assumption.

 right ; field ; apply Cnorm_no_R0 ; assumption.
Qed.

Definition SFL_interv : forall (fn:nat -> C -> C) (r:posreal)
  (cv : forall z : C, Boule 0 r z -> {l:C | Cseq_cv (fun N:nat => CFpartial_sum (fun n => fn n z) N) l }) (y:C), C.
Proof.
intros fn r cv z.
 destruct (Rlt_le_dec (Cnorm (0 - z)) r) as [z_bd | z_lb].
 unfold Boule in cv ; simpl in cv ; unfold C_dist in cv ;
 destruct (cv _ z_bd) as (l, _) ; apply l.
 exact 0.
Defined.

Lemma SFL_interv_right : forall fn r cv y, Boule 0 r y ->
     Cseq_cv (fun N:nat => CFpartial_sum (fun n => fn n y) N) (SFL_interv fn r cv y).
Proof.
intros fn r cv z z_bd ; unfold SFL_interv ;
 destruct (Rlt_le_dec (Cnorm (0 - z)) r) as [z_bd2 | z_lb].
 destruct (cv z z_bd2) as [l Hl] ; assumption.
 assert (Hf : Cnorm (0 - z) < Cnorm (0 - z)).
  apply Rlt_le_trans with r ; unfold Boule in * ; assumption.
 elim (Rlt_irrefl _ Hf).
Qed.

Lemma Rlt_minus_exchange : forall a b c, a - b < c -> a - c < b.
Proof.
intros a b c H ; lra.
Qed.

Lemma Rlt_plus_exchange : forall a b c,  a - b < c  -> a < b + c.
Proof.
intros a b c H ; lra.
Qed.

Lemma sum_cv_maj : forall (An : nat -> R) (fn : nat -> C -> C) (z l1 : C) (l2 : R),
       Cseq_cv (fun n : nat => CFpartial_sum (fun n => fn n z) n) l1 ->
       Rseq_cv (fun n : nat => sum_f_R0 An n) l2 ->
       (forall n : nat, Cnorm (fn n z) <= An n) -> Cnorm l1 <= l2.
Proof.
intros An fn z l1 l2 fn_cv An_cv fn_bd.
 destruct (Rle_lt_dec (Cnorm l1) l2) as [H | Hf].
  assumption.
  pose (eps := ((Cnorm l1 - l2) / 4)%R) ;
  assert (eps_pos : 0 < eps).
   unfold eps, Rdiv ; apply Rlt_mult_inv_pos ; lra.
  destruct (fn_cv _ eps_pos) as [Nfn Hfn] ;
  destruct (An_cv _ eps_pos) as [NAn HAn].
  pose (N := max Nfn NAn).
  assert (Main : Cnorm l1 - eps < l2 + eps).
   apply Rlt_trans with (Cnorm (CFpartial_sum (fun n : nat => fn n z) N)).
   apply Rlt_minus_exchange ; apply Rle_lt_trans with (Cnorm (CFpartial_sum (fun n : nat => fn n z) N - l1)) ;
   [apply Cnorm_triang_rev_r | apply Hfn ;  apply le_max_l].
   apply Rle_lt_trans with (Rabs (sum_f_R0 An N)).
   apply Rle_trans with (sum_f_R0 (fun n => Cnorm (fn n z)) N).
   unfold CFpartial_sum ; apply sum_f_C0_triang.
   clear - fn_bd ; induction N.
   simpl ; rewrite Rabs_right ; [| apply Rle_ge ; apply Rle_trans with (Cnorm (fn O z)) ;
   [apply Cnorm_pos |] ] ; apply fn_bd.
   simpl ; rewrite Rabs_right.
   apply Rle_trans with (Rplus (sum_f_R0 An N) (Cnorm (fn (S N) z))) ;
   [apply Rplus_le_compat_r ; rewrite <- Rabs_right ; [apply IHN |] |
   apply Rplus_le_compat_l ; apply fn_bd].
   apply Rle_ge ; apply cond_pos_sum.
   intro n ; apply Rle_trans with (Cnorm (fn n z)) ; [apply Cnorm_pos | apply fn_bd].
   rewrite <- tech5 ; apply Rle_ge ; apply cond_pos_sum.
   intro n ; apply Rle_trans with (Cnorm (fn n z)) ; [apply Cnorm_pos | apply fn_bd].
   apply Rlt_plus_exchange.
   apply Rle_lt_trans with (R_dist (sum_f_R0 An N) l2).
   apply Rle_trans with (Rminus (Rabs (sum_f_R0 An N)) (Rabs l2)).
   replace (Rabs l2) with l2.
   right ; reflexivity.
   symmetry ; apply Rabs_right.
   apply Rle_ge ; apply Rseq_limit_comparison with (fun _ => R0)  (fun n : nat => sum_f_R0 An n).
   intros n ; apply cond_pos_sum ; intro n' ; apply Rle_trans with (Cnorm (fn n' z)) ;
   [apply Cnorm_pos | apply fn_bd].
   intros ; exists O ; intros ; simpl ; unfold R_dist . rewrite Rminus_0_r.
   change R0 with (IZR 0). rewrite Rabs_R0 ; assumption.
   assumption.
   unfold R_dist ; apply Rabs_triang_inv.
   apply HAn ; apply le_max_r.
   assert (Cnorm l1 < Cnorm l1).
   apply Rlt_trans with (l2 + 2 * eps)%R.
   lra.
   unfold eps.
   apply Rle_lt_trans with ((Cnorm l1 + l2) / 2)%R.
   right ; field.
   rewrite Rplus_comm ; apply (middle_is_in_the_middle _ _ Hf).
   elim (Rlt_irrefl _ H).
Qed.

Definition Csigma f low high := sum_f_C0 (fun n : nat => f (low + n)%nat) (high - low).

Lemma   Csigma_split : forall (f : nat -> C) (low high k : nat),
       (low <= k)%nat ->  (k < high)%nat ->
       Csigma f low high = (Csigma f low k + Csigma f (S k) high).
Proof.
intros f low high k l_le_k k_lt_h.
 unfold Csigma.
 apply (proj1 (Ceq _ _)) ; split.
 rewrite <- Cre_add_compat ; do 3 rewrite <- sum_f_C0_Cre_compat.
 assert (H := sigma_split (fun n => Cre (f n))  l_le_k k_lt_h) ;
 unfold sigma in H ; assumption.
 rewrite <- Cim_add_compat ; do 3 rewrite <- sum_f_C0_Cim_compat.
 assert (H := sigma_split (fun n => Cim (f n))  l_le_k k_lt_h) ;
 unfold sigma in H ; assumption.
Qed.

Lemma sum_maj1 : forall (fn : nat -> C -> C) (An : nat -> R) (x l1: C) (l2 : R) (N : nat),
       Cseq_cv (fun n : nat => CFpartial_sum (fun n => fn n x) n) l1 ->
       Rseq_cv (fun n : nat => sum_f_R0 An n) l2 ->
       (forall n : nat, Cnorm (fn n x) <= An n) ->
       Cnorm (l1 - CFpartial_sum (fun n => fn n x) N) <= l2 - sum_f_R0 An N.
Proof.
  intros fn An x l1 l2 N fn_cv An_cv fn_bd ;
    cut { l:C | Cseq_cv (fun n => sum_f_C0 (fun l => fn (S N + l)%nat x) n) l }.
  intro X;
    cut { l:R | Rseq_cv (fun n => sum_f_R0 (fun l => An (S N + l)%nat) n) l }.
  intro X0; elim X; intros l1N H2.
  elim X0; intros l2N H3.
  cut (l1 - CFpartial_sum (fun n => fn n x) N = l1N).
  intro Temp; cut (Rminus l2 (sum_f_R0 An N) = l2N).
  intro Temp2; rewrite Temp, Temp2.
  apply sum_cv_maj with (fun n => An (S N + n)%nat) (fun I => fn (S N + I)%nat) x.
  assumption.
  assumption.
  intro n ; apply fn_bd.
  symmetry ; eapply Rseq_cv_unique.
  apply H3.
  unfold Rseq_cv in An_cv |-* ; intros eps eps_pos ; destruct (An_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))%R
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2)%R;
      [| ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n)%R with
  (sum_f_R0 An (S (N + n)))%R.
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := sigma_split An N_pos N_ub) ; unfold sigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  apply sum_eq; intros ;  reflexivity.
  apply sum_eq; intros ;  reflexivity.
  symmetry ; eapply Cseq_cv_unique.
  apply H2.
  unfold Rseq_cv in fn_cv |-* ; intros eps eps_pos ; destruct (fn_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n - (l1 -  CFpartial_sum (fun n0 : nat => fn n0 x) N))
    with ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n) - l1);
      [| ring ].
      replace ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n))
      with (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)%nat).
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := Csigma_split (fun n => fn n x) O (S (N + n)) N N_pos N_ub) ; unfold Csigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)) with
  (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) (S (N + n))).
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) N) with (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.

  exists (l2 - sum_f_R0 An N)%R.
   unfold Rseq_cv in An_cv |-* ; intros eps eps_pos ; destruct (An_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))%R
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2)%R;
      [| ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n)%R with
  (sum_f_R0 An (S (N + n)))%R.
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := sigma_split An N_pos N_ub) ; unfold sigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  apply sum_eq; intros ;  reflexivity.
  apply sum_eq; intros ;  reflexivity.

  exists (l1 - CFpartial_sum (fun n => fn n x) N).

 intros eps eps_pos ; destruct (fn_cv _ eps_pos) as [N' HN'] ; exists N' ; intros n n_lb.

    replace (sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n - (l1 -  CFpartial_sum (fun n0 : nat => fn n0 x) N))
    with ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n) - l1);
      [| ring ].
      replace ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n))
      with (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)%nat).
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := Csigma_split (fun n => fn n x) O (S (N + n)) N N_pos N_ub) ; unfold Csigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)) with
  (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) (S (N + n))).
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) N) with (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
Qed.

Lemma CVN_CVU_boule :forall (fn : nat -> C -> C) (r : posreal)
       (cv : forall z : C,  Boule 0 r z -> {l : C | Cseq_cv (fun N : nat => CFpartial_sum (fun n => fn n z) N) l}),
       CVN_r fn r ->
       CFseq_cvu (fun N  z => CFpartial_sum (fun n => fn n z) N) (SFL_interv fn r cv) 0 r.
Proof.
intros fn r cv cvn eps eps_pos.

 destruct cvn as [An [l [sum_cv fn_bd]]] ;
 destruct (sum_cv eps eps_pos) as [N HN] ;
 exists N ; intros n y n_lb y_bd.
 unfold SFL_interv.
 destruct (Rlt_le_dec (Cnorm (0 - y)) r) as [y_bd2 | y_lb].

  destruct (cv y y_bd2) as [l2 Hl2] ; unfold C_dist.

 apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k => Cnorm (An k)) n - l)).
  rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Cnorm (An k)) n - l));
    rewrite Ropp_minus_distr';
      rewrite (Rabs_right (l - sum_f_R0 (fun k:nat => Cnorm (An k)) n)).
  rewrite Cnorm_minus_sym ; eapply sum_maj1.
  apply Hl2.
  apply sum_cv.
  intros ; apply fn_bd ; assumption.
  apply Rge_minus ; apply Rle_ge ; apply sum_incr.
  assumption.
  intros ; apply Cnorm_pos.
  unfold R_dist in HN ; apply HN ; assumption.

unfold Boule in y_bd ; simpl in y_bd ; unfold C_dist in y_bd.
 assert (Hf : Cnorm (0 - y) < Cnorm (0 - y)).
  apply Rlt_le_trans with r ; assumption.
 destruct (Rlt_irrefl _ Hf).
Qed.

Lemma CVU_continuity_boule :forall (fn : nat -> C -> C) (f : C -> C) (c : C) (r : posreal),
       CFseq_cvu fn f c r ->
       (forall n z, Boule c r z -> continuity_pt (fn n) z) ->
       forall z, Boule c r z -> continuity_pt f z.
Proof.
intros fn f c r fn_cvu fn_cont z z_in.
 intros eps eps_pos ; assert (eps_3_pos : 0 < (eps / 3)%R) by lra ;
 destruct (fn_cvu _ eps_3_pos) as [N HN] ;
 destruct (fn_cont N z z_in _ eps_3_pos) as [delta1 [delta1_pos Hdelta]].
 pose (delta := Rmin delta1 ((r - Cnorm (c - z))/2)) ;
 assert (delta_pos : 0 < delta).
  unfold delta ; apply Rmin_pos_lt.
  assumption.
  unfold Rdiv ; apply Rlt_mult_inv_pos ; [apply Rlt_Rminus ; apply z_in | lra].
  exists delta ; split ; [assumption | intros x [_  Hx]].
  simpl ; unfold C_dist.
  apply Rle_lt_trans with (Cnorm (f x - fn N x) + Cnorm (fn N x - fn N z) + Cnorm (fn N z  - f z))%R.
  replace (f x - f z)%C with ((f x - fn N x) + (fn N x - fn N z) + (fn N z - f z))%C by ring.
  apply Rle_trans with (Cnorm ((f x - fn N x) + (fn N x - fn N z)) + Cnorm (fn N z - f z))%R ;
  [| apply Rplus_le_compat_r] ;  apply Cnorm_triang.
  apply Rlt_trans with (Cnorm (f x - fn N x) + Cnorm (fn N x - fn N z) + (eps/3))%R.
  apply Rplus_lt_compat_l ; apply HN ; trivial.
  apply Rlt_trans with (eps/3 + Cnorm (fn N x - fn N z) + eps / 3)%R.
  do 2 apply Rplus_lt_compat_r ; rewrite Cnorm_minus_sym ; apply HN ; trivial.
 unfold Boule in * ; simpl in * ; unfold C_dist in *.
 replace (c - x)%C with ((c - z) + - (x - z))%C by ring.
 apply Rle_lt_trans with (Cnorm (c - z) + Cnorm (- (x - z)))%R ;
 [apply Cnorm_triang | rewrite Cnorm_opp].
 apply Rlt_trans with (Cnorm (c - z) + delta)%R ;
 [apply Rplus_lt_compat_l ; assumption |].
 apply Rle_lt_trans with (Cnorm (c - z) +  (r - Cnorm (c - z))/2)%R ;
 [apply Rplus_le_compat_l ; apply Rmin_r |].
 field_simplify ; unfold Rdiv ; try rewrite Rinv_1, Rmult_1_r.
 apply (middle_is_in_the_middle _ _ z_in).
 destruct (Ceq_dec x z) as [eq | neq].
 subst ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ; lra.
 apply Rlt_le_trans with (eps/3 + eps/3 + eps/3)%R ; [| right ; field].
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; simpl in Hdelta ; apply Hdelta ; split.
 unfold Cderiv.D_x, no_cond ; split ; auto.
 apply Rlt_le_trans with delta ; [apply Hx | unfold delta ; apply Rmin_l].
Qed.