From discprob.basic Require Import base order nify.
From discprob.basic Require Export monad.
From discprob.prob Require Import prob countable finite stochastic_order.
Require Import Reals Fourier FunctionalExtensionality Psatz.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype finset finfun bigop.

Record ldist (A: Type) := mklDist {
  outcomes :> list (R * A);
  nonneg : all  (λ r, Rle_dec 0 r) [seq r.1 | r <- outcomes];
  sum1 : \big[Rplus/0]_(a <- map fst outcomes) a == R1
 }.

Arguments outcomes {_}.
Arguments sum1 {_}.
Arguments mklDist {_}.

Lemma ldist_irrel A (l1 l2: ldist A) :
  outcomes l1 = outcomes l2 → l1 = l2.
Proof.
  destruct l1 as [l1 pf1a pf1b].
  destruct l2 as [l2 pf2a pf2b] => //.
  rewrite /outcomes => ?. subst.
  f_equal; auto; exact: bool_irrelevance.
Qed.

Global Instance dist_ret: stdpp.base.MRet ldist.
  refine (λ A x, mklDist [::(R1, x)] _ _).
Proof.
{ abstract (rewrite //= andb_true_r; destruct (Rle_dec) => //=; nra). }
{ abstract (rewrite //= big_cons big_nil; apply /eqP => //=; field). }
Defined.

Definition dist_bind_aux :=
  λ {A B} (f: A → ldist B),
  fix go (l: seq (R * A)) :=
    match l with
      [::] => [::]
    | (r, x) :: l => map (λ py, (r * py.1, py.2)%R) (f x) ++ go l
    end.

Lemma dist_bind_pf1 {A B} (f: A → ldist B) d:
  all [eta (Rle_dec 0)] [seq r.1 | r <- dist_bind_aux f (outcomes d)].
Proof.
  apply /allP => r.
  destruct d as (l, pf1, pf2).
  rewrite //=; clear pf2.
  induction l as [| a l] => //=.
  destruct a as (r'&x) => //=.
  rewrite map_cat mem_cat.
  move /orP => [Hin|Hin].
  - move /allP in pf1. specialize (pf1 r').
    destruct (f x) as [l' pf1' pf2'].
    rewrite //= in Hin; clear pf2'.
    induction l' as [|? l'] => //=.
    rewrite //= in_cons in Hin.
    move /orP in Hin. destruct Hin as [Heq|Hin'].
    * move /eqP in Heq. rewrite Heq. destruct (Rle_dec 0 (_ * _)) as [|Hn] => //=; try nra.
      exfalso; apply Hn.
      apply Rmult_le_0_compat.
      ** cut (is_true (Rle_dec 0 r')); first by destruct (Rle_dec 0 r') => //=.
         apply pf1. rewrite in_cons. apply /orP; by left.
      ** cut (is_true (Rle_dec 0 (fst a))); first by destruct (Rle_dec 0 (fst a)) => //=.
         move /allP in pf1'. apply pf1'. rewrite in_cons. apply /orP; by left.
    * eapply IHl'; eauto; intros.
      rewrite //= in pf1'. move /andP in pf1'. destruct pf1'. auto.
  - eapply IHl; eauto.
      rewrite //= in pf1. move /andP in pf1. destruct pf1. auto.
Qed.

Lemma dist_bind_pf2 {A B} (f: A → ldist B) d:
  \big[Rplus/0]_(a<-[seq i.1 | i <- dist_bind_aux f (outcomes d)]) a == 1.
Proof.
 intros. apply /eqP.  destruct d as (l, pf1, pf2).
 rewrite //=; clear pf1.
 revert pf2.  move /eqP. replace 1 with R1 by auto. generalize R1 as t.
 induction l as [| a l] => t.
 - rewrite big_nil //= => ?.
 - destruct a as (r, x); rewrite //= big_cons => Hsum.
   rewrite map_cat -map_comp big_cat //= big_map //= (IHl (t - r)%R).
   * rewrite -big_distrr //=. specialize (sum1 (f x)). move /eqP. rewrite big_map => ->. field.
   * rewrite -Hsum. ring_simplify. done.
Qed.

Global Instance dist_bind: stdpp.base.MBind ldist :=
  λ A B f d, mklDist (dist_bind_aux f (outcomes d)) (dist_bind_pf1 f d) (dist_bind_pf2 f d).

Global Program Instance dist_join: stdpp.base.MJoin ldist :=
  λ A (lld: ldist (ldist A)),
  let fix go (ls : seq (R * ldist A)) :=
  match ls with [::] => [::] | (r, l) :: ls => [seq (r * i.1, i.2) | i <- l] ++ go ls end in
  mklDist (go lld) _ _.
Next Obligation.
  rewrite //= => A lld.
  apply /allP => r.
  destruct lld as (l, pf1, pf2).
  rewrite //=; clear pf2.
  induction l as [| a l] => //=.
  destruct a as (r'&x) => //=.
  rewrite map_cat mem_cat.
  move /orP => [Hin|Hin].
  - assert (0 ≤ r').
    { cut (is_true (Rle_dec 0 r')); first by destruct (Rle_dec 0 r') => //=.
      move /allP in pf1. apply pf1. rewrite in_cons //= eq_refl //. }
    clear pf1.
    destruct x as (l', pf1', pf2').
    rewrite //= in Hin. clear pf2'. induction l' as [| ? l'].
    { rewrite in_nil in Hin; done. }
    rewrite //= in_cons in Hin.
    move /orP in Hin. destruct Hin as [Heq|Hin'].
    * move /eqP in Heq. rewrite Heq.
      destruct (Rle_dec 0 (_ * _)) as [|Hn] => //=.
      contradiction Hn; apply Rmult_le_0_compat.
      ** auto.
      ** cut (is_true (Rle_dec 0 (fst a))); first by destruct (Rle_dec 0 (fst a)) => //=.
         move /allP in pf1'. apply pf1'. rewrite in_cons. apply /orP; by left.
    * eapply IHl'; eauto; intros.
      rewrite //= in pf1'. move /andP in pf1'. destruct pf1'; done.
  - eapply IHl; eauto.
    rewrite //= in pf1. move /andP in pf1. destruct pf1; done.
Qed.
Next Obligation.
 destruct lld as (l, pf1, pf2).
 apply /eqP.
 rewrite //=; clear pf1.
 revert pf2. move /eqP. generalize R1 as t.
 induction l as [| a l] => t.
 - intros. rewrite //=.
 - destruct a as (r, x); rewrite //= big_cons => Hsum.
   rewrite map_cat -map_comp big_cat //= big_map //= (IHl (t - r)%R).
   * rewrite -big_distrr //=. specialize (sum1 (x)). move /eqP. rewrite big_map => ->. field.
   * rewrite -Hsum; ring_simplify; done.
Qed.

Global Program Instance dist_fmap: stdpp.base.FMap ldist :=
  λ A B (f: A → B) (ld: ldist A),
  let fix go (l : seq (R * A)) := match l with [::] => [::] | (r, x) :: l => (r, f x) :: go l end in
  mklDist (go ld) _ _.
Next Obligation.
  intros A B f ld.
 apply /allP => r.
 destruct ld as (l, pf1, pf2).
 rewrite //=. clear pf2.
 induction l as [|a l] => //=.
 destruct a as (r', x) => //=.
 rewrite in_cons.
 move /orP => [Heq|Hin].
 - move /eqP in Heq. rewrite Heq.
   move /andP in pf1. apply pf1.
 - apply IHl, Hin. intros. rewrite //= in pf1. move /andP in pf1.
   destruct pf1; auto.
Qed.
Next Obligation.
 intros A B f ld.
 apply /eqP.
 destruct ld as (l, pf1, pf2).
 rewrite //=; clear pf1.
 revert pf2. move /eqP. generalize R1 as t.
 induction l as [| a l] => t.
 - intros. rewrite //=.
 - destruct a as (r, x); rewrite //= big_cons => Hsum.
   rewrite big_cons. rewrite (IHl (t - r)%R); first field.
   rewrite -Hsum; ring_simplify; done.
Qed.

Lemma bind_join_fmap {A B} (m: ldist A) (g: A → ldist B):
  outcomes (mbind g m) = outcomes (mjoin (fmap g m)).
Proof.
  rewrite /mbind/mjoin/fmap/dist_bind/dist_join/dist_fmap.
  destruct m as (lm, pf1m, pf2m) => //=.
  clear pf1m pf2m.
  induction lm as [|a l] => //.
  destruct a as (r, x) => //=; f_equal; done.
Qed.

Lemma in_ldist_bind {A B : eqType} (f: A → ldist B) r (x : B) (m: ldist A) :
  (r, x) \in outcomes (x ← m; f x) →
   ∃ r'' r' y, (r'', x) \in outcomes (f y)
               ∧ (r', y) \in outcomes m
               ∧ r = r' * r''.
Proof.
  rewrite /mbind/dist_bind//=.
  destruct m as (l, pf1, pf2) => //=.
  clear pf1 pf2.
  induction l as [|p l IH] => //.
  rewrite //=. destruct p as (r'&y) => //=.
  rewrite mem_cat. move /orP => [Hin1|Hintl].
  - move /mapP in Hin1. destruct Hin1 as [[r'' y'] Hin Heq].
    rewrite //= in Heq. inversion Heq; subst.
    exists r'', r', y; repeat split; auto.
    rewrite in_cons eq_refl //.
  - destruct IH as (r1&r2&y'&?&?&?); auto.
    exists r1, r2, y'; repeat split; auto.
    rewrite in_cons. apply /orP; by right.
Qed.

Lemma in_ldist_bind2 {A B : eqType} (f: A → ldist B) r' r'' (x : B) y (m: ldist A) :
   (r'', x) \in outcomes (f y) →
   (r', y) \in outcomes m →
   (r' * r'', x) \in outcomes (m ≫= f).
Proof.
  rewrite /mbind/dist_bind//=.
  destruct m as (l, pf1, pf2) => //=.
  clear pf1 pf2.
  induction l as [|p l IH] => //.
  rewrite //= => Hin1 Hin2'. destruct p as (?&?) => //=.
  rewrite mem_cat.
  rewrite in_cons in Hin2'. move /orP in Hin2'. destruct Hin2' as [Heq|Htl]; apply /orP.
  - left. move /eqP in Heq. inversion Heq; subst.
    apply /mapP. exists (r'',  x); auto.
  - right. apply IH; eauto.
Qed.

Lemma nth_lt_size {A: eqType} (d: A) m l (Hsize: (m < size l)%N):
  nth d l m \in l.
Proof.
  apply /all_nthP => //.
  apply /allP => x Hin //=.
Qed.

(* Every ldist can be regarded as a random variable *)
Definition dist_of_ldist {A: eqType} (ld: ldist A) : distrib [finType of ordinal (size ld)].
  apply (@mkDistrib _ (λ n, (nth R0 (map fst ld) (nat_of_ord n)))).
  - destruct a as [m Hlt]; destruct ld as (l, pf1, pf2); rewrite //=.
    rewrite //= in Hlt. move /allP in pf1.
    apply Rle_ge.
    cut (is_true (Rle_dec 0 (nth 0 [seq (fst i) | i <- l] m)));
      first by (destruct (Rle_dec) => //=).
    apply /pf1/nth_lt_size. rewrite size_map //.
  - destruct ld as (l, pf1, pf2); rewrite //=. move /eqP in pf2.
    replace 1 with R1 by auto.
    rewrite -pf2 -sum_index_ordinal -SeriesF_big_op.
    apply SeriesF_is_seriesC.
Defined.

Definition ld_def {A} (ld: seq (R *A) ) (n: 'I_(size ld)) : A.
  induction ld as [|(r, x)].
  - destruct n as (n&Hlt). inversion Hlt.
  - exact x.
Qed.

Lemma sum_index_ordinal_Fpair {A: eqType} (l: seq (R * A)) F:
  \big[Rplus/0]_(a in 'I_(size l))
   F (nth 0 [seq i.1 | i <- l] a, nth (ld_def l a) [seq i.2 | i <- l] a) =
  \big[Rplus/0]_(a<- l) F a.
Proof.
    induction l as [| a l].
    * rewrite //= big_nil big_ord0 //.
    * transitivity (\big[Rplus/0%R]_(0<= a' < (size l).+1)
                     F (nth 0 ([seq i.1 | i <- a :: l]) a', (nth (snd a) ([seq i.2 | i <- a :: l]) a'))).
      { rewrite big_mkord. apply eq_bigr => ??. rewrite (set_nth_default (snd a)); first done.
        rewrite size_map. auto. }
      rewrite //= big_cons big_ltn; last auto.
      destruct a; f_equal; rewrite big_add1 //=. rewrite -IHl big_mkord.
      apply eq_bigr => i H. rewrite (set_nth_default (ld_def l i)); first done.
      rewrite size_map. done.
Qed.

Definition rvar_of_ldist {A: eqType} (ld: ldist A) : rvar (dist_of_ldist ld) A :=
  mkRvar (dist_of_ldist ld) (λ n, (nth (ld_def ld n) (map snd ld) (nat_of_ord n))).

(* There must be some nice way to do this... I really need to learn ssreflect better *)
Lemma setP_help {A: finType} (P: A -> bool) (i: A):
  (pred_of_set [set x | P x]) i = P i.
Proof.
  rewrite -in_set.
  transitivity (i \in [set x | P x]); first by rewrite in_set.
  rewrite in_set. done.
Qed.

Lemma pr_rvar_ldist {A: eqType} (ld: ldist A) r :
  pr_eq (rvar_of_ldist ld) r = \big[Rplus/0%R]_(a <- outcomes ld | snd a == r) fst a.
Proof.
  rewrite /pr_eq/pr.
  rewrite SeriesC_fin_big -big_mkcondr.
  rewrite /dist_of_ldist //=.
  apply (sum_index_ordinal_P _ _ (R0, r)) => //= i.
  rewrite (nth_map (nth (0, r) ld i)) //.
  rewrite (set_nth_default (0, r)) //.
Qed.

Lemma pr_gt_rvar_ldist (ld: ldist R) r :
  pr_gt (rvar_of_ldist ld) r = \big[Rplus/0%R]_(a <- outcomes ld | Rgt_dec (snd a) r) fst a.
Proof.
  rewrite /pr_gt/pr.
  rewrite SeriesC_fin_big -big_mkcondr.
  rewrite /dist_of_ldist //=.
  apply (sum_index_ordinal_P _ _ (R0, r)) => //= i.
  rewrite (nth_map (nth (0, r) ld i)) //.
  rewrite (set_nth_default (0, r)) //.
Qed.

Lemma sum_mjoin {B: eqType} (lld: ldist (ldist B)) P:
  \big[Rplus/0]_(a <- outcomes (mjoin lld) | P (snd a)) a.1 =
  \big[Rplus/0]_(ld <- lld) \big[Rplus/0]_(a <- ld.2 | P (snd a)) (ld.1 * a.1).
Proof.
  destruct lld as (lld, pf1, pf2) => //=.
  clear pf1 pf2.
  induction lld as [|[r ld] lld] => //=.
  { rewrite ?big_nil //. }
  rewrite big_cons big_cat //=.
  f_equal; eauto.
  rewrite big_map //=.
Qed.

Lemma sum_fmap {A B} (f: A → B) (ld: ldist A) F:
  \big[Rplus/0]_(x <- outcomes (f <$> ld)) (F (x.1) (x.2)) =
  \big[Rplus/0]_(x <- ld) (F (x.1) (f x.2)).
Proof.
  destruct ld as (ld, pf1, pf2) => //=.
  clear pf1 pf2.
  induction ld as [|[r x] ld] => //=.
  { rewrite ?big_nil //. }
  rewrite ?big_cons //=.
  f_equal; eauto.
Qed.

Lemma nat_of_ord_map_iota {A} n (F: nat → A):
  [seq (F (nat_of_ord i)) | i <- enum 'I_n] =
  [seq (F i) | i <- iota 0%N n].
Proof.
    by rewrite -val_enum_ord map_comp.
Qed.

Lemma nat_of_ord_map_iota' {A} n (F: nat → A):
  [seq (F (nat_of_ord i)) | i <- Finite.enum [finType of 'I_n]] =
  [seq (F i) | i <- iota 0%N n].
Proof.
  rewrite -nat_of_ord_map_iota. f_equal.
  rewrite -enumT//=.
Qed.

Lemma map_nth_iota {A: eqType} (l: seq A) a:
      [seq nth a l i | i <- iota 0 (size l)] = l.
Proof.
  induction l => //=.
  replace 1%nat with (1 + 0)%nat by auto with *.
  rewrite iota_addl -map_comp; f_equal => //=.
Qed.

Lemma img_rvar_of_ldist {A: eqType} (h: ldist A):
  map sval (Finite.enum [finType of (imgT (rvar_of_ldist h))]) = undup [seq i.2 | i <- h].
Proof.
  rewrite {1}[@Finite.enum]unlock //=. rewrite img_fin_enum_sval.
  assert (a: A).
  { destruct h as (l, pf1, pf2). destruct l.
    - rewrite big_nil in pf2. move /eqP in pf2. exfalso.
      rewrite //= in pf2. fourier.
    - exact (snd p).
  }
  f_equal.
  etransitivity.
  - apply (@eq_map _ _ _ (λ n, nth a [seq i.2 | i <- h] (nat_of_ord n))).
    { intro i. erewrite set_nth_default; auto. rewrite size_map. done. }
  - rewrite -enumT. rewrite (nat_of_ord_map_iota (size h) (λ n, nth a [seq (snd i) | i <- h] n)).
  destruct h as (l, pf1, pf2) => //=; clear pf1 pf2.
  rewrite -(size_map snd l) map_nth_iota //.
Qed.

Lemma img_rvar_of_ldist' {A: eqType} (h: ldist A) a:
  a \in img (rvar_of_ldist h) = (a \in undup [seq (snd i) | i <- h]).
Proof.
  apply (introTF (exCP _)); case: ifP.
  - rewrite mem_undup. move /mapP. intros [x Hin Heq]; subst.
    rewrite //=.
    assert (index (snd x) (map snd h) < size h)%nat as Hsize.
    { rewrite -(size_map snd) index_mem. apply /mapP. eexists; eauto. }
    exists (Ordinal Hsize) => //=.
    rewrite nth_index => //=. apply /mapP. eexists; eauto.
  - rewrite mem_undup => Hfalse. intros (x&Heq).
    move /negP in Hfalse. apply Hfalse. move /eqP in Heq.
    rewrite -Heq. rewrite //=. apply nth_lt_size. rewrite size_map. destruct x. auto.
Qed.

(* Lemmas for simplifying monadic expressions *)
Lemma pr_mbind_ldist1 {A B: eqType} (h: ldist A) (f: A → ldist B) (b: B) :
  pr_eq (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a : imgT (rvar_of_ldist h))
   (pr_eq (rvar_of_ldist h) (sval a) * pr_eq (rvar_of_ldist (f (sval a))) b).
Proof.
  transitivity (Ex (rvar_comp (rvar_of_ldist h) (λ a, pr_eq (rvar_of_ldist (f a)) b))); last first.
  { rewrite Ex_fin_comp. eapply eq_bigr => ??. field. }
  rewrite pr_rvar_ldist Ex_fin_pt.
  symmetry. etransitivity.
  { apply eq_bigr => ?? /=. rewrite !pr_rvar_ldist. done. }
  rewrite bind_join_fmap.
  rewrite (sum_mjoin _ (λ x, x == b)).
  rewrite (sum_fmap f h (λ x y, \big[Rplus/0]_(a <- y | a.2 == b) (x * a.1))).
  rewrite /index_enum.
  rewrite //= (sum_index_ordinal_Fpair _ (λ xy,
     \big[Rplus/0]_(a <- f (xy.2) | a.2 == b) a.1 * (xy.1))).
  eapply eq_bigr => x _.
  rewrite Rmult_comm.
  rewrite big_distrr //.
Qed.

Lemma pr_mbind_ldist2 {A B: eqType} (h: ldist A) (f: A → ldist B) (b: B) :
  pr_eq (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a <- undup [seq i.2 | i <- h])
   (pr_eq (rvar_of_ldist h) a * pr_eq (rvar_of_ldist (f a)) b).
Proof.
  rewrite -img_rvar_of_ldist pr_mbind_ldist1 //.
  rewrite big_map //=.
Qed.

Lemma pr_mret_simpl {A: eqType} (x y: A):
  pr_eq (rvar_of_ldist (mret x)) y = if (x == y) then 1 else 0.
Proof.
  rewrite pr_rvar_ldist big_cons big_nil //=. case: ifP => ?; field.
Qed.

Lemma pr_mbind_mret {A B: eqType} (h: ldist A) (f: A → B) (b: B) :
  pr_eq (rvar_of_ldist (mbind (λ x, mret (f x)) h)) b =
  pr_eq (rvar_comp (rvar_of_ldist h) f) b.
Proof.
  rewrite pr_mbind_ldist1 //.
  symmetry. rewrite {1}/pr_eq pr_eq_alt_comp.
  eapply eq_bigr => a _.
  rewrite pr_mret_simpl.
  case: ifP => ?; rewrite //= ?Rmult_1_r ?Rmult_0_r; done.
Qed.

Lemma pr_mbind_mret_inj {A B: eqType} (h: ldist A) (f: A → B) (a: A) :
  injective f →
  pr_eq (rvar_of_ldist (mbind (λ x, mret (f x)) h)) (f a)=
  pr_eq (rvar_of_ldist h) a.
Proof.
  intros Hinj.
  rewrite pr_mbind_mret //= {1}/pr_eq pr_eq_alt_comp.
  rewrite {2}/pr_eq pr_eq_alt.
  eapply eq_bigr => i _. symmetry.
  case: ifP; move /eqP.
  * intros Heq1. rewrite Heq1 eq_refl. done.
  * intros Hneq. case: ifP; auto. move /eqP. intros Heq.
    apply Hinj in Heq. congruence.
Qed.

Lemma pr_mbind_mret_inj0 {A B: eqType} (h: ldist A) (f: A → B) (b: B) :
  (∀ a, f a ≠ b) →
  pr_eq (rvar_of_ldist (mbind (λ x, mret (f x)) h)) b = 0.
Proof.
  intros Hneq. rewrite pr_mbind_mret {1}/pr_eq pr_eq_alt_comp.
  apply big1 => i _. case: ifP; auto. move /eqP => Heq. exfalso.
  apply (Hneq (sval i)); auto.
Qed.

Lemma pr_gt_mbind_ldist1 {A: eqType} (h: ldist A) (f: A → ldist R) (b: R) :
  pr_gt (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a : imgT (rvar_of_ldist h))
   (pr_eq (rvar_of_ldist h) (sval a) * pr_gt (rvar_of_ldist (f (sval a))) b).
Proof.
  transitivity (Ex (rvar_comp (rvar_of_ldist h) (λ a, pr_gt (rvar_of_ldist (f a)) b))); last first.
  { rewrite Ex_fin_comp. eapply eq_bigr => ??. field. }
  rewrite pr_gt_rvar_ldist Ex_fin_pt.
  symmetry. etransitivity.
  { apply eq_bigr => ?? /=. rewrite !pr_gt_rvar_ldist. done. }
  rewrite bind_join_fmap.
  rewrite (sum_mjoin _ (λ x, Rgt_dec x b)).
  rewrite (sum_fmap f h (λ x y, \big[Rplus/0]_(a <- y | Rgt_dec a.2 b) (x * a.1))).
  rewrite /index_enum.
  rewrite //= (sum_index_ordinal_Fpair _ (λ xy,
     \big[Rplus/0]_(a <- f (xy.2) | Rgt_dec a.2 b) a.1 * (xy.1))).
  eapply eq_bigr => x _.
  rewrite Rmult_comm.
  rewrite big_distrr //.
Qed.

Lemma pr_gt_mbind_ldist2 {A: eqType} (h: ldist A) (f: A → ldist R) (b: R) :
  pr_gt (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a <- undup [seq i.2 | i <- h])
   (pr_eq (rvar_of_ldist h) a * pr_gt (rvar_of_ldist (f a)) b).
Proof.
  rewrite -img_rvar_of_ldist pr_gt_mbind_ldist1 //.
  rewrite big_map //=.
Qed.

Lemma pr_gt_mret_simpl (x y: R):
  pr_gt (rvar_of_ldist (mret x)) y = if (Rgt_dec x y) then 1 else 0.
Proof.
  rewrite pr_gt_rvar_ldist big_cons big_nil //=.
  destruct Rgt_dec => //=; try fourier; try nra.
Qed.

Lemma pr_gt_mbind_mret {A: eqType} (h: ldist A) (f: A → R) (b: R) :
  pr_gt (rvar_of_ldist (mbind (λ x, mret (f x)) h)) b =
  pr_gt (rvar_comp (rvar_of_ldist h) f) b.
Proof.
  rewrite pr_gt_mbind_ldist1 //.
  symmetry. rewrite {1}/pr_gt pr_gt_alt_comp.
  eapply eq_bigr => a _.
  rewrite pr_gt_mret_simpl.
  destruct Rgt_dec => //=; rewrite ?Rmult_1_r ?Rmult_0_r //=.
Qed.

Lemma Ex_mbind_ldist1 {A: eqType} (h: ldist A) (f: A → ldist R) :
  Ex (rvar_of_ldist (mbind f h)) =
  \big[Rplus/0]_(a : imgT (rvar_of_ldist h))
   (pr_eq (rvar_of_ldist h) (sval a) * Ex (rvar_of_ldist (f (sval a)))).
Proof.
  rewrite /Ex. rewrite SeriesC_fin_big.
  f_equal; etransitivity.
  {eapply eq_bigr => x _. rewrite pr_mbind_ldist1. rewrite big_distrl //. }
  rewrite exchange_big.
  apply eq_bigr => x _.
  rewrite SeriesC_fin_big.
  rewrite big_distrr //=.
  rewrite /index_enum//=.
  rewrite -(big_map sval (λ x, true) (λ i, _ * pr_eq _ i * i)).
  rewrite -(big_map sval (λ x, true) (λ i, _ * (pr_eq _ i * i))).
  rewrite img_rvar_of_ldist.
  rewrite (img_rvar_of_ldist (dist_bind _ _ f h)).
  eapply sum_reidx_map_sym with (h := id).
  - intros; rewrite //=. rewrite //=. rewrite Rmult_assoc. done.
  - intros ? Hin' ? Hnin. rewrite (pr_img_nin (rvar_of_ldist (f (sval x)))); first by ring.
    rewrite img_rvar_of_ldist'. auto.
  - intros ? Hin' ? Hnin. exfalso. apply Hnin.
    destruct x as (x&Hin).
    rewrite //= in Hin'. rewrite img_rvar_of_ldist' in Hin.
    rewrite ?mem_undup in Hin Hin'.
    move /mapP in Hin.
    move /mapP in Hin'.
    destruct Hin as [(r'&x') Hin1 ?]; subst.
    destruct Hin' as [(r''&y'') Hin2 ?]; subst.
    specialize (in_ldist_bind2 f _ _ _ _ h Hin2 Hin1).
    rewrite //= => Hin_comb.
    exists y''.  rewrite mem_undup; split; auto.
    apply /mapP; auto.
    exists (r' * r'', y''); auto.
  - apply undup_uniq.
  - apply undup_uniq.
  - intros ??; done.
Qed.

Lemma Ex_mbind_ldist2 {A: eqType} (h: ldist A) (f: A → ldist R) :
  Ex (rvar_of_ldist (mbind f h)) =
  \big[Rplus/0]_(a <- undup [seq i.2 | i <- h]) (pr_eq (rvar_of_ldist h) a * Ex (rvar_of_ldist (f a))).
Proof.
  rewrite -img_rvar_of_ldist Ex_mbind_ldist1 //.
  rewrite big_map //=.
Qed.

Lemma Ex_mret_simpl (x: R):
  Ex (rvar_of_ldist (mret x)) = x.
Proof.
  rewrite /Ex SeriesC_fin_big /index_enum.
  rewrite -(big_map sval (λ x, true) (λ i, pr_eq _ i * i)).
  rewrite img_rvar_of_ldist //= big_cons big_nil.
  rewrite pr_mret_simpl eq_refl. f_equal; field.
Qed.

Lemma Ex_mbind_mret {A: eqType} (h: ldist A) (f: A → R) :
  Ex (rvar_of_ldist (mbind (λ x, mret (f x)) h)) =
  Ex (rvar_comp (rvar_of_ldist h) f).
Proof.
  rewrite Ex_mbind_ldist1 //.
  rewrite Ex_fin_comp.
  eapply eq_bigr => a _.
  rewrite Ex_mret_simpl.
  f_equal.
Qed.

Lemma outcomes_eq_dist {A: eqType} (r1 r2: ldist A) :
  outcomes r1 = outcomes r2 →
  eq_dist (rvar_of_ldist r1) (rvar_of_ldist r2).
Proof.
  rewrite /eq_dist => Heq x.
  rewrite ?pr_rvar_ldist Heq. done.
Qed.

Lemma ldist_left_id {A B: eqType} (x: A) (f: A → ldist B):
  mbind f (mret x) = f x.
Proof.
  apply ldist_irrel => //=. rewrite cats0.
  rewrite (@eq_map _ _ _ id); first by apply map_id.
  intros (?&?) => //=; f_equal; auto; ring_simplify; done.
Qed.

Lemma ldist_right_id {A: eqType} (m: ldist A) :
  mbind mret m = m.
Proof.
  apply ldist_irrel => //=. induction (outcomes m) as [| a l] => //=.
  destruct a as (?&?) => //=; f_equal; auto.
  rewrite Rmult_1_r. done.
Qed.

Lemma ldist_assoc {A B C: eqType} (m: ldist A) (f: A → ldist B) (g: B → ldist C) :
  mbind g (mbind f m) = mbind (λ x, mbind g (f x)) m.
Proof.
  apply ldist_irrel.
  destruct m as [m pf1 pf2] => //=.
  clear pf1 pf2.
  assert (Haux: ∀ A B (f: A → ldist B) l1 l2, dist_bind_aux f (l1 ++ l2) =
                               dist_bind_aux  f l1 ++ dist_bind_aux f l2).
  { induction l1 as [| a l] => //=.
    intros. destruct a as (r&x).
    rewrite IHl catA. done.
  }
  induction m as [| a l]; first by rewrite //=.
  destruct a as (r&x).
  rewrite //= Haux; eauto.
  f_equal; eauto.
  clear -Haux. induction (outcomes (f x)) as [| a' l'] => //=.
  destruct a' as (r'&x'). rewrite map_cat; f_equal; eauto.
  rewrite -map_comp => //=.
  apply eq_map => c.
  destruct c as (r''&x'') => //=.
  f_equal; auto; field.
Qed.

Lemma ldist_bind_ext {A B: eqType} m (f g: A → ldist B):
  (∀ a, f a = g a) →
  mbind f m = mbind g m.
Proof.
  destruct m as [l pf1 pf2] => Hext //=.
  rewrite /dist_bind.
  apply ldist_irrel => //=.
  clear pf1 pf2. induction l as [| a l] => //=.
  destruct a as (r, x). by rewrite IHl Hext.
Qed.

Lemma ldist_fmap_bind {A B C: eqType} m (h: A → B) (f: B → ldist C):
  mbind f (x ← m; mret (h x)) = mbind (λ x, f (h x)) m.
Proof.
  rewrite ldist_assoc.
  apply ldist_bind_ext => a. rewrite ldist_left_id. done.
Qed.

Lemma eq_dist_ldist_bind_ext {A B: eqType} m (f g: A → ldist B):
  (∀ a, eq_dist (rvar_of_ldist (f a)) (rvar_of_ldist (g a))) →
  eq_dist (rvar_of_ldist (mbind f m)) (rvar_of_ldist (mbind g m)).
Proof.
  rewrite /eq_dist => Heq b. rewrite ?pr_mbind_ldist2.
  eapply eq_bigr => a _. rewrite Heq. done.
Qed.

Lemma le_dist_ldist_bind_ext {A: eqType} m (f g: A → ldist R):
  (∀ a k, pr_gt (rvar_of_ldist (f a)) k <= pr_gt (rvar_of_ldist (g a)) k) →
  (∀ k, pr_gt (rvar_of_ldist (mbind f m)) k <= pr_gt (rvar_of_ldist (mbind g m)) k).
Proof.
  rewrite /eq_dist => Heq b. rewrite ?pr_gt_mbind_ldist2.
  apply Rle_bigr => a _. apply Rmult_le_compat_l.
  * apply Rge_le, pr_eq_ge_0.
  * done.
Qed.

Lemma eq_dist_ldist_bind_congr {A B: eqType} m m' (f g: A → ldist B):
  eq_dist (rvar_of_ldist m) (rvar_of_ldist m') →
  (∀ a, eq_dist (rvar_of_ldist (f a)) (rvar_of_ldist (g a))) →
  eq_dist (rvar_of_ldist (mbind f m)) (rvar_of_ldist (mbind g m')).
Proof.
  rewrite /eq_dist => Hdist Heq b. rewrite ?pr_mbind_ldist2.
  rewrite bigop_cond_non0 [a in _ = a]bigop_cond_non0.
  eapply (sum_reidx_map _ _ _ _ id).
  - intros. rewrite Hdist Heq. done.
  - rewrite //=; intros a Hin Hnon0. rewrite -?img_rvar_of_ldist'; split.
    * apply pr_img. rewrite -Hdist. move /eqP in Hnon0.
      edestruct (ge_pr_0 (rvar_dist (rvar_of_ldist m))) as [|Heq0]; first by eauto.
      rewrite /pr_eq//= in Hnon0. rewrite Heq0 in Hnon0. nra.
    * rewrite -Heq -Hdist. done.
  - rewrite //= => a Hin. rewrite -?img_rvar_of_ldist' => Hnon0 Hfalse.
    exfalso; apply Hfalse. exists a.
    rewrite Heq Hdist; split; auto.
    rewrite -?img_rvar_of_ldist'.
    apply pr_img. rewrite Hdist. move /eqP in Hnon0.
    edestruct (ge_pr_0 (rvar_dist (rvar_of_ldist m'))) as [|Heq0]; first by eauto.
    rewrite /pr_eq in Hnon0. rewrite Heq0 in Hnon0. nra.
  - apply undup_uniq.
  - apply undup_uniq.
  - done.
Qed.

Lemma ldist_bind_swap {A B C: eqType} (m1: ldist A) (m2: ldist B) (f: A → B → ldist C):
  eq_dist (rvar_of_ldist (a ← m1;
                            b ← m2;
                            f a b))
          (rvar_of_ldist (b ← m2;
                            a ← m1;
                            f a b)).
Proof.
  intros c.
  rewrite ?pr_mbind_ldist2.
  etransitivity.
  { eapply eq_bigr. intros. rewrite pr_mbind_ldist2. rewrite big_distrr //. }
  symmetry.
  etransitivity.
  { eapply eq_bigr. intros. rewrite pr_mbind_ldist2. rewrite big_distrr //. }
  rewrite exchange_big.
  do 2 (eapply eq_bigr => ??).
  rewrite //=. nra.
Qed.

Lemma pr_eq_bind_pair {A B: eqType} (m1: ldist A) (m2: ldist B) (a: A) (b: B):
  pr_eq (rvar_of_ldist (a ← m1; b ← m2; mret (a, b))) (a, b) =
  pr_eq (rvar_of_ldist m1) a * pr_eq (rvar_of_ldist m2) b.
Proof.
  rewrite ?pr_mbind_ldist2.
  etransitivity.
  { eapply eq_bigr. intros a' _.
    rewrite pr_mbind_ldist2. apply Rmult_eq_compat_l.
    eapply eq_bigr. intros b' _.
    rewrite pr_mret_simpl.
    transitivity (pr_eq (rvar_of_ldist (mret a')) a *
                     (pr_eq (rvar_of_ldist m2) b' *
                      pr_eq (rvar_of_ldist (mret b')) b)); last done.
    rewrite ?pr_mret_simpl.
    case: ifP; move /eqP => Heq.
    - inversion Heq as [[Heqa Heqb]].
      subst. rewrite ?eq_refl. nra.
    - case: ifP; move /eqP => Heqa.
      { case: ifP; move /eqP => Heqb.
        * subst. congruence.
        * nra.
      }
      nra.
  }
  etransitivity.
  {
    eapply eq_bigr. intros. rewrite -big_distrr.
    rewrite -pr_mbind_ldist2. rewrite -Rmult_assoc. done.
  }
  rewrite -big_distrl. rewrite ldist_right_id //=; f_equal.
  specialize (pr_mbind_ldist2 m1 (λ x, mret x)) => //=. intros <-.
  (* For some reason I cannot just do the appropriate rewrite... *)
  assert (Hfinal: ∀ {A: eqType} (m1: ldist A) a,
             pr_eq (rvar_of_ldist (x ← m1; mret x)) a = pr_eq (rvar_of_ldist m1) a).
  { intros.  rewrite ldist_right_id. done. }
  eapply Hfinal.
Qed.

Lemma eq_dist_bind_rvar_pair {A B: eqType} (m1: ldist A) (m2: ldist B):
  eq_dist (rvar_of_ldist (a ← m1; b ← m2; mret (a, b)))
          (rvar_pair (rvar_of_ldist m1) (rvar_of_ldist m2)).
Proof.
  intros (a&b). rewrite pr_eq_bind_pair pr_eq_rvar_pair //.
Qed.

Program Definition bernoulli (p: R) (Hrange: (0 <= p <= 1)%R) : ldist bool :=
  mklDist [:: (p, true) ; (1 - p, false)%R] _ _.
Next Obligation.
  rewrite //=; intros p (?&?);
  repeat (apply /andP; split; auto); destruct (Rle_dec) => //. nra.
Qed.
Next Obligation.
  rewrite //=; intros p (?&?);
  rewrite ?big_cons ?big_nil; apply /eqP => //=; field.
Qed.

Lemma pr_bernoulli_true (p: R) (Hrange: 0 <= p <= 1):
  pr_eq (rvar_of_ldist (bernoulli p Hrange)) true = p.
Proof.
  rewrite pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
Qed.

Lemma pr_bernoulli_false (p: R) (Hrange: 0 <= p <= 1):
  pr_eq (rvar_of_ldist (bernoulli p Hrange)) false = 1 - p.
Proof.
  rewrite pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
Qed.

Module test.

  Program Definition test1 : ldist (bool * bool) :=
    x ← bernoulli (1/2) _ ;
    y ← bernoulli (1/2) _;
    mret (x, y).
  Next Obligation. split; fourier. Qed.
  Next Obligation. split; fourier. Qed.

  (* Eval compute in (outcomes test1). *)

  Definition von_neumann_coin (p: R) (Hrange: 0 <= p <= 1): ldist (option bool) :=
    x ← bernoulli p Hrange;
    y ← bernoulli p Hrange;
    match x, y with
      | true, false => mret (Some true)
      | false, true => mret (Some false)
      | _, _ => mret None
    end.

  Fixpoint von_neumann_repeat (p: R) (Hrange: 0 <= p <= 1) (n: nat): ldist (option bool) :=
    match n with
      | 0 => mret None
      | S n' =>
        res ← von_neumann_coin p Hrange;
        match res with
          | None => von_neumann_repeat p Hrange n'
          | _ => mret res
        end
    end.

  Lemma range_three_fourths: 0 <= 3/4 <= 1. Proof. split; fourier. Qed.
  (* Eval compute in (outcomes (von_neumann_coin (3/4) range_three_fourths)). *)

  Lemma von_neumann_fair (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_coin p Hrange)) (Some true) =
    pr_eq (rvar_of_ldist (von_neumann_coin p Hrange)) (Some false).
  Proof.
    rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
  Qed.

  Lemma von_neumann_fail (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_coin p Hrange)) None =
    1 - 2 * (p * (1 - p)).
  Proof.
    rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
  Qed.

  (* These are not yet the most efficient ways to prove these;
     mainly ``brute-force'' computation; see below for a way that uses
     facts about monadic operations and a simple 'coupling' argument *)
  Lemma von_neumann_repeat_fair (p: R) (Hrange: 0 <= p <= 1) n :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some true) =
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some false).
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
      rewrite ?big_cat //=. f_equal.
      * rewrite ?big_map //= -?big_distrr; f_equal.
        by rewrite ?pr_rvar_ldist in IHn.
      * rewrite ?cats0.
        rewrite ?big_cons //=; f_equal; first field.
        rewrite ?big_map //= -?big_distrr; f_equal.
        by rewrite ?pr_rvar_ldist in IHn.
  Qed.

  Lemma von_neumann_repeat_fail n (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) None =
    (1 - 2 * (p * (1 - p)))^n.
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
      rewrite ?cats0 ?big_cat //=.
      rewrite ?pr_rvar_ldist in IHn.
      rewrite ?big_map -?big_distrr //= IHn.
      rewrite ?big_cons //=.
      rewrite ?big_map //= -?big_distrr //= IHn.
      field.
  Qed.

  Lemma von_neumann_repeat_fair' (p: R) (Hrange: 0 <= p <= 1) n :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some true) =
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some false).
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
    - rewrite !pr_mbind_ldist2.
      (* Coupling *)
      eapply (sum_reidx_surj2 _ _ _ _ _ _
                            (λ a, match a with | Some b => Some (negb b) | None => None end )).
      * destruct a => ?.
        ** f_equal; destruct s; rewrite ?von_neumann_fair //=;
          rewrite (pr_rvar_ldist (dist_ret _ (Some true)));
          rewrite (pr_rvar_ldist (dist_ret _ (Some false)));
          rewrite //= ?big_cons ?big_nil //=; try field.
        ** f_equal. eauto.
      * intros [[|]|]; rewrite //=.
      * intros [[|]|]; rewrite //=.
      * apply undup_uniq.
      * apply undup_uniq.
      * intros [[|]|] [[|]|] => //=.
  Qed.

  Lemma von_neumann_repeat_fail' n (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) None =
    (1 - 2 * (p * (1 - p)))^n.
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
    - rewrite pr_mbind_ldist2.
      rewrite {1}/von_neumann_coin.
      rewrite ?big_cons ?big_nil IHn //=.
      rewrite von_neumann_fail //=.
      rewrite ?pr_mret_simpl //=; field.
  Qed.

End test.


(** * Facts about Stabilization and Place Design *)

Require Import common.CoqLib.
Require Import common.NatMap.
Require Import common.NatSet.
Require Import common.ListPlus.

Require Import hvhdl.Environment.
Require Import hvhdl.SemanticalDomains.
Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.CombinationalEvaluation.
Require Import hvhdl.HVhdlTypes.
Require Import hvhdl.Stabilize.
Require Import hvhdl.Place.
Require Import hvhdl.HilecopDesignStore.
Require Import hvhdl.WellDefinedDesign.
Require Import hvhdl.proofs.CombinationalEvaluationFacts.
Require Import hvhdl.proofs.PCombinationalEvaluationFacts.

(** Value of signal [s_marking] in a given P component [id__p] is
    invariant during stabilization. *)

Lemma stab_inv_s_marking :
  forall Δ σ behavior σ',
    Stabilize hdstore Δ σ behavior σ' ->
    forall id__p gm ipm opm σ__p σ__p' v Δ__p compids mm,
      InCs (cs_comp id__p Petri.place_id gm ipm opm) behavior ->
      MapsTo id__p (Component Δ__p) Δ ->
      AreCsCompIds behavior compids ->
      List.NoDup compids ->
      MapsTo id__p σ__p (cstore σ) ->
      MapsTo s_marking v (sstore σ__p) ->
      MapsTo s_marking (Internal (Tnat 0 mm)) Δ__p ->
      MapsTo id__p σ__p' (cstore σ') ->
      MapsTo s_marking v (sstore σ__p').
Proof.
  induction 1; intros.

  (* CASE No events, [σ = σ'] *)
  - erewrite <- MapsTo_fun with (e := σ__p) (e' := σ__p'); eauto.

  (* CASE Events *)
  - edestruct @vcomb_maps_cstore_id with (Δ := Δ) as (σ__pi, MapsTo_σ__pi); eauto.
    eapply IHStabilize; eauto.
    eapply vcomb_inv_s_marking; eauto.
Qed.


(** Pullbacks defined in terms of limits *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.

Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require        UniMath.CategoryTheory.limits.pullbacks.

Local Open Scope cat.

Section def_pb.

Variable C : category.

Local Open Scope stn.
Definition One : three := ● 0.
Definition Two : three := ● 1.
Definition Three : three := ● 2.

Definition pullback_graph : graph.
Proof.
  exists three.
  use three_rec.
  - apply three_rec.
    + apply empty.
    + apply unit.
    + apply empty.
  - apply (λ _, empty).
  - apply three_rec.
    + apply empty.
    + apply unit.
    + apply empty.
Defined.

Definition pullback_diagram {a b c : C} (f : C ⟦b,a⟧) (g : C⟦c,a⟧) :
  diagram pullback_graph C.
Proof.
  exists (three_rec b a c).
  use three_rec_dep.
  - use three_rec_dep; simpl.
    + apply fromempty.
    + intro x; assumption.
    + apply fromempty.
  - intro x; apply fromempty.
  - use three_rec_dep; simpl.
    + apply fromempty.
    + intro x; assumption.
    + apply fromempty.
Defined.

Definition PullbCone {a b c : C} (f : C ⟦b,a⟧) (g : C⟦c,a⟧)
           (d : C) (f' : C ⟦d, b⟧) (g' : C ⟦d,c⟧)
           (H : f' · f = g'· g)
  : cone (pullback_diagram f g) d.
Proof.
  use make_cone.
  - use three_rec_dep; try assumption.
    apply (f' · f).
  - use three_rec_dep; use three_rec_dep.
    + exact (empty_rect _ ).
    + intro x; apply idpath.
    + exact (empty_rect _ ).
    + exact (empty_rect _ ).
    + exact (empty_rect _ ).
    + exact (empty_rect _ ).
    + exact (empty_rect _ ).
    + intro x; apply (!H).
    + exact (empty_rect _ ).
Defined.

Definition isPullback {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧)
           (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) : UU :=
    isLimCone (pullback_diagram f g) d (PullbCone f g d p1 p2 H).
(*
   ∏ e (h : e --> b) (k : e --> c)(H : h · f = k · g ),
      iscontr (total2 (fun hk : e --> d => dirprod (hk · p1 = h)(hk · p2 = k))).
 *)

Definition make_isPullback {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧)
           (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) :
  (∏ e (h : C ⟦e, b⟧) (k : C⟦e,c⟧)(Hk : h · f = k · g ),
      iscontr (total2 (fun hk : C⟦e,d⟧ => dirprod (hk · p1 = h)(hk · p2 = k))))
  →
  isPullback f g p1 p2 H.
Proof.
  intros H' x cx; simpl in *.
  set (H1 := H' x (coneOut cx One) (coneOut cx Three) ).
  use (let p : coneOut cx One · f = coneOut cx Three · g := _ in _ ).
  { eapply pathscomp0; [apply (coneOutCommutes cx One Two tt)|].
    apply pathsinv0, (coneOutCommutes cx Three Two tt). }
  set (H2 := H1 p).
  use tpair.
  + exists (pr1 (pr1 H2)).
    use three_rec_dep.
    * apply (pr1 (pr2 (pr1 H2))).
    * simpl.
      change (three_rec_dep (λ n, C⟦d,_⟧) _ _ _ _) with (p1 · f).
      rewrite assoc.
      eapply pathscomp0.
        eapply cancel_postcomposition, (pr2 (pr1 H2)).
      apply (coneOutCommutes cx One Two tt).
    * apply (pr2 (pr2 (pr1 H2))).
  + abstract (intro t; apply subtypePath;
              [ intro; apply impred; intro; apply C
              | destruct t as [t p0];
                apply path_to_ctr; split; [ apply (p0 One) | apply (p0 Three) ]]).
Defined.

(*
Lemma isaprop_isPullback {a b c d : C} (f : b --> a) (g : c --> a)
        (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) :
       isaprop (isPullback f g p1 p2 H).
Proof.
  repeat (apply impred; intro).
  apply isapropiscontr.
Qed.
*)

Definition Pullback {a b c : C} (f : C⟦b, a⟧)(g : C⟦c, a⟧) :=
     LimCone (pullback_diagram f g).

Definition make_Pullback {a b c : C} (f : C⟦b, a⟧)(g : C⟦c, a⟧)
    (d : C) (p1 : C⟦d,b⟧) (p2 : C ⟦d,c⟧)
    (H : p1 · f = p2 · g)
    (ispb : isPullback f g p1 p2 H)
  : Pullback f g.
Proof.
  use tpair.
  - use tpair.
    + apply d.
    + use PullbCone; assumption.
  - apply ispb.
Defined.

(*
Definition Pullback {a b c : C} (f : b --> a)(g : c --> a) :=
     total2 (fun pfg : total2 (λ p : C, (p --> b) × (p --> c)) =>
         total2 (fun H : pr1 (pr2 pfg) · f = pr2 (pr2 pfg) · g =>
        isPullback f g (pr1 (pr2 pfg)) (pr2 (pr2 pfg)) H)).
 *)

Definition Pullbacks := ∏ (a b c : C)(f : C⟦b, a⟧)(g : C⟦c, a⟧),
       Pullback f g.

Definition hasPullbacks := ∏ (a b c : C) (f : C⟦b, a⟧) (g : C⟦c, a⟧),
         ishinh (Pullback f g).

Definition PullbackObject {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}:
   Pullback f g -> C := λ H, lim H.
(* Coercion PullbackObject : Pullback >-> ob. *)

Definition PullbackPr1 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
   (Pb : Pullback f g) : C⟦lim Pb, b⟧ := limOut Pb One.

Definition PullbackPr2 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
   (Pb : Pullback f g) : C⟦lim Pb, c⟧ := limOut Pb Three.

Definition PullbackSqrCommutes {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
           (Pb : Pullback f g) :
  PullbackPr1 Pb · f = PullbackPr2 Pb · g .
Proof.
  eapply pathscomp0; [apply (limOutCommutes Pb One Two tt) |].
  apply (!limOutCommutes Pb Three Two tt) .
Qed.

Definition PullbackArrow {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
           (Pb : Pullback f g) e (h : C⟦e, b⟧) (k : C⟦e, c⟧)(H : h · f = k · g)
  : C⟦e, lim Pb⟧.
Proof.
  now use limArrow; use PullbCone.
Defined.

Lemma PullbackArrow_PullbackPr1 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
   (Pb : Pullback f g) e (h : C⟦e, b⟧) (k : C⟦e, c⟧)(H : h · f = k · g) :
   PullbackArrow Pb e h k H · PullbackPr1 Pb = h.
Proof.
  exact (limArrowCommutes Pb e _ One).
Qed.

Lemma PullbackArrow_PullbackPr2 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
   (Pb : Pullback f g) e (h : C⟦e, b⟧) (k : C⟦e, c⟧)(H : h · f = k · g) :
   PullbackArrow Pb e h k H · PullbackPr2 Pb = k.
Proof.
  exact (limArrowCommutes Pb e _ Three).
Qed.

Lemma PullbackArrowUnique {a b c d : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧)
     (Pb : Pullback f g)
     e (h : C⟦e, b⟧) (k : C⟦e, c⟧)
     (Hcomm : h · f = k · g)
     (w : C⟦e, PullbackObject Pb⟧)
     (H1 : w · PullbackPr1 Pb  = h) (H2 : w · PullbackPr2 Pb = k) :
  w = PullbackArrow Pb _ h k Hcomm.
Proof.
  apply path_to_ctr.
  use three_rec_dep; try assumption.
  set (X:= limOutCommutes Pb Three Two tt).
  eapply pathscomp0.
    eapply maponpaths, pathsinv0, X.
  simpl.
  rewrite assoc.
  eapply pathscomp0.
    apply cancel_postcomposition, H2.
  apply (!Hcomm).
Qed.

Definition isPullback_Pullback {a b c : C} {f : C⟦b, a⟧}{g : C⟦c, a⟧}
   (P : Pullback f g) :
  isPullback f g (PullbackPr1 P) (PullbackPr2 P) (PullbackSqrCommutes P).
Proof.
  apply make_isPullback.
  intros e h k HK.
  use tpair.
  - use tpair.
    + apply (PullbackArrow P _ h k HK).
    + split.
      * apply PullbackArrow_PullbackPr1.
      * apply PullbackArrow_PullbackPr2.
  - intro t.
    apply subtypePath.
    + intro. apply isapropdirprod; apply C.
    + destruct t as [t p]. simpl.
      use (PullbackArrowUnique _ _ P).
      * apply e.
      * apply (pr1 p).
      * apply (pr2 p).
Qed.

(** ** Maps between pullbacks as special limits and
       direct formulation of pullbacks
*)

Lemma equiv_isPullback_1 {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧)
      (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) :
  limits.pullbacks.isPullback (*f g p1 p2*) H -> isPullback f g p1 p2 H.
Proof.
  intro X.
  intros R cc.
  set (XR := limits.pullbacks.make_Pullback _ X).
  use tpair.
  - use tpair.
    + use (pullbacks.PullbackArrow XR).
      * apply (coneOut cc One).
      * apply (coneOut cc Three).
      * abstract (
        assert (XRT := coneOutCommutes cc Three Two tt); simpl in XRT;
        eapply pathscomp0; [| apply (!XRT)]; clear XRT;
        assert (XRT := coneOutCommutes cc One Two tt); simpl in XRT;
        eapply pathscomp0; [| apply (XRT)]; apply idpath
         ).
    + use three_rec_dep.
      * abstract (apply (pullbacks.PullbackArrow_PullbackPr1 XR)).
      * abstract (simpl;
        change (three_rec_dep (λ n, C⟦d,_⟧) _ _ _ _) with (p1 · f);
        rewrite assoc;
        rewrite  (limits.pullbacks.PullbackArrow_PullbackPr1 XR);
        assert (XRT := coneOutCommutes cc One Two tt); simpl in XRT;
        eapply pathscomp0; [| apply (XRT)]; apply idpath).
      * abstract (apply (limits.pullbacks.PullbackArrow_PullbackPr2 XR)).
  - abstract (
    intro t;
    apply subtypePath;
    [intro; apply impred; intro; apply C |];
    simpl; destruct t as [t HH];  simpl in *;
    apply limits.pullbacks.PullbackArrowUnique;
    [ apply (HH One) | apply (HH Three)] ).
Qed.

Definition equiv_Pullback_1 {a b c : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) :
  limits.pullbacks.Pullback f g -> Pullback f g.
Proof.
  intros X.
  exact (make_Pullback
           f g (limits.pullbacks.PullbackObject X)
           (limits.pullbacks.PullbackPr1 X)
           (limits.pullbacks.PullbackPr2 X)
           (limits.pullbacks.PullbackSqrCommutes X)
           (equiv_isPullback_1 _ _ _ _ _ (limits.pullbacks.isPullback_Pullback X))).
Defined.

Definition equiv_Pullbacks_1: @limits.pullbacks.Pullbacks C -> Pullbacks.
Proof.
  intros X' a b c f g.
  set (X := X' a b c f g).
  exact (make_Pullback
           f g (limits.pullbacks.PullbackObject X)
           (limits.pullbacks.PullbackPr1 X)
           (limits.pullbacks.PullbackPr2 X)
           (limits.pullbacks.PullbackSqrCommutes X)
           (equiv_isPullback_1 _ _ _ _ _ (limits.pullbacks.isPullback_Pullback X))).
Defined.

Lemma equiv_isPullback_2 {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧)
      (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) :
  limits.pullbacks.isPullback (*f g p1 p2*) H <- isPullback f g p1 p2 H.
Proof.
  intro X.
  set (XR := make_Pullback _ _ _ _ _  _ X).
  intros R k h HH.
  use tpair.
  - use tpair.
    use (PullbackArrow XR); try assumption.
    split.
    + apply (PullbackArrow_PullbackPr1 XR).
    + apply (PullbackArrow_PullbackPr2 XR).
  - abstract (
    intro t; apply subtypePath;
    [ intro; apply isapropdirprod; apply C |] ;
    induction t as [x Hx]; simpl in * ;
    use (PullbackArrowUnique _ _ XR);
    [apply R | apply (pr1 Hx) | apply (pr2 Hx) ]
    ).
Qed.

Definition equiv_Pullback_2 {a b c : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) :
  limits.pullbacks.Pullback f g <- Pullback f g.
Proof.
  intros X.
  exact (limits.pullbacks.make_Pullback
           (*f g
           (PullbackObject X)
           (PullbackPr1 X)
           (PullbackPr2 X)
            *)
           (PullbackSqrCommutes X)
           (equiv_isPullback_2 _ _ _ _ _ (isPullback_Pullback X))).
Defined.

Definition equiv_Pullbacks_2 : @limits.pullbacks.Pullbacks C <- Pullbacks.
Proof.
  intros X' a b c f g.
  set (X := X' a b c f g).
  exact (limits.pullbacks.make_Pullback
           (*f g
           (PullbackObject X)
           (PullbackPr1 X)
           (PullbackPr2 X)
            *)
           (PullbackSqrCommutes X)
           (equiv_isPullback_2 _ _ _ _ _ (isPullback_Pullback X))).
Defined.

Definition identity_is_Pullback_input {a b c : C}{f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) :
 total2 (fun hk : C⟦lim Pb, lim Pb⟧ =>
   dirprod (hk · PullbackPr1 Pb = PullbackPr1 Pb)(hk · PullbackPr2 Pb = PullbackPr2 Pb)).
Proof.
  exists (identity (lim Pb)).
  apply make_dirprod; apply id_left.
Defined.

(* was PullbackArrowUnique *)
Lemma PullbackArrowUnique' {a b c d : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧)
      (p1 : C⟦d, b⟧) (p2 : C⟦d, c⟧) (H : p1 · f = p2 · g) (P : isPullback f g p1 p2 H)
      (e : C) (h : C⟦e, b⟧) (k : C⟦e, c⟧) (Hcomm : h · f = k · g) (w : C⟦e, d⟧)
      (H1 : w · p1 = h) (H2 : w · p2 = k) :
  w =  (pr1 (pr1 (P e (PullbCone f g _ h k Hcomm)))).
Proof.
  apply path_to_ctr.
  use three_rec_dep; try assumption; simpl.
  change (three_rec_dep (λ n, C⟦d,_⟧) _ _ _ _) with (p1 · f).
  change (three_rec_dep (λ n, C⟦e,_⟧) _ _ _ _) with (h · f).
  now rewrite <- H1, assoc.
Qed.

Lemma PullbackEndo_is_identity {a b c : C}{f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g)
      (k : C⟦lim Pb, lim Pb⟧) (kH1 : k · PullbackPr1 Pb = PullbackPr1 Pb)
      (kH2 : k · PullbackPr2 Pb = PullbackPr2 Pb) : identity (lim Pb) = k.
Proof.
  apply lim_endo_is_identity.
  use three_rec_dep.
  - apply kH1.
  - unfold limOut. simpl.
    assert (T:= coneOutCommutes (limCone Pb) Three Two tt).
    eapply pathscomp0. apply maponpaths. apply (!T).
    rewrite assoc.
    eapply pathscomp0. apply cancel_postcomposition.
       apply kH2.
       apply T.
 - assumption.
Qed.

Definition from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
           (Pb Pb': Pullback f g) : C⟦lim Pb, lim Pb'⟧.
Proof.
  apply (PullbackArrow Pb' (lim Pb) (PullbackPr1 _ ) (PullbackPr2 _)).
  exact (PullbackSqrCommutes _ ).
Defined.

Lemma are_inverses_from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
      (Pb Pb': Pullback f g) :
  is_inverse_in_precat (from_Pullback_to_Pullback Pb Pb') (from_Pullback_to_Pullback Pb' Pb).
Proof.
  split; apply pathsinv0;
  apply PullbackEndo_is_identity;
  rewrite <- assoc;
  unfold from_Pullback_to_Pullback;
  repeat rewrite PullbackArrow_PullbackPr1;
  repeat rewrite PullbackArrow_PullbackPr2;
  auto.
Qed.

Lemma isiso_from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
      (Pb Pb': Pullback f g) : is_iso (from_Pullback_to_Pullback Pb Pb').
Proof.
  apply (is_iso_qinv _ (from_Pullback_to_Pullback Pb' Pb)).
  apply are_inverses_from_Pullback_to_Pullback.
Defined.

Definition iso_from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}
           (Pb Pb': Pullback f g) : iso (lim Pb) (lim Pb') :=
  tpair _ _ (isiso_from_Pullback_to_Pullback Pb Pb').

(** pullback lemma *)

Section pullback_lemma.

Variables a b c d e x : C.
Variables (f : C⟦b, a⟧) (g : C⟦c, a⟧) (h : C⟦e, b⟧) (k : C⟦e, c⟧)
          (i : C⟦d, b⟧) (j : C⟦x, e⟧) (m : C⟦x, d⟧).
Hypothesis H1 : h · f = k · g.
Hypothesis H2 : m · i = j · h.
Hypothesis P1 : isPullback _ _ _ _ H1.
Hypothesis P2 : isPullback _ _ _ _ H2.

Lemma glueSquares : m · (i · f) = (j · k) · g.
Proof.
  rewrite assoc.
  rewrite H2.
  repeat rewrite <- assoc.
  rewrite H1.
  apply idpath.
Qed.

(*
Lemma isPullbackGluedSquare : isPullback (i · f) g m (j · k) glueSquares.
Proof.
  apply make_isPullback.
  intros y p q.
  intro Hrt.
  assert (ex : (p· i)· f = q· g).
   { rewrite <- Hrt.
     rewrite assoc; apply idpath.
   }
  set (rt := P1 _ (p · i) q ex).
  set (Ppiq := pr1 (pr1 (rt))).
  assert (owiej : p · i = Ppiq · h).
   { apply pathsinv0. apply (pr1 (pr2 (pr1 rt))). }
  set (rt' := P2 _ p Ppiq owiej).
  set (awe := pr1 (pr1 rt')).
  assert (Hawe1 : awe · m = p).
   { exact (pr1 (pr2 (pr1 rt'))). }
  assert (Hawe2 : awe · (j · k) = q).
   { rewrite assoc.
     set (X := pr2 (pr2 (pr1 rt'))). simpl in X.
           unfold awe. rewrite X.
           exact (pr2 (pr2 (pr1 rt))).
   }
  exists (tpair _ awe (make_dirprod Hawe1 Hawe2)).
  intro t.
  apply subtypePath.
  - intro a0. apply isapropdirprod;
    apply hs.
  - simpl. destruct t as [t [Ht1 Ht2]].
    simpl in *.
    apply PullbackArrowUnique.
    + assumption.
    + apply PullbackArrowUnique.
      * rewrite <- Ht1.
        repeat rewrite <- assoc.
        rewrite H2.
        apply idpath.
      * rewrite <- assoc.
        assumption.
Qed.
 *)

End pullback_lemma.

Lemma inv_from_iso_iso_from_Pullback (a b c : C) (f : C⟦b, a⟧) (g : C⟦c, a⟧)
  (Pb : Pullback f g) (Pb' : Pullback f g):
    inv_from_iso (iso_from_Pullback_to_Pullback Pb Pb') = from_Pullback_to_Pullback Pb' Pb.
Proof.
  apply pathsinv0.
  apply inv_iso_unique'.
  set (T:= are_inverses_from_Pullback_to_Pullback Pb Pb').
  apply (pr1 T).
Qed.

(*
Lemma isaprop_Pullbacks: isaprop Pullbacks.
Proof.
  apply impred; intro a;
  apply impred; intro b;
  apply impred; intro c;
  apply impred; intro f;
  apply impred; intro g;
  apply invproofirrelevance.
  intros Pb Pb'.
  apply subtypePath.
  - intro; apply isofhleveltotal2.
    + apply hs.
    + intros; apply isaprop_isPullback.
  - apply (total2_paths_f  (isotoid _ H (iso_from_Pullback_to_Pullback Pb Pb' ))).
    rewrite transportf_dirprod, transportf_isotoid.
    rewrite inv_from_iso_iso_from_Pullback.
    rewrite transportf_isotoid.
    rewrite inv_from_iso_iso_from_Pullback.
    destruct Pb as [Cone bla];
    destruct Pb' as [Cone' bla'];
    simpl in *.
    destruct Cone as [p [h k]];
    destruct Cone' as [p' [h' k']];
    simpl in *.
    unfold from_Pullback_to_Pullback;
    rewrite PullbackArrow_PullbackPr2, PullbackArrow_PullbackPr1.
    apply idpath.
Qed.
 *)

End def_pb.

Lemma Pullbacks_from_Lims (C : category) :
  Lims C -> Pullbacks C.
Proof.
  intros H a b c f g; apply H.
Defined.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import SeqProp.
Require Import PartSum.
Require Import Max.
Local Open Scope R_scope.

Definition tg_alt (Un:nat -> R) (i:nat) : R := (-1) ^ i * Un i.
Definition positivity_seq (Un:nat -> R) : Prop := forall n:nat, 0 <= Un n.

Lemma CV_ALT_step0 :
forall Un:nat -> R,
Un_decreasing Un ->
Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof. hammer_hook "AltSeries" "AltSeries.CV_ALT_step0".
intros; unfold Un_growing; intro.
cut ((2 * S n)%nat = S (S (2 * n))).
intro; rewrite H0.
do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
pattern (tg_alt Un (S (2 * n))) at 1; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
rewrite Rmult_1_l.
apply Rplus_le_reg_l with (Un (S (2 * S n))).
rewrite Rplus_0_r;
replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -1 * Un (S (2 * S n)))) with
(Un (2 * S n)%nat); [ idtac | ring ].
apply H.
cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

Lemma CV_ALT_step1 :
forall Un:nat -> R,
Un_decreasing Un ->
Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
Proof. hammer_hook "AltSeries" "AltSeries.CV_ALT_step1".
intros; unfold Un_decreasing; intro.
cut ((2 * S n)%nat = S (S (2 * n))).
intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
rewrite Rmult_1_l.
apply Rplus_le_reg_l with (Un (S (2 * n))).
rewrite Rplus_0_r;
replace (Un (S (2 * n)) + (-1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with
(Un (2 * S n)%nat); [ idtac | ring ].
rewrite H0; apply H.
cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

Lemma CV_ALT_step2 :
forall (Un:nat -> R) (N:nat),
Un_decreasing Un ->
positivity_seq Un ->
sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0.
Proof. hammer_hook "AltSeries" "AltSeries.CV_ALT_step2".
intros; induction  N as [| N HrecN].
simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ].
apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat);
[ apply H | ring ].
cut (S (2 * S N) = S (S (S (2 * N)))).
intro; rewrite H1; do 2 rewrite tech5.
apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2;
rewrite <- Rplus_0_r.
rewrite Rplus_assoc; apply Rplus_le_compat_l.
unfold tg_alt; rewrite <- H1.
rewrite pow_1_odd.
cut (S (S (2 * S N)) = (2 * S (S N))%nat).
intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
apply Rplus_le_reg_l with (Un (S (2 * S N))).
rewrite Rplus_0_r;
replace (Un (S (2 * S N)) + (-1 * Un (S (2 * S N)) + Un (S (S (2 * S N)))))
with (Un (S (S (2 * S N)))); [ idtac | ring ].
apply H.
ring.
apply HrecN.
ring.
Qed.

Lemma CV_ALT_step3 :
forall (Un:nat -> R) (N:nat),
Un_decreasing Un ->
positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0.
Proof. hammer_hook "AltSeries" "AltSeries.CV_ALT_step3".
intros; induction  N as [| N HrecN].
simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
apply Rplus_le_reg_l with (Un 1%nat).
rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0;
[ apply H0 | ring ].
assert (H1 := even_odd_cor N).
elim H1; intros.
elim H2; intro.
rewrite H3; apply CV_ALT_step2; assumption.
rewrite H3; rewrite tech5.
apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2;
rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
unfold tg_alt; simpl.
replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
rewrite pow_1_even.
replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with
(- Un (S (S (S (2 * x))))); [ idtac | ring ].
apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))).
rewrite Rplus_0_r; rewrite Rplus_opp_r.
apply H0.
apply CV_ALT_step2; assumption.
Qed.

Lemma CV_ALT_step4 :
forall Un:nat -> R,
Un_decreasing Un ->
positivity_seq Un ->
has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof. hammer_hook "AltSeries" "AltSeries.CV_ALT_step4".
intros; unfold has_ub; unfold bound.
exists (Un 0%nat).
unfold is_upper_bound; intros; elim H1; intros.
rewrite H2; rewrite decomp_sum.
replace (tg_alt Un 0) with (Un 0%nat).
pattern (Un 0%nat) at 2; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
apply CV_ALT_step3; assumption.
unfold tg_alt; simpl; ring.
apply lt_O_Sn.
Qed.

Lemma CV_ALT :
forall Un:nat -> R,
Un_decreasing Un ->
positivity_seq Un ->
Un_cv Un 0 ->
{ l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof. hammer_hook "AltSeries" "AltSeries.CV_ALT".
intros.
assert (H2 := CV_ALT_step0 _ H).
assert (H3 := CV_ALT_step4 _ H H0).
destruct (growing_cv _ H2 H3) as (x,p).
exists x.
unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
intros; cut (0 < eps / 2);
[ intro
| unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
elim (H1 (eps / 2) H5); intros N2 H6.
elim (p (eps / 2) H5); intros N1 H7.
set (N := max (S (2 * N1)) N2).
exists N; intros.
assert (H9 := even_odd_cor n).
elim H9; intros P H10.
cut (N1 <= P)%nat.
intro; elim H10; intro.
replace (sum_f_R0 (tg_alt Un) n - x) with
(sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)).
apply Rle_lt_trans with
(Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))).
apply Rabs_triang.
rewrite (double_var eps); apply Rplus_lt_compat.
rewrite H12; apply H7; assumption.
rewrite Rabs_Ropp; unfold tg_alt; rewrite Rabs_mult;
rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n)));
apply H6.
unfold ge; apply le_trans with n.
apply le_trans with N; [ unfold N; apply le_max_r | assumption ].
apply le_n_Sn.
rewrite tech5; ring.
rewrite H12; apply Rlt_trans with (eps / 2).
apply H7; assumption.
unfold Rdiv; apply Rmult_lt_reg_l with 2.
prove_sup0.
rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
[ rewrite Rmult_1_r | discrR ].
rewrite double.
pattern eps at 1; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
assumption.
elim H10; intro; apply le_double.
rewrite <- H11; apply le_trans with N.
unfold N; apply le_trans with (S (2 * N1));
[ apply le_n_Sn | apply le_max_l ].
assumption.
apply lt_n_Sm_le.
rewrite <- H11.
apply lt_le_trans with N.
unfold N; apply lt_le_trans with (S (2 * N1)).
apply lt_n_Sn.
apply le_max_l.
assumption.
Qed.

Theorem alternated_series :
forall Un:nat -> R,
Un_decreasing Un ->
Un_cv Un 0 ->
{ l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof. hammer_hook "AltSeries" "AltSeries.alternated_series".
intros; apply CV_ALT.
assumption.
unfold positivity_seq; apply decreasing_ineq; assumption.
assumption.
Qed.

Theorem alternated_series_ineq :
forall (Un:nat -> R) (l:R) (N:nat),
Un_decreasing Un ->
Un_cv Un 0 ->
Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l ->
sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N).
Proof. hammer_hook "AltSeries" "AltSeries.alternated_series_ineq".
intros.
cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l).
cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l).
intros; split.
apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))).
apply CV_ALT_step0; assumption.
assumption.
apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
apply CV_ALT_step1; assumption.
assumption.
unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
unfold R_dist in H1; intros.
elim (H1 eps H2); intros.
exists x; intros.
apply H3.
unfold ge; apply le_trans with (2 * n)%nat.
apply le_trans with n.
assumption.
assert (H5 := mult_O_le n 2).
elim H5; intro.
cut (0%nat <> 2%nat);
[ intro; elim H7; symmetry ; assumption | discriminate ].
assumption.
apply le_n_Sn.
unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
unfold R_dist in H1; intros.
elim (H1 eps H2); intros.
exists x; intros.
apply H3.
unfold ge; apply le_trans with n.
assumption.
assert (H5 := mult_O_le n 2).
elim H5; intro.
cut (0%nat <> 2%nat);
[ intro; elim H7; symmetry ; assumption | discriminate ].
assumption.
Qed.

Definition PI_tg (n:nat) := / INR (2 * n + 1).

Lemma PI_tg_pos : forall n:nat, 0 <= PI_tg n.
Proof. hammer_hook "AltSeries" "AltSeries.PI_tg_pos".
intro; unfold PI_tg; left; apply Rinv_0_lt_compat; apply lt_INR_0;
replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
Qed.

Lemma PI_tg_decreasing : Un_decreasing PI_tg.
Proof. hammer_hook "AltSeries" "AltSeries.PI_tg_decreasing".
unfold PI_tg, Un_decreasing; intro.
apply Rmult_le_reg_l with (INR (2 * n + 1)).
apply lt_INR_0.
replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
rewrite <- Rinv_r_sym.
apply Rmult_le_reg_l with (INR (2 * S n + 1)).
apply lt_INR_0.
replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply lt_O_Sn | ring ].
rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc;
rewrite <- Rinv_l_sym.
do 2 rewrite Rmult_1_r; apply le_INR.
replace (2 * S n + 1)%nat with (S (S (2 * n + 1))).
apply le_trans with (S (2 * n + 1)); apply le_n_Sn.
ring.
apply not_O_INR; discriminate.
apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
[ discriminate | ring ].
Qed.

Lemma PI_tg_cv : Un_cv PI_tg 0.
Proof. hammer_hook "AltSeries" "AltSeries.PI_tg_cv".
unfold Un_cv; unfold R_dist; intros.
cut (0 < 2 * eps);
[ intro | apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ].
assert (H1 := archimed (/ (2 * eps))).
cut (0 <= up (/ (2 * eps)))%Z.
intro; assert (H3 := IZN (up (/ (2 * eps))) H2).
elim H3; intros N H4.
cut (0 < N)%nat.
intro; exists N; intros.
cut (0 < n)%nat.
intro; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
rewrite Rabs_right.
unfold PI_tg; apply Rlt_trans with (/ INR (2 * n)).
apply Rmult_lt_reg_l with (INR (2 * n)).
apply lt_INR_0.
replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
apply lt_le_trans with n.
assumption.
apply le_plus_l.
rewrite <- Rinv_r_sym.
apply Rmult_lt_reg_l with (INR (2 * n + 1)).
apply lt_INR_0.
replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
rewrite (Rmult_comm (INR (2 * n + 1))).
rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
do 2 rewrite Rmult_1_r; apply lt_INR.
replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_n_Sn | ring ].
apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
[ discriminate | ring ].
replace n with (S (pred n)).
apply not_O_INR; discriminate.
symmetry ; apply S_pred with 0%nat.
assumption.
apply Rle_lt_trans with (/ INR (2 * N)).
apply Rinv_le_contravar.
rewrite mult_INR; apply Rmult_lt_0_compat;
[ simpl; prove_sup0 | apply lt_INR_0; assumption ].
apply le_INR.
now apply mult_le_compat_l.
rewrite mult_INR.
apply Rmult_lt_reg_l with (INR N / eps).
apply Rdiv_lt_0_compat with (2 := H).
now apply (lt_INR 0).
replace (_ */ _) with (/(2 * eps)).
replace (_ / _ * _) with (INR N).
rewrite INR_IZR_INZ.
now rewrite <- H4.
field.
now apply Rgt_not_eq.
simpl (INR 2); field; split.
now apply Rgt_not_eq, (lt_INR 0).
now apply Rgt_not_eq.
apply Rle_ge; apply PI_tg_pos.
apply lt_le_trans with N; assumption.
elim H1; intros H5 _.
destruct (lt_eq_lt_dec 0 N) as [[| <- ]|H6].
assumption.
rewrite H4 in H5.
simpl in H5.
cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
elim (Rlt_irrefl _ (Rlt_trans _ _ _ H6 H5)).
elim (lt_n_O _ H6).
apply le_IZR.
left; apply Rlt_trans with (/ (2 * eps)).
apply Rinv_0_lt_compat; assumption.
elim H1; intros; assumption.
Qed.

Lemma exist_PI :
{ l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l }.
Proof. hammer_hook "AltSeries" "AltSeries.exist_PI".
apply alternated_series.
apply PI_tg_decreasing.
apply PI_tg_cv.
Qed.

Definition Alt_PI : R := 4 * (let (a,_) := exist_PI in a).

Lemma Alt_PI_ineq :
forall N:nat,
sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= Alt_PI / 4 <=
sum_f_R0 (tg_alt PI_tg) (2 * N).
Proof. hammer_hook "AltSeries" "AltSeries.Alt_PI_ineq".
intro; apply alternated_series_ineq.
apply PI_tg_decreasing.
apply PI_tg_cv.
unfold Alt_PI; case exist_PI; intro.
replace (4 * x / 4) with x.
trivial.
unfold Rdiv; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
Qed.

Lemma Alt_PI_RGT_0 : 0 < Alt_PI.
Proof. hammer_hook "AltSeries" "AltSeries.Alt_PI_RGT_0".
assert (H := Alt_PI_ineq 0).
apply Rmult_lt_reg_l with (/ 4).
apply Rinv_0_lt_compat; prove_sup0.
rewrite Rmult_0_r; rewrite Rmult_comm.
elim H; clear H; intros H _.
unfold Rdiv in H;
apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
simpl; unfold tg_alt; simpl; rewrite Rmult_1_l;
rewrite Rmult_1_r; apply Rplus_lt_reg_l with (PI_tg 1).
rewrite Rplus_0_r;
replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
[ unfold PI_tg | ring ].
simpl; apply Rinv_lt_contravar.
rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ].
rewrite Rplus_comm; pattern 1 at 1; rewrite <- Rplus_0_r;
apply Rplus_lt_compat_l; prove_sup0.
assumption.
Qed.


Require Import ExtLib.Data.HList.
Require Import ExtLib.Core.RelDec.

Require Import Charge.Logics.ILogic.
Require Import Charge.ModularFunc.ListType.
Require Import Charge.ModularFunc.BaseType.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.SemiEqDecTyp.
Require Import Charge.Tactics.Base.DenotationTacs.
Require Import Charge.Tactics.Base.MirrorCoreTacs.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.Lambda.Expr.

Section NoDup.
  Context {typ func : Type} {RType_typ : RType typ} {RSym_func : RSym func}
          {BT : BaseType typ} {BTD : BaseTypeD BT}
          {LT : ListType typ} {LTD: ListTypeD LT}.
  Context {BF : BaseFunc typ func} {LF : ListFunc typ func}.
  Context {RelDec_eq : RelDec (@eq typ)} {RelDecOk_eq : RelDec_Correct RelDec_eq}.
  Context {Heqd : SemiEqDecTyp typ} {HeqdOk : SemiEqDecTypOk Heqd}.

   Context {EU : ExprUVar (expr typ func)}.

  Context {RType_typOk : RTypeOk} {RsymOk_func : RSymOk RSym_func}.

  Context {Typ0_tyProp : Typ0 _ Prop}.
  Context {Typ2_tyArr : Typ2 _ Fun}.

  Context {Typ0Ok_tyProp : Typ0Ok Typ0_tyProp}.
  Context {Typ2Ok_tyArr : Typ2Ok Typ2_tyArr}.

  Context {BFOk : BaseFuncOk typ func } {LFOk : ListFuncOk typ func}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyProp := @typ0 typ RType_typ Prop Typ0_tyProp.

  Fixpoint in_dec {t : typ} (e : typD t) (xs : list (typD t)) : option bool :=
    match xs with
      | nil => Some false
      | x :: xs =>
        match semi_eq_dec_typ e x with
          | Some true => Some true
          | Some false => in_dec e xs
          | None => None
        end
    end.

  Lemma in_dec_true {t : typ} (e : typD t) (lst : list (typD t)) (H : in_dec e lst = Some true) : In e lst.
  Proof.
    induction lst.
    + simpl in H; congruence.
    + simpl in H. destruct_match_oneres.
      destruct b.
      * apply semi_eq_dec_typ_eq in Heqo. subst.
        left; reflexivity.
      * apply semi_eq_dec_typ_neq in Heqo.
        right; apply IHlst; apply H.
  Qed.

  Lemma in_dec_false {t : typ} (e : typD t) (lst : list (typD t)) (H : in_dec e lst = Some false) (HIn : In e lst) : False.
  Proof.
    induction lst.
    + destruct HIn.
    + destruct HIn as [Heq | HIn]; subst.
      * simpl in H.
        remember (semi_eq_dec_typ e e).
        destruct o; [|inversion H].
        symmetry in Heqo.
        apply semi_eq_dec_typ_refl in Heqo; subst. inversion H.
      * simpl in H. destruct (semi_eq_dec_typ e a); subst; [|inversion H].
        destruct b; [inversion H|].
        apply IHlst; assumption.
  Qed.

  Fixpoint no_dup {t : typ} (xs : list (typD t)) : option bool :=
    match xs with
      | nil => Some true
      | x :: xs =>
        match in_dec x xs with
          | Some true => Some false
          | Some false => no_dup xs
          | None => None
        end
    end.

  Lemma no_dup_sound (t : typ) (xs : list (typD t)) (H : no_dup xs = Some true) : NoDup xs.
  Proof.
    induction xs.
    + constructor.
    + simpl in H.
      do 2 destruct_match_oneres.
      constructor; [|apply IHxs; assumption]; subst.
      intros HIn.
      eapply in_dec_false; eassumption.
  Qed.

  Definition NODUP : rtac typ (expr typ func) :=
    fun tus tvs nus nvs ctx s e =>
    match e with
	  | App f lst =>
	    match listS f, baseS lst with
	      | Some (pNoDup t), Some (pConst u lst') =>
		    match type_cast u (tyList t) with
		  	  | Some pf =>
	            match no_dup (listD (eq_rect _ typD lst' _ pf)) with
	              | Some true => Solved s
	              | _ => Fail
		        end
		      | None => Fail
		    end
	      | _, _ => Fail
	    end
	  | _ => Fail
    end.

  Existing Instance Expr_expr.
  Existing Instance ExprOk_expr.

  Lemma propD_to_exprD tus tvs e eD (H : propD tus tvs e = Some eD) :
    exists eD', exprD' tus tvs tyProp e = Some eD' /\ eD = fun us vs => PropD (eD' us vs).
  Proof.
    unfold propD, exprD'_typ0 in H.
    destruct_match_oneres; inv_all; subst.
    exists e0; split; [apply Heqo|].
    unfold PropD, eq_rect; simpl.
    pose proof typ0_match_zeta.
    specialize (H typ _ Prop _  _ (exprT tus tvs) (fun us vs => PropD (e0 us vs)) e0).
    unfold exprT, OpenT.
    generalize (typ0_cast (F := Prop)). intros.
    destruct e1. reflexivity.
  Qed.

  Lemma NODUP_sound : rtac_sound NODUP.
  Proof.
    unfold rtac_sound; intros; subst.
    destruct g; simpl; try apply I.
    do 7 (destruct_exprs; try apply I).
    intros.
    split; [assumption|].
    repeat destruct_match_oneres.
    split; [reflexivity|]; intros; subst.
    eapply Pure_pctxD; [eassumption|]; intros.
    apply propD_to_exprD in Heqo4.
    destruct Heqo4 as [? [? ?]]; subst.
    simpl in *.
    reduce.
    unfold PropD, NoDupD, PropR. reduce.
    apply no_dup_sound. assumption.
  Qed.

End NoDup.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive matrix
  (a:Type) :=
  | mk_matrix : Z -> Z -> (map.Map.map Z (map.Map.map Z a)) -> matrix a.
Axiom matrix_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (matrix a).
Existing Instance matrix_WhyType.
Implicit Arguments mk_matrix [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(matrix a)): (map.Map.map Z
  (map.Map.map Z a)) := match v with
  | (mk_matrix x x1 x2) => x2
  end.

(* Why3 assumption *)
Definition columns {a:Type} {a_WT:WhyType a} (v:(matrix a)): Z :=
  match v with
  | (mk_matrix x x1 x2) => x1
  end.

(* Why3 assumption *)
Definition rows {a:Type} {a_WT:WhyType a} (v:(matrix a)): Z :=
  match v with
  | (mk_matrix x x1 x2) => x
  end.

(* Why3 assumption *)
Definition index := (Z* Z)%type.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(matrix a)) (i:(Z*
  Z)%type): a :=
  match i with
  | (r, c) => (map.Map.get (map.Map.get (elts a1) r) c)
  end.

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(matrix a)) (i:(Z* Z)%type)
  (v:a): (matrix a) :=
  match i with
  | (r, c) => (mk_matrix (rows a1) (columns a1) (map.Map.set (elts a1) r
      (map.Map.set (map.Map.get (elts a1) r) c v)))
  end.

(* Why3 assumption *)
Definition valid_index {a:Type} {a_WT:WhyType a} (a1:(matrix a)) (i:(Z*
  Z)%type): Prop :=
  match i with
  | (r, c) => ((0%Z <= r)%Z /\ (r < (rows a1))%Z) /\ ((0%Z <= c)%Z /\
      (c < (columns a1))%Z)
  end.

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (r:Z) (c:Z) (v:a): (matrix a) :=
  (mk_matrix r c (map.Map.const (map.Map.const v: (map.Map.map Z
  a)): (map.Map.map Z (map.Map.map Z a)))).

(* Why3 assumption *)
Inductive path: (matrix bool) -> Z -> Z -> Z -> Prop :=
  | Path_empty : forall (m:(matrix bool)) (i:Z) (j:Z) (k:Z), ((get m (i,
      j)) = true) -> (path m i j k)
  | Path_cons : forall (m:(matrix bool)) (i:Z) (x:Z) (j:Z) (k:Z),
      ((0%Z <= x)%Z /\ (x < k)%Z) -> ((path m i x k) -> ((path m x j k) ->
      (path m i j k))).

Axiom weakening : forall (m:(matrix bool)) (i:Z) (j:Z) (k1:Z) (k2:Z),
  ((0%Z <= k1)%Z /\ (k1 <= k2)%Z) -> ((path m i j k1) -> (path m i j k2)).

Hint Constructors path.

(* Why3 goal *)
Theorem decomposition : forall (m:(matrix bool)) (k:Z), (0%Z <= k)%Z ->
  forall (i:Z) (j:Z), (path m i j (k + 1%Z)%Z) -> ((path m i j k) \/ ((path m
  i k k) /\ (path m k j k))).
(* Why3 intros m k h1 i j h2. *)
intros m k hk i j h.
remember (k+1)%Z as t in h.
induction h.
left; apply Path_empty; auto.
subst k0; intuition.
assert (case: (x=k \/ x < k)%Z) by omega. destruct case.
subst; eauto.
left; eauto.
assert (case: (x=k \/ x < k)%Z) by omega. destruct case.
subst x.
right; eauto.
right; eauto.
assert (case: (x=k \/ x < k)%Z) by omega. destruct case.
subst; eauto.
right; eauto.
Qed.