From discprob.basic Require Import base order nify seq_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.finite Require Import monad monad_cost_hoare monad_cost quicksort quicksort_correct.
From discprob.monad.finite Require Import max_triangle.
From discprob.rec Require Import rec_convert quicksort_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From mathcomp Require Import path.
Require Import Reals Fourier Psatz Omega.

Definition h (l: seq nat) :=
  match l with
  | [::] => mret ([::], [::])
  | [::a] => mret ([::], [::])
  | a :: l =>
      p ← draw_pivot a l;
      spl ← dist_ret _ (partition' (sval p) (a :: l));
      mret (lower (sval spl), upper (sval spl))
  end.
Definition rsize (l: seq nat) := INR (size l).

Definition m x :=
  match (Rlt_dec x (4/3)) with
  | left _ => 0
  | _ => x * (3/4)
  end.

Lemma uniq_unif n:
  uniq (outcomes (unif n)).
Proof.
  rewrite /unif//=.
  rewrite map_inj_uniq.
  - apply enum_uniq.
  - intros (?&?) (?&?). inversion 1; auto.
    subst; f_equal. apply bool_irrelevance.
Qed.

Lemma uniq_unif2 n:
  uniq ([seq i.2 | i <- outcomes (unif n)]).
Proof.
  rewrite /unif//=.
  rewrite map_inj_in_uniq.
  - apply uniq_unif.
  - intros (?&?) (?&?).
    move /mapP => [? ? Heq1]. inversion Heq1; subst.
    move /mapP => [? ? Heq2]. inversion Heq2; subst.
    rewrite //=. inversion 1. repeat f_equal.
    apply val_inj => //=.
Qed.

Lemma unif_all n x (Hle: (x <= n)%nat):
  (O, exist _ x Hle) \in [seq i.2 | i <- outcomes (unif n)].
Proof.
  apply /mapP.
  set (a := exist _ x Hle).
  replace (O, a) with (1/INR (S n), (O, a)).2; last done.
  do 2 apply /mapP; eexists; eauto.
  rewrite /unif => //=.
  apply /mapP => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  exists (Ordinal Hlt).
  - apply mem_enum.
  - rewrite /a; repeat f_equal. apply bool_irrelevance.
Qed.

Lemma unif_all2 n x (Hle: (x <= n)%nat):
  exist _ x Hle \in [seq i.2.2 | i <- outcomes (unif n)].
Proof.
  apply /mapP.
  set (a := exist _ x Hle).
  replace (a) with (1/INR (S n), (O, a)).2.2; last done.
  do 2 apply /mapP; eexists; eauto.
  rewrite /unif => //=.
  apply /mapP => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  exists (Ordinal Hlt).
  - apply mem_enum.
  - rewrite /a; repeat f_equal. apply bool_irrelevance.
Qed.

Lemma unif_cost n a c :
  (c, a) \in [seq i.2 | i <- outcomes (unif n)] →
  c = O.
Proof.
  replace (c, a) with (1/INR (S n), (c, a)).2; last done.
  move /mapP => [[r' [c' a']] Hin].
  move: Hin. rewrite /unif//=.
  move /mapP => [[c'' a''] Hin] [] => ??? []. subst. done.
Qed.

Lemma unif_cost2 n:
  [seq (O, (i.2.2)) | i <- unif n] = [seq i.2 | i <- unif n].
Proof.
  apply eq_in_map.
  intros (r, (c, a)) Hin.
  rewrite //=. f_equal; symmetry.
  eapply (unif_cost n a).
  apply /mapP; eauto.
Qed.

Lemma unif_cost3 n:
  [seq (O, i) | i <- [seq i.2.2 | i <- unif n]] = [seq i.2 | i <- unif n].
Proof.
  rewrite -map_comp -unif_cost2 => //=.
Qed.

Lemma unif_pr n a :
  a \in [seq i.2 | i <- outcomes (unif n)] →
  pr_eq (rvar_of_ldist (unif n)) a = 1 / INR (S n).
Proof.
  intros Hin. rewrite pr_rvar_ldist /unif//=.
  rewrite big_map -big_filter //=.
  destruct a as (c&(x&Hle)) => //=.
  assert (c = O); last subst.
  { eapply unif_cost. apply Hin. }
  assert (Hlt: (x < S n)%nat) by auto.
  rewrite (bigD1_seq (Ordinal Hlt)) => //=.
  - rewrite -[a in _ = a]Rplus_0_r; f_equal.
    rewrite -big_filter -filter_predI big_filter. apply big_pred0.
    intros i => //=. apply negbTE. apply /andP => [] []. move /eqP => Heq.
    move /eqP => []. intros. subst. apply Heq.
    destruct i. f_equal. apply bool_irrelevance.
  - rewrite mem_filter. apply /andP; split; auto.
    * apply /eqP; f_equal; auto. f_equal. apply bool_irrelevance.
    * apply mem_enum.
  - apply /filter_uniq/enum_uniq.
Qed.

Lemma partition_split l pv:
  let x := partition' pv l in
  lower (sval x.2) = [ seq n <- l | ltn n pv] ∧
  middle (sval x.2) = [ seq n <- l | n == pv] ∧
  upper (sval x.2) = [ seq n <- l | ltn pv n].
Proof.
      induction l as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
Qed.

Lemma sorted_nth_trans {A: eqType} (R: rel A) s (Ht: transitive R)
      (Hsorted : sorted R s) x0 a b:
  (a < b < size s)%nat ->
  R (nth x0 s a) (nth x0 s b).
Proof.
  move /andP => [Hab Hbs]. revert s Ht Hsorted Hbs. nify.
  induction Hab => s Ht Hsorted Hbs.
  - induction s.
    * rewrite //= in Hbs.
    * move /pathP in Hsorted => //=. apply Hsorted. rewrite //= in Hbs.
  - induction s.
    * rewrite //= in Hbs.
    * rewrite //=. eapply Ht; last apply IHHab; eauto.
      move /pathP in Hsorted => //=. apply Hsorted.
      ** nify. rewrite //= in Hbs. omega.
      ** rewrite //= in Hsorted. destruct s => //=.
         move /andP in Hsorted. destruct Hsorted as (?&?); eauto.
Qed.

Lemma sorted_nth_trans_refl {A : eqType} T (s: seq A) (Hr: reflexive T) (Ht: transitive T)
      (Hsorted : sorted T s) x0 a b:
  (a <= b < size s)%nat -> T (nth x0 s a) (nth x0 s b).
Proof.
  move /andP => [Hab Hbs].
  rewrite leq_eqVlt in Hab. move /orP in Hab. destruct Hab as [Heq|Hab].
  - move /eqP in Heq; subst; apply Hr.
  - apply sorted_nth_trans; auto. apply /andP; split => //.
Qed.

Lemma eq_filter_in (T: eqType) (a1 a2: T → bool) (l: seq T):
  (∀ i, i \in l → a1 i = a2 i) →
  filter a1 l = filter a2 l.
Proof.
  induction l => //=.
  intros Hin. rewrite Hin; last first.
  - rewrite in_cons eq_refl //.
  - rewrite IHl => //.
    intros i Hin'; apply Hin. by rewrite in_cons Hin' orbT.
Qed.

Lemma lower_split_sorted l1 l2 x:
  sorted leq (l1 ++ x :: l2) →
  ∃ lmid, ([seq n <- l1 ++ x :: l2 | n < x] ++ lmid = l1)%nat.
Proof.
  revert l2 x. induction l1 => l2 x Hsorted.
  - exists [::].
    rewrite cat0s cats0.
    etransitivity; first eapply eq_filter_in; last apply filter_pred0.
    intros i Hin => //=.
    rewrite //= in Hsorted.
    replace x with (nth O (x :: l2) 0) => //.
    rewrite -(nth_index O Hin). apply negbTE. rewrite -leqNgt.
    apply sorted_nth_trans_refl; auto.
    * by intros => ?.
    * rewrite /= => ?????. eapply leq_trans; eauto.
    * apply /andP; split; auto.  rewrite index_mem. done.
  - rewrite /=. case: ifP.
    * intros. edestruct IHl1 as (lmid&Heq).
      { eapply path_sorted. rewrite //= in Hsorted. eauto. }
      exists lmid => /=. f_equal; done.
    * move /negbT. rewrite -leqNgt => Hle. exists (a :: l1).
      rewrite -[a in _ = a]cat0s; f_equal => //.
      etransitivity; first eapply eq_filter_in; last apply filter_pred0.
      intros i Hin => //=.
      rewrite //= in Hsorted.
      apply negbTE. rewrite -leqNgt. apply (leq_trans Hle).
      replace a with (nth O (a :: l1 ++ x :: l2) 0) => //.
      assert (Hin': i \in a :: (l1 ++ x :: l2)).
      { rewrite in_cons Hin orbT //. }
      rewrite -(nth_index O Hin').
      apply sorted_nth_trans_refl; auto.
      ** by intros => ?.
      ** rewrite /= => ?????. eapply leq_trans; eauto.
      ** apply /andP; split; auto.  rewrite index_mem. done.
Qed.

Lemma lower_split_size_sorted l1 l2 x:
  sorted leq (l1 ++ x :: l2) →
  (size [seq n <- l1 ++ x :: l2 | n < x] <= size l1)%nat.
Proof.
  intros (lmid&Heq)%lower_split_sorted.
  rewrite -[a in (_ <= size a)%nat]Heq.
  rewrite size_cat. rewrite -plusE. apply /leP. destruct size; omega.
Qed.

Lemma lower_split_size_sorted_nth  l x a:
  sorted leq l →
  (x < size l →
  size [seq n <- l | n < nth a l x] <= x)%nat.
Proof.
  rewrite nth_legacy => Hsort Hlt.
  edestruct (@nth_split _ x l a) as (l1&l2&Heq&Hlen).
  { rewrite -size_legacy. apply /ltP. auto. }
  rewrite {2}Heq.
  rewrite -{3}Hlen. apply lower_split_size_sorted. rewrite Heq in Hsort => //.
Qed.

Lemma sorted_cat_inv {A: eqType} (R: rel A) (HTrans: transitive R) (l1 l2: seq A):
  sorted R (l1 ++ l2) → sorted R l1 ∧ sorted R l2.
Proof.
  intros HS; split; eapply subseq_sorted; try apply HS; auto.
  - rewrite -[a in subseq a _]cats0.
    apply cat_subseq; eauto using sub0seq.
  - rewrite -[a in subseq a _]cat0s.
    apply cat_subseq; eauto using sub0seq.
Qed.

Lemma upper_split_sorted l1 l2 x:
  sorted leq (l1 ++ x :: l2) →
  (∃ lmid, lmid ++ [seq n <- l1 ++ x :: l2 | x < n] = l2)%nat.
Proof.
  revert l1 x. induction l2 as [| a l2] using rev_ind => l1 x Hsorted.
  - exists [::].
    rewrite ?cat0s ?cats0.
    etransitivity; first eapply eq_filter_in; last apply filter_pred0.
    intros i Hin => //=.
    rewrite //= in Hsorted.
    replace x with (nth O (l1 ++ [:: x]) (size l1)); last first.
    { rewrite nth_cat ltnn subnn //. }
    rewrite -(nth_index O Hin). apply negbTE. rewrite -leqNgt.
    apply sorted_nth_trans_refl; auto.
    * by intros => ?.
    * rewrite /= => ?????. eapply leq_trans; eauto.
    * apply /andP; split; auto.
      ** rewrite -index_mem size_cat //= in Hin. rewrite -ltnS //. move: Hin. by nat_norm.
      ** rewrite size_cat //=. nat_norm => //.
  - edestruct (IHl2 l1 x) as (lmid&Heq).
    {
      rewrite -cat_cons catA in Hsorted.
      apply sorted_cat_inv in Hsorted; first (destruct Hsorted; auto).
      intros ?????. eauto using leq_trans.
    }
    rewrite -cat_cons catA filter_cat.
    rewrite {2}/filter.
    case: ifP => Hlt.
    * exists lmid. rewrite catA Heq. done.
    * exists (lmid ++ [::a]).
      rewrite cats0. rewrite -[a in _ = a]cats0.
      cut ([seq n <- l1 ++ x :: l2 | x < n] = [::])%nat.
      {
        intros Hnil. rewrite ?Hnil -Heq ?Hnil ?cats0 ?cat0s. done.
      }
    etransitivity; first eapply eq_filter_in; last apply filter_pred0.
    intros i Hin => //=.
    apply negbTE. rewrite -leqNgt. apply negbT in Hlt. rewrite -leqNgt in Hlt.
    eapply leq_trans; last apply Hlt.
    replace a with (nth O (l1 ++ x :: (l2 ++ [:: a])) (size (l1 ++ x :: l2 ))); last first.
    { rewrite -cat_cons catA nth_cat ltnn subnn //. }
    assert (Hin': i \in l1 ++ x:: l2 ++ [:: a]).
    { rewrite -cat_cons catA. rewrite mem_cat Hin //. }
    rewrite -(nth_index O Hin').
    apply sorted_nth_trans_refl; auto.
    ** by intros => ?.
    ** rewrite /= => ?????. eapply leq_trans; eauto.
    ** apply /andP; split; auto.
      *** rewrite -index_mem ?size_cat //= ?size_cat in Hin'.
          move: Hin'.
          rewrite ?size_cat //= -?plusE. move /leP => Hle'. apply /leP. destruct (size l2); omega.
      *** repeat (rewrite ?size_cat //=). rewrite -?plusE. apply /ltP => //=. omega.
Qed.

Lemma upper_split_size_sorted l1 l2 x:
  sorted leq (l1 ++ x :: l2) →
  (size [seq n <- l1 ++ x :: l2 | x < n] <= size l2)%nat.
Proof.
  intros (lmid&Heq)%upper_split_sorted.
  rewrite -[a in (_ <= size a)%nat]Heq.
  rewrite size_cat. rewrite -plusE. apply /leP. destruct size; omega.
Qed.

Lemma upper_split_size_sorted_nth  l x a:
  sorted leq l →
  (x < size l →
  size [seq n <- l | nth a l x < n] <= size l - x - 1)%nat.
Proof.
  rewrite nth_legacy => Hsort Hlt.
  edestruct (@nth_split _ x l a) as (l1&l2&Heq&Hlen).
  { rewrite -size_legacy. apply /ltP. auto. }
  rewrite {2}Heq.
  assert (Hlen': (length l2 <= length l - x - 1)%nat).
  { rewrite Heq app_length //=. rewrite -?plusE -?minusE. apply /leP. rewrite -Hlen //=. omega. }
  eapply leq_trans; last apply Hlen'.
  apply upper_split_size_sorted. rewrite Heq in Hsort => //.
Qed.

Lemma perm_filter {T: eqType} {P: pred T} (s t: seq T):
  perm_eq s t → perm_eq [seq i <- s | P i] [seq i <- t | P i].
Proof.
  move /permP => Hcount.
  apply /permP => P'. rewrite ?count_filter. apply Hcount.
Qed.

Lemma perm_eq_bij {A: eqType} (a: A) (l1 l2: seq A):
  perm_eq l1 l2 →
  (∃ f : nat → nat,
           (∀ x, x < size l1 → nth a l1 x = nth a l2 (f x))%nat ∧
           (∀ x, x < size l1 → f x < size l1)%nat ∧
           (∀ x, x < size l1 → ∃ x', x' < size l1 ∧ f x' = x)%nat ∧
           (∀ x x', x < size l1 → x' < size l1 → f x = f x' → x = x')%nat).
Proof.
  intros Hperm.
  assert (Hsize: size l1 = size l2).
  { apply perm_size => //. }
  move /perm_iotaP in Hperm. specialize (Hperm a).
  destruct Hperm as [Is Hperm Heq].
  assert (HsizeIs: size Is = size l2) by (rewrite (perm_size Hperm) size_iota //).
  exists (λ x, nth O Is x).
  repeat split.
  - intros x Hlt.
    rewrite Heq => //=. erewrite nth_map; auto; rewrite HsizeIs; nify; omega.
  - intros x Hlt.
    assert (Hin: nth O Is x \in Is).
    { apply nth_lt_size. nify. omega. }
    apply perm_mem in Hperm. specialize (Hperm (nth O Is x)).
    rewrite Hperm mem_iota in Hin. move /andP in Hin. destruct Hin as (?&?).
    nify. omega.
  - intros x lt. exists (index x Is); split.
    * rewrite Hsize -(size_iota O (size l2)) -(perm_size Hperm) index_mem.
      rewrite (perm_mem Hperm) mem_iota. apply /andP; split; nify; omega.
    * apply nth_index.
      rewrite (perm_mem Hperm) mem_iota. apply /andP; split; nify; omega.
  - intros x x' Hlt Hlt'. move /eqP. rewrite nth_uniq; first by move /eqP.
    * rewrite HsizeIs; nify; omega.
    * rewrite HsizeIs; nify; omega.
    * rewrite (perm_uniq Hperm). apply iota_uniq.
Qed.

Lemma Ex_max_partition_sum l:
  Ex (rvar_comp (rvar_of_ldist (h l)) (λ x, Rmax (rsize (x.2.1)) (rsize (x.2.2)))) <=
  match (size l) with
     | O => 0
     | _ => \big[Rplus/0]_(i < size l) (/INR (size l) * (Rmax (INR i) (INR (size l - i - 1))))
  end.
Proof.
  destruct l as [| a l].
  - rewrite Ex_fin_comp.
    rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ (_ (fst (snd a))) (_ (snd (snd a))))).
    rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
    rewrite pr_mret_simpl //= /m/rsize//=.
    rewrite Rmax_left //; last (fourier).
    rewrite /INR. ring_simplify. fourier.
  - destruct l as [| b0 l0].
    {
      rewrite Ex_fin_comp.
      rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ (_ (fst (snd a))) (_ (snd (snd a))))).
      rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
      rewrite pr_mret_simpl //= /m/rsize//=.
      rewrite Rmax_left //; last (fourier).
      replace (INR 0) with 0 by auto. ring_simplify.
      apply Rle_big0 => i _ //=.
      destruct i as (i&Hlt) => //=. assert (i = O) as -> by (nify; omega).
      replace (1 - 0 - 1)%nat with O by (nify; omega).
      replace (INR 0) with 0 by auto. rewrite Rmax_left; last fourier.
      replace (INR 1) with 1 by auto. fourier.
    }
    remember (b0 :: l0) as l eqn:Heql0.

    replace (size (a :: l)) with (S (size l)) by auto.
    rewrite -(Ex_mbind_mret (h (a :: l))).
    rewrite /h Heql0. rewrite -Heql0. clear l0 Heql0.

    rewrite ldist_assoc. rewrite ldist_assoc.
    rewrite Ex_mbind_ldist2.
    rewrite undup_id; last first.
    { apply uniq_unif2. }
    rewrite -unif_cost3 big_map.
    edestruct (perm_eq_bij O) as (f&Hfspec&Hfsize&Hinv&Hinj).
    { rewrite perm_sym. apply (permEl (perm_sort leq (a :: l))). }
    eapply sum_reidx_map_le with
        (h := (λ (H : {x : nat | (x <= size l)%nat}),
               let (x, i) := H in
                (Ordinal (n:=(size l).+1) (m:=f x) (Hfsize x i)))).
    * intros (x, Hle) Hin.
      rewrite unif_pr. rewrite /Rdiv Rmult_1_l. apply Rmult_le_compat_l.
      ** left. apply Rinv_0_lt_compat. apply lt_0_INR. rewrite //=. omega.
      ** rewrite -ldist_assoc. rewrite Ex_mbind_mret.
         apply Ex_bound.
         rewrite ldist_cost_bind_fold.
         rewrite ?ldist_left_id.
         assert (Hlt: (x < size (a :: l))%nat) by auto.
         rewrite //= in Hlt.
         eapply (@cspec_mspec _ _ (λ x0 : (seq nat * seq nat),
                                      Rmax (rsize x0.1) (rsize x0.2)
                                      <= Rmax (INR (f (Ordinal (n:= S (size l)) Hle)))
                                              (INR (S (size l) - (f (Ordinal (n := S (size l)) Hle))
                                                    - 1)))).
         tbind (λ y, nth 0%nat (a :: l) x = sval y).
         { apply mspec_mret => //=. }
         intros (pv&Hin') Heq.
         tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                     middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                     upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
         { apply mspec_mret. apply partition_split. }
         remember (a :: l) as l0 eqn:Heql0.
         assert (Hsize: S (size l) = (size l0)) by (rewrite Heql0; auto).
         intros (spl&Hin'') => //=. intros (Hl&Hm&Hu).
         apply mspec_mret => //=.
         rewrite /rsize.
         rewrite ?Rmax_INR. apply le_INR.
         rewrite Hl Hu.
         apply Nat.max_le_compat.
         *** rewrite //= in Heq. rewrite -Heq.
             apply /leP. rewrite Hfspec.
             specialize (permEl (perm_sort leq l0)) => Hperm.
             rewrite -(perm_size (perm_filter _ _ Hperm)).
             apply lower_split_size_sorted_nth; auto.
             **** apply sort_sorted => ??. apply leq_total.
             **** rewrite (perm_size (permEl (perm_sort leq l0))) /=.
                  apply Hfsize. rewrite Heql0. done.
             **** rewrite Heql0 //=.
         *** rewrite //= in Heq. rewrite -Heq.
             apply /leP. rewrite Hfspec.
             assert (Hsize': (size l).+1 = size l0) by rewrite Heql0 //.
             rewrite Hsize'.
             specialize (permEl (perm_sort leq l0)) => Hperm.
             rewrite -(perm_size (permEl (perm_sort leq l0))).
             rewrite -(perm_size (perm_filter _ _ Hperm)).
             apply upper_split_size_sorted_nth; auto.
             **** apply sort_sorted => ??. apply leq_total.
             **** rewrite (perm_size (permEl (perm_sort leq l0))) /=.
                  apply Hfsize. rewrite Heql0. done.
             **** rewrite Heql0 //=.
      ** rewrite -unif_cost3 //. apply /mapP. eexists; eauto.
    * intros (?&?) Hin; split; auto.
      rewrite /index_enum. rewrite -enumT. rewrite mem_enum => //=.
    * intros b Hin _ Hfalse. contradiction Hfalse.
      destruct b as (m, Hle).
      destruct (Hinv m Hle) as (x'&Hle'&Heq).
      exists (exist _ x' Hle'); repeat split; auto.
      ** apply unif_all2.
      ** apply ord_inj => //=.
    * eapply map_uniq with (f := λ x, (O, x)). rewrite unif_cost3. eapply uniq_unif2.
    * rewrite /index_enum. rewrite -enumT. apply enum_uniq.
    * intros (?&?) (?&?) _ => //=. inversion 1; subst. apply /val_inj/Hinj => //=.
Qed.

Lemma INR_half k:
  (odd k → INR (k./2) = INR k / 2 - /2) ∧
  (~~ odd k → INR (k./2) = INR k / 2).
Proof.
  induction k.
  - rewrite //=; replace (INR 0) with 0 by auto. split; intros; try done. field.
  - rewrite //=; split.
    * intros. rewrite uphalf_half. destruct (odd k); rewrite //=.
      rewrite ?S_INR ?plus_INR. destruct IHk as (_&IHk). rewrite IHk => //.
      replace (INR 0) with 0 by auto. destruct k => //=; field.
    * rewrite negbK => Hodd.
      rewrite uphalf_half Hodd //=.
      specialize (S_INR). rewrite //= => ->.
      specialize (S_INR). rewrite //= => ->.
      destruct IHk as (IHk&_). rewrite IHk => //. replace (INR 1) with 1 by auto. field.
Qed.

Lemma INR_uphalf_half_odd k: odd k → INR (uphalf k * half k) = (INR k + 1) * (INR k - 1) / 4.
Proof.
  intros Hodd. rewrite uphalf_half Hodd //=. nify.
  rewrite mult_INR plus_INR.
  destruct (INR_half k) as (Hhalf&_).
  rewrite ?Hhalf //=.
  replace (INR 1) with 1 by auto. field.
Qed.

Lemma INR_uphalf_half_even k: ~~ odd k → INR (uphalf k * half k) = (INR k) * (INR k) / 4.
Proof.
  move /negbTE => Heven.
  rewrite uphalf_half Heven add0n //=. nify.
  rewrite mult_INR.
  destruct (INR_half k) as (_&Hhalf).
  rewrite ?Hhalf; last by (rewrite Heven).
  field.
Qed.

Lemma succ_product_even k:
  ~~ odd (S k * k).
Proof.
  rewrite odd_mul => //=. destruct (odd k) => //=.
Qed.

Lemma sum_le_m l:
  match (size l) with
     | O => 0
     | _ => \big[Rplus/0]_(i < size l) (/INR (size l) * (Rmax (INR i) (INR (size l - i - 1))))
  end ≤
  m (rsize l).
Proof.
  rewrite /rsize.
  remember (size l) as k eqn:Heqk. clear Heqk l.
  induction k => //=.
  - rewrite /m. destruct (Rlt_dec) => //=; try fourier.
  - rewrite -big_distrr => /=.
    eapply Rle_trans.
    {
      apply Rmult_le_compat_l.
      { left. apply Rinv_0_lt_compat. replace 0 with (INR 0) by auto.
        apply (lt_INR 0 (S k)). omega. }
      { right. eapply eq_bigr => i /=. rewrite Rmax_INR => //.  }
    }
    rewrite big_INR.
    specialize (max_triangular_sum (S k)). rewrite big_mkord => ->.
    rewrite bin2.
    destruct k.
    {  rewrite plus_INR mult_INR => //=.
       replace (INR 0) with 0 by auto.
       replace (INR 1) with 1 by auto.
       rewrite /m//=. destruct (Rlt_dec) => //=; fourier.
    }
    rewrite /m. rewrite S_INR. destruct (Rlt_dec).
    { rewrite ?S_INR. intros. exfalso.
      specialize (pos_INR k). intros. nra. }
    rewrite plus_INR.
    destruct (INR_half ((S (S k)) * (S k))) as (_&Hhalf).
    rewrite Hhalf; last apply succ_product_even.
    case_eq (odd (S (S k))) => Hparity.
    * rewrite INR_uphalf_half_odd //. nify.
      rewrite mult_INR ?S_INR.
      specialize (pos_INR k) => Hpos.
      apply (Rmult_le_reg_l (INR k + 1 + 1 )); first by fourier.
      field_simplify; last first.
      { apply Rgt_not_eq. fourier. }
      nra.
    * rewrite INR_uphalf_half_even //; last by (rewrite Hparity). nify.
      rewrite mult_INR ?S_INR.
      specialize (pos_INR k) => Hpos.
      apply (Rmult_le_reg_l (INR k + 1 + 1 )); first by fourier.
      field_simplify; last first.
      { apply Rgt_not_eq. fourier. }
      nra.
Qed.

Lemma Ex_max_partition l:
  Ex (rvar_comp (rvar_of_ldist (h l)) (λ x, Rmax (rsize (x.2.1)) (rsize (x.2.2)))) <=
   m (rsize l).
Proof.
  eapply Rle_trans; [ apply Ex_max_partition_sum | apply sum_le_m ].
Qed.

Definition T := λ x, rvar_comp (rvar_of_ldist (qs x)) (λ x, INR (fst x)).
Definition a x :=
    match (Rle_dec x 1) with
      | left _ => 0
      | _ => x
    end.
Definition h' x := rvar_comp (rvar_of_ldist (h x)) snd.

Lemma Trec:
    ∀ x r,  pr_eq (T x) r =
            \big[Rplus/0]_(x' : imgT (h' x))
                        (pr_eq (h' x) (sval x') *
                         pr_eq (rvar_comp (rvar_pair (T (fst (sval x'))) (T (snd (sval x'))))
                                         (fun xy => (fst xy) + (snd xy))) (r - a (rsize x))).
Proof.
  intros ls r.
  induction ls as [| a0 ls].
  - rewrite /T. rewrite -pr_mbind_mret.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' [::]) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR x.1))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR x.1)))
               (λ xy : prod_eqType R_eqType R_eqType, xy.1 + xy.2)) (r - a (rsize [::]))))).
    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    rewrite /a/rsize/size.
    replace (INR 0) with 0 by auto.
    destruct (Rle_dec); last nra.
    specialize (pr_rvar_ldist ((x ← qs [::]; mret (INR x.1)))) => -> //=.
    rewrite big_cons big_nil /=.
    rewrite /pr_eq; rewrite 2!pr_eq_alt_comp.

    rewrite -(big_map _ (λ x, true) (λ v, if (snd v) == _ then
                                            pr_eq _ v
                                          else
                                            0)).

    rewrite -(big_map _ (λ x, true) (λ v, if (fst v) + (snd v) == r - 0 then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite (perm_big _ (img_pair_rv _ _ _ _)).
    rewrite allpairs_comp.
    rewrite img_rvar_comp.
    rewrite map_comp //=.
    rewrite (map_comp fst).
    specialize (img_rvar_of_ldist (qs [::])) => ->.
    rewrite Rmult_1_r Rplus_0_r.
    specialize (img_rvar_of_ldist (h [::])) => ->.
    rewrite //= !big_cons !big_nil ?Rplus_0_r //= ?Rminus_0_r.
    rewrite [a in _ = _ * a]big_cons ?big_nil //= ?Rplus_0_r.
    case: ifP; last first.
    { intros; field.  }
    rewrite pr_mret_simpl //=. intros. ring_simplify. rewrite pr_eq_rvar_pair //=.
    rewrite /pr_eq pr_eq_alt_comp.
    rewrite -(big_map _ (λ x, true) (λ v, if INR (fst (v)) == 0 then pr_eq _ v else 0)).
    rewrite -(big_map _ (λ x, true) (λ v, if INR (fst (v)) == 0 then pr_eq _ v else 0)).
    specialize (img_rvar_of_ldist (qs [::])) => -> //=.
    rewrite ?big_cons ?big_nil //= eq_refl.
    rewrite pr_mret_simpl //=. field.
  - destruct ls as [| b0 ls0].
    { rewrite /T. rewrite -pr_mbind_mret.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' _) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR x.1))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR x.1)))
               (λ xy : prod_eqType R_eqType R_eqType, xy.1 + xy.2)) (r - a (rsize _))))).
    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    rewrite /a/rsize/size.
    replace (INR 1) with 1 by auto.
    destruct (Rle_dec); last nra.
    specialize (pr_rvar_ldist ((x ← qs [:: a0]; mret (INR x.1)))) => -> //=.
    rewrite big_cons big_nil /=.
    rewrite /h'/h.
    rewrite {1}/pr_eq. rewrite 1!pr_eq_alt_comp.
    rewrite -(big_map _ (λ x, true) (λ v, if (snd v) == _ then
                                            pr_eq _ v
                                          else
                                            0)).
    specialize (img_rvar_of_ldist (h [::a0])) => ->. rewrite /h.
    rewrite ?big_cons ?big_nil ?Rplus_0_r //= ?Rminus_0_r.
    rewrite pr_mret_simpl //=. ring_simplify.
    rewrite {1}/pr_eq. rewrite 1!pr_eq_alt_comp.
    rewrite -(big_map _ (λ x, true) (λ v, if (fst v) + (snd v) == r then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite (perm_big _ (img_pair_rv _ _ _ _)).
    rewrite allpairs_comp.
    rewrite img_rvar_comp map_comp (map_comp fst).
    specialize (img_rvar_of_ldist (qs [::])) => -> //=.
    rewrite ?big_cons ?big_nil //=. replace (INR 0) with 0 by auto.
    rewrite ?Rplus_0_r.
    case: ifP; intros; last field.
    rewrite pr_eq_rvar_pair.
    f_equal.
    * rewrite /pr_eq pr_eq_alt_comp.
      rewrite -(big_map _ (λ x, true) (λ v, if INR (fst (v)) == 0 then pr_eq _ v else 0)).
      specialize (img_rvar_of_ldist (qs [::])) => -> //=.
      rewrite ?big_cons ?big_nil //= eq_refl.
      rewrite pr_mret_simpl //=. field.
    * rewrite /pr_eq pr_eq_alt_comp.
      rewrite -(big_map _ (λ x, true) (λ v, if INR (fst (v)) == 0 then pr_eq _ v else 0)).
      specialize (img_rvar_of_ldist (qs [::])) => -> //=.
      rewrite ?big_cons ?big_nil //= eq_refl.
      rewrite pr_mret_simpl //=. field.
    }
    remember (b0 :: ls0) as ls eqn:Heql0.
   rewrite /T.
    rewrite qs_unfold.
    transitivity
  (pr_eq (rvar_comp (rvar_of_ldist
         ('(ll, lu) ← h (a0 :: ls);
            lls ← qs ll;
            lus ← qs lu;
            mret (lls, lus))) (λ x, INR (fst x)))  r); last first.
    {
      rewrite /h'.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' _) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR x.1))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR x.1)))
               (λ xy : prod_eqType R_eqType R_eqType, xy.1 + xy.2)) (r - a (rsize _))))).

    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist.
      rewrite (cost_bind_const (size (a0 :: ls))).
      * rewrite -undup_map. rewrite -map_comp.
        eapply eq_bigr. intros (ll&lu) _.
        f_equal.
        specialize (ldist_cost_pair (qs ll) (qs lu) (λ a b, (a, b))
                                    (λ x, INR (x + size (a0 :: ls)))) => ->.
        rewrite !rvar_pair_comp !rvar_comp_comp.
          rewrite {1}/pr_eq {1}[a in _ = a]/pr_eq.
          rewrite ?pr_eq_alt_comp /=. eapply eq_bigr => x ?.
          apply if_case_match. rewrite ?plus_INR /rsize//=/a//=.
          rewrite Heql0 //=. specialize (S_INR (size ls0)) => /= => ->.
          destruct (Rle_dec).
          {specialize (pos_INR (size ls0)). intros. nra. }
          apply /eqP.
          apply /eqP. case: ifP; first by (move /eqP => ->; nra).
          move /eqP. intros. nra.
      * intros d'. rewrite map_comp. move /mapP. intros [? Hin Heq]. rewrite Heq.
        cut (cspec (h (a0 :: ls )) (λ x, fst x = size (a0 :: ls))); first by auto.
        rewrite /h. rewrite Heql0. rewrite -Heql0.
        cbind (λ x, fst x = O).
        {
          rewrite /draw_pivot.
          cbind (λ x, fst x = O).
          { rewrite /cspec/coutput. destruct y as (c, a).
            rewrite /fst. eapply unif_cost; auto. }
          intros (c0, pv) => /= ->.
          apply cspec_mret => //=.
        }
        intros (?, pv) ->.
        cbind (λ x, fst x = size (a0 :: ls)).
        {
         eapply cspec_dist_ret.
         clear. rewrite /snd. destruct pv as (pv&?).  rewrite /sval.
         remember (a0 :: ls) as l. clear.
         induction l as [| a l] => //=.
         destruct (ltngtP a pv) => //=; nify; rewrite /partition' /= in IHl; rewrite IHl; omega.
        }
        intros (c, spl) ->.
        apply cspec_mret => //=. nify. omega.
    }
    (* TODO TODO: a good deal of this could be automated *)
    rewrite Heql0.
    rewrite /h.
    rewrite -?pr_mbind_mret.
    f_equal.
    apply outcomes_eq_dist.
    rewrite ?ldist_assoc.
    f_equal; eapply ldist_bind_ext.
    intros (?&?).
    eapply ldist_bind_ext.
    intros (?&?).
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros (?&?).
    rewrite ?ldist_assoc.
    rewrite ?ldist_left_id ?ldist_right_id.
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros (?&?).
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros (?&?).
    rewrite ?ldist_left_id ?ldist_right_id.
    f_equal => //=. f_equal. nify. omega.
Qed.

Definition k := -/ ln(3/4).

Theorem bound x w:
    rsize x > 1 →
    pr_gt (T x) (rsize x * (k * ln (rsize x) + 1) + INR w * rsize x)
       ≤ (rsize x) * (3/4)^w.
Proof.
  specialize (quicksort_rec.recurrence_work3.qs_work_bound _ _ _ _ T h').
  rewrite /size/rsize => Hrec. eapply Hrec; clear.
  - intros x' n. rewrite //=. apply Rle_ge. apply pos_INR.
  - intros l ?. rewrite //=.
    rewrite /quicksort_rec.recurrence_work3.size //=.
    cut (∀ n, INR (length (fst (snd (rvar_of_ldist (h l) n)))) +
              INR (length (snd (snd (rvar_of_ldist (h l) n)))) <=
                   INR (length l)); first by rewrite //=.
    intros n'. apply fun_to_cspec.
    rewrite /h.
    destruct l as [| a l].
    { apply cspec_mret => //=. replace (INR 0) with 0 by auto. nra. }
    destruct l as [| b l0].
    { apply cspec_mret => //=. replace (INR 0) with 0 by auto. replace (INR 1) with 1 by auto. nra. }
    remember (b::l0) as l eqn:Heql0.
    clear b l0 Heql0.
    eapply (cspec_mspec _ (λ x, INR (length (fst x)) + INR (length (snd x)) <= INR (length _))).
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin') => //= ?. apply mspec_mret.
    move /andP in Hin'.
    destruct Hin' as (pf1&pf2); move /implyP in pf2.
    replace (length l0) with (size l0) by auto.
    rewrite -(perm_size pf1) //= ?size_cat -?plusE //.
    assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
    rewrite -plus_INR. apply le_INR. rewrite //=.
    assert (length (lower spl) = size (lower spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    assert (length (upper spl) = size (upper spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    clear -Hlt. rewrite //=. omega.
  - rewrite /quicksort_rec.recurrence_work3.size //=.
    intros l ? Hgt. rewrite //=.
    cut (∀ n, INR (length (fst (snd (rvar_of_ldist (h l) n)))) +
              INR (length (snd (snd (rvar_of_ldist (h l) n)))) <=
                   INR (length l) - 1); first by rewrite //=.
    intros n'. apply fun_to_cspec.
    rewrite /h.
    destruct l as [| a l].
    { move : Hgt. rewrite //=. replace (INR 0) with 0 by auto. nra. }
    destruct l as [| b l0].
    { move : Hgt. rewrite //=. replace (INR 1) with 1 by auto. nra. }
    remember (b::l0) as l eqn:Heql0.
    clear b l0 Heql0.
    eapply (cspec_mspec _ (λ x, INR (length (fst x)) + INR (length (snd x)) <= INR (length _) - 1)).
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin') => //= ?. apply mspec_mret.
    move /andP in Hin'.
    destruct Hin' as (pf1&pf2); move /implyP in pf2.
    replace (length l0) with (size l0) by auto.
    rewrite -(perm_size pf1) //= ?size_cat -?plusE //.
    assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
    rewrite ?plus_INR.
    assert (length (lower spl) = size (lower spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    assert (length (upper spl) = size (upper spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    specialize (pos_INR (size (lower (spl)))).
    specialize (pos_INR (size (upper (spl)))).
    rewrite //=. intros.
    assert (Hge1: 1 <= INR (size (middle spl))).
    { replace 1 with (INR 1) by auto. apply le_INR. omega. }
    rewrite //= in Hge1. nra.
  - rewrite /quicksort_rec.recurrence_work3.size/quicksort_rec.recurrence_work3.d //=.
    intros x n Hle.
    replace 1 with (INR 1) in Hle by auto. apply INR_le in Hle.
    cut (INR (fst (rvar_of_ldist (qs x) n)) = 0); first by rewrite //=.
    apply fun_to_cspec.
    destruct x; [| destruct x].
    * rewrite qs_unfold.
      apply cspec_mret => //=.
    * rewrite qs_unfold.
      apply cspec_mret => //=.
    * rewrite //= in Hle. omega.
  - intros. eapply (rec_pr_rec_gt _ rsize _ _ _ _ T h' (λ x, true)); auto; intros; apply Trec.
  - intros x. rewrite /quicksort_rec.recurrence_work3.size/quicksort_rec.recurrence_work3.d //=.
    eapply Ex_max_partition.
Qed.

From Interval Require Import Tactic.
Remark concrete:
  ∀ l, rsize l = 10 ^ 8 →
       pr_gt (T l) (10^8 * (8 * 1/(ln 2) * ln (10^8))) ≤ 1/(10^10).
Proof.
  intros l Hsize.
  transitivity (pr_gt (T l) (10^8 * (k * ln (rsize l) + 1) + 147 * 10^8)).
  - apply Rge_le, pr_gt_contra.
    rewrite Hsize. rewrite /k. interval.
  - replace 147 with (INR 147); last first.
    { vm_compute. nra. }
    rewrite -Hsize.
    etransitivity; first apply bound; auto; try nra; try rewrite Hsize; interval.
Qed.

Remark concrete2:
  ∀ l, rsize l = 10 ^ 7 →
       pr_gt (T l) (10^7 * (8 * 1/(ln 2) * ln (10^7))) ≤ 1/(10^9).
Proof.
  intros l Hsize.
  transitivity (pr_gt (T l) (10^7 * (k * ln (rsize l) + 1) + 129 * 10^7)).
  - apply Rge_le, pr_gt_contra.
    rewrite Hsize. rewrite /k. interval.
  - replace 129 with (INR 129); last first.
    { vm_compute. nra. }
    rewrite -Hsize.
    etransitivity; first apply bound; auto; try nra; try rewrite Hsize; interval.
Qed.


(* $Id: CalculusTheorems.v,v 1.23 2003/03/13 12:06:17 lcf Exp $ *)

Require Export Rolle.
Require Export MoreFunTactics.

Opaque Min Max.

Section Various_Theorems.

(* Tex_Prose
\chapter{Calculus Theorems}

This file is intended to present a collection of miscellaneous, mostly technical results in differential calculus that are interesting or useful in future work.

We begin with some properties of continuous functions.  Every continuous function commutes with the Limit of a numerical sequence (sometimes called Heine continuity).
*)

(* Begin_Tex_Verb *)
Lemma Continuous_imp_comm_Lim : (F,x,e:?)
  (Zero[<]e)->(Continuous (clcr (Lim x)[-]e (Lim x)[+]e) F)->
  (Hx,Hxn,H:?)((F (Lim x) Hx)[=]
    (Lim (Build_CauchySeq IR [n:nat](F (x n) (Hxn n)) H))).
(* End_Tex_Verb *)
Intros.
LetTac a:=(Lim x).
LetTac I:=(clcr a[-]e a[+]e).
Cut (compact_ I); Intros.
2: Simpl; Apply ts.
2: Apply less_leEq; Apply less_transitive_unfolded with a.
2: Apply shift_minus_less; Apply shift_less_plus'.
2: Step (Zero::IR); Auto.
2: Apply shift_less_plus'.
2: Step (Zero::IR); Auto.
Apply Limits_unique.
Simpl.
Red; Intros.
LetTac H2':=H2.
Simpl in H2'; Elim H2'; Clear H2'; Intro H2'.
Cut (!Continuous_I (Lend H2) (Rend H2) H2' F); Intros.
2: Apply Int_Continuous; Auto.
Elim (contin_prop ???? H4 ? H3); Intros d H5 H6.
Elim (Cauchy_complete x (Min d e)).
2: Apply less_Min; Auto.
Intros N HN.
Exists N; Intros.
Fold a in HN.
Apply AbsIR_imp_AbsSmall.
Elim (HN m H7); Intros.
Apply H6.
Split; Simpl.
Unfold cg_minus; Apply shift_plus_leEq'.
EApply leEq_transitive.
2: Apply H8.
Apply inv_resp_leEq; Apply Min_leEq_rht.
Apply shift_leEq_plus'.
EApply leEq_transitive.
Apply H9.
Apply Min_leEq_rht.
Split; Simpl.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Step (Zero::IR); Apply less_leEq; Auto.
Apply shift_leEq_plus'; Step (Zero::IR).
Apply less_leEq; Auto.
Apply AbsSmall_imp_AbsIR.
Apply AbsSmall_leEq_trans with (Min d e).
Apply Min_leEq_lft.
Auto.
Qed.

(* Tex_Prose
This is a tricky result: if $F$ is continuous and positive in both $[a,b]$ and $]b,c]$, then it is positive in $[a,c]$.
*)

(* Begin_Tex_Verb *)
Lemma Continuous_imp_pos : (a,b,c:IR)(Hac:a[<=]c)
  (a[<=]b)->(b[<]c)->(F:PartIR)(Continuous_I Hac F)->
  ((t:IR)(a[<=]t)->(t[<=]b)->(Ht:?)(Zero[<](F t Ht)))->
  ((t:IR)(b[<]t)->(t[<=]c)->(Ht:?)(Zero[<](F t Ht)))->
  ((t:IR)(a[<=]t)->(t[<=]c)->(Ht:?)(Zero[<](F t Ht))).
(* End_Tex_Verb *)
Intros.
Inversion_clear H1.
Cut (Compact Hac b); [Intro | Split; Auto].
2: Apply less_leEq; Auto.
LetTac e:=(F b (H6 ? H1))[/]TwoNZ.
Cut Zero[<]e; Intros.
2: Unfold e; Apply pos_div_two; Apply H2; Auto.
2: Apply leEq_reflexive.
Elim H7 with e; Auto.
Intros d H9 H10.
Cut b[-]d[<]b.
2: Apply shift_minus_less; Apply shift_less_plus'.
2: Step (Zero::IR); Auto.
Intro.
Elim (cotrans_less_unfolded ??? H11 t); Intro.
Clear H11.
Elim (cotrans_less_unfolded ??? H9 t[-]b); Intro.
Apply H3.
Step Zero[+]b; Apply shift_plus_less; Auto.
Auto.
Apply cont_no_sign_change_pos with Hab:=Hac e:=e Hx:=(H6 ? H1); Auto.
Split; Auto.
Apply H10; Auto.
Split; Auto.
Apply AbsSmall_imp_AbsIR.
Apply AbsIR_eq_AbsSmall.
RStepr [--](t[-]b); Apply inv_resp_leEq.
Apply less_leEq; Auto.
Apply less_leEq; Apply shift_minus_less; Apply shift_less_plus'; Auto.
Unfold e.
EApply less_leEq_trans.
Apply pos_div_two'.
Apply H2; Auto.
Apply leEq_reflexive.
Apply leEq_AbsIR.
Unfold e.
Apply pos_div_two'.
Apply H2; Auto.
Apply leEq_reflexive.
Apply H2; Auto.
Apply less_leEq; Auto.
Qed.

(* Tex_Prose
Similar results for increasing functions:
*)

(* Begin_Tex_Verb *)
Lemma strict_inc_glues : (a,b,c:IR)(F:PartIR)
  (Hab:a[<=]b)(Hbc:b[<=]c)(Hac:a[<=]c)
  (included (Compact Hac) (Pred F))->
  ((x,y:IR)(Compact Hab x)->(Compact Hab y)->
    (x[<]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  ((x,y:IR)(Compact Hbc x)->(Compact Hbc y)->
    (x[<]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  (x,y:IR)(Compact Hac x)->(Compact Hac y)->
    (x[<]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)).
(* End_Tex_Verb *)
Intros.
Cut (Pred F a); [Intro Ha | Apply H; Apply compact_inc_lft].
Cut (Pred F b); [Intro Hb | Apply H; Split; Auto].
Cut (Pred F c); [Intro Hc | Apply H; Apply compact_inc_rht].
Elim (cotrans_less_unfolded ??? H4 b); Intro.
Cut (Pred F (Min b y)); [Intro | Apply H; Split].
2: Apply leEq_Min; Auto; Elim H3; Auto.
2: EApply leEq_transitive; [Apply Min_leEq_lft | Auto].
Apply less_leEq_trans with (F ? H5).
Cut (Pred F (Min (x[+]b)[/]TwoNZ y)); [Intro Hxy | Apply H; Split].
3: Elim H3; Intros; EApply leEq_transitive; [Apply Min_leEq_rht | Auto].
2: Apply leEq_Min.
3: Elim H3; Auto.
2: Apply shift_leEq_div; [Apply pos_two | RStep a[+]a].
2: Apply plus_resp_leEq_both; Elim H2; Auto.
Apply less_leEq_trans with (F ? Hxy).
Apply H0; Try Split.
Elim H2; Auto.
Apply less_leEq; Auto.
Apply leEq_Min.
2: Elim H3; Auto.
Apply shift_leEq_div; [Apply pos_two | RStep a[+]a].
Apply plus_resp_leEq_both; Elim H2; Auto.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply shift_div_leEq; [Apply pos_two | RStepr b[+]b].
Apply plus_resp_leEq; Apply less_leEq; Auto.
Apply less_Min; Auto.
Apply shift_less_div; [Apply pos_two | RStep x[+]x].
Apply plus_resp_leEq_less; [Apply leEq_reflexive | Auto].
Apply part_mon_imp_mon' with (Compact Hab); Auto.
Intros; Apply H; Inversion_clear H6; Split; Auto.
Apply leEq_transitive with b; Auto.
Split.
Apply leEq_Min.
Apply shift_leEq_div; [Apply pos_two | RStep a[+]a].
Apply plus_resp_leEq_both; Auto; Elim H2; Auto.
Elim H3; Auto.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply shift_div_leEq; [Apply pos_two | RStepr b[+]b].
Apply plus_resp_leEq; Apply less_leEq; Auto.
Split.
Apply leEq_Min; Auto; Elim H3; Auto.
Apply Min_leEq_lft.
Apply leEq_Min.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply shift_div_leEq; [Apply pos_two | RStepr b[+]b].
Apply plus_resp_leEq; Apply less_leEq; Auto.
Apply Min_leEq_rht.
Intro.
Cut y[<=]b; Intro.
Apply (less_irreflexive_unfolded ? (F y Hy)).
EApply less_wdr.
Apply H6.
Apply pfwdef; EApply eq_transitive_unfolded.
Apply Min_comm.
Apply leEq_imp_Min_is_lft; Auto.
Apply (less_irreflexive_unfolded ? (F y Hy)).
EApply less_transitive_unfolded.
Apply H6.
Apply less_wdl with (F b Hb).
2: Apply pfwdef; Apply eq_symmetric_unfolded; Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto.
Apply H1; Auto.
Apply compact_inc_lft.
Split; [Apply less_leEq | Elim H3]; Auto.

Cut (Pred F (Max b x)); [Intro | Apply H; Split].
3: Apply Max_leEq; Auto; Elim H2; Auto.
2: EApply leEq_transitive; [Apply Hab | Apply lft_leEq_Max].
Apply leEq_less_trans with (F ? H5).
2: Cut (Pred F (Max (y[+]b)[/]TwoNZ x)); [Intro Hxy | Apply H; Split].
3: Elim H2; Intros; EApply leEq_transitive; [Apply a0 | Apply rht_leEq_Max].
3: Apply Max_leEq.
4: Elim H2; Auto.
3: Apply shift_div_leEq; [Apply pos_two | RStepr c[+]c].
3: Apply plus_resp_leEq_both; Elim H3; Auto.
2: Apply leEq_less_trans with (F ? Hxy).
3: Apply H1; Try Split.
6: Elim H3; Auto.
5: Apply less_leEq; Auto.
4: Apply Max_leEq.
5: Elim H2; Auto.
4: Apply shift_div_leEq; [Apply pos_two | RStepr c[+]c].
4: Apply plus_resp_leEq_both; Elim H3; Auto.
3: EApply leEq_transitive.
4: Apply lft_leEq_Max.
3: Apply shift_leEq_div; [Apply pos_two | RStep b[+]b].
3: Apply plus_resp_leEq; Apply less_leEq; Auto.
3: Apply Max_less; Auto.
3: Apply shift_div_less; [Apply pos_two | RStepr y[+]y].
3: Apply plus_resp_less_lft; Auto.
2: Apply part_mon_imp_mon' with (Compact Hbc); Auto.
2: Intros; Apply H; Inversion_clear H6; Split; Auto.
2: Apply leEq_transitive with b; Auto.
3: Split.
4: Apply Max_leEq.
4: Apply shift_div_leEq; [Apply pos_two | RStepr c[+]c].
4: Apply plus_resp_leEq_both; Auto; Elim H3; Auto.
4: Elim H2; Auto.
3: EApply leEq_transitive.
4: Apply lft_leEq_Max.
3: Apply shift_leEq_div; [Apply pos_two | RStep b[+]b].
3: Apply plus_resp_leEq; Apply less_leEq; Auto.
2: Split.
3: Apply Max_leEq; Auto; Elim H2; Auto.
2: Apply lft_leEq_Max.
2: Apply Max_leEq.
2: EApply leEq_transitive.
3: Apply lft_leEq_Max.
2: Apply shift_leEq_div; [Apply pos_two | RStep b[+]b].
2: Apply plus_resp_leEq; Apply less_leEq; Auto.
2: Apply rht_leEq_Max.
Intro.
Cut b[<=]x; Intro.
Apply (less_irreflexive_unfolded ? (F x Hx)).
EApply less_wdl.
Apply H6.
Apply pfwdef; Apply leEq_imp_Max_is_rht; Auto.
Apply (less_irreflexive_unfolded ? (F x Hx)).
EApply less_transitive_unfolded.
2: Apply H6.
Apply less_wdr with (F b Hb).
2: Apply pfwdef; Apply eq_symmetric_unfolded; EApply eq_transitive_unfolded.
2: Apply Max_comm.
2: Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto.
Apply H0; Auto.
2: Apply compact_inc_rht.
Split; [Elim H2 | Apply less_leEq]; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma strict_inc_glues' : (a,b,c:IR)(F:PartIR)
  (a[<]b)->(b[<]c)->
  (included (iprop (olor a c)) (Pred F))->
  ((x,y:IR)(iprop (olcr a b) x)->(iprop (olcr a b) y)->
    (x[<]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  ((x,y:IR)(iprop (clor b c) x)->(iprop (clor b c) y)->
    (x[<]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  (x,y:IR)(iprop (olor a c) x)->(iprop (olor a c) y)->
    (x[<]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)).
(* End_Tex_Verb *)
Intros a b c F Hab Hbc; Intros.
Cut (Pred F b); [Intro Hb | Apply H; Split; Auto].
Elim (cotrans_less_unfolded ??? H4 b); Intro.
Cut (Pred F (Min b y)); [Intro | Apply H; Split].
2: Apply less_Min; Auto; Elim H3; Auto.
2: EApply leEq_less_trans; [Apply Min_leEq_lft | Auto].
Apply less_leEq_trans with (F ? H5).
Cut (Pred F (Min (x[+]b)[/]TwoNZ y)); [Intro Hxy | Apply H; Split].
3: Elim H3; Intros; EApply leEq_less_trans; [Apply Min_leEq_rht | Auto].
2: Apply less_Min.
3: Elim H3; Auto.
2: Apply shift_less_div; [Apply pos_two | RStep a[+]a].
2: Apply plus_resp_less_both; Elim H2; Auto.
Apply less_leEq_trans with (F ? Hxy).
Apply H0; Try Split.
Elim H2; Auto.
Apply less_leEq; Auto.
Apply less_Min.
2: Elim H3; Auto.
Apply shift_less_div; [Apply pos_two | RStep a[+]a].
Apply plus_resp_less_both; Elim H2; Auto.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply shift_div_leEq; [Apply pos_two | RStepr b[+]b].
Apply plus_resp_leEq; Apply less_leEq; Auto.
Apply less_Min; Auto.
Apply shift_less_div; [Apply pos_two | RStep x[+]x].
Apply plus_resp_leEq_less; [Apply leEq_reflexive | Auto].
Apply part_mon_imp_mon' with (iprop (olcr a b)); Auto.
Intros; Apply H; Inversion_clear H6; Split; Auto.
Apply leEq_less_trans with b; Auto.
Split.
Apply less_Min.
Apply shift_less_div; [Apply pos_two | RStep a[+]a].
Apply plus_resp_less_both; Auto; Elim H2; Auto.
Elim H3; Auto.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply shift_div_leEq; [Apply pos_two | RStepr b[+]b].
Apply plus_resp_leEq; Apply less_leEq; Auto.
Split.
Apply less_Min; Auto; Elim H3; Auto.
Apply Min_leEq_lft.
Apply leEq_Min.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply shift_div_leEq; [Apply pos_two | RStepr b[+]b].
Apply plus_resp_leEq; Apply less_leEq; Auto.
Apply Min_leEq_rht.
Intro.
Cut y[<=]b; Intro.
Apply (less_irreflexive_unfolded ? (F y Hy)).
EApply less_wdr.
Apply H6.
Apply pfwdef; EApply eq_transitive_unfolded.
Apply Min_comm.
Apply leEq_imp_Min_is_lft; Auto.
Apply (less_irreflexive_unfolded ? (F y Hy)).
EApply less_transitive_unfolded.
Apply H6.
Apply less_wdl with (F b Hb).
2: Apply pfwdef; Apply eq_symmetric_unfolded; Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto.
Apply H1; Auto.
Split; Auto; Apply leEq_reflexive.
Split; [Apply less_leEq | Elim H3]; Auto.

Cut (Pred F (Max b x)); [Intro | Apply H; Split].
3: Apply Max_less; Auto; Elim H2; Auto.
2: EApply less_leEq_trans; [Apply Hab | Apply lft_leEq_Max].
Apply leEq_less_trans with (F ? H5).
2: Cut (Pred F (Max (y[+]b)[/]TwoNZ x)); [Intro Hxy | Apply H; Split].
3: Elim H2; Intros; EApply less_leEq_trans; [Apply a0 | Apply rht_leEq_Max].
3: Apply Max_less.
4: Elim H2; Auto.
3: Apply shift_div_less; [Apply pos_two | RStepr c[+]c].
3: Apply plus_resp_less_both; Elim H3; Auto.
2: Apply leEq_less_trans with (F ? Hxy).
3: Apply H1; Try Split.
6: Elim H3; Auto.
5: Apply less_leEq; Auto.
4: Apply Max_less.
5: Elim H2; Auto.
4: Apply shift_div_less; [Apply pos_two | RStepr c[+]c].
4: Apply plus_resp_less_both; Elim H3; Auto.
3: EApply leEq_transitive.
4: Apply lft_leEq_Max.
3: Apply shift_leEq_div; [Apply pos_two | RStep b[+]b].
3: Apply plus_resp_leEq; Apply less_leEq; Auto.
3: Apply Max_less; Auto.
3: Apply shift_div_less; [Apply pos_two | RStepr y[+]y].
3: Apply plus_resp_less_lft; Auto.
2: Apply part_mon_imp_mon' with (iprop (clor b c)); Auto.
2: Intros; Apply H; Inversion_clear H6; Split; Auto.
2: Apply less_leEq_trans with b; Auto.
3: Split.
4: Apply Max_less.
4: Apply shift_div_less; [Apply pos_two | RStepr c[+]c].
4: Apply plus_resp_less_both; Auto; Elim H3; Auto.
4: Elim H2; Auto.
3: EApply leEq_transitive.
4: Apply lft_leEq_Max.
3: Apply shift_leEq_div; [Apply pos_two | RStep b[+]b].
3: Apply plus_resp_leEq; Apply less_leEq; Auto.
2: Split.
3: Apply Max_less; Auto; Elim H2; Auto.
2: Apply lft_leEq_Max.
2: Apply Max_leEq.
2: EApply leEq_transitive.
3: Apply lft_leEq_Max.
2: Apply shift_leEq_div; [Apply pos_two | RStep b[+]b].
2: Apply plus_resp_leEq; Apply less_leEq; Auto.
2: Apply rht_leEq_Max.
Intro.
Cut b[<=]x; Intro.
Apply (less_irreflexive_unfolded ? (F x Hx)).
EApply less_wdl.
Apply H6.
Apply pfwdef; Apply leEq_imp_Max_is_rht; Auto.
Apply (less_irreflexive_unfolded ? (F x Hx)).
EApply less_transitive_unfolded.
2: Apply H6.
Apply less_wdr with (F b Hb).
2: Apply pfwdef; Apply eq_symmetric_unfolded; EApply eq_transitive_unfolded.
2: Apply Max_comm.
2: Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto.
Apply H0; Auto.
Split; [Elim H2 | Apply less_leEq]; Auto.
Split; Auto; Apply leEq_reflexive.
Qed.

(* Begin_Tex_Verb *)
Lemma strict_dec_glues : (a,b,c:IR)(F:PartIR)
  (Hab:a[<=]b)(Hbc:b[<=]c)(Hac:a[<=]c)
  (included (Compact Hac) (Pred F))->
  ((x,y:IR)(Compact Hab x)->(Compact Hab y)->
    (x[>]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  ((x,y:IR)(Compact Hbc x)->(Compact Hbc y)->
    (x[>]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  (x,y:IR)(Compact Hac x)->(Compact Hac y)->
    (x[>]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)).
(* End_Tex_Verb *)
Intros.
Apply inv_cancel_less.
Step ({--}F y Hy); Stepr ({--}F x Hx).
Apply strict_inc_glues with a b c Hab Hbc Hac; Auto.
Intros; Simpl; Apply inv_resp_less; Auto.
Intros; Simpl; Apply inv_resp_less; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma strict_dec_glues' : (a,b,c:IR)(F:PartIR)
  (a[<]b)->(b[<]c)->
  (included (iprop (olor a c)) (Pred F))->
  ((x,y:IR)(iprop (olcr a b) x)->(iprop (olcr a b) y)->
    (x[>]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  ((x,y:IR)(iprop (clor b c) x)->(iprop (clor b c) y)->
    (x[>]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)))->
  (x,y:IR)(iprop (olor a c) x)->(iprop (olor a c) y)->
    (x[>]y)->(Hx,Hy:?)((F x Hx)[<](F y Hy)).
(* End_Tex_Verb *)
Intros.
Apply inv_cancel_less.
Step ({--}F y Hy); Stepr ({--}F x Hx).
Apply strict_inc_glues' with a b c; Auto.
Intros; Simpl; Apply inv_resp_less; Auto.
Intros; Simpl; Apply inv_resp_less; Auto.
Qed.

(* Tex_Prose
More on glueing intervals.
*)

(* Begin_Tex_Verb *)
Lemma olor_pos_clor_nonneg : (a,b:IR)(F:PartIR)
  ((x:IR)(iprop (olor a b) x)->(Hx:?)(Zero[<](F x Hx)))->
  (Ha:?)(Zero[<=](F a Ha))->
  (x:IR)(iprop (clor a b) x)->(Hx:?)(Zero[<=](F x Hx)).
(* End_Tex_Verb *)
Intros; Intro.
Cut (Not (iprop (olor a b) x)); Intro.
Cut x[=]a; Intros.
Apply H0.
EApply less_wdl; [Apply H2 | Algebra].
Red in H3.
Apply not_ap_imp_eq; Intro.
Inversion_clear H1.
Elim (ap_imp_less ??? H4); Intros.
Apply (less_irreflexive_unfolded ? a); Apply leEq_less_trans with x; Auto.
Apply H3; Split; Auto.
Apply (less_irreflexive_unfolded IR Zero); Apply less_transitive_unfolded with (F x Hx); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma olor_pos_olcr_nonneg : (a,b:IR)(F:PartIR)
  ((x:IR)(iprop (olor a b) x)->(Hx:?)(Zero[<](F x Hx)))->
  (Hb:?)(Zero[<=](F b Hb))->
  (x:IR)(iprop (olcr a b) x)->(Hx:?)(Zero[<=](F x Hx)).
(* End_Tex_Verb *)
Intros; Intro.
Cut (Not (iprop (olor a b) x)); Intro.
Cut x[=]b; Intros.
Apply H0.
EApply less_wdl; [Apply H2 | Algebra].
Red in H3.
Apply not_ap_imp_eq; Intro.
Inversion_clear H1.
Elim (ap_imp_less ??? H4); Intros.
Apply H3; Split; Auto.
Apply (less_irreflexive_unfolded ? b); Apply less_leEq_trans with x; Auto.
Apply (less_irreflexive_unfolded IR Zero); Apply less_transitive_unfolded with (F x Hx); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma olor_pos_clcr_nonneg : (a,b:IR)(F:PartIR)(a[<]b)->
  ((x:IR)(iprop (olor a b) x)->(Hx:?)(Zero[<](F x Hx)))->
  (Ha:?)(Zero[<=](F a Ha))->(Hb:?)(Zero[<=](F b Hb))->
  (x:IR)(iprop (clcr a b) x)->(Hx:?)(Zero[<=](F x Hx)).
(* End_Tex_Verb *)
Intros a b F Hab; Intros; Intro.
Cut (Not (iprop (olor a b) x)); Intro.
Elim (cotrans_less_unfolded ??? Hab x); Intro.
Cut (x[=]b); Intros.
Apply H1.
EApply less_wdl; [Apply H3 | Algebra].
Red in H4.
Apply not_ap_imp_eq; Intro.
Inversion_clear H2.
Elim (ap_imp_less ??? H5); Intros.
Apply H4; Split; Auto.
Apply (less_irreflexive_unfolded ? b); Apply less_leEq_trans with x; Auto.
Cut (x[=]a); Intros.
Apply H0.
EApply less_wdl; [Apply H3 | Algebra].
Red in H4.
Apply not_ap_imp_eq; Intro.
Inversion_clear H2.
Elim (ap_imp_less ??? H5); Intros.
Apply (less_irreflexive_unfolded ? a); Apply leEq_less_trans with x; Auto.
Apply H4; Split; Auto.
Apply (less_irreflexive_unfolded IR Zero); Apply less_transitive_unfolded with (F x Hx); Auto.
Qed.

(* Tex_Prose
Any function that has the null function as its derivative must be constant.
*)

(* Begin_Tex_Verb *)
Lemma FConst_prop :
  (J,pJ:?)(F':PartIR)(Derivative J pJ F' {-C-}Zero)->
    {c:IR & (Feq (iprop J) F' {-C-}c)}.
(* End_Tex_Verb *)
Intros.
Elim (nonvoid_point ? (proper_nonvoid ? pJ)); Intros x0 Hx0.
Exists (F' x0 (Derivative_imp_inc ???? H x0 Hx0)).
FEQ.
Simpl.
Apply cg_inv_unique_2.
Apply AbsIR_approach_zero; Intros.
Simpl in Hx'.
Elim (Mean_Law ???? H ?? Hx0 H0 e H1).
Intros y H2 H3.
EApply leEq_wdl.
Apply (H3 (Derivative_imp_inc ???? H ? Hx0) Hx CI).
Apply AbsIR_wd; Simpl; Rational.
Qed.

(* Tex_Prose
As a corollary, two functions with the same derivative must differ by a constant.
*)

(* Begin_Tex_Verb *)
Lemma Feq_crit_with_const : (J,pJ,F,G,H:?)
  (Derivative J pJ F H)->(Derivative J pJ G H)->
    {c:IR & (Feq (iprop J) F{-}G {-C-}c)}.
(* End_Tex_Verb *)
Intros.
Apply FConst_prop with pJ.
Derivative_Help; FEQ.
Qed.

(* Tex_Prose
This yields the following known result: any differential equation of the form $f'=g$ with initial condition $f(a)=b$ has a unique solution.
*)

(* Begin_Tex_Verb *)
Lemma Feq_criterium : (J,pJ,F,G,H:?)
  (Derivative J pJ F H)->(Derivative J pJ G H)->
  (x:IR)((iprop J x)->((Hx,Hx':?)(F x Hx)[=](G x Hx'))->
    (Feq (iprop J) F G)).
(* End_Tex_Verb *)
Intros.
Elim (Feq_crit_with_const ????? H0 H1); Intros c Hc.
Apply Feq_transitive with (F{-}G){+}G.
FEQ.
Apply Feq_transitive with {-C-}Zero{+}G.
2: FEQ.
Apply Feq_plus.
2: Apply Feq_reflexive; Included.
Apply Feq_transitive with {-C-}c.
Auto.
FEQ.
Simpl.
Inversion_clear Hc.
Clear H5 Hx' Hx.
Simpl in H6.
Cut (Conj (Pred F) (Pred G) x); Intros.
Apply eq_symmetric_unfolded; EApply eq_transitive_unfolded.
2: Apply H6 with Hx:=H5; Auto.
Apply eq_symmetric_unfolded; Apply x_minus_x; Auto.
Split.
Exact (Derivative_imp_inc ???? H0 ? H2).
Exact (Derivative_imp_inc ???? H1 ? H2).
Qed.

(* Tex_Prose
Finally, a well known result: any function with a (strictly) positive derivative is (strictly) increasing.  Although the two lemmas look quite similar the proofs are completely different, both from the formalization and from the mathematical point of view.
*)

(* Begin_Tex_Verb *)
Lemma Derivative_imp_resp_less : (J,pJ,a,b,F,F':?)
  (Derivative J pJ F F')->(a[<]b)->(iprop J a)->(iprop J b)->
  ((contF':?)Zero[<](glb_funct ?? (Min_leEq_Max a b) F' contF'))->
    (Ha,Hb:?)(F a Ha)[<](F b Hb).
(* End_Tex_Verb *)
Intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb.
Step Zero[+](pfpfun ? ? Ha); Apply shift_plus_less.
Cut (Continuous_I (Min_leEq_Max a b) F'); Intros.
2: Apply included_imp_Continuous with J; [Apply Derivative_imp_Continuous' with pJ F | Apply included_interval]; Auto.
Elim (glb_is_glb ???? H).
Simpl; Intros Hglb1 Hglb2.
Cut Zero[<](glb_funct ???? H); [Intro | Auto].
Elim (Mean_Law ???? derF a b) with e:=((glb_funct ???? H)[*](b[-]a))[/]TwoNZ; Auto.
Intros x H1 H2.
Apply less_leEq_trans with (F' x (contin_imp_inc ???? H x H1))[*](b[-]a)[-]((glb_funct ???? H)[*](b[-]a))[/]TwoNZ.
RStepr ((F' x (contin_imp_inc ???? H x H1))[-](glb_funct ???? H)[/]TwoNZ)[*](b[-]a).
Apply mult_resp_pos.
Apply shift_less_minus; Step (glb_funct ???? H)[/]TwoNZ.
EApply less_leEq_trans.
Apply pos_div_two'; Auto.
Auto.
Apply shift_less_minus; Step a; Auto.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
RStep [--](((pfpfun ? ? Hb)[-](pfpfun ? ? Ha))[-](pfpfun ? ? (contin_imp_inc ???? H ? H1))[*](b[-]a)).
EApply leEq_transitive.
Apply inv_leEq_AbsIR.
Apply H2.
Apply pos_div_two; Apply mult_resp_pos; Auto.
Apply shift_less_minus; Step a; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_imp_resp_leEq : (J,pJ,a,b,F,F':?)
  (Derivative J pJ F F')->(a[<=]b)->(iprop J a)->(iprop J b)->
  ((contF':?)Zero[<=](glb_funct ?? (Min_leEq_Max b a) F' contF'))->
    (Ha,Hb:?)(F a Ha)[<=](F b Hb).
(* End_Tex_Verb *)
Intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb.
Stepr Zero[+](pfpfun ? ? Hb); Apply shift_leEq_plus.
Cut (Continuous_I (Min_leEq_Max b a) F'); Intros.
2: Apply included_imp_Continuous with J; [Apply Derivative_imp_Continuous' with pJ F | Apply included_interval]; Auto.
Elim (glb_is_glb ???? H).
Simpl; Intros Hglb1 Hglb2.
Cut Zero[<=](glb_funct ???? H); [Intro | Auto].
Red; Apply approach_zero_weak.
Intros.
Elim (Mean_Law ???? derF b a) with e:=e; Auto.
Intros x H2 H3.
EApply leEq_transitive.
2: Apply (H3 Hb Ha (contin_imp_inc ???? H x H2)).
EApply leEq_transitive.
2: Apply leEq_AbsIR.
RStep ((pfpfun ? ? Ha)[-](pfpfun ? ? Hb))[-][--]Zero.
Unfold 1 3 cg_minus; Apply plus_resp_leEq_lft.
Apply inv_resp_leEq.
RStep [--]((pfpfun ? ? (contin_imp_inc ???? H ? H2))[*](b[-]a)).
Apply inv_resp_leEq.
Apply mult_resp_nonneg.
EApply leEq_transitive; [Apply H0 | Apply Hglb1].
Apply shift_leEq_minus; Step a; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_imp_resp_less' : (J,pJ,a,b,F,F':?)
  (Derivative J pJ F F')->(a[<]b)->
  (iprop J a)->(iprop J b)->
  ((contF':?)(Zero[<=](glb_funct ?? (Min_leEq_Max b a) F' contF')))->
  (Ha,Hb:?)(((F a Ha)[#](F b Hb))->(F a Ha)[<](F b Hb)).
(* End_Tex_Verb *)
Intros.
Elim (ap_imp_less ??? H4); Intro; Auto.
ElimType False.
Apply less_irreflexive_unfolded with x:=(F a Ha).
Apply leEq_less_trans with (F b Hb); Auto.
Apply Derivative_imp_resp_leEq with J pJ F'; Auto.
Apply less_leEq; Auto.
Qed.

(* Tex_Prose
From these results we can finally prove that exponentiation to a real power preserves the less or equal than relation!
*)

(* Begin_Tex_Verb *)
Lemma nexp_resp_leEq_odd : (n:nat)
  (odd n)->(x,y:IR)(x[<=]y)->(x[^]n)[<=](y[^]n).
(* End_Tex_Verb *)
Intro; Case n.
Intros; ElimType False; Inversion H.
Clear n; Intros.
Step (Part FId{^}(S n) x CI).
Stepr (Part FId{^}(S n) y CI).
Apply Derivative_imp_resp_leEq with realline CI (!nring IR (S n)){**}(FId{^}n).
Opaque nring.
Derivative_Help.
FEQ.
Transparent nring.
Auto.
Split.
Split.
Intros.
Apply leEq_glb; Intros.
Simpl.
Apply mult_resp_nonneg.
Apply less_leEq; EApply leEq_less_trans.
2: Apply less_plusOne.
Apply nring_nonneg.
Stepr y0[^]n; Apply nexp_even_nonneg.
Inversion H; Auto.
Qed.

End Various_Theorems.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Import Notations.
Require Import Logic.
Declare ML Module "nat_syntax_plugin".

Inductive Empty_set : Set :=.

Inductive unit : Set :=
tt : unit.

Inductive bool : Set :=
| true : bool
| false : bool.

Add Printing If bool.

Delimit Scope bool_scope with bool.

Bind Scope bool_scope with bool.

Definition andb (b1 b2:bool) : bool := if b1 then b2 else false.

Definition orb (b1 b2:bool) : bool := if b1 then true else b2.

Definition implb (b1 b2:bool) : bool := if b1 then b2 else true.

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

Definition negb (b:bool) := if b then false else true.

Infix "||" := orb : bool_scope.
Infix "&&" := andb : bool_scope.

Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true.
Proof. hammer_hook "Datatypes" "Datatypes.andb_prop".
destruct a, b; repeat split; assumption.
Qed.
Hint Resolve andb_prop: bool.

Lemma andb_true_intro :
forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true.
Proof. hammer_hook "Datatypes" "Datatypes.andb_true_intro".
destruct b1; destruct b2; simpl; intros [? ?]; assumption.
Qed.
Hint Resolve andb_true_intro: bool.

Inductive eq_true : bool -> Prop := is_eq_true : eq_true true.

Hint Constructors eq_true : eq_true.

Definition is_true b := b = true.

Lemma eq_true_ind_r :
forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true.
Proof. hammer_hook "Datatypes" "Datatypes.eq_true_ind_r".
intros P b H H0; destruct H0 in H; assumption.
Defined.

Lemma eq_true_rec_r :
forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true.
Proof. hammer_hook "Datatypes" "Datatypes.eq_true_rec_r".
intros P b H H0; destruct H0 in H; assumption.
Defined.

Lemma eq_true_rect_r :
forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true.
Proof. hammer_hook "Datatypes" "Datatypes.eq_true_rect_r".
intros P b H H0; destruct H0 in H; assumption.
Defined.

Inductive BoolSpec (P Q : Prop) : bool -> Prop :=
| BoolSpecT : P -> BoolSpec P Q true
| BoolSpecF : Q -> BoolSpec P Q false.
Hint Constructors BoolSpec.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Delimit Scope nat_scope with nat.
Bind Scope nat_scope with nat.
Arguments S _%nat.

Inductive option (A:Type) : Type :=
| Some : A -> option A
| None : option A.

Arguments Some {A} a.
Arguments None {A}.

Definition option_map (A B:Type) (f:A->B) (o : option A) : option B :=
match o with
| Some a => @Some B (f a)
| None => @None B
end.

Inductive sum (A B:Type) : Type :=
| inl : A -> sum A B
| inr : B -> sum A B.

Notation "x + y" := (sum x y) : type_scope.

Arguments inl {A B} _ , [A] B _.
Arguments inr {A B} _ , A [B] _.

Inductive prod (A B:Type) : Type :=
pair : A -> B -> prod A B.

Add Printing Let prod.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.

Arguments pair {A B} _ _.

Section projections.
Context {A : Type} {B : Type}.

Definition fst (p:A * B) := match p with
| (x, y) => x
end.
Definition snd (p:A * B) := match p with
| (x, y) => y
end.
End projections.

Hint Resolve pair inl inr: core.

Lemma surjective_pairing :
forall (A B:Type) (p:A * B), p = pair (fst p) (snd p).
Proof. hammer_hook "Datatypes" "Datatypes.surjective_pairing".
destruct p; reflexivity.
Qed.

Lemma injective_projections :
forall (A B:Type) (p1 p2:A * B),
fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
Proof. hammer_hook "Datatypes" "Datatypes.injective_projections".
destruct p1; destruct p2; simpl; intros Hfst Hsnd.
rewrite Hfst; rewrite Hsnd; reflexivity.
Qed.

Definition prod_uncurry (A B C:Type) (f:prod A B -> C)
(x:A) (y:B) : C := f (pair x y).

Definition prod_curry (A B C:Type) (f:A -> B -> C)
(p:prod A B) : C := match p with
| pair x y => f x y
end.

Inductive list (A : Type) : Type :=
| nil : list A
| cons : A -> list A -> list A.

Arguments nil {A}.
Arguments cons {A} a l.
Infix "::" := cons (at level 60, right associativity) : list_scope.
Delimit Scope list_scope with list.
Bind Scope list_scope with list.

Local Open Scope list_scope.

Definition length (A : Type) : list A -> nat :=
fix length l :=
match l with
| nil => O
| _ :: l' => S (length l')
end.

Definition app (A : Type) : list A -> list A -> list A :=
fix app l m :=
match l with
| nil => m
| a :: l1 => a :: app l1 m
end.

Infix "++" := app (right associativity, at level 60) : list_scope.

Inductive comparison : Set :=
| Eq : comparison
| Lt : comparison
| Gt : comparison.

Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'.
Proof. hammer_hook "Datatypes" "Datatypes.comparison_eq_stable".
destruct c, c'; intro H; reflexivity || destruct H; discriminate.
Qed.

Definition CompOpp (r:comparison) :=
match r with
| Eq => Eq
| Lt => Gt
| Gt => Lt
end.

Lemma CompOpp_involutive : forall c, CompOpp (CompOpp c) = c.
Proof. hammer_hook "Datatypes" "Datatypes.CompOpp_involutive".
destruct c; reflexivity.
Qed.

Lemma CompOpp_inj : forall c c', CompOpp c = CompOpp c' -> c = c'.
Proof. hammer_hook "Datatypes" "Datatypes.CompOpp_inj".
destruct c; destruct c'; auto; discriminate.
Qed.

Lemma CompOpp_iff : forall c c', CompOpp c = c' <-> c = CompOpp c'.
Proof. hammer_hook "Datatypes" "Datatypes.CompOpp_iff".
split; intros; apply CompOpp_inj; rewrite CompOpp_involutive; auto.
Qed.

Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop :=
| CompEq : Peq -> CompareSpec Peq Plt Pgt Eq
| CompLt : Plt -> CompareSpec Peq Plt Pgt Lt
| CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt.
Hint Constructors CompareSpec.

Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type :=
| CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq
| CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt
| CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt.
Hint Constructors CompareSpecT.

Lemma CompareSpec2Type : forall Peq Plt Pgt c,
CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c.
Proof. hammer_hook "Datatypes" "Datatypes.CompareSpec2Type".
destruct c; intros H; constructor; inversion_clear H; auto.
Defined.

Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop :=
CompareSpec (eq x y) (lt x y) (lt y x).

Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type :=
CompareSpecT (eq x y) (lt x y) (lt y x).
Hint Unfold CompSpec CompSpecT.

Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c,
CompSpec eq lt x y c -> CompSpecT eq lt x y c.
Proof. hammer_hook "Datatypes" "Datatypes.CompSpec2Type".   intros. apply CompareSpec2Type; assumption. Defined.

Inductive identity (A:Type) (a:A) : A -> Type :=
identity_refl : identity a a.
Hint Resolve identity_refl: core.

Arguments identity_ind [A] a P f y i.
Arguments identity_rec [A] a P f y i.
Arguments identity_rect [A] a P f y i.

Definition ID := forall A:Type, A -> A.
Definition id : ID := fun A x => x.

Definition IDProp := forall A:Prop, A -> A.
Definition idProp : IDProp := fun A x => x.

Notation prodT := prod (compat "8.2").
Notation pairT := pair (compat "8.2").
Notation prodT_rect := prod_rect (compat "8.2").
Notation prodT_rec := prod_rec (compat "8.2").
Notation prodT_ind := prod_ind (compat "8.2").
Notation fstT := fst (compat "8.2").
Notation sndT := snd (compat "8.2").
Notation prodT_uncurry := prod_uncurry (compat "8.2").
Notation prodT_curry := prod_curry (compat "8.2").


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2011-01-18

finite graphs
*)

From Coq Require Import OrderedType.
From CoLoR Require Import ListUtil FSetUtil FMapUtil RelUtil LogicUtil.

Set Implicit Arguments.

Module Make (XSet : FSetInterface.S)
       (XMap : FMapInterface.S with Module E := XSet.E).

  Module Export S := FSetUtil.Make XSet.
  Module Export M := FMapUtil.Make XMap.

  Module R := RelUtil.
  Module Import X := E.

  Lemma eq_com x y : eq x y <-> eq y x.

  Proof. firstorder auto with crelations. Qed.

(***********************************************************************)
(** A finite graph on X.t is represented by its successor map: a
finite map from X.t to the type of finite sets on X.t. Since an
element can be mapped to the empty set, this representation is not
unique and the setoid equality on maps based on the setoid equality on
sets (meq) does not identify a map with no mapping for x and a map
mapping x to the empty set. We therefore have to consider another
equivalence (geq). We will consider that two graphs are equivalent if
they define the same relation. See below for more details. *)

  Definition graph := XMap.t XSet.t.

  Implicit Type g h : graph.

  Definition meq : relation graph := XMap.Equiv XSet.Equal.

  Global Instance Equal_meq : subrelation Equal meq.

  Proof. intros g h gh. apply Equal_Equiv with (eq:=XSet.Equal) in gh; fo. Qed.

(***********************************************************************)
(** relation corresponding to a graph *)

  (*COQ: necessary to define rel (hereafter) as a coercion *)
  SubClass relation_on_X := relation X.t.

  Definition rel g : relation_on_X :=
    fun x y => exists s, find x g = Some s /\ XSet.In y s.

  Coercion rel : graph >-> relation_on_X.

  Lemma rel_empty : rel empty == empty_rel.

  Proof.
    rewrite rel_eq; intros a b. unfold empty_rel. split_all.
    destruct H as [sa [a1 a2]]. rewrite <- find_mapsto_iff in a1.
    rewrite empty_mapsto_iff in a1. hyp.
  Qed.

  Global Instance rel_meq_ext' : Proper (meq ==> eq ==> eq ==> impl) rel.

  Proof.
    intros g g' gg' x x' xx' y y' yy'. unfold impl, rel. intro h.
    destruct h as [sx [hx hy]].
    destruct (Equiv_find_Some gg' hx) as [sx' [h1 h2]].
    exists sx'. rewrite <- yy'. rewrite <- h2 at 2. split_all.
    (*SLOW:rewrite <- xx'.*) rewrite <- h1. apply find_o. hyp.
  Qed.

  (*COQ: can be removed? Coq stuck in In_preds_rel *)
  Global Instance rel_meq_ext : Proper (meq ==> eq ==> eq ==> iff) rel.

  Proof.
    intros g g' gg' x x' xx' y y' yy'. split; intro h.
    rewrite  <- gg', <- xx', <- yy'. hyp.
    rewrite  gg', xx', yy'. hyp.
  Qed.

  Lemma find_Some_rel {g x s} : find x g = Some s ->
    XSet.is_empty s = false -> exists y, rel g x y.

  Proof.
    intros hx hs. destruct (choose_mem_3 _ hs) as [y [h1 h2]].
    rewrite <- mem_iff in h2. ex y s. tauto.
  Qed.

(***********************************************************************)
(** singleton relation *)

  Definition id x y a b := eq a x /\ eq b y.

(***********************************************************************)
(** relation defined by an element and a set of successors *)

  Definition succ x s a b := eq a x /\ XSet.In b s.

  Global Instance succ_m_ext' : Proper (eq ==> XSet.Equal ==> eq ==> eq ==> impl) succ.

  Proof.
    intros x x' xx' s s' ss' a a' aa' b b' bb'. unfold succ.
    rewrite xx', ss', aa', bb'. refl.
  Qed.

  (*COQ: can be removed? used in rel_set_fold_add_edge *)
  Global Instance succ_m' : Proper (eq ==> XSet.Equal ==> inclusion) succ.

  Proof.
    intros x x' xx' s s' ss' a b. unfold succ. rewrite xx', ss'. tauto.
  Qed.

  (*COQ: can be removed? used in rel_set_fold_add_edge *)
  Global Instance succ_m : Proper (eq ==> XSet.Equal ==> same) succ.

  Proof.
    intros x x' xx' s s' ss'. split.
    rewrite xx', ss'. refl. rewrite <- xx', <- ss'. refl.
  Qed.

  Lemma succ_empty : forall x, succ x XSet.empty == empty_rel.

  Proof.
    intro x. rewrite rel_eq; intros a b. unfold succ, empty_rel. split_all.
    revert H0. set_iff. auto.
  Qed.

  Lemma succ_add : forall x y s, succ x (XSet.add y s) == id x y U succ x s.

  Proof.
    intros x y s. apply rel_eq; intros a b.
    unfold Relation_Operators.union, succ, id. rewrite add_iff. firstorder auto with crelations.
  Qed.

  Lemma rel_add : forall x g s, ~In x g -> rel (add x s g) == succ x s U g.

  Proof.
    intros x g s n. rewrite rel_eq; intros a b.
    unfold Relation_Operators.union. split.
    (* -> *)
    intros [t [t1 t2]]. rewrite add_o in t1. destruct (eq_dec x a).
    inversion t1. subst t. firstorder auto with crelations.
    right. exists t. tauto.
    (* <- *)
    intros [ab|ab]. exists s. unfold succ in ab. split_all. rewrite add_o.
    destruct (eq_dec x a). refl. absurd (eq x a); hyp.
    destruct ab as [t [t1 t2]]. exists t. split_all. rewrite add_o.
    destruct (eq_dec x a). 2: hyp. absurd (In x g). hyp. rewrite e.
    exists t. change (MapsTo a t g). rewrite find_mapsto_iff. hyp.
  Qed.

(***********************************************************************)
(** relation defined by an element and a list of successors *)

  Definition succ_list x s a (b : X.t) := eq a x /\ InA eq b s.

  Global Instance succ_list_m_ext' :
    Proper (eq ==> eqlistA eq ==> eq ==> eq ==> impl) succ_list.

  Proof.
    intros x x' xx' s s' ss' a a' aa' b b' bb'. unfold succ_list.
    (*SLOW*)rewrite xx', ss', aa', bb'. refl.
  Qed.

  Lemma succ_list_nil : forall x, succ_list x nil == empty_rel.

  Proof.
    intro x. rewrite rel_eq; intros a b. unfold succ_list, empty_rel.
    split_all. inversion H0.
  Qed.

  Lemma succ_list_cons : forall x y l,
    succ_list x (y :: l) == id x y U succ_list x l.

  Proof.
    intros x y l. apply rel_eq; intros a b.
    unfold Relation_Operators.union, succ_list, id. rewrite InA_cons. fo.
  Qed.

(***********************************************************************)
(** product relation *)

  Definition prod s t a b := XSet.In a s /\ XSet.In b t.

  Lemma prod_m_ext :
    Proper (XSet.Equal ==> XSet.Equal ==> eq ==> eq ==> iff) prod.

  Proof.
    intros s s' ss' t t' tt' a a' aa' b b' bb'. unfold prod.
    rewrite ss', tt', aa', bb'. refl.
  Qed.

(***********************************************************************)
(** ordering on graphs: [g] is smaller than [g'] if [rel g] is
included in [rel g'] *)

  Definition gle g h := g << h.

  Global Instance gle_PreOrder : PreOrder gle.

  Proof. fo. Qed.

  Lemma empty_gle : forall g, rel empty << g.

  Proof. intro g. rewrite rel_empty. fo. Qed.

(***********************************************************************)
(** equality on graphs: two graphs are equivalent if they define the
same relation *)

  Definition geq g h := g == h.

  Global Instance geq_Equivalence : Equivalence geq.

  Proof. fo. Qed.

  Lemma meq_geq : meq << geq.

  Proof.
    intros g h gh. split; intros x y xy. rewrite <- gh. hyp. rewrite gh. hyp.
  Qed.

  Global Instance geq_meq : Proper (meq ==> meq ==> iff) geq.

  Proof.
    intros g g' gg' h h' hh'. apply meq_geq in gg'. apply meq_geq in hh'.
    split; intro H. rewrite <- gg', <- hh'. hyp. rewrite gg', hh'. hyp.
  Qed.

  Global Instance geq_Equal : Proper (Equal ==> Equal ==> iff) geq.

  Proof.
    eapply prop2_incl. 4: apply geq_meq.
    apply Equal_meq. apply Equal_meq. refl.
  Qed.

  Lemma Equal_geq : Equal << geq.

  Proof. trans meq. apply Equal_meq. apply meq_geq. Qed.

(***********************************************************************)
(** relations between gle and geq *)

  Lemma gle_antisym : forall g h, geq g h <-> (gle g h /\ gle h g).

  Proof. fo. Qed.

  Global Instance gle_geq' : Proper (geq ==> geq ==> impl) gle.

  Proof.
    intros g g' gg' h h' hh'. rewrite gle_antisym in gg', hh'. unfold impl.
    intuition. trans g. hyp. trans h. hyp. hyp.
  Qed.

(***********************************************************************)
(** properties of rel *)

  Global Instance rel_gle_ext : Proper (gle ==> eq ==> eq ==> impl) rel.

  Proof.
    intros g g' gg' x x' xx' y y' yy' [s [s1 s2]]. apply gg'. exists s.
    (*SLOW:rewrite <- xx', <- yy'. tauto.*) split.
    rewrite <- s1. apply find_o. hyp. rewrite <- yy'. hyp.
  Qed.

  (*COQ: can be removed? used in TransClos *)
  Global Instance rel_geq_ext' : Proper (geq ==> eq ==> eq ==> impl) rel.

  Proof.
    intros g g' gg' x x' xx' y y' yy' [s [s1 s2]]. apply gg'. exists s.
    (*SLOW:rewrite <- xx', <- yy'. tauto.*) split.
    rewrite <- s1. apply find_o. hyp. rewrite <- yy'. hyp.
  Qed.

(***********************************************************************)
(** successors of a node *)

  Definition succs x g :=
    match find x g with
      | Some s => s
      | None => XSet.empty
    end.

  Lemma In_succs_rel : forall g x y, XSet.In y (succs x g) <-> rel g x y.

  Proof.
    intros. unfold succs, rel. destruct (find x g) as [t|]; split_all.
    ex t. tauto. inversion H. hyp. revert H. set_iff. tauto. discr.
  Qed.

  Lemma mem_succs_rel : forall g x y,
    XSet.mem y (succs x g) = true <-> rel g x y.

  Proof. intros. rewrite <- mem_iff. apply In_succs_rel. Qed.

  Lemma succs_empty : forall x, succs x empty = XSet.empty.

  Proof. intro x. unfold succs. rewrite find_empty. refl. Qed.

  Lemma succs_add : forall x y s g,
    succs x (add y s g) = if eq_dec y x then s else succs x g.

  Proof.
    intros x y s g. unfold succs at 1. rewrite add_o.
    destruct (eq_dec y x); refl.
  Qed.

  Lemma succs_add_id : forall x s g, succs x (add x s g) = s.

  Proof. intros x s g. unfold succs. rewrite add_eq_o. refl. refl. Qed.

  Global Instance succs_gle : Proper (eq ==> gle ==> XSet.Subset) succs.

  Proof.
    intros x x' xx' g g' gg'. unfold succs. rewrite <- xx'. clear x' xx'.
    destruct (find x g) as [t|] eqn:H; destruct (find x g') as [t0|] eqn:H0.
    (* find x g = Some t0, find x g' = Some t1 *)
    intros y hy.
    assert (xy : rel g x y). exists t. intuition. rewrite gg' in xy.
    destruct xy as [s [s1 s2]]. rewrite H0 in s1. inversion s1. subst t0. hyp.
    (* find x g = Some t0, find x g' = None *)
    case_eq (XSet.is_empty t); intros.
    rewrite is_empty_eq in H1. rewrite H1. refl.
    destruct (find_Some_rel H H1) as [y hy]. rewrite gg' in hy.
    destruct hy as [s [s1 s2]]. rewrite H0 in s1. discr.
    (* find x g = None, find x g' = Some t0 *)
    intro; set_iff; intuition.
    (* find x g = None, find x g' = None *)
    refl.
  Qed.

  (*COQ: can be removed? used in geq_add_remove *)
  Global Instance succs_geq : Proper (eq ==> geq ==> XSet.Equal) succs.

  Proof.
    intros x x' xx' g g' gg'. rewrite gle_antisym in gg'.
    destruct gg' as [gg' g'g]. rewrite Subset_antisym. split.
    rewrite xx', gg'. refl. (*SLOW:rewrite xx', g'g. refl.*)
    apply succs_gle; hyp.
  Qed.

  Lemma mem_succs_id : forall g x y,
    XSet.mem y (succs x g) = true -> g U id x y == g.

  Proof.
    intros g x y h. split. rewrite union_incl_eq. split. refl.
    intros a b [xa yb]. rewrite xa, yb. rewrite <- mem_succs_rel. hyp.
    apply incl_union_l. refl.
  Qed.

(***********************************************************************)
(** g is smaller then g' iff the successors of g are included in the
successors of g' *)

  Lemma gle_succs : forall g g',
    gle g g' <-> forall x, succs x g [<=] succs x g'.

  Proof.
    intros g g'. split.
    intros gg' x. rewrite gg'. refl.
    intro h. intros x y. rewrite <- !In_succs_rel.
    rewrite (h x). auto.
  Qed.

(***********************************************************************)
(** two graphs are equivalent iff they have the same successors *)

  Lemma geq_succs : forall g g',
    geq g g' <-> forall x, succs x g [=] succs x g'.

  Proof. intros g g'. rewrite gle_antisym. rewrite !gle_succs. fo. Qed.

(***********************************************************************)
(** properties of geq wrt add *)

  Lemma geq_add_remove : forall y s g g', ~In y g -> geq (add y s g) g' ->
    geq g (if XSet.is_empty s then g' else remove y g').

  Proof.
    intros y s g g' n e. case_eq (XSet.is_empty s); intros.
    (* s empty *)
    rewrite geq_succs; intro z. rewrite <- e. rewrite succs_add.
    destruct (eq_dec y z). 2: refl. rewrite <- e0. unfold succs.
    rewrite not_find_in_iff in n. rewrite n. sym. apply is_empty_eq. hyp.
    (* s not empty *)
    rewrite geq_succs; intro z. unfold succs at 2. rewrite remove_o.
    case_eq (eq_dec y z); intros.
    rewrite <- e0. unfold succs. rewrite not_find_in_iff in n. rewrite n. refl.
    fold (succs z g'). trans (succs z (add y s g)).
    rewrite succs_add. rewrite H0. refl. rewrite e. refl.
  Qed.

  Lemma geq_add : forall y s g g', ~In y g -> geq (add y s g) g' ->
    if XSet.is_empty s then geq g' g else Add y (succs y g') (remove y g') g'.

  Proof.
    intros y s g g' n e. case_eq (XSet.is_empty s); intros.
    (* s empty *)
    rewrite geq_succs; intro z. rewrite <- e. rewrite succs_add.
    destruct (eq_dec y z). 2: refl.
    rewrite <- e0. unfold succs. rewrite not_find_in_iff in n. rewrite n.
    apply is_empty_eq. hyp.
    (* s not empty *)
    unfold Add. intro z. rewrite add_o. case_eq (eq_dec y z); intros.
    (* y = z *)
    unfold succs. (*SLOW*)rewrite e0. case_eq (find z g'); intros. refl.
    rewrite geq_succs in e. ded (e y). rewrite succs_add_id in H2.
    rewrite e0 in H2. unfold succs in H2. rewrite H1 in H2.
    rewrite <- is_empty_eq in H2. rewrite H in H2. discr.
    (* y <> z *)
    rewrite remove_o. rewrite H0. refl.
  Qed.

(***********************************************************************)
(** predecessors of a node *)

  Definition preds_aux x y sy s := if XSet.mem x sy then XSet.add y s else s.

  Global Instance preds_aux_m :
    Proper (eq ==> eq ==> XSet.Equal ==> XSet.Equal ==> XSet.Equal) preds_aux.

  Proof.
    intros x x' xx' y y' yy' s s' ss' t t' tt'. unfold preds_aux.
    rewrite xx', ss'. destruct (XSet.mem x' s'). rewrite yy', tt'. refl. hyp.
  Qed.

  (*COQ: can be removed? apply preds_aux_m doesn't work in some cases *)
  Global Instance preds_aux_m' :
    Proper (Logic.eq ==> eq ==> Logic.eq ==> XSet.Equal ==> XSet.Equal)
    preds_aux.

  Proof.
    eapply prop4_incl. 6: apply preds_aux_m.
    apply eq_incl_refl_rel. class.
    refl.
    apply eq_incl_refl_rel. class.
    refl.
    refl.
  Qed.

  Lemma preds_aux_transp : forall x, transpose_neqkey XSet.Equal (preds_aux x).

  Proof.
    unfold transpose_neqkey. intros x y z s t u n. unfold preds_aux.
    destruct (XSet.mem x s); destruct (XSet.mem x t); try refl.
    apply XSetProps.add_add.
  Qed.

  Definition preds x g := fold (preds_aux x) g XSet.empty.

  Global Instance preds_Equal : Proper (eq ==> Equal ==> XSet.Equal) preds.

  Proof.
    intros x x' xx' g g' gg'. unfold preds.
    apply fold_Equiv_ext with (eq := XSet.Equal). fo. fo.
    apply preds_aux_m. refl. apply preds_aux_transp.
    apply preds_aux_m. hyp. apply Equal_Equiv. fo. hyp. refl.
  Qed.

  Lemma preds_empty : forall x, preds x empty [=] XSet.empty.

  Proof. intro x. unfold preds. rewrite fold_empty. refl. Qed.

  Lemma preds_add : forall x y s g, ~In y g -> preds x (add y s g)
    [=] if XSet.mem x s then XSet.add y (preds x g) else preds x g.

  Proof.
    intros x y s g nyg. unfold preds. rewrite fold_add. refl. fo.
    apply preds_aux_m'. refl. apply preds_aux_transp. hyp.
  Qed.

  Lemma preds_geq_empty : forall x g,
    geq g empty -> preds x g [=] XSet.empty.

  Proof.
    intros x g. pattern g; apply map_induction_bis; clear g.
    (* Equal *)
    intros m m' mm' h hm'. rewrite <- mm'. apply h. rewrite mm'. hyp.
    (* empty *)
    intros _. unfold preds. rewrite fold_empty. refl.
    (* add *)
    intros y s g n h e. rewrite preds_add. 2: hyp.
    case_eq (XSet.mem x s); intros.
    (* x in s *)
    ded (geq_add n e). rewrite (mem_is_empty H) in H0. ded (H0 y).
    rewrite empty_o, succs_empty, add_o in H1.
    destruct (eq_dec y y). discr. absurd (eq y y). hyp. refl.
    (* x not in s *)
    apply h. ded (geq_add_remove n e). rewrite H0. destruct (XSet.is_empty s).
    refl. rewrite remove_empty. refl.
  Qed.

  Global Instance preds_geq : Proper (eq ==> geq ==> XSet.Equal) preds.

  Proof.
    intros x x' xx' g; revert x x' xx'.
    pattern g; apply map_induction_bis; clear g.
    (* [=] *)
    intros m m' mm' hm x x' xx' g m'g. apply Equal_geq in mm'.
    trans (preds x m).
    sym. apply hm. refl. hyp.
    apply hm. hyp. trans m'; hyp.
    (* empty *)
    intros x x' xx' g hg. rewrite preds_empty. sym. apply preds_geq_empty. hyp.
    (* add *)
    intros y s g n h x x' xx' g' e. unfold preds. rewrite fold_add.
    2: class. 2: apply preds_aux_m'. 2: refl. 2: apply preds_aux_transp.
    2: hyp. fold (preds x g). fold (preds x' g'). ded (geq_add_remove n e).
    revert H. case_eq (XSet.is_empty s); intros; unfold preds_aux.
    (* s empty *)
    rewrite mem_3. apply h; hyp. rewrite <- XSetFacts.is_empty_iff in H.
    apply H.
    (* s not empty *)
    ded (geq_add n e). rewrite H in H1. unfold preds at 3. rewrite fold_Add.
    6: apply H1. 2: class. 2: apply preds_aux_m'. 2: refl.
    2: apply preds_aux_transp.
    2:{rewrite remove_in_iff. intros [h1 h2]. absurd (eq y y). hyp. refl. }
    fold (preds x' (remove y g')). unfold preds_aux. rewrite <- xx'.
    rewrite <- e at 1. rewrite succs_add_id. destruct (XSet.mem x s).
    rewrite <- xx'. apply XSetFacts.add_m. refl. apply h. refl. hyp.
    apply h. hyp. hyp.
  Qed.

  Lemma In_preds_rel : forall x y g, XSet.In x (preds y g) <-> rel g x y.

  Proof.
    intros x y g. pattern g; apply map_induction_bis; clear g.
    (* Equal *)
    intros m m' mm' h. (*SLOW*)rewrite <- mm'. hyp.
    (* empty *)
    rewrite preds_empty. split. intro h. revert h. set_iff. tauto.
    intros [s [s1 s2]]. rewrite empty_o in s1. discr.
    (* add *)
    intros z s g n h. rewrite preds_add. 2: hyp.
    case_eq (XSet.mem y s); intros.
    (* y in s *)
    rewrite add_iff. rewrite h. split.
    (* -> *)
    intros [h'|h']. exists s. rewrite add_eq_o. rewrite mem_iff. intuition. hyp.
    destruct h' as [t [t1 t2]]. exists t. rewrite add_o. destruct (eq_dec z x).
    (*SLOW*)rewrite not_find_in_iff, e in n. rewrite n in t1. discr. tauto.
    (* <- *)
    intros [t [t1 t2]]. rewrite add_o in t1. destruct (eq_dec z x). auto.
    right. exists t. tauto.
    (* y not in s *)
    rewrite h. split.
    (* -> *)
    intros [t [t1 t2]]. exists t. rewrite add_o. destruct (eq_dec z x).
    (*SLOW*)rewrite not_find_in_iff, e in n. rewrite n in t1. discr. tauto.
    (* <- *)
    intros [t [t1 t2]]. rewrite add_o in t1. destruct (eq_dec z x).
    inversion t1. subst t. rewrite XSetFacts.mem_iff in t2. rewrite H in t2.
    discr.
    exists t. tauto.
  Qed.

  Lemma prod_add_incl_tc_id : forall x y g,
    prod (XSet.add x (preds x g)) (XSet.add y (succs y g)) << (g U id x y)!.

  Proof.
    intros x y g a b. unfold prod. rewrite !add_iff.
    rewrite In_preds_rel, In_succs_rel. split_all.
    (* eq x a /\ eq y b *)
    apply t_step. firstorder auto with crelations.
    (* g a x /\ eq y b *)
    apply t_trans with x; apply t_step; firstorder auto with crelations.
    (* eq x a /\ g y b *)
    apply t_trans with y; apply t_step; firstorder auto with crelations.
    (* g a x /\ g y b *)
    apply t_trans with x. firstorder auto with sets.
    apply t_trans with y; apply t_step; firstorder auto with crelations.
  Qed.

(***********************************************************************)
(** add an edge into a graph *)

  Definition add_edge x y g : graph := add x (XSet.add y (succs x g)) g.

  Global Instance add_edge_gle : Proper (eq ==> eq ==> gle ==> gle) add_edge.

  Proof.
    intros x x' xx' y y' yy' g g' gg'. unfold add_edge.
    rewrite gle_succs. intro z. rewrite !succs_add.
    destruct (eq_dec x z); destruct (eq_dec x' z).
    rewrite xx', yy', gg'. refl.
    rewrite xx' in e. contr. rewrite xx' in n. contr.
    rewrite gg'. refl.
  Qed.

  (*COQ: can be removed? used in TransClos*)
  Global Instance add_edge_geq : Proper (eq ==> eq ==> geq ==> geq) add_edge.

  Proof.
    intros x x' xx' y y' yy' g g' gg'. rewrite gle_antisym.
    rewrite gle_antisym in gg'. destruct gg' as [gg' g'g]. split.
    (*SLOW:rewrite xx', yy', gg'. refl.*) apply add_edge_gle; hyp.
    (*SLOW:rewrite <- xx', <- yy', g'g. refl.*) apply add_edge_gle; hyp.
  Qed.

  Lemma rel_add_edge : forall x y g, add_edge x y g == g U id x y.

  Proof.
    intros. rewrite rel_eq; intros a b.
    unfold add_edge, Relation_Operators.union, id. split_all.
    destruct H as [sa [a1 a2]]. rewrite add_o in a1. destruct (eq_dec x a).
    inversion a1. subst sa. rewrite add_iff in a2. rewrite In_succs_rel in a2.
    rewrite e in a2. split_all. auto with ordered_type.
    left. exists sa. tauto.
    destruct H as [sa [a1 a2]]. unfold rel. rewrite add_o.
    destruct (eq_dec x a).
    exists (XSet.add y (succs x g)). split_all. rewrite add_iff. right.
    rewrite e, In_succs_rel. exists sa. auto.
    exists sa. auto.
    unfold rel. rewrite add_o. destruct (eq_dec x a).
    exists (XSet.add y (succs x g)). split_all. rewrite add_iff. auto with ordered_type.
    absurd (eq x a); hyp.
  Qed.

  Lemma add_edge_transp_geq : forall x, transpose geq (add_edge x).

  Proof.
    intros x y z g. unfold geq. rewrite !rel_add_edge.
    unfold same, inclusion, id, Relation_Operators.union. tauto.
  Qed.

(***********************************************************************)
(** set iteration of (add_edge x) *)

  Lemma rel_set_fold_add_edge : forall x s g0,
    XSet.fold (add_edge x) s g0 == succ x s U g0.

  Proof.
    intros x s g0. pattern (XSet.fold (add_edge x) s g0).
    apply XSetProps.fold_rec_weak; clear s.
    (* [=] *)
    intros s t g st i. rewrite <- st. hyp.
    (* empty *)
    rewrite succ_empty. rewrite R.union_empty_l. refl.
    (* add *)
    intros z g s nzs e. rewrite rel_add_edge. rewrite e.
    rewrite R.union_assoc. rewrite union_commut with (R:=rel g0).
    rewrite <- R.union_assoc. apply R.union_same. 2: refl.
    rewrite rel_eq; intros a b. unfold succ, Relation_Operators.union, id.
    rewrite add_iff, (eq_com b z). tauto.
  Qed.

  (*COQ: can we remove this lemma? *)
  Lemma rel_set_fold_add_edge_ext : forall x s g0 a b,
    rel (XSet.fold (add_edge x) s g0) a b <-> succ x s a b \/ rel g0 a b.

  Proof.
    split; intro h. apply rel_set_fold_add_edge in h. hyp.
    apply rel_set_fold_add_edge. hyp.
  Qed.

(***********************************************************************)
(** list iteration of (add_edge x) *)

  Definition add_edge' x g y := add_edge x y g.

  Lemma rel_list_fold_left_add_edge : forall x l g0,
    fold_left (add_edge' x) l g0 == succ_list x l U g0.

  Proof.
    induction l; simpl; intro g. rewrite succ_list_nil, R.union_empty_l. refl.
    rewrite IHl, succ_list_cons. unfold add_edge'. rewrite rel_add_edge.
    rewrite union_commut with (R:=rel g). rewrite <- R.union_assoc.
    rewrite union_commut with (R:=id x a). refl.
  Qed.

(***********************************************************************)
(** building graphs by list iteration *)

  Section list_fold_left.

    Variables (A : Type) (F : graph -> A -> graph)
      (hF : forall g a, F g a == F empty a U g).

    Lemma rel_list_fold_left : forall l g x y, rel (fold_left F l g) x y
      <-> (rel g x y \/ exists a, List.In a l /\ rel (F empty a) x y).

    Proof.
      induction l; simpl. fo. intros g x y. rewrite IHl. split_all.
      apply hF in H. destruct H. right. exists a. tauto. tauto.
      right. exists x0. tauto.
      left. apply hF. right. hyp.
      subst x0. left. apply hF. left. hyp.
      right. exists x0. tauto.
    Qed.

  End list_fold_left.

End Make.


Require Import Setoid.

From Typonomikon Require Import F3.

(** Rozwiązanie:
    - https://github.com/agda/agda-stdlib/blob/master/src/Codata/Guarded/Stream/Relation/Binary/Pointwise.agda
    - https://www.cse.chalmers.se/~nad/publications/danielsson-productivity.pdf
*)

Module FirstTry.

Variant BisimCF (F : conat -> conat -> Prop) : NatF conat -> NatF conat -> Prop :=
| BisimC_Z : BisimCF F Z Z
| BisimC_S : forall n1 n2 : conat, F n1 n2 -> BisimCF F (S n1) (S n2)
| BisimC_comm :
    forall n1 n2 : conat,
      BisimCF F (out (add n1 n2)) (out (add n2 n1)).

CoInductive BisimC (n1 n2 : conat) : Prop :=
{
  BisimC_out : BisimCF BisimC (out n1) (out n2);
}.

Lemma from_sim :
  forall n1 n2 : conat,
    sim n1 n2 -> BisimC n1 n2.
Proof.
  cofix CH.
  intros n1 n2 [H].
  constructor.
  inversion H; constructor.
  now apply CH.
Qed.

Lemma BisimC_add_comm :
  forall n1 n2 : conat,
    BisimC (add n1 n2) (add n2 n1).
Proof.
  do 2 constructor.
Qed.

#[export]
Instance Equivalence_BisimC : Equivalence BisimC.
Proof.
  split; red.
  - cofix CH.
    constructor.
    destruct (out x); constructor.
    now apply CH.
  - cofix CH.
    intros n1 n2 [H].
    constructor.
    inversion H.
    + now constructor.
    + constructor.
      now apply CH.
    + cbn in *.
      destruct (out n0) as [| n0'] eqn: Heq0,
               (out n3) as [| n3'] eqn: Heq3;
        constructor.
      * apply from_sim.
        now rewrite add_zero_r'.
      * apply from_sim.
        now rewrite add_zero_r'.
      * admit.
  -
Admitted.

Lemma BisimC_trans :
  forall a b c : conat,
    BisimC a b -> BisimC b c -> BisimC a c.
Proof.
  cofix CH.
  intros a b c [ab] [bc].
  constructor.
  inversion ab; inversion bc.
  - now constructor.
  - now congruence.
  - now congruence.
  - now congruence.
  - constructor.
    eapply CH with n2; [easy |].
    now congruence.
  - cbn in *.
    destruct (out n3) as [| n3'] eqn: Heq.
    + rewrite H4 in H3.
      destruct (out c) as [| c'] eqn: Heqc.
      * now congruence.
      * rewrite H4.
        constructor.
        admit.
    + constructor.
Admitted.

Lemma BisimC_Bisim :
  forall n1 n2 : conat,
    BisimC n1 n2 -> sim n1 n2.
Proof.
  cofix CH.
  intros n1 n2 [H].
  constructor.
  inversion H.
  - now constructor.
  - now constructor; apply CH.
  - cbn in *.
    destruct (out n0) as [| n0'] eqn: Heq0,
             (out n3) as [| n3'] eqn: Heq3.
    + now constructor.
    + constructor.
      now rewrite add_zero_r'.
    + constructor.
      now rewrite add_zero_r'.
    + constructor.
      apply CH.
      rewrite (BisimC_add_comm n0'), (BisimC_add_comm n3').
      constructor; cbn.
      rewrite Heq0, Heq3.
      constructor.
      do 2 constructor.
Qed.

End FirstTry.

Module SecondTry.

Variant BisimCF (F : conat -> conat -> Prop) : NatF conat -> NatF conat -> Prop :=
| BisimCF_Z : BisimCF F Z Z
| BisimCF_S : forall n1 n2 : conat, F n1 n2 -> BisimCF F (S n1) (S n2)
| BisimCF_comm :
    forall n1 n2 n2' n n' : conat,
      out n2 = S n2' -> out n = S n' ->
        F (add n1 n2') n' -> BisimCF F (out (add n1 n2)) (out n).

CoInductive BisimC (n1 n2 : conat) : Prop :=
{
  BisimC_out : BisimCF BisimC (out n1) (out n2);
}.

Lemma from_sim :
  forall n1 n2 : conat,
    sim n1 n2 -> BisimC n1 n2.
Proof.
  cofix CH.
  intros n1 n2 [H].
  constructor.
  inversion H; constructor.
  now apply CH.
Qed.

Lemma BisimC_add_comm :
  forall n1 n2 : conat,
    BisimC (add n1 n2) (add n2 n1).
Proof.
  cofix CH.
  constructor; cbn.
  destruct (out n1) as [| n1'] eqn: Heq1,
           (out n2) as [| n2'] eqn: Heq2;
    constructor.
  - apply from_sim.
    now rewrite add_zero_r'.
  - apply from_sim.
    now rewrite add_zero_r'.
  - constructor.

Admitted.

#[export]
Instance Equivalence_BisimC : Equivalence BisimC.
Proof.
  split; red.
  - cofix CH.
    constructor.
    destruct (out x); constructor.
    now apply CH.
  - cofix CH.
    intros n1 n2 [H].
    constructor.
    inversion H.
    + now constructor.
    + constructor.
      now apply CH.
Admitted.
(*
    + econstructor 3; [eassumption.. |].
      now apply CH.
  - cofix CH.
    intros a b c [ab] [bc].
    constructor.
    inversion ab; inversion bc.
    + now constructor.
    + now congruence.
    + now congruence.
    + now congruence.
    + constructor.
      eapply CH with n2; [easy |].
      now congruence.
    +
 cbn in *.
      destruct (out n3) as [| n3'] eqn: Heq.
      + rewrite H4 in H3.
        destruct (out c) as [| c'] eqn: Heqc.
        * now congruence.
        * rewrite H4.
          constructor.
          admit.
   cbn in *.
        destruct (out n0) as [| n0'] eqn: Heq0,
                 (out n3) as [| n3'] eqn: Heq3;
          constructor.
        * apply from_sim.
          now rewrite add_zero_r'.
        * apply from_sim.
          now rewrite add_zero_r'.
        *
Admitted.
*)

Lemma BisimC_Bisim :
  forall n1 n2 : conat,
    BisimC n1 n2 -> sim n1 n2.
Proof.
  cofix CH.
  intros n1 n2 [H].
  constructor.
  inversion H.
  - now constructor.
  - now constructor; apply CH.
  - cbn in *.
    destruct (out n0) as [| n0'] eqn: Heq0,
             (out n3) as [| n3'] eqn: Heq3.
Admitted.
(*
    + now constructor.
    + constructor.
      now rewrite add_zero_r'.
    + constructor.
      now rewrite add_zero_r'.
    + constructor.
      apply CH.
Admitted.
*)

End SecondTry.


Require Import Undecidability.CFG.CFG.

From Undecidability.CFG.Reductions Require
  CFPP_to_CFP CFPI_to_CFI.

Require Import Undecidability.Synthetic.Undecidability.

Require Undecidability.CFG.CFP_undec.

(* The Context-free Palindrome Problem is undecidable. *)
Lemma CFP_undec : undecidable CFP.
Proof.
  eapply undecidability_from_reducibility.
  exact CFP_undec.CFPP_undec.
  exact CFPP_to_CFP.reduction.
Qed.

Check CFP_undec.

(* The Context-free Intersection Problem is undecidable. *)
Lemma CFI_undec : undecidable CFI.
Proof.
  eapply undecidability_from_reducibility.
  exact CFP_undec.CFPI_undec.
  exact CFPI_to_CFI.reduction.
Qed.

Check CFI_undec.


From mathcomp Require Import all_ssreflect all_algebra.
Require Export Field.
Require Import cells.
Require Import trials.
Require Import draw.

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

Check two_triangles.

Definition tt_events := Eval compute in
      match trials.seq_nat_to_edges two_triangles with
      | Some v => edges_to_events v
      | _ => nil
      end.

Compute tt_events.

Check start.

Lemma scan_eq events open_cells closed_cells:
  scan events open_cells closed_cells =
      match events with
      | [::] => closed_cells
      | e::q => let (open, closed) := (step e open_cells closed_cells) in  scan q open closed
 end.
Proof.  by case: events. Qed.

Compute (* map (fun c => display_cell "50 mul " c "") *) (start [::
     Bevent {| p_x := 1; p_y := 2 |}
        [:: [edge of {| p_x := 1; p_y := 2 |},
                     {| p_x := 5; p_y := 1 |}];
            [edge of {| p_x := 1; p_y := 2 |},
                     {| p_x := 6; p_y := 17 |}]];
     Bevent {| p_x := 2; p_y := 2 |}

        [:: [edge of {| p_x := 2; p_y := 2 |},
                     {| p_x := 4; p_y := 4 |}];
            [edge of {| p_x := 2; p_y := 2 |},
                     {| p_x := 3; p_y := 5 |}]];
     Bevent {| p_x := 3%:R; p_y := 5%:R |}

        [:: [edge of {| p_x := 3%:R; p_y := 5%:R|},
                {| p_x := 4%:R; p_y := 4%:R|}]];
    Bevent {| p_x := 4%:R; p_y := 4%:R |}
           [::];
    Bevent {| p_x := 5%:R; p_y := 1%:R |}
      [:: [edge of {| p_x := 5; p_y := 1|},
                   {| p_x := 6; p_y := 17 |}]];
    Bevent {| p_x := 6; p_y := 17 |}
           [::]] dummy_low dummy_high).

Compute seq_nat_to_edges two_triangles.
Definition edge1 :=  Bedge
               (erefl
                  (p_x {| p_x := 2%:R; p_y := 2%:R |} <
                   p_x {| p_x := 4%:R; p_y := 4%:R |})).
Definition edge2 :=
   Bedge
               (erefl
                  (p_x {| p_x := 2%:R; p_y := 2%:R |} <
                   p_x {| p_x := 3%:R; p_y := 5%:R |})).
Definition edge3 :=
   Bedge
               (erefl
                  (p_x {| p_x :=1%:R; p_y := 2%:R |} <
                   p_x {| p_x := 5%:R; p_y := 1%:R |})).
Definition edge4 :=
   Bedge
               (erefl
                  (p_x {| p_x :=1%:R; p_y := 2%:R |} <
                   p_x {| p_x := 6%:R; p_y := 17%:R |})).
Arguments Bedge: clear implicits.
Definition ev0 :=
  {| point := {| p_x := 1%:R; p_y := 1%:R |};
     incoming := [::]; outgoing := [::] |}.

Definition ev1 : event := nth ev0 tt_events 0.
Definition ev2 : event := nth ev0 tt_events 1.
Definition ev3 : event := nth ev0 tt_events 2.
Definition ev4 : event := nth ev0 tt_events 3.
Definition ev5 : event := nth ev0 tt_events 4.
Definition ev6 : event := nth ev0 tt_events 5.
Definition ev7 : event := nth ev0 tt_events 6.
(* example of step-by-step execution. *)
(*
Lemma sandbox : start tt_events dummy_low dummy_high = nil.
rewrite /start.
rewrite /tt_events.
set e := outgoing _.
compute in e.
rewrite /e.
set es := (X in scan X).

set c1 := (init_cells _ _ _).
rewrite scan_eq.
rewrite /es.
set Vs := (step _ _ _).
compute in Vs.
rewrite /Vs.
rewrite scan_eq.
rewrite /es.
set Vs2 := (step _ _ _).
compute in Vs2.
Admitted.

Lemma sandbox2 : step ev2 (init_cells
        (point ev1) (head edge1 (outgoing ev1)) (behead (outgoing ev1))) [::]  = (nil,nil).
Proof.
rewrite /init_cells /=.
rewrite /step.
set V:= extract_l_h_edges _.
compute in V.
compute.
move => e0 rest.
case nn: (step e0 c1 [::]) => [open closed].
compute in nn.
Admitted.

*)