Require Export BaseDef.
Require Import Arith Even Div2.
Require Import Coq.Logic.Classical_Prop.

Set Implicit Arguments.

Lemma class_wretract: forall f,
  class (wretract f).
Proof.
 intros f H.
 apply (NNPP _ H).
Qed.

Lemma cover_eq_prod: forall (A B:Type) (P:A -> MF A) (Q:B -> MF B),
 (forall a, cover (eq a) (P a)) ->
 (forall b, cover (eq b) (Q b)) ->
 forall ab : A * B,
  cover (eq ab) (fun ab' => P (fst ab) (fst ab') * Q (snd ab) (snd ab'))%U.
Proof.
 intros A B P Q HP HQ ab.
 apply cover_equiv_stable with
  (inter (fun ab' => eq (fst ab') (fst ab)) (fun ab' => eq (snd ab') (snd ab))).
 unfold Sets.equiv, inter; split.
 intros [H1 H2].
 destruct ab; destruct x; simpl in *; rewrite H1, H2; trivial.
 intros H1.
 destruct ab; destruct x; simpl; injection H1; auto.
 apply cover_inter_mult.
 intros ab'; split; intros.
 apply (cover_eq_one _ (HP (fst ab)) (eq_sym H)).
 apply (cover_eq_zero _ (HP (fst ab)) (not_eq_sym H)).
 intros ab'; split; intros.
 apply (cover_eq_one _ (HQ (snd ab)) (eq_sym H)).
 apply (cover_eq_zero _ (HQ (snd ab)) (not_eq_sym H)).
Qed.

 Lemma even_2n : forall n, even (2*n).
 Proof.
  intro n.
  apply even_mult_l.
  repeat constructor.
 Qed.

 Lemma odd_S2n : forall n, odd (S(2*n)).
 Proof.
  intro n.
  constructor.
  apply even_2n.
 Qed.

 Lemma lub_le_n: forall (c:cpo) (f:natO -m> c) (x:c) k,
   (forall n : natO, k <= n -> f n <= x) ->
   lub (c:=c) f <= x.
 Proof.
  intros.
  set (f' := fun n => if le_lt_dec n k then f k else f n).
  assert (Hf' : forall n : nat, f' n <= f' (S n)).
    intro; unfold f'.
    destruct (le_lt_dec (S n) k); destruct (le_lt_dec n k);
      [ trivial | exfalso; omega | apply fmon_le_compat;
        auto with arith | apply fnatO_elim ].
  refine (@Ole_trans _ _ (lub (c:=c) (fnatO_intro Hf')) _ _ _).
    apply lub_le_compat.
    refine (ford_le_intro _); intro n; unfold f'; simpl.
    destruct (le_lt_dec n k); auto.
    apply lub_le; intros; unfold f'; simpl.
    destruct (le_lt_dec n k); auto with arith.
 Qed.

Lemma Umult_zero_left_strong: forall a b,
  (~ b == 0 -> a == 0) ->
  a * b == 0.
Proof.
 intros.
 apply (Ueq_orc b 0); [ auto | | ]; intro Hb.
   apply (Umult_zero_right_eq _ Hb).
   apply (Umult_zero_left_eq _  (H Hb)).
Qed.

(* Given two discrete disctribution over [A], restate them in terms
   of the same enumearion of [A]'s elements *)
Section SAME_ENUM.

 Variable A : Type.
 Variable AeqU : A -> A -O-> U.
 Hypothesis cover_uR: forall a : A, cover (eq a) (AeqU a).

 Variable d1 d2 : Distr A.
 Hypothesis is_Discr_d1 : is_Discrete d1.
 Hypothesis is_Discr_d2 : is_Discrete d2.

(*
  parity_split f g (2m) = f m
  parity_split f g (2m+1) = g m
*)
 Definition parity_split := fun (A:Type) (f g : nat -> A) n  =>
   match (even_odd_dec n) with
   | left x => f (div2 n)
   | right x => g (div2 (pred n))
   end.

 Let p1 := D_points is_Discr_d1.
 Let p2 := D_points is_Discr_d2.
 Let D1 := D_Discr is_Discr_d1.
 Let D2 := D_Discr is_Discr_d2.

 Let c1 : nat -> U := parity_split (coeff AeqU p1 d1) (fzero _).
 Let c2 : nat -> U := parity_split (fzero _) (coeff AeqU p2 d2).
 Let p  : nat -> A := parity_split p1 p2.

 Lemma disc_eqpoint_l : Discrete (@eq A) p d1.
 Proof.
  apply range_weaken with (2:=D1); fold p1.
  unfold In_classes; intros x Hx.
  unfold p, parity_split.
  unfold exc in *.
  intros P HP H.
  apply (Hx _ HP).
  intros n Hn.
  generalize (H (2*n)%nat).
  elim (even_odd_dec (2*n)%nat); intro Hn'.
     rewrite div2_double.
     exact (fun n => n Hn).
     elimtype False; refine (not_even_and_odd _ (even_2n _) Hn').
 Qed.

 Lemma disc_eqpoint_r : Discrete (@eq A) p d2.
 Proof.
  apply range_weaken with (2:=D2); fold p2.
  unfold In_classes; intros x Hx.
  unfold p, parity_split.
  unfold exc in *.
  intros P HP H.
  apply (Hx _ HP).
  intros n Hn.
  generalize (H (S(2*n))).
  elim (even_odd_dec (S(2*n))); intro Hn'.
     elimtype False; refine (not_even_and_odd _ Hn' (odd_S2n _)).
     rewrite <-pred_Sn, div2_double; exact (fun n => n Hn).
 Qed.

End SAME_ENUM.

Section COEFF.

 Variable A : Type.
 Variable AeqU : A -> A -O-> U.
 Hypothesis cover_uR: forall a : A, cover (eq a) (AeqU a).

 Variable d: Distr A.

 Variable p: nat -> A.
 Hypothesis H_d: Discrete (@eq A) p d.

  Variable Uleb : U -> U -> bool.
  Hypothesis Ule_eq_compat: forall x1 y1 x2 y2,
   x1 == x2->
   y1 == y2 ->
   Uleb x1 y1 = Uleb x2 y2.
  Hypothesis Uleb_corr_conv: forall x y : U,
   x <= y -> Uleb x y.
  Hypothesis Uleb_compl_conv : forall (x y: U),
   y < x -> Uleb x y = false.

 Lemma coeff_first_repr: forall k,
   not_first_repr AeqU p k == 0 ->
   coeff AeqU p d k == mu d (AeqU (p k)).
  Proof.
   intros k Hk.
   rewrite (mu_is_Discrete _ cover_uR (mkDiscr H_d)); simpl.
   split.
     (* left ineq *)
     rewrite <-(@serie_le _ k), (@cover_eq_one A (fun a => p k = a) _ (p k)
         (cover_uR (p k)) (eq_refl _)); auto.
     (* right ineq *)
     apply lub_le_n with (S k); intros n Hn.
     rewrite <-(le_plus_minus_r _ _ Hn), sigma_plus_lift, sigma_S.
     rewrite (@cover_eq_one A (fun a => p k = a) _ (p k) (cover_uR (p k)) (eq_refl _)), Umult_one_right.
     match goal with |- _ + ?X1 + ?X2 <= _ => setoid_replace X1 with (@D0 U);
       [ setoid_replace X2 with (@D0 U) | ] end; [ rewrite 2 Uplus_zero_right; trivial | | ].
     apply sigma_zero; intros n' Hn'.
     apply (cover_elim (cover_uR (p k)) (p (S k + n'))); [ auto | | ]; intros (Heq',Heq).
       rewrite Heq; auto.
       apply Umult_zero_left_eq; apply Umult_zero_left_eq.
       rewrite (@cover_eq_one _ (fun k => exc (fun k' => (k' < k)%nat /\ p k = p k'))
         _ (S k + n')%nat (cover_not_first_repr _ _ cover_uR p)); trivial.
       apply exc_intro with k; split; [ omega | auto ].
     apply Ule_zero_eq; rewrite <-Hk; apply sigma_le_compat; intros; auto.
  Qed.

  Lemma coeff_not_first_repr: forall k,
   not_first_repr AeqU p k == 1 ->
   coeff AeqU p d k == 0.
  Proof.
   intros k Hk.
   unfold coeff.
   rewrite Hk, Uinv_one; auto.
  Qed.

End COEFF.

Lemma exc_weaken: forall (A:Type) (P Q: A -> Prop),
  (forall a, P a -> Q a) ->
  exc P ->
  exc Q.
Proof.
 unfold exc; intros A P Q HPQ HP C H1C H2C.
 apply (HP _ H1C).
 intros a Ha; apply (H2C _ (HPQ _ Ha)).
Qed.

Section ELEM_IN_ENUM_CASE.

 Variable A:Type.
 Variable carA : A -> MF A.
 Hypothesis carA_prop: forall a, cover (fun x => a = x) (carA a).
 Variable p:nat -> A.

Lemma is_in_finite_enum: forall a n,
  orc (forall k, (k < n)%nat -> p k <> a)
      (exc (fun k => (k < n)%nat /\ p k = a /\ [1-] (sigma (fun i => carA a (p i))) k == 1)).
Proof.
 induction n.
   (* base case *)
   apply orc_left.
   intros k Hk; elim (lt_n_O _ Hk).
   (* inductive cae *)
   unfold orc in *; intros C HC H1C H2C.
   apply (IHn _ HC); clear IHn.
     (* left *)
     intro H.
     destruct (classic (p n = a)) as [H' | H'].
       apply H2C, exc_intro with n; repeat split; trivial.
         auto with arith.
         rewrite sigma_zero; [ Usimpl; trivial | ].
         intros k Hk; apply (cover_eq_zero (p k) (carA_prop a)),
           not_eq_sym, (H _ Hk).
       apply H1C; intros k Hk'.
       destruct (le_lt_or_eq _ _ (lt_n_Sm_le _ _ Hk')) as [Hk | Hk]; clear Hk'.
         auto.
         rewrite Hk; trivial.
     (* right *)
     intro H; apply H2C; clear H1C H2C HC C.
     unfold exc in *; intros C H1C H2C.
     apply (H _ H1C); intros k (H1k,(H2k,H3k)).
     apply H2C with k; split; [ | split ]; auto with arith.
Qed.

Lemma is_in_enum_aux: forall k a,
  p k = a ->
  exc (fun k : nat => p k = a /\ [1-] not_first_repr carA p k == 1).
Proof.
 intros k a Hk.
 pose proof (@is_in_finite_enum (p k) (S k)) as H.
 unfold exc; unfold orc in *; intros C H1C H2C.
 apply (H _ H1C); intro H'; clear H.
   (* left *)
   elim (H' k (lt_n_Sn _) (eq_refl _)).
   (* right *)
   apply (H' _ H1C); intros k' (H1k',(H2k',H3k')).
   apply H2C with k'; split.
     rewrite <-Hk; trivial.
     unfold not_first_repr.
     rewrite H2k'; trivial.
Qed.

Lemma is_in_enum: forall (a:A),
  orc
   (exc (fun k => p k = a /\ [1-] not_first_repr carA p k == 1))
   (forall k, p k <> a).
Proof.
 intro a.
 apply orc_intro.
 intros H1 H2.
 apply H1; clear H1.
 destruct (Classical_Pred_Type.not_all_ex_not _ _ H2)
   as (k', Hk'); apply NNPP in Hk'.
 apply is_in_enum_aux with k'; trivial.
Qed.

End  ELEM_IN_ENUM_CASE.

Section ENUMERATIONS_PROP.

Lemma enum_le: forall (A:Type) (d1 d2: Distr A) (p:nat -> A),
  Discrete (@eq A) p d2 ->
  d1 <= d2 ->
  Discrete (@eq A) p d1.
Proof.
 unfold Discrete, range; intros A d1 d2 p Hd2 Hd f Hf.
 split; trivial.
 rewrite (Hd f); auto.
Qed.

Lemma enum_Munit: forall (A:Type) (a:A) (p:nat -> A),
 exc (fun k : nat => a = p k) ->
 Discrete (@eq A) p (Munit a).
Proof.
 intros A a p Hp f Hf.
 refine (Hf a Hp).
Qed.

Lemma enum_Mlet: forall (A B:Type) (d: Distr A) (F:A -> Distr B) (p:nat -> A)
  (P: A -> nat -> B),
  Discrete (@eq A) p d ->
  (forall a, Discrete (@eq B) (P a) (F a)) ->
  Discrete (@eq B) (fun k => let (i, j) := bij_n_nxn k in P (p i) j) (Mlet d F).
Proof.
 intros A B d F p P Hd HF.
 red.
 apply range_Mlet with (1:=Hd).
 intros a Ha.
 apply range_weaken with (2:=HF a).
 intros b Hb.
 apply Ha;[ unfold In_classes; trivial | intros i Hi].
 apply Hb;[ unfold In_classes; trivial | intros j Hj].
 destruct (bij_surj i j) as (k, Heq).
 red; apply exc_intro with k.
 rewrite Heq.
 rewrite Hj, <- Hi; trivial.
Qed.

Lemma enum_wretract_eq: forall (A:Type) (carA : A -> MF A) (p:nat ->A),
 (forall a, cover (fun x => a = x) (carA a)) ->
 forall a,
  wretract (fun k => [1-] not_first_repr carA p k * carA (p k) a).
Proof.
 intros A carA p carA_prop a.
 apply (@is_in_enum _ _ carA_prop p a); [ apply class_wretract | | ].
   (* case [a] is in the enumerarion [p1] *)
   intro H.
   apply H; [ apply  class_wretract | ].
   intros k' (H1k',H2k').
   assert (Haux: sigma (fun k => [1-] not_first_repr carA p k * carA (p k) a) k' == 0).
     split; trivial.
     rewrite <-Uinv_one, <-(Uinv_le_perm_right _ _ (proj2 H2k')).
     unfold not_first_repr at 2; rewrite H1k'.
     apply sigma_le_compat; intros k Hk.
     rewrite (carA_sym _ carA_prop); trivial.
   apply retract_zero_wretract with (S k').
     apply retractS_intro.
       apply retract_lt; rewrite Haux; trivial.
       rewrite Haux; Usimpl; trivial.
     intros k Hk.
     apply Umult_zero_left_strong; intro H'.
     apply (cover_elim (carA_prop (p k)) a); [ auto | | ];
       intros [H4 H5]; [ tauto | clear H' ].
     split; trivial; apply Uinv_le_perm_left; Usimpl.
     unfold not_first_repr.
     rewrite <-(sigma_incr _ Hk), sigma_S, H1k', H5; trivial.
   (* case [a] is not in the enumerarion [p1] *)
   intros H.
   apply wretract_lt; intro n; rewrite sigma_zero; trivial.
    intros k Hk.
     apply Umult_zero_right_eq.
     apply (cover_eq_zero a (carA_prop (p k)) (H _)).
 Qed.

Lemma enum_wretact_mu: forall (A:Type) (d:Distr A) (carA : A -> MF A) (p:nat ->A),
 (forall a, cover (fun x => a = x) (carA a)) ->
 wretract (fun k  => [1-] not_first_repr carA p k * mu d (carA (p k))).
Proof.
 intros A d carA p carA_prop.
 intro k.
 apply (cover_elim (cover_not_first_repr _ _ carA_prop p) k);
    [auto | | ]; intros [H4 H5]; rewrite H5; repeat Usimpl.
     (* case [first repr k of (p k) == 1] *)
     (* Push factor [[1-] not_first_repr carA p k0] inside
       the function measured by d *)
     transitivity ([1-] (sigma (fun k => mu d
       (fmult ([1-] not_first_repr carA p k) (carA (p k)))) k));
       [ | apply Uinv_le_compat; apply sigma_le_compat; intros; apply mu_stable_mult ].
     (* Push the [sigma] inside the function measured by d *)
     rewrite <-mu_sigma_eq.
     Focus 2.
     intros a k' Hk'; unfold fmult.
     apply (cover_elim (cover_not_first_repr _ _ carA_prop p) k');
     [auto | | ]; intros [_ H5'].
       (* case [first repr k' of (p k') == 1] *)
       rewrite H5'; repeat Usimpl.
       apply (cover_elim (carA_prop (p k')) a); [auto | | ]; intros [H1 H2].
         rewrite H2; trivial.
         rewrite H2, sigma_zero; [auto | ].
         intros k'' Hk''.
         apply Umult_zero_right_eq.
         rewrite <-H1, (carA_sym _ carA_prop).
         apply (@sigma_zero_elim (fun i => carA (p k') (p i)) k'); trivial.
       (* case [first repr k' of (p k') == 1] *)
       rewrite H5'; repeat Usimpl; trivial.
     (* Conclude the proof *)
     apply mu_fplusok; intro a; unfold finv, sigma_fun, fmult.
     apply (cover_elim (carA_prop (p k)) a); [auto | | ]; intros [? Heq].
       rewrite Heq; trivial.
       rewrite Heq, sigma_zero; [auto | ].
       intros k' Hk'.
       apply Umult_zero_right_eq.
       rewrite <-H, (carA_sym _ carA_prop).
       apply (@sigma_zero_elim (fun i => carA (p k) (p i)) k); trivial.

     (* case [first repr k of (p k) == 1] *)
     trivial.
Qed.

(*
Lemma enum_Mfst: forall (A B:Type) (d: Distr (A*B)) (p:nat -> A*B),
  Discrete (@eq (A*B)) p d ->
  Discrete (@eq A) (fun k => fst (p k)) (Mfst d).
Proof.
 intros; red.
 apply range_weaken with (In_classes eq (fun k => let (i,j):=bij_n_nxn k in fst (p i))).

 unfold In_classes, exc; intros a Ha C HclassC HC.
 apply (Ha _ HclassC).
 intros k Hk.
 apply (HC (fst (bij_n_nxn k))).
 destruct (bij_n_nxn k); simpl; trivial.

 apply (enum_Mlet _ (fun ab _ => fst ab) H).
 intros (a,b); simpl.
 apply enum_Munit; refine (exc_intro _ 0%nat (eq_refl a)).
Qed.

Lemma enum_Msnd: forall (A B:Type) (d: Distr (A*B)) (p:nat -> A*B),
  Discrete (@eq (A*B)) p d ->
  Discrete (@eq B) (fun k => snd (p k)) (Msnd d).
Proof.
 intros.
 intros; red.
 apply range_weaken with (In_classes eq (fun k => let (i,j):=bij_n_nxn k in snd (p i))).

 unfold In_classes, exc; intros a Ha C HclassC HC.
 apply (Ha _ HclassC).
 intros k Hk.
 apply (HC (fst (bij_n_nxn k))).
 destruct (bij_n_nxn k); simpl; trivial.

 apply (enum_Mlet _ (fun ab _ => snd ab) H).
 intros (a,b); simpl.
 apply enum_Munit; refine (exc_intro _ 0%nat (eq_refl b)).
Qed.
*)

End ENUMERATIONS_PROP.

Add Parametric Morphism (A:Type) (p:nat -> A) : (@Discrete A (@eq A) p)
 with signature Ole (o:=Distr A) --> impl as Discrete_le_compat_morph.
Proof.
 unfold impl; eauto using enum_le.
Qed.

(* Construction of the "minimum" distribution between a pair of distributions *)
Section DISTR_MIN.

 Variable A : Type.
 Variable AeqU : A -> A -O-> U.
 Hypothesis cover_uR: forall a : A, cover (eq a) (AeqU a).
 Variable p: nat -> A.

(*
 Section DISTR_RESTRICTION.

  Variable d1 d2 : Distr A.
  Hypothesis H_d1: Discrete (@eq A) p d1.
  Hypothesis H_d2: Discrete (@eq A) p d2.

  Variable Uleb : U -> U -> bool.

  Hypothesis Ule_eq_compat: forall x1 y1 x2 y2,
   x1 == x2->
   y1 == y2 ->
   Uleb x1 y1 = Uleb x2 y2.
  Hypothesis Uleb_corr_conv: forall x y : U,
   x <= y -> Uleb x y.
  Hypothesis Uleb_compl_conv : forall (x y: U),
   y < x -> Uleb x y = false.

  Lemma restr_left_le_right: forall f,
   let P := fun a => Uleb (mu d1 (AeqU a)) (mu d2 (AeqU a)) in
   mu d1 (restr P f) <= mu d2 (restr P f).
  Proof.
  intros.
  rewrite (mu_is_Discrete _ cover_uR (mkDiscr H_d1)),
    (mu_is_Discrete _ cover_uR (mkDiscr H_d2)); simpl.
  apply serie_le_compat.
  intros k.
  apply (cover_elim (cover_not_first_repr _ _ cover_uR p) k); [auto | | ]; intros [H4 H5].
    unfold P, restr.
    rewrite (coeff_first_repr _ cover_uR H_d1 _ H5), (coeff_first_repr _ cover_uR H_d2 _ H5).
    apply (Ule_orc (mu d1 (AeqU (p k))) (mu d2 (AeqU (p k)))); [ auto | | ]; intro Hle.
      rewrite (Uleb_corr_conv _ _ Hle); auto.
      rewrite (Uleb_compl_conv Hle), 2 Umult_zero_right; auto.
    rewrite 2 (coeff_not_first_repr _ _ _ _ H5); auto.
  Qed.

 End DISTR_RESTRICTION.
*)

 Variable d1 d2 : Distr A.

 Hypothesis H_d1: Discrete (@eq A) p d1.
 Hypothesis H_d2: Discrete (@eq A) p d2.

 Variable Uleb : U -> U -> bool.
 Hypothesis Uleb_corr_conv: forall x y : U,
   x <= y -> Uleb x y.
 Hypothesis Uleb_compl_conv : forall (x y: U),
   y < x -> Uleb x y = false.

  Lemma wretract_coeff:
    wretract (coeff AeqU p d1).
  Proof.
   unfold wretract, coeff; intros.
   apply (Ueq_orc 1 (not_first_repr AeqU p k)); [auto | | ]; intros.

  (* case [first repr k of (p k) == 0] *)
  rewrite <-H; repeat Usimpl; trivial.

  (* case [first repr k of (p k) == 1] *)
  apply (not_first_repr_bool _ cover_uR) in H.
  rewrite H; repeat Usimpl; unfold not_first_repr.

  (* Push factor [([1-] not_first_repr AeqU p i)] inside
     the function measured by d1 *)
  transitivity ([1-]
   (sigma (fun i => mu d1 (fmult ([1-] not_first_repr AeqU p i) (AeqU (p i))))) k);
  [ | apply Uinv_le_compat; apply sigma_eq_compat; intros; apply mu_stable_mult].

  (* Push the [sigma] inside the function measured by d1 *)
  rewrite <-mu_sigma_eq.
  Focus 2.
  intros ? ? ?; unfold fmult.
  apply (Ueq_orc 1 (not_first_repr AeqU p k0)); [auto | | ]; intros.

  rewrite <-H1; repeat Usimpl; trivial.

  apply (not_first_repr_bool _ cover_uR) in H1.
  rewrite H1; repeat Usimpl.
  apply (cover_elim (cover_uR (p k0)) x); [auto | | ]; intros [? ?].
  rewrite H3; trivial.
  rewrite H3, sigma_zero; [auto | ].
  intros.
  assert (AeqU (p k1) x == 0).
  rewrite <-H2, (carA_sym _ cover_uR).
  apply (@sigma_zero_elim (fun i => AeqU (p k0) (p i)) k0);  trivial.
  rewrite H5; trivial.

  apply mu_fplusok; intro x; unfold finv, sigma_fun.
  apply (cover_elim (cover_uR (p k)) x); [auto | | ]; intros [? Heq].
  rewrite Heq; trivial.
  rewrite Heq, sigma_zero; [auto | ].
  intros k0 Hlt; unfold fmult.
  assert (AeqU (p k0) x == 0).
  unfold not_first_repr in H0.
  rewrite <-H0, (carA_sym _ cover_uR).
  apply (@sigma_zero_elim (fun i => AeqU (p k) (p i)) k); trivial.
  rewrite H1; trivial.

 Qed.

 Definition dmin:Distr A.
  apply PP.Discrete.
  refine (@Build_discr _ (fun k => min (coeff AeqU p d1 k) (coeff AeqU p d2 k)) _ p).
  apply wretract_le with (coeff AeqU p d1); [ auto |  apply wretract_coeff ].
 Defined.

 Lemma dmin_le_d1: forall f, mu dmin f <= mu d1 f.
 Proof.
  unfold dmin; intros; simpl.
  rewrite (mu_is_Discrete _ cover_uR (mkDiscr H_d1)); auto.
 Qed.

 Lemma dmin_le_d2: forall f, mu dmin f <= mu d2 f.
 Proof.
  unfold dmin; intros; simpl.
  rewrite (mu_is_Discrete _ cover_uR (mkDiscr H_d2)); auto.
 Qed.

 Lemma dmin_simpl: forall f,
   let P := fun a => Uleb (mu d1 (AeqU a)) (mu d2 (AeqU a)) in
   mu dmin f == mu d1 (restr P f) + mu d2 (restr (negP P) f).
 Proof.
  intros.
  rewrite (mu_is_Discrete _ cover_uR (mkDiscr H_d1)),
     (mu_is_Discrete _ cover_uR (mkDiscr H_d2)); simpl.
  rewrite <-serie_plus; apply serie_eq_compat.
  intros k.
  apply (cover_elim (cover_not_first_repr _ _ cover_uR p) k); [auto | | ]; intros [H4 H5].

    rewrite (coeff_first_repr _ cover_uR H_d1 _ H5), (coeff_first_repr _ cover_uR H_d2 _ H5).
    apply (Ule_orc (mu d1 (AeqU (p k))) (mu d2 (AeqU (p k)))); [ auto | | ];
      intro Hle; unfold P, restr, negP, negb.
      rewrite (Uleb_corr_conv _ _ Hle), (min_eq_right _ _ Hle), Umult_zero_right; auto.
      rewrite (Uleb_compl_conv Hle), (min_eq_left _ _ (Ult_le Hle)), Umult_zero_right; auto.

    rewrite 2 (coeff_not_first_repr _ _ _ _ H5).
    unfold min; repeat Usimpl; trivial.
 Qed.

End DISTR_MIN.

(* Given a distribution [d] on a product [A*B] and a distribution [d2] on [B],
   if [Msnd d <= d2], then one can compute [mu d f] as shown below *)
Section DISCR_PROJ_R.

 Variables A B: Type.

 Variable carB : B -> MF B.
 Hypothesis carB_prop : forall b, cover (fun x => b = x) (carB b).

 Variable d2 : Distr B.
 Hypothesis Hd2_discr: is_Discrete d2.

 Variable d  : Distr (A*B).
 Hypothesis Msd_d_le_d2: forall f,
   mu (Msnd d) f <= mu d2 f.

 Let p2 := D_points Hd2_discr.
 Let c2 := coeff carB p2 d2.

 Lemma cp_retract_p2d : forall x,
   wretract (fun k : nat => c2 k / c2 k * carB (p2 k) x).
  Proof.
   unfold wretract; intros.
   apply (Ueq_orc 0 (c2 k)); [auto | | ]; intros.
   rewrite Udiv_by_zero; trivial; repeat Usimpl; auto.
   apply (cover_elim (carB_prop (p2 k)) x); [auto | | ]; intros [H4 H5].
   rewrite H5; repeat Usimpl; auto.
   rewrite sigma_zero; [ auto | intros].
   apply (cover_elim (carB_prop (p2 k0)) x); [auto | | ]; intros [H2 H3].
   rewrite H3; repeat Usimpl; auto.
   elim H; unfold c2, coeff.
   set (P1:=fun k => exc (fun k0 => (k0 < k)%nat /\ p2 k = p2 k0)).
   rewrite (@cover_eq_one _ P1 _ k (cover_not_first_repr (@eq B) carB carB_prop p2)).
   Usimpl; auto.
   red; apply exc_intro with k0; split; trivial.
   rewrite H2; trivial.
  Qed.

  Definition in_p2_d b := serie (fun k : nat => c2 k / c2 k * carB (p2 k) b).

  Lemma in_p2_d_dec : forall b, orc (in_p2_d b == 0) (in_p2_d b == 1).
  Proof.
   intros; apply orc_intro; intros.
   elim H.
   unfold in_p2_d.
   apply serie_zero.
   intros k; apply (Ueq_orc (c2 k / c2 k * carB (p2 k) b) 0); auto; intros.
   elim H0; split; trivial.
   transitivity (c2 k / c2 k * carB (p2 k) b).
   apply (Ueq_orc (c2 k)  0); auto; intros.
   elim H1; rewrite H2, Udiv_by_zero; auto.
   apply (cover_elim (carB_prop (p2 k)) b); [auto | | ]; intros [H4 H5].
   elim H1; rewrite H5; auto.
   rewrite H5, Udiv_refl; auto.
   exact (serie_le (fun k0 : nat => c2 k0 / c2 k0 * carB (p2 k0) b) k).
  Qed.

  Lemma in_p2_d_p : forall k, ~c2 k == 0 -> in_p2_d (p2 k) == 1.
  Proof.
   intros; unfold in_p2_d; split; trivial.
   transitivity (c2 k / c2 k * carB (p2 k) (p2 k)).
   rewrite Udiv_refl; [ auto | ].
   rewrite (cover_eq_one _ (carB_prop (p2 k)) (refl_equal (p2 k))).
   auto.
   auto.
   exact (serie_le (fun k0 : nat => c2 k0 / c2 k0 * carB (p2 k0) (p2 k)) k).
  Qed.

 Lemma distr_pointwise_sum_r: forall f,
   mu d2 (fun b => mu d (fun ab => carB b (snd ab) * f ab) /
      mu d2 (carB b)) ==
   mu d f.
 Proof.
  intro f.
  rewrite (mu_is_Discrete _ carB_prop  Hd2_discr);
    simpl; fold p2 c2.
  transitivity  (serie (fun k => mu d (fun ab =>
    (c2 k / c2 k) * (carB (p2 k) (snd ab) * f ab)))).
    apply serie_eq_compat; intros.
    rewrite <-Umult_div_assoc, Umult_sym, Umult_div_assoc,
      Umult_sym.
    rewrite (mu_stable_mult d (c2 k / c2 k) (fun ab =>
      carB (p2 k) (snd ab) * f ab)).
    apply Umult_eq_compat_left.
    apply (cover_elim (cover_not_first_repr _ _ carB_prop p2) k);
      [auto | | ]; intros [_ H5]; [ unfold p2 | unfold c2 ].
      rewrite <-(coeff_first_repr _ carB_prop (D_Discr Hd2_discr) _ H5); trivial.
      rewrite (coeff_not_first_repr carB d2 _ _ H5), 2 Udiv_zero; trivial.
    apply (cover_elim (cover_not_first_repr _ _ carB_prop p2) k);
      [auto | | ]; intros [_ H5]; [ unfold p2 | unfold c2 ].
      rewrite <-(coeff_first_repr _ carB_prop (D_Discr Hd2_discr) _ H5); trivial.
      rewrite (coeff_not_first_repr carB d2 _ _ H5); trivial.
    rewrite <-Msd_d_le_d2; simpl; apply (mu_monotonic d); intro; auto.
  rewrite <-mu_serie_eq; [ unfold serie_fun | intro x;
    apply wretract_le with (2:=cp_retract_p2d (snd x)); auto ].
  apply (@range_eq _ (fun x => in_p2_d (snd x) == 1) d).
    intros f' Hf'; split; trivial.
    transitivity (mu d (fun p => [1-] (in_p2_d (snd p)))).
      apply (mu_monotonic d); intro x; apply (in_p2_d_dec (snd x));
        [auto | | ]; intros H0; [rewrite H0 | rewrite <-Hf']; auto.
    rewrite (Msd_d_le_d2 (fun b : B => [1-] in_p2_d b)),
      (mu_is_Discrete _ carB_prop  Hd2_discr); simpl; fold p2 c2.
    apply serie_zero; intros.
    apply (Ueq_orc (c2 k) 0); [auto | | ]; intros;
      [ rewrite H | rewrite in_p2_d_p; [ Usimpl | ] ]; auto.
  intros ab Hab; symmetry.
  transitivity (serie (fun k => f ab * (c2 k / c2 k * carB (p2 k) (snd ab))));
    [ | auto ].
  rewrite (serie_mult _ (cp_retract_p2d (snd ab))), Hab; auto.
 Qed.

End DISCR_PROJ_R.

(* Given a distribution [d] on a product [A*B] and a distribution [d1] on [A],
   if [Mfst d <= d1], then one can compute [mu d f] as shown below *)
Section DISCR_PROJ_L.

 Variables A B: Type.

 Variable carA : A -> MF A.
 Hypothesis carA_prop : forall a, cover (fun x => a = x) (carA a).

 Variable d1 : Distr A.
 Hypothesis Hd1_discr: is_Discrete d1.

 Variable d  : Distr (A*B).

 Hypothesis Msd_d_le_d2: forall f,
   mu (Mfst d) f <= mu d1 f.

 Lemma distr_pointwise_sum_l: forall f,
   mu d1 (fun a => mu d (fun ab => carA a (fst ab) * f ab) /
      mu d1 (carA a)) ==
   mu d f.
 Proof.
  intro f.
  set (f':=fun ba => f (swap ba)).
  transitivity (mu d1 (fun a => mu (Mswap d) (fun ba => carA a (snd ba) * f' ba) /
      mu d1 (carA a))).
    apply mu_stable_eq; refine (ford_eq_intro _); intro a.
    apply Udiv_eq_compat_left.
    unfold f', swap; simpl; apply (mu_stable_eq d); refine (ford_eq_intro _); intro ab.
      rewrite <-surjective_pairing; trivial.
  rewrite (distr_pointwise_sum_r _  carA_prop Hd1_discr (Mswap d)).
  unfold f', swap; simpl.
  apply (mu_stable_eq d); refine (ford_eq_intro _); intro ab;
      rewrite <-surjective_pairing; trivial.
  intro g; rewrite (ford_eq_elim (Mswap_snd d) g); auto.
 Qed.

End  DISCR_PROJ_L.

(* Given a distribution on a product, if both projections  *
 * are discrete, then the distribution is discrete.        *)
Section DISCR_PRODUCT.

 Variables A B: Type.

 Variable carB : B -> MF B.
 Variable carA : A -> MF A.

 Hypothesis carB_prop : forall b, cover (fun x => b = x) (carB b).
 Hypothesis carA_prop : forall a, cover (fun x => a = x) (carA a).

 Variable d  : Distr (A * B).

 Hypothesis discr_d1: is_Discrete (Mfst d).
 Hypothesis discr_d2: is_Discrete (Msnd d).

 Lemma discr_projs: is_Discrete d.
 Proof.
  destruct discr_d1 as [p1 H1].
  destruct discr_d2 as [p2 H2].
  apply mkDiscr with (fun k => (p1 (fst (bij_n_nxn k)), p2 (snd (bij_n_nxn k)))).
  unfold Discrete, range in *; simpl in *.
  intros f Hf.
  rewrite <-(distr_pointwise_sum_r _ carB_prop  discr_d2 d
    (fun _ => Ole_refl _)); simpl.
  apply H2 with (f:= fun b =>
      (mu d) (fun ab : A * B => carB b (snd ab) * f ab) /
      (mu d) (fun ab : A * B => carB b (snd ab))).

  intros b Hb; apply Hb; [ auto | intros kb Hkb ].
  symmetry; apply Udiv_zero_eq.
  rewrite <-(distr_pointwise_sum_l _ carA_prop  discr_d1 d
    (fun _ => Ole_refl _)); simpl.
  apply H1 with (f:= fun a  => mu d
    (fun ab => carA a (fst ab) * (carB b (snd ab) * f ab)) /
    mu d (fun ab => carA a (fst ab))).
  intros a Ha; apply Ha; [ auto | intros ka Hka ].
  symmetry; apply Udiv_zero_eq.

  rewrite <-(mu_zero d); unfold fzero;
  apply mu_stable_eq; refine (ford_eq_intro _).
  intros (a',b'); simpl.
  apply (cover_elim (carB_prop b) b'); [ auto | | ]; intros [H4 H5].
    rewrite H5; repeat Usimpl; trivial.
    rewrite H5, <-H4; Usimpl; clear H4 H5.
    apply (cover_elim (carA_prop a) a'); [ auto | | ]; intros [H4 H5].
      rewrite H5; repeat Usimpl; trivial.
      rewrite H5, <-H4; Usimpl; clear H4 H5.
      apply Hf.
      destruct (bij_surj ka kb) as [k Hk].
      apply exc_intro with k.
      rewrite Hk; simpl; rewrite Hkb, Hka; trivial.
 Qed.

End DISCR_PRODUCT.

 Lemma discr_ext: forall (A:Type) (d1 d2: Distr A),
   (forall f, mu d1 f == 0 -> mu d2 f == 0) ->
   is_Discrete d1 ->
   is_Discrete d2.
 Proof.
  intros A d1 d2 Hd [p Hdis1].
  apply mkDiscr with p.
  unfold Discrete in *.
  intros f Hf.
  symmetry; apply Hd.
  symmetry; apply (Hdis1 _ Hf).
 Qed.

 Lemma Discr_distr_comm_elim: forall (A B:Type) (carA : A -> MF A)
   (d1: Distr A) (d2:Distr B),
   (forall a : A, cover (eq a) (carA a)) ->
   is_Discrete d1 ->
   forall f,
   mu d1 (fun a => mu d2 (fun b => f a b)) ==
   mu d2 (fun b => mu d1 (fun a => f a b)).
 Proof.
  intros.
  generalize (eq_distr_elim  (is_Discrete_commute _ H X d2)
    (fun ab => f (snd ab) (fst ab))).
  unfold prod_distr; auto.
 Qed.

Section RANGE_CHARACT.

 Variables A: Type.
 Variable d  : Distr A.
 Variable R : A -> Prop.

 Hypothesis discr_d1: is_Discrete d.

 Variable carA : A -> MF A.

 Hypothesis carA_prop : forall a, cover (fun x => a = x) (carA a).

 Lemma carA_sym: forall a1 a2, carA a1 a2 == carA a2 a1.
 Proof.
   intros.
   apply (cover_elim (carA_prop a1) a2); [ auto | | ]; intros (H,H').
     rewrite H', (@cover_eq_zero _ _ _ a1 (carA_prop a2)); auto.
     rewrite H', (@cover_eq_one _ _ _ a1 (carA_prop a2)); auto.
 Qed.

 Lemma range_discr_elim:
   range R d ->
   forall (a:A), ~ 0 == mu d (carA a) -> R a.
 Proof.
   intros Hran a Ha.
   apply NNPP; intro H; apply Ha; clear Ha.
   apply Hran; intros a' Ha'.
   rewrite carA_sym; symmetry;
     apply (@cover_eq_zero _ _ _ a (carA_prop a')).
   intros H'; subst; tauto.
 Qed.

 Lemma range_discr_intro:
  (forall (a:A), ~ 0 == mu d (carA a) -> R a) ->
  range R d.
 Proof.
  intros H f Hf.
  rewrite (mu_is_Discrete _ carA_prop discr_d1); simpl.
  symmetry; apply serie_zero; intros.
  apply (Ueq_orc (coeff carA (D_points discr_d1) d k) 0); [ auto | | ]; intro Hk.
    rewrite Hk; auto.
    destruct discr_d1 as (p, Hdiscr); simpl in *.
    apply (cover_elim (cover_not_first_repr _ _ carA_prop p) k);
      [auto | | ]; intros [_ Hpk].
      (* case first repr *)
      rewrite (coeff_first_repr _ carA_prop Hdiscr _ Hpk).
      apply Umult_zero_right_eq.
      symmetry; apply Hf; apply H.
      intro H'; elim Hk; apply Ule_zero_eq; rewrite H'.
      rewrite (mu_is_Discrete _ carA_prop (mkDiscr Hdiscr)); simpl.
      rewrite <-(serie_le _ k), (@cover_eq_one A (fun a => p k = a) _ (p k)
        (carA_prop (p k)) (eq_refl _)); auto.
      (* case not first repr *)
      rewrite (coeff_not_first_repr _ _ _ _ Hpk); auto.
 Qed.

End RANGE_CHARACT.

Section RANGE_STRENGTHEN.

 Variables A: Type.
 Variable d  : Distr A.
 Variable R S: A -> Prop.

 Hypothesis discr_d1: is_Discrete d.

 Variable carA : A -> MF A.
 Hypothesis carA_prop : forall a, cover (fun x => a = x) (carA a).

 Lemma range_discr_strengthen:
   range R d ->
   range S d ->
   range (fun a => R a /\ S a) d.
 Proof.
  intros HR HS.
  apply (range_discr_intro _ discr_d1 _ carA_prop).
  intros a Ha; split.
    apply (range_discr_elim _ carA_prop HR _ Ha).
    apply (range_discr_elim _ carA_prop HS _ Ha).
 Qed.

End RANGE_STRENGTHEN.

Section SERIE_OVER_PRODUCT_SPLIT_L.

 Variables A B: Type.
 Variable carA : A -> MF A.
 Variable carB : B -> MF B.

 Variable p:nat -> (A*B).

 Hypothesis carA_prop : forall b, cover (fun x => b = x) (carA b).
 Hypothesis carB_prop : forall b, cover (fun x => b = x) (carB b).

 Definition carProd: A*B -> MF (A*B) :=
   fun ab => fun ab' => carA (fst ab) (fst ab') * carB (snd ab) (snd ab').

 Lemma  carProd_prop: forall ab, cover (fun x => ab = x) (carProd ab).
 Proof.
  apply (cover_eq_prod _ _ carA_prop carB_prop).
 Qed.

 Lemma sigma_prod_split_l: forall H,
  serie (fun k =>  [1-] not_first_repr carProd p k * H (p k)) ==
  serie (fun kb => [1-] not_first_repr carB (fun k => snd (p k)) kb *
     serie (fun ka =>  [1-] not_first_repr carProd p ka * carB (snd (p ka)) (snd (p kb)) *
       H (fst (p ka), snd (p kb)))).
 Proof.
  generalize carA_prop, carB_prop.
  admit.
 Qed.

End SERIE_OVER_PRODUCT_SPLIT_L.

Section SERIE_OVER_PRODUCT_SPLIT_R.

 Variables A B: Type.
 Variable carA : A -> MF A.
 Variable carB : B -> MF B.

 Variable p:nat -> (A*B).

 Hypothesis carA_prop : forall b, cover (fun x => b = x) (carA b).
 Hypothesis carB_prop : forall b, cover (fun x => b = x) (carB b).

 Lemma sigma_prod_split_r: forall H,
  serie (fun k =>  [1-] not_first_repr (carProd carA carB) p k * H (p k)) ==
  serie (fun ka => [1-] not_first_repr carA (fun k => fst (p k)) ka *
     serie (fun kb =>  [1-] not_first_repr (carProd carA carB) p kb * carA (fst (p kb)) (fst (p ka)) *
       H (fst (p ka), snd (p kb)))).
 Proof.
  intro H.
  set (H':= fun ba => H (swap ba)).
  set (p':= fun k => swap (p k)).
  transitivity (serie (fun k => [1-] not_first_repr (carProd carB carA) p' k * H' (p' k))).
    apply serie_eq_compat; intro k; apply Umult_eq_compat.
      Usimpl; unfold not_first_repr.
      apply sigma_eq_compat; intros k' Hk'; unfold carProd, p'; simpl; auto.
      unfold H', p', swap; simpl; rewrite <-surjective_pairing; trivial.
  rewrite (sigma_prod_split_l _ _ _ carB_prop carA_prop).
    apply serie_eq_compat; intro ka; apply Umult_eq_compat.
      Usimpl; unfold not_first_repr.
      apply sigma_eq_compat; intros k' Hk'; unfold p'; simpl; auto.
      apply serie_eq_compat; intro kb; repeat apply Umult_eq_compat.
        Usimpl; unfold not_first_repr; apply sigma_eq_compat;
          intros k' Hk'; unfold carProd, p'; simpl; auto.
        unfold p'; simpl; trivial.
        unfold H', p', swap; simpl; trivial.
 Qed.

End SERIE_OVER_PRODUCT_SPLIT_R.

(*
Section DISCR_PROJ'.

 Variables B: Type.

 Variable carB : B -> MF B.
 Hypothesis carB_prop : forall b, cover (fun x => b = x) (carB b).

 Variable d2 : Distr B.
 Hypothesis Hd2_discr: is_Discrete d2.

 Variable d  : Distr B.

 Let p2 := D_points Hd2_discr.
 Let c2 := coeff carB p2 d2.

 Hypothesis d_le_d2: forall f,
   mu d f <= mu d2 f.

 Lemma distr_pointwise_sum': forall f,
   mu d2 (fun b => mu d (fun b' => carB b b' * f b') /
      mu d2 (carB b)) ==
   mu d f.
 Proof.
  intro f.
  rewrite (mu_is_Discrete _ carB_prop  Hd2_discr);
    simpl; fold p2 c2.
  transitivity  (serie (fun k => mu d (fun b' =>
    (c2 k / c2 k) * (carB (p2 k) b' * f b')))).
    apply serie_eq_compat; intros.
    rewrite <-Umult_div_assoc, Umult_sym, Umult_div_assoc,
      Umult_sym.
    rewrite (mu_stable_mult d (c2 k / c2 k) (fun b' =>
      carB (p2 k) b' * f b')).
    apply Umult_eq_compat_left.
    apply (cover_elim (cover_not_first_repr _ _ carB_prop p2) k);
      [auto | | ]; intros [_ H5]; [ unfold p2 | unfold c2 ].
      rewrite <-(coeff_first_repr _ carB_prop (D_Discr Hd2_discr) _ H5); trivial.
      rewrite (coeff_not_first_repr carB d2 _ _ H5), 2 Udiv_zero; trivial.
    apply (cover_elim (cover_not_first_repr _ _ carB_prop p2) k);
      [auto | | ]; intros [_ H5]; [ unfold p2 | unfold c2 ].
      rewrite <-(coeff_first_repr _ carB_prop (D_Discr Hd2_discr) _ H5); trivial.
      rewrite (coeff_not_first_repr carB d2 _ _ H5); trivial.
    rewrite <-d_le_d2; simpl; apply (mu_monotonic d); intro; auto.
  rewrite <-mu_serie_eq; [ unfold serie_fun | intro x; apply wretract_le
    with (2:=cp_retract_p2d _ carB_prop Hd2_discr x); auto ].
  apply (@range_eq _ (fun x => in_p2_d carB Hd2_discr x == 1) d).
    intros f' Hf'; split; trivial.
    transitivity (mu d (fun p => [1-] (in_p2_d carB Hd2_discr p))).
      apply (mu_monotonic d); intro x; apply (in_p2_d_dec _ carB_prop Hd2_discr x);
        [auto | | ]; intros H0; [rewrite H0 | rewrite <-Hf']; auto.
    rewrite (d_le_d2 (fun b : B => [1-] in_p2_d carB Hd2_discr b)),
      (mu_is_Discrete _ carB_prop  Hd2_discr); simpl; fold p2 c2.
    apply serie_zero; intros.
    apply (Ueq_orc (c2 k) 0); [auto | | ]; intros;
     [ rewrite H | unfold p2; rewrite (in_p2_d_p carB_prop Hd2_discr);
       [ Usimpl | ] ]; auto.
  intros b Hb; symmetry.
  transitivity (serie (fun k => f b * (c2 k / c2 k * carB (p2 k) b)));
    [ | auto ].
  unfold c2, p2; rewrite (serie_mult _ (cp_retract_p2d _ carB_prop Hd2_discr b)).
  unfold in_p2_d in Hb; rewrite Hb; auto.
 Qed.

 Hypothesis d2_le_d: forall f,
   mu d2 f <= mu d f.

 Lemma distr_pointwise_sum'': forall f,
   mu d2 (fun b => mu d (fun b' => carB b b' * f b') /
     mu d (carB b)) ==  mu d2 f.
 Proof.
  intro f.
  rewrite 2 (mu_is_Discrete _ carB_prop  Hd2_discr);
    simpl; fold p2 c2.
  apply serie_eq_compat; intro k.
  transitivity (c2 k * f (p2 k) * (mu d (carB (p2 k)) / mu d (carB (p2 k)))).
    rewrite <-Umult_assoc; Usimpl.
    rewrite <-(Umult_div_assoc _ _ _ (Ole_refl _)); apply Udiv_eq_compat_left.
    rewrite <-(mu_stable_mult d (f (p2 k))).
    apply (mu_stable_eq d); unfold fmult; refine (ford_eq_intro _); intro b;
      rewrite Umult_sym.
    apply (cover_elim (carB_prop (p2 k)) b); [ auto | | ];
        intros [H4 H5]; rewrite H5; repeat Usimpl; [ | rewrite H4 ]; trivial.
  apply (cover_elim (cover_not_first_repr _ _ carB_prop p2) k);
    [auto | | ]; intros [_ H5].
    unfold c2, p2; rewrite (coeff_first_repr _ carB_prop (D_Discr Hd2_discr) _ H5);
      fold p2 c2; clear H5.
    apply (Ueq_orc 0 (mu d (carB (p2 k)))); [ auto | | ]; intro H6.
      rewrite (Udiv_zero_eq _ H6); Usimpl; symmetry; apply Umult_zero_left_eq;
        apply Ule_zero_eq; rewrite H6; apply d2_le_d.
      rewrite (Udiv_refl H6); auto.
    unfold c2; rewrite (coeff_not_first_repr carB d2 _ _ H5); repeat Usimpl; trivial.
 Qed.

End DISCR_PROJ'.
*)

(*
Section DISCR_PROJ_LE.

 Variables A B: Type.

 Variable carB : B -> MF B.
 Hypothesis carB_prop : forall b, cover (fun x => b = x) (carB b).

 Variable d2 : Distr B.
 Hypothesis Hd2_discr: is_Discrete d2.

 Variable d  : Distr (A*B).

 Let p2 := D_points Hd2_discr.
 Let c2 := coeff carB p2 d2.

 Variable F : B -o> U.
 Variable ep: U.

 Hypothesis Fbound1: forall k,
   not_first_repr carB p2 k == 0 ->
   F (p2 k) <= mu d2 (carB (p2 k)) * ep.

 Hypothesis Fbound2: forall k,
   not_first_repr carB p2 k == 1 ->
   F (p2 k) == 0.

 Lemma distr_pointwise_le:
   mu d2 (fun b => F b /
      mu d2 (carB b)) <= ep.
 Proof.
  rewrite (mu_is_Discrete _ carB_prop  Hd2_discr);
    simpl; fold p2 c2.
  transitivity  (serie (fun k => F (p2 k))).
    apply serie_le_compat; intro k.
    apply (cover_elim (cover_not_first_repr _ _ carB_prop p2) k);
      [auto | | ]; intros [_ H5]; [ unfold p2 | unfold c2 ].
      rewrite <-(coeff_first_repr _ carB_prop (D_Discr Hd2_discr) _ H5);
        fold p2 c2; apply Umult_div_le.
      rewrite (coeff_not_first_repr carB d2 _ _ H5); Usimpl; auto.
  rewrite <-(mu_cte_le d2 ep).
  rewrite (mu_is_Discrete _ carB_prop  Hd2_discr);
    simpl; fold p2 c2.
  unfold fcte.
  apply serie_le_compat.
  intro k.
  apply (cover_elim (cover_not_first_repr _ _ carB_prop p2) k);
      [auto | | ]; intros [_ H5].
    unfold c2, coeff; rewrite H5; repeat Usimpl; auto.
    unfold c2, coeff; rewrite H5; repeat Usimpl; auto.
 Qed.

End DISCR_PROJ_LE.
*)


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector theory of real numbers based on Function
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. Use real numbers to represent components.
  2. it is based on VectorThySig

  ref:
  1. 《高等数学学习手册》徐小湛，p173
  2. Vector Calculus - Michael Corral
  3. https://github.com/coq/coq/blob/master/test-suite/success/Nsatz.v
     注意，这里有Coq库中定义的几何学形式化内容，包括点，平行，共线等。
*)

Require Export NatFun.VectorThy.
Require Export FieldStruct.
Require Export ListListExt RExt.

Module VectorThyR := VectorThy FieldR.FieldDefR.
Export VectorThyR.

Open Scope R.

(* ######################################################################### *)
(** * 向量理论在实数域上的扩充 *)

(* ======================================================================= *)
(** ** 任意维度上的通用向量操作 *)
Section DimAny.

  (** 向量的长度，模，范数（欧几里得范数）的平方。方便计算。*)
  Definition vlen_sqr {n} (v : V n) : R := vdot v v.

  (** 向量的长度，模，范数（欧几里得范数）。存在性的构造，适合证明 *)
  Definition vlen {n} (v : V n) : R := sqrt (vlen_sqr v).

  (** 非零向量的单位化 *)
  Definition vnormalize {n} (v : V n) (H : vnonzero v) : V n :=
    let k := 1 / (vlen v) in
      vcmul k v.

  (** 长度为0的向量，也都是零向量 *)
  Lemma vec_len0_is_vec0 : forall v : V 0, v = vec0.
  Proof.
    intros. apply meq_iff. intro. intros. easy.
  Qed.

  (** 非零向量v的k倍等于0，则k必为0 *)
  Lemma vcmul_nonzero_eq_zero_imply_k0 : forall {n} (v : V n) k,
    vnonzero v -> k c* v = vec0 -> k = 0.
  Proof.
    intros. destruct v as [g].
    unfold vnonzero,vzero,vec0,mat0 in *.
    apply meq_iff in H0. apply neq_imply_mneq in H.
    unfold mcmul,vzero,vec0,mat0,meq in H,H0. simpl in *.
    Admitted.
(*     !! Something wrong.
    assert (~(forall i j, (i < n)%nat -> (j < 1)%nat -> g i j = A0)).
    { intro. destruct H. f_equal.
      apply functional_extensionality. intros.
      apply functional_extensionality. intros. auto. }
    (*  ∀ij(k * g i j = 0)  ~∀ij(g i j = 0)   -> k = 0
      思路：由 ∀ij(k * g i j = 0) 得 k = 0 \/ ∀ij(g i j = 0) *)
    destruct (Aeqdec k 0); auto.
    assert (forall i j, (i < n)%nat -> (j < 1)%nat -> g i j = A0).
    { intros. assert ((k * g i j)%A = A0).
      { apply H0; auto. }
      (* k<>0 /\ k * (g i j) = 0 -> g i j = 0 *)
      apply Rmult_integral in H4. destruct H4; try easy. }
    {
  Qed. *)

  (** 向量平行（共线）：零向量与任何向量平行，或者非零向量是k倍的关系
    定义：u和v中，一个是另一个的数乘。
    平行：parallel
    共线：colinear

    遗留问题：主流做法是零向量与任何向量都平行、都垂直。
    是否可以：仅考虑非零向量的平行，零向量不考虑。
    一个原因是：考虑零向量后，平行传递性不完美了。
    *)

  (* 关于零向量的平行？
    1. https://www.zhihu.com/question/489006373
    两个方面:
    a. “平行”或“不平行”是对两个可以被识别的方向的比较，对于零向量，“方向”是不可
      识别的，或说，是不确定的。从这个角度讲，“平行”这个概念不该被用到评价两个
      零向量的关系上的。
    b. 不过，两个零向量是“相等”的，对于向量而言，“相等”这件事包含了大小和方向
      的相等，这么说来，说两个零向量“方向”相等，也就是“平行”或也是说得通的。
  *)

  (* 定义1：v1是v2的k倍，或者 v2是v1的k倍。*)
  Definition vparallel_ver1 {n} (v1 v2 : V n) : Prop :=
    exists k, (v1 = k c* v2 \/ v2 = k c* v1).

  (* 定义2：v1 是 0，或者 v2 是 0，或者 v1 是 v2 的 k 倍 *)
  Definition vparallel_ver2 {n} (v1 v2 : V n) : Prop :=
    (vzero v1) \/ (vzero v2) \/ (exists k, v1 = k c* v2).

  (* 证明这两个定义等价 *)
  Lemma vparallel_ver1_eq_ver2 : forall {n} (v1 v2 : V n),
    vparallel_ver1 v1 v2 <-> vparallel_ver2 v1 v2.
  Proof.
    intros. unfold vparallel_ver1, vparallel_ver2.
    unfold vzero, vnonzero. split; intros.
    - destruct H. destruct H.
      + right. right. exists x. auto.
      + destruct (veq_dec v1 (vec0)); auto.
        destruct (veq_dec v2 (vec0)); auto.
        right. right. exists (X1/x)%X. rewrite H.
        apply meq_iff.
        intros i j Hi Hj. destruct v1 as [g1], v2 as [g2]. simpl in *.
        field.
        apply vec_eq_vcmul_imply_coef_neq0 in H; auto.
    - destruct H as [H1 | [H2 | H3]].
      + exists X0. left. rewrite H1. compute. f_equal.
        apply functional_extensionality. intros.
        apply functional_extensionality. intros. ring.
      + exists X0. right. rewrite H2. compute. f_equal.
        apply functional_extensionality. intros.
        apply functional_extensionality. intros. ring.
      + destruct H3. exists x. left; auto.
  Qed.

  (** 向量平行谓词的定义 *)
  Definition vparallel {n} (v0 v1 : V n) : Prop :=
    vparallel_ver2 v0 v1.

  Notation "v0 // v1" := (vparallel (v0) (v1)) (at level 70) : vec_scope.

  (** * 向量平行的性质 *)

  (** 向量平行是等价关系 *)

  (** 自反性 *)
  Lemma vparallel_refl : forall {n} (v : V n), v // v.
  Proof.
    intros. unfold vparallel,vparallel_ver2. right. right. exists 1.
    rewrite mcmul_1_l. easy.
  Qed.

  (** 对称性 *)
  Lemma vparallel_sym : forall {n} (v0 v1 : V n), v0 // v1 -> v1 // v0.
  Proof.
    intros. unfold vparallel,vparallel_ver2 in *.
    assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
    assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
    destruct H0.
    - right; left; auto.
    - destruct H1.
      + left; auto.
      + destruct H; auto. destruct H; auto. destruct H.
        right; right. exists (X1/x)%X. rewrite H.
        compute. intros.
        remember v1. destruct v3. f_equal.
(*         apply meq_iff. intros i j Hi Hj. simpl. *)
        apply functional_extensionality. intros.
        apply functional_extensionality. intros.
        unfold X in *. field.
        rewrite Heqv3 in *.
        apply (vec_eq_vcmul_imply_coef_neq0 v0 v1); auto.
  Qed.

  (** 传递性 *)
  (* 要求v1是非零向量。因为若v1为0，v0//v1, v1//v2, 但 v0,v2 不平行 *)
  Lemma vparallel_trans : forall {n} (v0 v1 v2 : V n),
    vnonzero v1 -> v0 // v1 -> v1 // v2 -> v0 // v2.
  Proof.
    intros. unfold vparallel, vparallel_ver2 in *.
    assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
    assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
    assert ({vzero v2} + {vnonzero v2}). apply meq_dec.
    destruct H2.
    - left; auto.
    - destruct H4.
      + right; left; auto.
      + right; right.
        destruct H3.
        * destruct H0; try contradiction.
        * destruct H0,H1; try contradiction.
          destruct H0,H1; try contradiction.
          destruct H0,H1.
          exists (x*x0). rewrite H0,H1. apply mcmul_assoc.
  Qed.

  (** 数乘非零向量得到零向量，则该系数必为 0 *)
  Lemma vcmul_vnonzero_eq0_imply_k_eq0 :
    forall {n} (v : V n) (H : vnonzero v) k, k c* v = vec0 -> k = X0.
  Proof.
    intros. destruct v as [g].
    unfold vnonzero,vzero,vec0,mat0,meq in *; simpl in *.
    (* ∀i(f i <> 0 /\ k * f i = 0 -> k = 0 *)
    (* 方法：先由 k = 0 的结论反推出 k <> 0 的前提；然后构造某个全称量词中的
      否定命题。 *)
    destruct (Xeqdec k 0); auto. (* 得到了 k <> 0 的前提 *)
    destruct H. (* 转而证明 f i = 0 *)
    f_equal. apply functional_extensionality.
    intros i. apply functional_extensionality.
(* (*     intros j. remember (H0 i j). H H1) as E.  (* 以上两步，消去了全称量词 *) *)
(*     clear HeqE. *)
    apply Rmult_integral in E. destruct E; auto. easy.
  Qed. *)
  Admitted.

  (** 数乘非零向量得到非零向量，则该系数必不为 0 *)
  Lemma vcmul_vnonzero_neq0_imply_k_neq0 :
    forall {n} (v : V n) (H : vnonzero v) k, ~(k c* v = vec0) -> k <> X0.
  Proof.
    intros. intro. subst. rewrite vcmul_0_l in H0. destruct H0. easy.
  Qed.

  (** 两个非零向量k倍相等，k唯一 *)
  Lemma vcmul_vnonzero_eq_iff_unique_k :
    forall {n} (v : V n) (H : vnonzero v) k1 k2,
      k1 c* v = k2 c* v -> k1 = k2.
  Proof.
    intros. destruct v as [g]. unfold vnonzero,vzero,vec0,mat0,meq in *.
    simpl in *.
    (* ∀i(f(i)=0 /\ k1*f(i) = k2*f(i)) -> k1 = k2 *)
    destruct (Xeqdec k1 k2); auto.
    destruct H. intros. (* 消去了全称量词 *)
(*     remember (H0 i j H H1) as E. clear HeqE.
    (* k1 * x = k2 * x  /\  k1 <> k2  -> x = 0 *)
    apply Rmult_eq_imply_eq0_r in E; auto.
  Qed. *)
  Admitted.

  (** 非零向量k倍相等于自己，则k为1 *)
  Lemma vcmul_vnonzero_eq_self_iff_k1 :
    forall {n} (v : V n) (H : vnonzero v) k,
      k c* v = v -> k = 1.
  Proof.
    intros. destruct v as [g].
    unfold vnonzero,vzero,vec0,mat0,meq in *; simpl in *.
    (* 证明 k = 1，老的方法，先得到 k <> 1 的前提，然后消去全称量词 *)
    destruct (Xeqdec k 1); auto.
    destruct H. intros. (* 消去了全称量词 *)
(*     remember (H0 i j H H1) as E. clear HeqE.
    destruct (Aeqdec (g i j) A0); auto.
    (* k * x = x /\  k <> 1 /\ x <> 0 -> x = 0 *)
    (* 需要一条性质：
      forall k, (forall x, k * x = x -> x = 0 \/ (x <> 0 /\ k = 1)). *)
    apply Rmult_eq_self_imply_0_or_k1 in E. destruct E; try easy.
  Qed.
 *)
 Admitted.

  (** 非零向量平行，则存在唯一比例系数k *)
  Lemma vparallel_vnonezero_imply_unique_k : forall {n} (v1 v2 : V n)
    (H1 : vnonzero v1) (H2 : vnonzero v2),
    v1 // v2 -> (exists ! k, v1 = k c* v2).
  Proof.
    intros.
    destruct H; try contradiction.
    destruct H; try contradiction.
    destruct H. exists x. unfold unique. split; auto.
    intros. apply vcmul_vnonzero_eq_iff_unique_k with (v:=v2); auto.
    rewrite <- H,H0. easy.
  Qed.

  (** 给定 向量v1，v2，
    v1<>0 /\ v1//v2 <=> 存在唯一实数 a 使得 v2 = a * v1 *)
  Lemma vparallel_iff1 : forall {n} (v1 v2 : V n) (H : vnonzero v1),
    (v1 // v2) <-> (exists ! a, v2 = a c* v1).
  Proof.
    intros.
(*     unfold vparallel, vparallel_ver2, vnonzero in *. *)
    split; intros.
    - destruct (veq_dec v2 (vec0)).
      + exists 0. split.
(*         * rewrite v. compute. intros. ring.
        * intros. rewrite v in H1. apply veq_sym in H1.
          apply eq_sym. apply vcmul_vnonzero_eq0_imply_k_eq0 in H1; auto.
      + unfold vparallel,vparallel_ver2 in *.
        destruct H0; try easy. destruct H0; try easy.
        destruct H0. exists (A1/x)%A. split.
        * rewrite H0. intros i j Hi Hj. simpl. field.
          apply vcmul_vnonzero_neq0_imply_k_neq0 with (v2); auto.
          rewrite <- H0. auto.
        * intros. rewrite H0 in H1.
          rewrite vcmul_assoc1 in H1.
          apply veq_sym in H1.
          apply vcmul_vnonzero_eq_self_iff_k1 in H1; auto.
          rewrite <- H1. field.
          apply vcmul_vnonzero_neq0_imply_k_neq0 with (v2); auto.
          rewrite <- H0. auto.
    - destruct H0. destruct H0. apply vparallel_sym.
      unfold vparallel, vparallel_ver2.
      right. right. exists x. auto.
  Qed. *)
  Admitted.

End DimAny.

(* ======================================================================= *)
(** ** 3-dim vector operations *)
Section Dim3.

  (** 3阶方阵的行列式 *)
  Definition det3 (m : M 3 3) : X :=
    let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) :=
      m2t_3x3 m in
    let b1 := (a11 * a22 * a33) in
    let b2 := (a12 * a23 * a31) in
    let b3 := (a13 * a21 * a32) in
    let c1 := (a11 * a23 * a32) in
    let c2 := (a12 * a21 * a33) in
    let c3 := (a13 * a22 * a31) in
    let b := (b1 + b2 + b3) in
    let c := (c1 + c2 + c3) in
      (b - c).

  (** V3斜对称矩阵 *)
  Definition skew_sym_mat_of_v3 (v : V 3) : M 3 3 :=
    let '(x,y,z) := v2t_3 v in
      mk_mat_3_3
        X0    (-z)  y
        z     X0    (-x)
        (-y)  x     X0.

  (** V3叉乘，向量积 *)
  Definition vcross3 (v1 v2 : V 3) : V 3 := ((skew_sym_mat_of_v3 v1) * v2)%M.

  (** 矩阵是否为SO3（李群，旋转群） *)
  Definition so3 (m : M 3 3) : Prop :=
    let so3_mul_unit : Prop := ((m ᵀ) * m)%M = mat1 3 in
    let so3_det : Prop := (det3 m) = X1 in
      so3_mul_unit /\ so3_det.

   (** 计算两个向量的夹角 *)
  Definition vangle3 (v0 v1 : V 3) : R :=
    acos (scalar_of_mat (v0 ᵀ * v1)%M).

  (** (1,0,0) 和 (1,1,0) 的夹角是 45度，即 π/4 *)
  Example vangle3_ex1 : vangle3 (l2v [1;0;0]) (l2v [1;1;0]) = PI/4.
  Proof.
    compute.
(*     Search acos. *)
    Abort. (* 暂不知哪里错了，要去查叉乘的意义 *)

  (** 根据两个向量来计算旋转轴 *)
  Definition rot_axis_by_twovec (v0 v1 : V 3) : V 3 :=
    let s : R := (vlen v0 * vlen v1)%R in
      (s c* (vcross3 v0 v1))%M.

  (* 谓词：两向量不共线（不平行的） *)
  (* Definition v3_non_colinear (v0 v1 : V3) : Prop :=
    v0 <> v1 /\ v0 <> (-v1)%M.
   *)

End Dim3.


From Coq Require Import Arith NArith Lia.

Local Open Scope list_scope.

(** An OpenArray is an infinite array in which only finite amount of items are nonzero. *)
Class class {Value: Type} (Zero: Value) (A: Type) := {
  get: A -> N -> Value;
  empty: A;

  empty_ok: forall n: N,
              get empty n = Zero;

  put: A -> N -> Value -> A;

  put_ok: forall (a: A) (n k: N) (v: Value),
            get (put a n v) k
             =
            if (n =? k)%N
              then v
              else get a k;

  to_list: A -> list Value;

  to_list_ok: forall (a: A) (n: N),
                get a n = List.nth (N.to_nat n) (to_list a) Zero;

  (** Given an offset and a count, convert the corresponding subarray to a list. *)
  view: A -> N -> N -> list Value;
  view_len: forall (a: A) (offset count: N),
              List.length (view a offset count) = N.to_nat count;
  view_ok: forall (a: A) (offset count: N) (n: N) (ok: (n < count)%N),
                  List.nth_error (view a offset count) (N.to_nat n) = Some (get a (offset + n)%N);

  from_list: list Value -> A;
  from_list_ok: forall (l: list Value) (n: N),
                  get (from_list l) n = List.nth (N.to_nat n) l Zero;
}.

Lemma put_same {Value: Type} {Zero: Value} {A: Type} (C: class Zero A)
               (a: A) (n: N) (v: Value):
  get (put a n v) n = v.
Proof.
rewrite put_ok.
enough (H: (n =? n)%N = true) by now rewrite H.
now apply N.eqb_eq.
Qed.

Fixpoint firstn_or_pad {A} (l: list A) (n: nat) (pad: A)
: list A
:= match n, l with
   | 0, _ => nil
   | S n', nil => List.repeat pad n
   | S n', h :: t => h :: firstn_or_pad t n' pad
   end.

Lemma firstn_or_pad_length {A} (l: list A) (n: nat) (pad: A):
  List.length (firstn_or_pad l n pad) = n.
Proof.
revert l. induction n; intro l.
{ now induction l. }
destruct l. { cbn. f_equal. apply List.repeat_length. }
cbn. f_equal. apply IHn.
Qed.

Lemma nth_skipn {A} (a: list A) (m n: nat) (default: A):
  List.nth (m + n) a default = List.nth n (List.skipn m a) default.
Proof.
revert n a. induction m; intros; cbn. { trivial. }
destruct a as [|h]. { now destruct n. }
cbn. apply IHm.
Qed.

Lemma view0 {Value: Type} {Zero: Value} {A: Type} (C: class Zero A)
            (a: A) (n: N):
  view a n 0 = nil.
Proof.
assert (LenOk := view_len a n 0).
remember (view _ _ _) as v.
destruct v. 2:discriminate.
trivial.
Qed.

Lemma view1 {Value: Type} {Zero: Value} {A: Type} (C: class Zero A)
            (a: A) (n: N):
  view a n 1 = get a n :: nil.
Proof.
assert (LenOk := view_len a n 1).
remember (view _ _ _) as v.
destruct v as [|x]. { discriminate. }
destruct v. 2:discriminate.
assert (OkX := view_ok a n 1 0 N.lt_0_1).
rewrite<- Heqv in OkX.
cbn in OkX.
rewrite N.add_0_r in OkX.
inversion OkX. now subst x.
Qed.

Lemma view2 {Value: Type} {Zero: Value} {A: Type} (C: class Zero A)
            (a: A) (n: N):
  view a n 2 = get a n :: get a (N.succ n) :: nil.
Proof.
assert (LenOk := view_len a n 2).
remember (view _ _ _) as v.
destruct v as [|x]. { discriminate. }
destruct v as [|y]. { discriminate. }
destruct v. 2:discriminate.
assert (OkX := view_ok a n 2 0 N.lt_0_2).
assert (OkY := view_ok a n 2 1 N.lt_1_2).
rewrite<- Heqv in OkX.
rewrite<- Heqv in OkY.
rewrite N.add_0_r in OkX.
rewrite N.add_1_r in OkY.
cbn in OkX.
replace (N.to_nat 1) with 1 in OkY by trivial.
cbn in OkY.
inversion OkX. subst x.
inversion OkY. now subst y.
Qed.

Section ListInst.
  Context {Value: Type} (Zero: Value).

  Lemma list_empty_ok (n: N):
    List.nth (N.to_nat n) nil Zero = Zero.
  Proof.
  cbn. now destruct N.to_nat.
  Qed.

  Lemma list_put_single (n k: nat) (v: Value):
    List.nth k (List.repeat Zero n ++ v :: nil) Zero
     =
    if n =? k then v else Zero.
  Proof.
  remember (n =? k) as e. symmetry in Heqe. destruct e.
  {
    rewrite Nat.eqb_eq in Heqe. subst k.
    induction n; easy.
  }
  apply Nat.eqb_neq in Heqe.
  revert k Heqe. induction n; intros.
  {
    induction k. { easy. }
    now destruct k.
  }
  induction k. { easy. }
  cbn. apply IHn.
  intro H. now subst.
  Qed.

  Lemma list_put_ok (a: list Value) (n k: N) (v: Value):
    List.nth (N.to_nat k)
      (if N.to_nat n <? length a
        then List.firstn (N.to_nat n) a ++ v :: List.skipn (S (N.to_nat n)) a
        else a ++ List.repeat Zero (N.to_nat n - length a) ++ v :: nil) Zero =
    (if (n =? k)%N then v else List.nth (N.to_nat k) a Zero).
  Proof.
  remember (N.to_nat n) as n'. remember (N.to_nat k) as k'.
  replace (n =? k)%N with (n' =? k').
  2:{
    subst. remember (n =? k)%N as eq_N. symmetry in Heqeq_N.
    destruct eq_N.
    { rewrite N.eqb_eq in Heqeq_N. subst. now rewrite Nat.eqb_eq. }
    remember (N.to_nat n =? N.to_nat k) as eq_nat. symmetry in Heqeq_nat.
    destruct eq_nat. 2:trivial.
    rewrite Nat.eqb_eq in Heqeq_nat. apply N2Nat.inj in Heqeq_nat. subst.
    apply N.eqb_neq in Heqeq_N. tauto.
  }
  clear Heqn' Heqk' n k.
  remember (n' <? length a) as n_lt_len. symmetry in Heqn_lt_len.
  revert k' a Heqn_lt_len. induction n'; intros.
  {
    destruct k', a; cbn in Heqn_lt_len; subst; cbn; trivial.
    now destruct k'.
  }
  destruct a as [ | h].
  {
    cbn.
    destruct n_lt_len. { easy. }
    destruct k'. { easy. }
    cbn. apply list_put_single.
  }
  replace (S n' <? length (h :: a)) with (n' <? length a) in Heqn_lt_len by easy.
  replace (List.firstn (S n') (h :: a)) with (h :: List.firstn n' a) by easy.
  repeat rewrite<- List.app_comm_cons.
  match goal with
  |- context G [ if ?cond then (h :: ?x) else (h :: ?y) ] =>
        replace (if cond then (h :: x) else (h :: y)) with (h :: if n_lt_len then x else y)
          by now destruct cond
  end.
  destruct k'. { easy. }
  cbn. now apply IHn'.
  Qed.

  Lemma list_view_ok (a: list Value) (offset count n: N) (Ok: (n < count)%N):
    List.nth_error
      (firstn_or_pad (List.skipn (N.to_nat offset) a) (N.to_nat count) Zero)
      (N.to_nat n)
     =
    Some (List.nth (N.to_nat (offset + n)) a Zero).
  Proof.
  rewrite N2Nat.inj_add. rewrite nth_skipn.
  remember (List.skipn (N.to_nat offset) a) as l. clear a Heql offset.
  remember (N.to_nat n) as k.
  remember (N.to_nat count) as c.
  assert (L: k < c) by lia.
  clear n count Heqk Heqc Ok.
  revert k c L. induction l; intros.
  {
    cbn. replace (match k with 0 | _ => Zero end) with Zero by now destruct k.
    replace (match c with
             | 0 => nil
             | S _ => List.repeat Zero c
             end)
      with (List.repeat Zero c)
      by now destruct c.
    rewrite List.nth_error_nth' with (d := Zero) by (rewrite List.repeat_length; lia).
    f_equal.

    revert k L. induction c; intros. { now destruct k. }
    destruct k. { easy. }
    cbn. apply IHc.
    lia.
  }
  cbn. destruct k, c; try easy.
  cbn. apply IHl. lia.
  Qed.

  Definition list_inst
  : class Zero (list Value)
  := {| get a n := List.nth (N.to_nat n) a Zero
      ; empty := nil
      ; empty_ok := list_empty_ok
      ; put a n v := let i := N.to_nat n in
                     let len := List.length a in
                     if i <? len
                       then List.firstn i a ++ v :: List.skipn (S i) a
                       else a ++ List.repeat Zero (i - len) ++ v :: nil
      ; put_ok := list_put_ok
      ; to_list a := a
      ; to_list_ok a n := eq_refl
      ; from_list a := a
      ; from_list_ok a n := eq_refl
      ; view a offset count := firstn_or_pad (List.skipn (N.to_nat offset) a) (N.to_nat count) Zero
      ; view_len a offset count := firstn_or_pad_length _ _ _
      ; view_ok := list_view_ok
     |}.

End ListInst.


(** ** Uniqueness of M-types

    M-types are unique up to propositional equality.

    Author: Langston Barrett (@siddharthist)
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.Univalence.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Induction.FunctorCoalgebras_legacy.
Require Import UniMath.CategoryTheory.categories.Type.Core.
Require Import UniMath.Induction.PolynomialFunctors.
Require Import UniMath.Induction.M.Core.

Section Uniqueness.

  Local Open Scope functions.
  Local Open Scope cat.

  Context (A : UU).
  Context (B : A → UU).

  (** Following the paper, we have [X ⇒ Y] = Hom(X, Y) *)
  Local Notation F := (polynomial_functor A B). (* can be coerced to a function *)
  Local Notation "F*" := (polynomial_functor_arr A B).
  Local Notation "X ⇒ Y" := (coalgebra_homo F X Y).

  (** Since we can't use the standard categorical proof, we must re-prove that
      final coalgebras are unique up to isomorphism.

      (Lemma 5 in Ahrens, Capriotti, and Spadotti)
   *)

  (** We prove that their carriers (first projections) are isomorphic, and hence
      equal (by univalence).

      This is standard categorical reasoning: each has exactly one arrow to the
      other, which, composing, gives an endormorphism. However, each has exactly
      one endomorphism, the identity map. Therefore, they are isomorphic. *)

  Lemma M_carriers_iso : ∏ X Y : M B, (coalgebra_ob _ X) ≃
                                      (coalgebra_ob _ Y).
  Proof.
    intros X Y.

    (** Get the coalgebra morphisms X → Y and Y → X via finality *)
    pose (X_mor_Y := iscontrpr1 (pr2 Y X)).
    pose (Y_mor_X := iscontrpr1 (pr2 X Y)).

    apply (weq_iso
             (mor_from_coalgebra_homo _ _ _ X_mor_Y)
             (mor_from_coalgebra_homo _ _ _ Y_mor_X)).
    - intro x.
      apply (@eqtohomot _ _ (Y_mor_X ∘ X_mor_Y) (idfun _)).
      refine (base_paths (coalgebra_homo_comp _ _ _ _ X_mor_Y Y_mor_X)
                         (coalgebra_homo_id F X) _).
      apply (proofirrelevancecontr (pr2 X X)).
    - intro y.
      apply (@eqtohomot _ _ (X_mor_Y ∘ Y_mor_X) (idfun _)).
      refine (base_paths (coalgebra_homo_comp _ _ _ _ Y_mor_X X_mor_Y)
                         (coalgebra_homo_id F Y) _).
      apply (proofirrelevancecontr (pr2 Y Y)).
  Defined.

  (** Note the crucial use of univalence *)
  Lemma M_carriers_eq : ∏ X Y : M B, (coalgebra_ob _ X) = (coalgebra_ob _ Y).
  Proof.
    exact (fun X Y => weqtopaths (M_carriers_iso X Y)).
  Defined.

  (** Now we must prove that the coalgebra morphisms, when transported along
      the path M_carriers_eq, will be equal.

      (≅⇒≡ in HoTT/M-types)
   *)

  (* We use "refine (x @ _)" instead of "rewrite" for more predictable proof terms. *)
  Lemma M_coalg_eq : ∏ X Y : M B, M_coalgebra B X = M_coalgebra B Y.
  Proof.
    intros X Y.
    pose (π1eq := (M_carriers_eq X Y)).
    pose (f := pr1 ((pr2 Y) (M_coalgebra B X))).
    apply (total2_paths_f π1eq).

    (** Some shorthands for items we'll use *)
    pose (is_final_X := pr2 X).
    pose (is_final_Y := pr2 Y).
    pose (θ := pr2 (pr1 X)).
    pose (ψ := pr2 (pr1 Y)).

    (** substⁱ-lemma in HoTT/M-types *)
    assert (trans_fun : forall {X Y : UU} {F : UU → UU} {f : X → F X} {g : Y → F Y}
                          (p : X = Y),
               (forall (x : X), transportf F p (f x) = g (transportf (idfun UU) p x)) →
               transportf (λ X, X → F X) p f = g).
    {
      intros ? ? ? ? ? p H.
      induction p.
      unfold transportf.
      apply funextfun.
      exact H.
    }

    apply trans_fun.
    intro x.

    (** imap-subst in HoTT/M-types *)
    assert (arr_transport :
              forall {X Y : UU} (p : X = Y),
                F* (transportf (idfun _) p) = transportf F p).
    {
      intros ? ? p.
      induction p.
      reflexivity.
    }

    (** In HoTT/M-types: lemma₁ : ∀ i x → subst (λ Z → Z i) π₁≡ x ≡ proj₁ f i x *)
    assert (lemma1 : forall x : pr1 (pr1 X), transportf (idfun UU) π1eq x = (pr1 f) x).
    {
      intro.
      refine (toforallpaths _ _ _ _ x0).
      refine ((weqpath_transport (M_carriers_iso _ Y)) @ _).
      reflexivity.
    }

    (** lemma₂ in HoTT/M-types *)
    assert (lemma2 : transportf F π1eq = F* (pr1 f)).
    {
      refine (!(arr_transport _ _ π1eq) @ _).
      apply maponpaths.
      unfold π1eq, M_carriers_eq.
      refine ((weqpath_transport (M_carriers_iso _ _)) @ _).
      reflexivity.
    }

    refine (_ @ !(maponpaths ψ (lemma1 x))).
    refine (toforallpaths _ (transportf F π1eq) (F* (pr1 f)) lemma2 (θ x) @ _).

    (** Now our goal is simply the condition that f is a coalgebra morphism *)
    apply (toforallpaths _ (F* (pr1 f) ∘ θ) (ψ ∘ pr1 f)).
    exact (pr2 f).
  Defined.

  Lemma isaprop_M : isaprop (M B).
    apply invproofirrelevance.
    intros X Y.
    apply subtypePath.
    - exact isaprop_is_final.
    - exact (M_coalg_eq X Y).
  Defined.
End Uniqueness.


Require Import Monad.
Require Import Monoid.
Require Import TypingContext.

Section IndexContext.
Set Implicit Arguments.

Variable A : Type.

(* An index map is a map from nats to A's encoded as a list of option A's;
   index i maps to a if ls[i]=Some a *)
Definition IdxMap := list (option A).
Definition IdxCtx := option IdxMap.

Definition mergeOption (o1 o2 : option A) : option (option A) :=
  match o1, o2 with
  | _, None => Some o1
  | None, _ => Some o2
  | Some _, Some _ => None
  end.
Fixpoint mergeIdxMap (i1 i2 : IdxMap) : option IdxMap :=
  match i1, i2 with
  | nil, _ => Some i2
  | _, nil => Some i1
  | o1 :: i1, o2 :: i2 => do o ← mergeOption o1 o2;
                          do i ← mergeIdxMap i1 i2;
                          Some (o :: i)
  end.

Lemma mergeIdxMap_nil_r : forall i, mergeIdxMap i nil = Some i.
Proof.
  destruct i; auto.
Defined.

Lemma mergeIdxMap_step : forall o1 o2 i1 i2,
    mergeIdxMap (o1 :: i1) (o2 :: i2) = do o ← mergeOption o1 o2;
                                        do i ← mergeIdxMap i1 i2;
                                        Some (o :: i).
Proof.
  intros; auto.
Defined.

Fixpoint is_empty_map (i : IdxMap) :=
  match i with
  | nil => true
  | None :: i => is_empty_map i
  | Some _ :: _ => false
  end.

(* This will hold for all monads if you depend on functional extensionality *)
Lemma bind_option_eq : forall X Y (e : option X) (f f' : X -> option Y),
      (forall x, f x = f' x) -> bind e f = bind e f'.
Proof.
  intros. destruct e; auto.
  simpl. auto.
Defined.
Arguments bind_option_eq {X Y} e.

(* This should really hold for all monads *)
Lemma bind_permut : forall {X Y Z} (ma : option X) (mb : option Y) (g : X -> Y -> option Z),
  bind ma (fun x => bind mb (g x)) = bind mb (fun y => bind ma (fun x => g x y)).
Proof.
  intros. destruct ma; destruct mb; auto.
Defined.

Lemma mergeOption_assoc : forall x y z,
                          do a ← mergeOption x y; mergeOption a z
                        = do b ← mergeOption y z; mergeOption x b.
Proof.
  destruct x; destruct y; destruct z; auto.
Defined.

Lemma mergeOption_comm : forall x y, mergeOption x y = mergeOption y x.
Proof.
  destruct x; destruct y; auto.
Defined.

Hint Resolve mergeIdxMap_nil_r.
Lemma IdxMap_assoc : forall a b c,
      (do x ← mergeIdxMap b c; mergeIdxMap a x) = (do x ← mergeIdxMap a b; mergeIdxMap x c).
    assert (H : forall X (x : X), Some x = return_ x) by reflexivity.
    induction a as [ | x a]; intros;
    [  simpl; destruct (mergeIdxMap b c); auto | ].
    destruct b as [ | y b]; destruct c as [ | z c]; auto.
    * repeat rewrite mergeIdxMap_nil_r.
      rewrite H, <- bind_left_unit.
      rewrite (bind_right_unit _ (mergeIdxMap (x :: a) (y :: b))) at 1.
      apply bind_option_eq; auto.
    * repeat rewrite mergeIdxMap_step.
      repeat rewrite <- bind_associativity.
      rewrite (bind_option_eq (mergeOption y z) _
                (fun x0 => do i ← mergeIdxMap b c; mergeIdxMap (x :: a) (x0 :: i)));
        [ | intros; rewrite <- bind_associativity; apply bind_option_eq; auto ].
      rewrite (bind_option_eq (mergeOption x y)  _
                (fun x0 => do i ← mergeIdxMap a b; mergeIdxMap (x0 :: i) (z :: c)));
        [ | intros; rewrite <- bind_associativity; apply bind_option_eq; auto ].
      erewrite (bind_option_eq (mergeOption y z));
        [ | intros; apply bind_option_eq; intros; apply mergeIdxMap_step ].
      erewrite (bind_option_eq (mergeOption x y));
        [ | intros; apply bind_option_eq; intros; apply mergeIdxMap_step ].
      erewrite (bind_option_eq (mergeOption y z));
        [ | intros; apply bind_permut].
      erewrite (bind_option_eq (mergeOption x y));
        [ | intros; apply bind_permut].
      repeat rewrite bind_associativity.
      rewrite mergeOption_assoc.
      apply bind_option_eq; intros.
      repeat rewrite bind_associativity.
      rewrite IHa. reflexivity.
Defined.

Lemma IdxMap_comm : forall a b, mergeIdxMap a b = mergeIdxMap b a.
Proof.
  induction a as [ | x a]; destruct b as [ | y b]; auto.
    repeat rewrite mergeIdxMap_step.
    rewrite mergeOption_comm.
    apply bind_option_eq; intros o.
    rewrite IHa. reflexivity.
Defined.

Fixpoint singleton' (x : nat) (a : A) :=
  match x with
  | O => Some a :: nil
  | S x' => None :: singleton' x' a
  end.

Lemma m'_cons_step : forall (o1 o2 : option A) Γ1 Γ2,
      mergeIdxMap (o1 :: Γ1) (o2 :: Γ2) = match mergeIdxMap Γ1 Γ2, o1, o2 with
                                          | Some Γ, _, None => Some (o1 :: Γ)
                                          | Some Γ, None, _ => Some (o2 :: Γ)
                                          | _, _, _         => None
                                          end.
Proof.
  simpl. intros. destruct o1; destruct o2; auto. simpl. destruct (mergeIdxMap Γ1 Γ2); auto.
Qed.

Lemma is_Some_m'_None_None : forall Γ1 Γ2,
      is_Some (mergeIdxMap (None :: Γ1) (None :: Γ2)) = is_Some (mergeIdxMap Γ1 Γ2).
Admitted.

Lemma is_Some_m'_Some_None : forall a Γ1 Γ2,
      is_Some (mergeIdxMap (Some a :: Γ1) (None :: Γ2)) = is_Some (mergeIdxMap Γ1 Γ2).
Admitted.

Lemma is_Some_m'_None_Some : forall a Γ1 Γ2,
      is_Some (mergeIdxMap (None :: Γ1) (Some a :: Γ2)) = is_Some (mergeIdxMap Γ1 Γ2).
Admitted.

Lemma is_Some_m'_Some_Some : forall a1 a2 Γ1 Γ2,
      is_Some (mergeIdxMap (Some a1 :: Γ1) (Some a2 :: Γ2)) = false.
Admitted.

End IndexContext.
Hint Resolve mergeIdxMap_nil_r.
About singleton.

Instance PMonoid_IdxMap A : PPCM (IdxMap A) :=
    { one' := nil; m' := @mergeIdxMap A}.
Instance PMonoid_IdxMap_Laws A : PPCM_Laws (IdxMap A).
Proof.
  split.
  - simpl; auto.
  - apply IdxMap_assoc.
  - apply IdxMap_comm.
Defined.
Instance Monoid_IdxMap_Laws A : PCM_Laws (IdxCtx A) :=
  PPCM_to_PCM_Laws (IdxMap A).
(* WHY IS THIS NECESSARY? (see examples at end of file *)
Hint Resolve Monoid_IdxMap_Laws.

Instance PTypingContext_IdxMap A : PTypingContext nat A (IdxMap A) :=
  { singleton' := @singleton' A
  }.

Ltac unfold_m' :=
  repeat match goal with
  | [ |- context[m' ?Γ1 ?Γ2] ] => replace (m' Γ1 Γ2) with (mergeIdxMap Γ1 Γ2) by auto
  end.

Instance PTypingContext_IdxMap_Laws A : PTypingContext_Laws nat A (IdxMap A).
Proof.
  split.
  - unfold IdxMap.
    induction Γ1 as [ | o1 Γ1]; destruct Γ2 as [ | o2 Γ2], Γ3 as [ | o3 Γ3]; auto.
    * rewrite Bool.andb_true_r. auto.
    * repeat rewrite Bool.andb_true_r. simpl.
      destruct (mergeOption o1 o2); auto.
      destruct (mergeIdxMap Γ1 Γ2); auto.
    * unfold_m'.
      remember (mergeIdxMap (o1 :: Γ1) (o2 :: Γ2)) as Γ eqn:HeqΓ.
      destruct Γ as [ Γ | ]; [ | auto].
      replace (is_Some (Some Γ)) with true by auto.
      rewrite Bool.andb_true_l.
      replace (Some Γ) with (return_ Γ : IdxCtx A) by auto.
      rewrite <- bind_left_unit.
      destruct (mergeIdxMap Γ1 Γ2) as [Γ' | ] eqn:HeqΓ';
      [ | rewrite m'_cons_step in HeqΓ; rewrite HeqΓ' in HeqΓ; inversion HeqΓ ].
      assert (IH' : is_Some (m' Γ' Γ3) = is_Some (m' Γ1 Γ3) && is_Some (m' Γ2 Γ3)).
      { specialize (IHΓ1 Γ2 Γ3).
        simpl in IHΓ1.
        rewrite HeqΓ' in IHΓ1.
        apply IHΓ1.
      }
      destruct o1 as [a1 | ]; destruct o2 as [a2 | ]; try (inversion HeqΓ; fail);
        simpl in HeqΓ, HeqΓ'; rewrite HeqΓ' in HeqΓ; inversion HeqΓ;
        unfold_m'.
      + destruct o3; auto.
(*        rewrite is_Some_m'_Some_None.*)
        (* WHAT IS GOING ON? CAN'T APPLY MY LEMMAS *)
        simpl in *.
        destruct (mergeIdxMap Γ' Γ3), (mergeIdxMap Γ1 Γ3), (mergeIdxMap Γ2 Γ3);
        auto.
      + destruct o3.
        ++ simpl. rewrite Bool.andb_false_r. auto.
        ++ simpl in *.
           destruct (mergeIdxMap Γ' Γ3), (mergeIdxMap Γ1 Γ3), (mergeIdxMap Γ2 Γ3);
           auto.
      + simpl in *.
        destruct o3;
        destruct (mergeIdxMap Γ' Γ3), (mergeIdxMap Γ1 Γ3), (mergeIdxMap Γ2 Γ3);
          auto.
  - intros.
    generalize dependent y. induction x, y; intros; split; intros H; simpl in *; auto; try (inversion H; fail).
    * rewrite mergeIdxMap_nil_r in H. inversion H.
    * destruct (mergeIdxMap (singleton' x a) (singleton' y b)) eqn:Hxy.
      + inversion H.
      + apply IHx in Hxy. auto.
    * inversion H.
      destruct (IHx y) as [_ IHx'].
      subst.
      rewrite IHx'; auto.
Qed.

Instance TypingContext_IdxMap A : TypingContext_Laws nat A (IdxCtx A)  :=
  PTypingContext_to_TypingContext_Laws nat A (IdxMap A).
Hint Resolve TypingContext_IdxMap.

(* Now option IdxCtx should be a typing context *)

Section Tests.
Variable A : Type.

Lemma singleton_not_empty : forall x a, is_valid (singleton x a : IdxCtx A).
Proof.
  intros. eapply singleton_is_valid; auto.
Defined.

Example test : forall x y a b,
    singleton x a ∙ singleton y b = singleton y b ∙ singleton x a ∙ (⊤ : IdxCtx A).
Proof.
  intros. monoid.
Defined.

Example test' : forall x y a b, x <> y ->
    singleton x a ⊎ singleton y b == singleton y b ∙ singleton x a ∙ (⊤ : IdxCtx A).
Proof.
  intros.
  solve_ctx.
Defined.

End Tests.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*********************************************************)
(**     Definition of the derivative,continuity          *)
(*                                                       *)
(*********************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rlimit.
Require Import Fourier.
Require Import Omega.
Local Open Scope R_scope.

(*********)
Definition D_x (D:R -> Prop) (y x:R) : Prop := D x /\ y <> x.

(*********)
Definition continue_in (f:R -> R) (D:R -> Prop) (x0:R) : Prop :=
  limit1_in f (D_x D x0) (f x0) x0.

(*********)
Definition D_in (f d:R -> R) (D:R -> Prop) (x0:R) : Prop :=
  limit1_in (fun x:R => (f x - f x0) / (x - x0)) (D_x D x0) (d x0) x0.

(*********)
Lemma cont_deriv :
  forall (f d:R -> R) (D:R -> Prop) (x0:R),
    D_in f d D x0 -> continue_in f D x0.
Proof.
  unfold continue_in; unfold D_in; unfold limit1_in;
    unfold limit_in; unfold Rdiv; simpl;
      intros; elim (H eps H0); clear H; intros; elim H;
        clear H; intros; elim (Req_dec (d x0) 0); intro.
  split with (Rmin 1 x); split.
  elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)).
  intros; elim H3; clear H3; intros;
    generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1);
      unfold Rgt; intro; elim (H5 H4); clear H5;
        intros; generalize (H1 x1 (conj H3 H6)); clear H1;
          intro; unfold D_x in H3; elim H3; intros.
  rewrite H2 in H1; unfold R_dist; unfold R_dist in H1;
    cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)).
  intro; unfold R_dist in H5;
    generalize (Rmult_lt_compat_l eps (Rabs (x1 - x0)) 1 H0 H5);
      rewrite Rmult_1_r; intro; apply Rlt_trans with (r2 := eps * Rabs (x1 - x0));
        assumption.
  rewrite (Rminus_0_r ((f x1 - f x0) * / (x1 - x0))) in H1;
    rewrite Rabs_mult in H1; cut (x1 - x0 <> 0).
  intro; rewrite (Rabs_Rinv (x1 - x0) H9) in H1;
    generalize
      (Rmult_lt_compat_l (Rabs (x1 - x0)) (Rabs (f x1 - f x0) * / Rabs (x1 - x0))
        eps (Rabs_pos_lt (x1 - x0) H9) H1); intro; rewrite Rmult_comm in H10;
      rewrite Rmult_assoc in H10; rewrite Rinv_l in H10.
  rewrite Rmult_1_r in H10; rewrite Rmult_comm; assumption.
  apply Rabs_no_R0; auto.
  apply Rminus_eq_contra; auto.
(**)
  split with (Rmin (Rmin (/ 2) x) (eps * / Rabs (2 * d x0))); split.
  cut (Rmin (/ 2) x > 0).
  cut (eps * / Rabs (2 * d x0) > 0).
  intros; elim (Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) 0);
    intros a b; apply (b (conj H4 H3)).
  apply Rmult_gt_0_compat; auto.
  unfold Rgt; apply Rinv_0_lt_compat; apply Rabs_pos_lt;
    apply Rmult_integral_contrapositive; split.
  discrR.
  assumption.
  elim (Rmin_Rgt (/ 2) x 0); intros a b; cut (0 < 2).
  intro; generalize (Rinv_0_lt_compat 2 H3); intro; fold (/ 2 > 0) in H4;
    apply (b (conj H4 H)).
  fourier.
  intros; elim H3; clear H3; intros;
    generalize
      (let (H1, H2) :=
        Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in
        H1); unfold Rgt; intro; elim (H5 H4); clear H5;
      intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1);
        unfold Rgt; intro; elim (H7 H5); clear H7;
          intros; clear H4 H5; generalize (H1 x1 (conj H3 H8));
            clear H1; intro; unfold D_x in H3; elim H3; intros;
              generalize (not_eq_sym H5); clear H5; intro H5;
                generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1;
                  pattern (d x0) at 1;
                    rewrite <- (let (H1, H2) := Rmult_ne (d x0) in H2);
                      rewrite <- (Rinv_l (x1 - x0) H9); unfold R_dist;
                        unfold Rminus at 1; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0)));
                          rewrite (Rmult_comm (/ (x1 - x0) * (x1 - x0)) (d x0));
                            rewrite <- (Ropp_mult_distr_l_reverse (d x0) (/ (x1 - x0) * (x1 - x0)));
                              rewrite (Rmult_comm (- d x0) (/ (x1 - x0) * (x1 - x0)));
                                rewrite (Rmult_assoc (/ (x1 - x0)) (x1 - x0) (- d x0));
                                  rewrite <-
                                    (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) ((x1 - x0) * - d x0))
                                    ; rewrite (Rabs_mult (/ (x1 - x0)) (f x1 - f x0 + (x1 - x0) * - d x0));
                                      clear H1; intro;
                                        generalize
                                          (Rmult_lt_compat_l (Rabs (x1 - x0))
                                            (Rabs (/ (x1 - x0)) * Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) eps
                                            (Rabs_pos_lt (x1 - x0) H9) H1);
                                          rewrite <-
                                            (Rmult_assoc (Rabs (x1 - x0)) (Rabs (/ (x1 - x0)))
                                              (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)));
                                            rewrite (Rabs_Rinv (x1 - x0) H9);
                                              rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9));
                                                rewrite
                                                  (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2)
                                                  ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0));
                                                    intro; rewrite (Rmult_comm (x1 - x0) (- d x0));
                                                      rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0));
                                                        fold (f x1 - f x0 - d x0 * (x1 - x0));
                                                          rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1;
                                                            intro;
                                                              generalize
                                                                (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0)))
                                                                  (Rabs (f x1 - f x0 - d x0 * (x1 - x0))) (Rabs (x1 - x0) * eps) H10 H1);
                                                                clear H1; intro;
                                                                  generalize
                                                                    (Rplus_lt_compat_l (Rabs (d x0 * (x1 - x0)))
                                                                      (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) (
                                                                        Rabs (x1 - x0) * eps) H1); unfold Rminus at 2;
                                                                    rewrite (Rplus_comm (Rabs (f x1 - f x0)) (- Rabs (d x0 * (x1 - x0))));
                                                                      rewrite <-
                                                                        (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0)))
                                                                          (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0))));
                                                                        rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2);
                                                                          clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps).
  intro;
    apply
      (Rlt_trans (Rabs (f x1 - f x0))
        (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11).
  clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro;
    unfold Rgt in H0;
      generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7);
        clear H7; intro;
          generalize
            (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) (
              eps * / Rabs (2 * d x0)) H1 H6); clear H6; intro;
            rewrite (Rmult_comm eps (R_dist x1 x0)) in H3; unfold R_dist in H3, H5;
              rewrite <- (Rabs_mult (d x0) (x1 - x0)) in H5;
                rewrite (Rabs_mult 2 (d x0)) in H5; cut (Rabs 2 <> 0).
  intro; fold (Rabs (d x0) > 0) in H1;
    rewrite
      (Rinv_mult_distr (Rabs 2) (Rabs (d x0)) H6
        (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
      in H5;
      rewrite (Rmult_comm (Rabs (d x0)) (eps * (/ Rabs 2 * / Rabs (d x0)))) in H5;
        rewrite <- (Rmult_assoc eps (/ Rabs 2) (/ Rabs (d x0))) in H5;
          rewrite (Rmult_assoc (eps * / Rabs 2) (/ Rabs (d x0)) (Rabs (d x0))) in H5;
            rewrite
              (Rinv_l (Rabs (d x0))
                (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
              in H5; rewrite (let (H1, H2) := Rmult_ne (eps * / Rabs 2) in H1) in H5;
                cut (Rabs 2 = 2).
  intro; rewrite H7 in H5;
    generalize
      (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
        (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro;
      rewrite eps2 in H10; assumption.
  unfold Rabs; destruct (Rcase_abs 2) as [Hlt|Hge]; auto.
  cut (0 < 2).
  intro H7; elim (Rlt_asym 0 2 H7 Hlt).
  fourier.
  apply Rabs_no_R0.
  discrR.
Qed.

(*********)
Lemma Dconst :
  forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0.
Proof.
  unfold D_in; intros; unfold limit1_in;
    unfold limit_in; unfold Rdiv; intros;
      simpl; split with eps; split; auto.
  intros; rewrite (Rminus_diag_eq y y (eq_refl y)); rewrite Rmult_0_l;
    unfold R_dist; rewrite (Rminus_diag_eq 0 0 (eq_refl 0));
      unfold Rabs; case (Rcase_abs 0); intro.
  absurd (0 < 0); auto.
  red; intro; apply (Rlt_irrefl 0 H1).
  unfold Rgt in H0; assumption.
Qed.

(*********)
Lemma Dx :
  forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0.
Proof.
  unfold D_in; unfold Rdiv; intros; unfold limit1_in;
    unfold limit_in; intros; simpl; split with eps;
      split; auto.
  intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
    rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
      unfold R_dist; rewrite (Rminus_diag_eq 1 1 (refl_equal 1));
        unfold Rabs; case (Rcase_abs 0) as [Hlt|Hge].
  absurd (0 < 0); auto.
  red in |- *; intro; apply (Rlt_irrefl 0 Hlt).
  unfold Rgt in H; assumption.
Qed.

(*********)
Lemma Dadd :
  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df D x0 ->
    D_in g dg D x0 ->
    D_in (fun x:R => f x + g x) (fun x:R => df x + dg x) D x0.
Proof.
  unfold D_in; intros;
    generalize
      (limit_plus (fun x:R => (f x - f x0) * / (x - x0))
        (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) (
          df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in;
      unfold limit_in; simpl; intros; elim (H eps H0);
        clear H; intros; elim H; clear H; intros; split with x;
          split; auto; intros; generalize (H1 x1 H2); clear H1;
            intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
              rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
                rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0))
                  in H1;
                  rewrite (Rmult_comm (/ (x1 - x0)) (f x1 - f x0 + (g x1 - g x0))) in H1;
                    cut (f x1 - f x0 + (g x1 - g x0) = f x1 + g x1 - (f x0 + g x0)).
  intro; rewrite H3 in H1; assumption.
  ring.
Qed.

(*********)
Lemma Dmult :
  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df D x0 ->
    D_in g dg D x0 ->
    D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0.
Proof.
  intros; unfold D_in; generalize H H0; intros; unfold D_in in H, H0;
    generalize (cont_deriv f df D x0 H1); unfold continue_in;
      intro;
        generalize
          (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) (
            fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3);
          intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0).
  intro;
    generalize
      (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
        fun _:R => g x0) (D_x D x0) (df x0) (g x0) x0 H H5);
      clear H H0 H1 H2 H3 H5; intro;
        generalize
          (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0)
            (fun x:R => (g x - g x0) * / (x - x0) * f x) (
              D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4);
          clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H;
            simpl in H; unfold limit1_in; unfold limit_in;
              simpl; intros; elim (H eps H0); clear H; intros;
                elim H; clear H; intros; split with x; split; auto;
                  intros; generalize (H1 x1 H2); clear H1; intro;
                    rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
                      rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
                        rewrite (Rmult_assoc (/ (x1 - x0)) (f x1 - f x0) (g x0)) in H1;
                          rewrite (Rmult_assoc (/ (x1 - x0)) (g x1 - g x0) (f x1)) in H1;
                            rewrite <-
                              (Rmult_plus_distr_l (/ (x1 - x0)) ((f x1 - f x0) * g x0)
                                ((g x1 - g x0) * f x1)) in H1;
                              rewrite
                                (Rmult_comm (/ (x1 - x0)) ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1))
                                in H1; rewrite (Rmult_comm (dg x0) (f x0)) in H1;
                                  cut
                                    ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1 = f x1 * g x1 - f x0 * g x0).
  intro; rewrite H3 in H1; assumption.
  ring.
  unfold limit1_in; unfold limit_in; simpl; intros;
    split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0));
      intros a b; rewrite (b (eq_refl (g x0))); unfold Rgt in H;
        assumption.
Qed.

(*********)
Lemma Dmult_const :
  forall (D:R -> Prop) (f df:R -> R) (x0 a:R),
    D_in f df D x0 -> D_in (fun x:R => a * f x) (fun x:R => a * df x) D x0.
Proof.
  intros;
    generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H);
      unfold D_in; intros; rewrite (Rmult_0_l (f x0)) in H0;
        rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0;
          assumption.
Qed.

(*********)
Lemma Dopp :
  forall (D:R -> Prop) (f df:R -> R) (x0:R),
    D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0.
Proof.
  intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in;
    unfold limit1_in; unfold limit_in;
      intros; generalize (H0 eps H1); clear H0; intro; elim H0;
        clear H0; intros; elim H0; clear H0; simpl;
          intros; split with x; split; auto.
  intros; generalize (H2 x1 H3); clear H2; intro.
  replace (- f x1 - - f x0) with (-1 * f x1 - -1 * f x0) by ring.
  replace (- df x0) with (-1 * df x0) by ring.
  exact H2.
Qed.

(*********)
Lemma Dminus :
  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df D x0 ->
    D_in g dg D x0 ->
    D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0.
Proof.
  unfold Rminus; intros; generalize (Dopp D g dg x0 H0); intro;
    apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0);
      assumption.
Qed.

(*********)
Lemma Dx_pow_n :
  forall (n:nat) (D:R -> Prop) (x0:R),
    D_in (fun x:R => x ^ n) (fun x:R => INR n * x ^ (n - 1)) D x0.
Proof.
  simple induction n; intros.
  simpl; rewrite Rmult_0_l; apply Dconst.
  intros; cut (n0 = (S n0 - 1)%nat);
    [ intro a; rewrite <- a; clear a | simpl; apply minus_n_O ].
  generalize
    (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) (
      fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) (
        H D x0)); unfold D_in; unfold limit1_in;
    unfold limit_in; simpl; intros; elim (H0 eps H1);
      clear H0; intros; elim H0; clear H0; intros; split with x;
        split; auto.
  intros; generalize (H2 x1 H3); clear H2 H3; intro;
    rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2;
      rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2;
        rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2;
          rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2;
            rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (Peano_dec.eq_nat_dec n0 0) ; intros cond.
  rewrite cond in H2; rewrite cond; simpl in H2; simpl;
    cut (1 + x0 * 1 * 0 = 1 * 1);
      [ intro A; rewrite A in H2; assumption | ring ].
  cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | omega ];
    rewrite (H3 cond) in H2; rewrite (Rmult_comm (x0 ^ n0) (INR n0)) in H2;
      rewrite (tech_pow_Rplus x0 n0 n0) in H2; assumption.
Qed.

(*********)
Lemma Dcomp :
  forall (Df Dg:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df Df x0 ->
    D_in g dg Dg (f x0) ->
    D_in (fun x:R => g (f x)) (fun x:R => df x * dg (f x)) (Dgf Df Dg f) x0.
Proof.
  intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in;
    unfold Rdiv; intros;
      generalize
        (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) (
          D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0);
        intro; generalize (cont_deriv f df Df x0 H); intro;
          unfold continue_in in H4; generalize (H3 H4 H2); clear H3;
            intro;
              generalize
                (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0))
                  (fun x:R => (f x - f x0) * / (x - x0))
                  (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (dg (f x0)) (
                    df x0) x0 H3); intro;
                cut
                  (limit1_in (fun x:R => (f x - f x0) * / (x - x0))
                    (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (df x0) x0).
  intro; generalize (H5 H6); clear H5; intro;
    generalize
      (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
        fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1
      (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0));
      intro; unfold limit1_in; unfold limit_in;
        simpl; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
          simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8);
            clear H5 H7; intros; elim H5; elim H7; clear H5 H7;
              intros; split with (Rmin x x1); split.
  elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b.
  intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0));
    intros a b; clear b; unfold Rgt in a; elim (a H12);
      clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10;
        clear H12; elim (Req_dec (f x2) (f x0)); intro.
  elim H11; clear H11; intros; elim H11; clear H11; intros;
    generalize (H10 x2 (conj (conj H11 H14) H5)); intro;
      rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16;
        rewrite (Rmult_0_l (/ (x2 - x0))) in H16;
          rewrite (Rmult_0_l (dg (f x0))) in H16; rewrite H12;
            rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (eq_refl (g (f x0))));
              rewrite (Rmult_0_l (/ (x2 - x0))); assumption.
  clear H10 H5; elim H11; clear H11; intros; elim H5; clear H5; intros;
    cut
      (((Df x2 /\ x0 <> x2) /\ Dg (f x2) /\ f x0 <> f x2) /\ R_dist x2 x0 < x1);
      auto; intro; generalize (H7 x2 H14); intro;
        generalize (Rminus_eq_contra (f x2) (f x0) H12); intro;
          rewrite
            (Rmult_assoc (g (f x2) - g (f x0)) (/ (f x2 - f x0))
              ((f x2 - f x0) * / (x2 - x0))) in H15;
            rewrite <- (Rmult_assoc (/ (f x2 - f x0)) (f x2 - f x0) (/ (x2 - x0)))
              in H15; rewrite (Rinv_l (f x2 - f x0) H16) in H15;
                rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15;
                  rewrite (Rmult_comm (df x0) (dg (f x0))); assumption.
  clear H5 H3 H4 H2; unfold limit1_in; unfold limit_in;
    simpl; unfold limit1_in in H1; unfold limit_in in H1;
      simpl in H1; intros; elim (H1 eps H2); clear H1; intros;
        elim H1; clear H1; intros; split with x; split; auto;
          intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4;
            intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)).
Qed.

(*********)
Lemma D_pow_n :
  forall (n:nat) (D:R -> Prop) (x0:R) (expr dexpr:R -> R),
    D_in expr dexpr D x0 ->
    D_in (fun x:R => expr x ^ n)
    (fun x:R => INR n * expr x ^ (n - 1) * dexpr x) (
      Dgf D D expr) x0.
Proof.
  intros n D x0 expr dexpr H;
    generalize
      (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr (
        fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0)));
      intro; unfold D_in; unfold limit1_in;
        unfold limit_in; simpl; intros; unfold D_in in H0;
          unfold limit1_in in H0; unfold limit_in in H0; simpl in H0;
            elim (H0 eps H1); clear H0; intros; elim H0; clear H0;
              intros; split with x; split; intros; auto.
  cut
    (dexpr x0 * (INR n * expr x0 ^ (n - 1)) =
      INR n * expr x0 ^ (n - 1) * dexpr x0);
    [ intro Rew; rewrite <- Rew; exact (H2 x1 H3) | ring ].
Qed.


Require Import List.
Import ListNotations.

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

Context {q : positive}.

Definition var := nat.

(* Expressions that can be used in constraints *)
Inductive expr : Type :=
| Sig (s : F q)
| Var (v : var)
| Opp (e : expr)
| Add (e1 e2 : expr)
| Mul (e1 e2 : expr).

Inductive stmt : Type :=
  (* Constrain *)
| C (e1 e2 : expr).

Definition tmpl := list stmt.

Definition state := (list Prop * list stmt) % type.

Fixpoint reduce' (c : list Prop) (s : list stmt) : list Prop :=
  match s with
  | [] => c
  | (C e1 e2) :: s' =>
      reduce' ((e1 = e2) :: c) s'
  end.

Definition reduce (s : state) : list Prop := reduce' (fst s) (snd s).

(* IsZero from circomlib: 0 -> in, 1 -> out, 2 -> inv *)
Definition IsZero := [
    C (Var 1) (Add (Opp (Mul (Var 0) (Var 2))) (Sig 1)) ;
    C (Mul (Var 0) (Var 1)) (Sig 0)
  ].

Definition reduce_is_zero := reduce ([], IsZero).

Compute reduce_is_zero.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.ModalLogic.Model.KripkeModel.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.
Import KripkeModelFamilyNotation.

Module Semantics.

Definition boxp {worlds: Type} {R: KM.Relation worlds} (X: Ensemble worlds): Ensemble worlds :=
  fun m => forall n, Krelation m n -> X n.

End Semantics.

Class KripkeModalSemantics (L: Language) {minL: MinimunLanguage L} {mL: ModalLanguage L} (MD: Model) {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} (SM: Semantics L MD): Type := {
  denote_boxp: forall x: expr, Same_set _ (Kdenotation M (boxp x)) (Semantics.boxp (Kdenotation M x))
}.

Lemma sat_boxp {L: Language} {minL: MinimunLanguage L} {mL: ModalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R: Relation (Kworlds M)} {SM: Semantics L MD} {kmSM: KripkeModalSemantics L MD M SM}: forall m x, KRIPKE: M , m |= boxp x <-> (forall n, KM.Krelation m n -> KRIPKE: M , n |= x).
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_boxp x).
  split; [apply H | apply H0].
Qed.