Require Import Reals Psatz Omega Fourier.
From stdpp Require Import tactics list.
From discprob.basic Require Import seq_ext.
From mathcomp Require Import bigop.
From discprob.measure Require Export measures borel convergence integral_prelim.
Require Import ClassicalEpsilon SetoidList.

Section integral.
  Context {A: Type}.
  Context {F: measurable_space A}.
  Context (μ: measure A).

  Local Notation is_pos_integral := (@is_pos_integral A F μ).
  Local Notation ex_pos_integral := (@ex_pos_integral A F μ).
  Local Notation Pos_integral := (@Pos_integral A F μ).

  Definition is_integral (f: A → R) v :=
    measurable f ∧
    ∃ v1 v2, is_pos_integral (λ x, Rmax (f x) 0) v1 ∧
             is_pos_integral (λ x, Rmax (- f x) 0) v2 ∧
             v = v1 - v2.

  Definition ex_integral (f: A → R) :=
    ∃ v, is_integral f v.

  Definition Integral (f : A → R) : R :=
    Pos_integral (λ x, Rmax (f x) 0) - Pos_integral (λ x, Rmax (- f x) 0).

  Definition is_integral_over (U : A → Prop) (f: A → R) v :=
    F U ∧ is_integral (λ x, f x *  match excluded_middle_informative (U x) with
                                   | left _ => 1
                                   | right _ => 0
                                   end) v.

  Definition ex_integral_over U f := ∃ v, is_integral_over U f v.

  Definition Integral_over U f :=
    Integral (λ x, f x * match excluded_middle_informative (U x) with
                         | left _ => 1
                         | right _ => 0
                         end).

  Lemma is_integral_unique f v :
    is_integral f v → Integral f = v.
  Proof.
    rewrite /is_integral. intros (Hmeas&v1&v2&?&?&Heq).
    rewrite /Integral.
    erewrite is_pos_integral_unique; eauto.
    erewrite is_pos_integral_unique; eauto.
  Qed.

  Lemma Integral_correct f: ex_integral f → is_integral f (Integral f).
  Proof.
    intros [v Hpos]. rewrite (is_integral_unique f v) //=.
  Qed.

  Lemma is_pos_integral_diff f1 f2 g1 g2 v1 v2 v1' v2':
    (∀ x, 0 <= f1 x) →
    (∀ x, 0 <= f2 x) →
    (∀ x, 0 <= g1 x) →
    (∀ x, 0 <= g2 x) →
    (∀ x, f1 x - f2 x = g1 x - g2 x) →
    is_pos_integral f1 v1 →
    is_pos_integral f2 v2 →
    is_pos_integral g1 v1' →
    is_pos_integral g2 v2' →
    v1 - v2 = v1' - v2'.
  Proof.
    intros ???? Hdiff Hi1 Hi2 Hi1' Hi2'.
    assert (Hsum: ∀ x, f1 x + g2 x = g1 x + f2 x).
    { intros x. specialize (Hdiff x). nra. }
    cut (v1 + v2' = v1' + v2); first by nra.
    feed pose proof (is_pos_integral_plus μ f1 v1 g2 v2'); eauto.
    feed pose proof (is_pos_integral_plus μ g1 v1' f2 v2); eauto.
    etransitivity; last apply is_pos_integral_unique; eauto.
    symmetry. apply is_pos_integral_unique.
    setoid_rewrite <-Hsum. done.
  Qed.

  Lemma is_integral_scal k f v:
    is_integral f v → is_integral (λ x, k * f x) (k * v).
  Proof.
    destruct (Rle_dec 0 k).
    - intros (Hmeas&v1&v2&Hpos1&Hpos2&Hdiff).
      split.
      { by apply measurable_scal. }
      exists (k * v1), (k * v2).
      split_and!.
      * eapply is_pos_integral_ext; last first.
        { eapply is_pos_integral_scal; auto; last eauto.
          intros x => //=. apply Rmax_r. }
        intros x => //=.
        replace 0 with (k * 0) at 2 by field.
        rewrite Rmult_comm Rmax_mult; auto.
        f_equal; nra.
      * eapply is_pos_integral_ext; last first.
        { eapply is_pos_integral_scal; auto; last apply Hpos2.
          intros x => //=. apply Rmax_r. }
        intros x => //=.
        replace 0 with (k * 0) at 2 by field.
        rewrite Rmult_comm Rmax_mult; auto.
        f_equal; nra.
      * nra.
    - intros (Hmeas&v1&v2&Hpos1&Hpos2&Hdiff).
      split.
      { by apply measurable_scal. }
      exists (-k * v2), (-k * v1).
      split_and!.
      * eapply is_pos_integral_ext; last first.
        { eapply is_pos_integral_scal; auto; last eauto; try nra.
          intros x => //=. apply Rmax_r. }
        intros x => //=.
        replace 0 with (- k * 0) at 2 by field.
        rewrite Rmult_comm Rmax_mult; auto; last nra.
        f_equal; nra.
      * eapply is_pos_integral_ext; last first.
        { eapply is_pos_integral_scal; auto; last eauto; try nra.
          intros x => //=. apply Rmax_r. }
        intros x => //=.
        replace 0 with (- k * 0) at 2 by field.
        rewrite Rmult_comm Rmax_mult; auto; last nra.
        f_equal; nra.
      * nra.
  Qed.

  Lemma ex_integral_scal k f:
    ex_integral f →
    ex_integral (λ x, k * f x).
  Proof.
    intros (v1&?); eexists; eapply is_integral_scal; eauto.
  Qed.

  Lemma Integral_scal k f:
    ex_integral f →
    Integral (λ x, k * f x) = k * Integral f.
  Proof.
    intros Hex.
    apply is_integral_unique.
    apply is_integral_scal; apply Integral_correct; eauto.
  Qed.

  Lemma is_integral_plus f1 v1 f2 v2:
    is_integral f1 v1 →
    is_integral f2 v2 →
    is_integral (λ x, f1 x + f2 x) (v1 + v2).
  Proof.
    intros Hi1 Hi2.
    destruct Hi1 as (Hmeas1&v1p&v1n&Hi1p&Hi1n&Hdiff1).
    destruct Hi2 as (Hmeas2&v2p&v2n&Hi2p&Hi2n&Hdiff2).
    split.
    - apply measurable_plus; auto.
    - exists (Pos_integral (λ x, (Rmax (f1 x + f2 x) 0))).
      exists (Pos_integral (λ x, (Rmax (-(f1 x + f2 x)) 0))).
      assert (ex_pos_integral (λ x, (Rmax (f1 x + f2 x) 0))).
      {
        edestruct (is_pos_integral_mono_ex μ
                     (λ x, Rmax (f1 x + f2 x) 0)
                     (λ x, Rmax (f1 x) 0 + Rmax (f2 x) 0)) as (Hex&?); eauto.
        ** intros x => //=. apply Rmax_r.
        ** intros x => //=. repeat apply Rmax_case_strong; nra.
        ** apply measurable_Rmax.
           *** apply measurable_plus; auto.
           *** eapply measurable_const.
        ** apply is_pos_integral_plus; eauto using Rmax_r.
      }
      assert (ex_pos_integral (λ x, (Rmax (- (f1 x + f2 x)) 0))).
      {
        edestruct (is_pos_integral_mono_ex μ
                     (λ x, Rmax (- (f1 x + f2 x)) 0)
                     (λ x, Rmax (- f1 x) 0 + Rmax (- f2 x) 0)) as (Hex&?); eauto.
        ** intros x => //=. apply Rmax_r.
        ** intros x => //=. repeat apply Rmax_case_strong; nra.
        ** apply measurable_Rmax.
           *** eapply measurable_opp. apply measurable_plus; auto.
           *** eapply measurable_const.
        ** apply is_pos_integral_plus; eauto using Rmax_r.
      }
      split_and!.
      * apply Pos_integral_correct; eauto.
      * apply Pos_integral_correct; eauto.
      * replace (v1 + v2) with ((v1p + v2p) - (v1n + v2n)) by nra.
        eapply (is_pos_integral_diff (λ x, Rmax (f1 x) 0 + Rmax (f2 x) 0)
                                     (λ x, Rmax (- f1 x) 0 + Rmax (- f2 x) 0));
          try (eapply Pos_integral_correct; eauto);
          try (intros x; eapply Rmax_r; eauto).
        ** intros; repeat apply Rmax_case_strong; nra.
        ** intros; repeat apply Rmax_case_strong; nra.
        ** intros; repeat apply Rmax_case_strong; nra.
        ** apply is_pos_integral_plus; auto using Rmax_r.
        ** apply is_pos_integral_plus; auto using Rmax_r.
  Qed.

  Lemma ex_integral_plus f1 f2:
    ex_integral f1 →
    ex_integral f2 →
    ex_integral (λ x, f1 x + f2 x).
  Proof.
    intros (v1&?) (v2&?).
    eexists; eauto using is_integral_plus.
  Qed.

  Lemma Integral_plus f1 f2:
    ex_integral f1 →
    ex_integral f2 →
    Integral (λ x, f1 x + f2 x) = Integral f1 + Integral f2.
  Proof.
    intros Hex1 Hex2.
    apply is_integral_unique.
    apply is_integral_plus; apply Integral_correct; eauto.
  Qed.

  Lemma is_integral_ext f1 f2 v:
    (∀ x, f1 x = f2 x) →
    is_integral f1 v →
    is_integral f2 v.
  Proof.
    intros Heq (Hmeas&Hp).
    split.
    - eapply measurable_proper.
      * intros x. rewrite -Heq. reflexivity.
      * eauto.
    - destruct Hp as (v1&v2&?&?&?).
      exists v1, v2; split_and!; eauto.
      * setoid_rewrite <-Heq. auto.
      * setoid_rewrite <-Heq. auto.
  Qed.

  Lemma ex_integral_ext f1 f2:
    (∀ x, f1 x = f2 x) →
    ex_integral f1 →
    ex_integral f2.
  Proof.
    intros Hex (v1&?). exists v1. eapply is_integral_ext; eauto.
  Qed.

  Lemma Integral_ext f1 f2:
    (∀ x, f1 x = f2 x) →
    Integral f1 = Integral f2.
  Proof.
    intros Hex. rewrite /Integral. f_equal; apply Pos_integral_ext => x; rewrite Hex; done.
  Qed.

  Global Instance is_integral_Proper:
    Proper (pointwise_relation _ eq ==> eq ==> iff) (is_integral).
  Proof.
    intros ?? Heq ?? ->. split; eapply is_integral_ext; eauto.
  Qed.

  Global Instance ex_integral_Proper:
    Proper (pointwise_relation _ eq ==> iff) (ex_integral).
  Proof.
    intros ?? Heq. split; eapply ex_integral_ext; eauto.
  Qed.

  Global Instance Integral_Proper:
    Proper (pointwise_relation _ eq ==> eq) Integral.
  Proof.
    intros ?? Heq. by apply Integral_ext.
  Qed.

  Lemma is_integral_minus f1 v1 f2 v2:
    is_integral f1 v1 →
    is_integral f2 v2 →
    is_integral (λ x, f2 x - f1 x) (v2 - v1).
  Proof.
    intros Hi1 Hi2.
    assert (Heq: ∀ x, f2 x - f1 x = f2 x + -1 * f1 x) by (intros; nra).
    replace (v2 - v1) with (v2 + - 1 * v1) by field.
    setoid_rewrite Heq.
    apply is_integral_plus; auto.
    apply is_integral_scal. done.
  Qed.

  Lemma ex_integral_minus f1 f2:
    ex_integral f1 →
    ex_integral f2 →
    ex_integral (λ x, f2 x - f1 x).
  Proof.
    intros (v1&?) (v2&?); eexists; eapply is_integral_minus; eauto.
  Qed.

  Lemma Integral_minus f1 f2:
    ex_integral f1 →
    ex_integral f2 →
    Integral (λ x, f1 x - f2 x) = Integral f1 - Integral f2.
  Proof.
    intros Hex1 Hex2.
    apply is_integral_unique.
    apply is_integral_minus; apply Integral_correct; eauto.
  Qed.

  Lemma is_pos_integral_0:
    is_pos_integral (λ _, 0) 0.
  Proof.
    split.
    - apply measurable_const.
    - split.
      * intros ? (wpt&?&?). subst.
        replace 0 with (wpt_integral μ (wpt_const 0)).
        { apply wpt_integral_mono => //=. intros. rewrite wpt_const_spec.
          done. }
        rewrite wpt_integral_const; nra.
      * intros ? H. apply H.
        exists (wpt_const 0); split.
        ** intros; rewrite wpt_const_spec; nra.
        ** rewrite wpt_integral_const; nra.
  Qed.

  Lemma Pos_integral_0:
    Pos_integral (λ _, 0) = 0.
  Proof. apply is_pos_integral_unique, is_pos_integral_0. Qed.

  Hint Resolve is_pos_integral_measurable.

  Lemma is_integral_equiv_pos_integral f v:
    (∀ x, 0 <= f x) →
    is_integral f v ↔ is_pos_integral f v.
  Proof.
    intros Hpos; split.
    - intros (Hmeas&v1&v2&?&Hp2&?).
      cut (v2 = 0).
      { intros. replace v with v1 by nra.
        eapply is_pos_integral_ext; try eassumption.
        intros => //=. rewrite Rmax_left; eauto.
      }
      assert (Heq: ∀ x, Rmax (- f x) 0 = 0).
      { intros. rewrite Rmax_right; auto.
        apply Rge_le, Ropp_0_le_ge_contravar. eauto.
      }
      setoid_rewrite Heq in Hp2.
      erewrite <-(is_pos_integral_unique μ _ v2); eauto.
      apply is_pos_integral_unique. apply is_pos_integral_0.
    - intros Hpos'. split; eauto.
      * exists v, 0; split_and!; last field.
        ** eapply is_pos_integral_ext; last eassumption.
           intros x. rewrite Rmax_left; eauto.
        ** eapply is_pos_integral_ext; last eapply is_pos_integral_0.
           intros x. rewrite Rmax_right; eauto.
           apply Rge_le, Ropp_0_le_ge_contravar. eauto.
  Qed.

  Lemma ex_integral_equiv_pos_integral f:
    (∀ x, 0 <= f x) →
    ex_integral f ↔ ex_pos_integral f.
  Proof.
    intros Hpos. split; intros (v&?); eexists; eapply is_integral_equiv_pos_integral; eauto.
  Qed.

  Lemma Integral_equiv_Pos_integral f:
    (∀ x, 0 <= f x) →
    Integral f = Pos_integral f.
  Proof.
    intros Hpos. rewrite /Integral.
    assert (Hequiv: ∀ x, (λ x, Rmax (- f x) 0) x = 0).
    { intros x. specialize (Hpos x). apply Rmax_case_strong; nra. }
    setoid_rewrite Hequiv. rewrite Pos_integral_0 Rminus_0_r.
    apply Pos_integral_ext.
    intros x. rewrite Rmax_left; auto.
  Qed.

  Lemma is_integral_mono f1 v1 f2 v2:
    (∀ x, f1 x <= f2 x) →
    is_integral f1 v1 →
    is_integral f2 v2 →
    v1 <= v2.
  Proof.
    intros Hle Hint1 Hint2.
    cut (0 <= v2 - v1); first by nra.
    assert (His: is_integral (λ x, f2 x - f1 x) (v2 - v1)).
    { apply is_integral_minus; auto. }
    apply is_integral_equiv_pos_integral in His; last by (intros x; specialize (Hle x); nra).
    eapply is_pos_integral_mono in His; first eassumption; try eapply is_pos_integral_0.
    intros x => //=. specialize (Hle x); nra.
  Qed.

  Lemma Integral_mono f1 f2:
    (∀ x, f1 x <= f2 x) →
    ex_integral f1 →
    ex_integral f2 →
    Integral f1 <= Integral f2.
  Proof.
    intros Hmono (v1&Heq1) (v2&Heq2).
    rewrite (is_integral_unique _ _ Heq1).
    rewrite (is_integral_unique _ _ Heq2).
    eapply is_integral_mono; eauto.
  Qed.

  Lemma is_integral_measurable f v:
    is_integral f v → measurable f.
  Proof. destruct 1; eauto. Qed.

  Lemma ex_integral_measurable f:
    ex_integral f → measurable f.
  Proof. destruct 1 as (?&?); eauto using is_integral_measurable. Qed.

  Hint Resolve is_integral_measurable ex_integral_measurable.

  Lemma is_pos_integral_wpt wpt:
    (∀ x, 0 <= wpt_fun wpt x) →
    is_pos_integral (wpt_fun wpt) (wpt_integral μ wpt).
  Proof.
    intros Hpos.
    eapply (is_pos_integral_mct_wpt μ (λ n, wpt)).
    - apply wpt_fun_measurable.
    - intros; apply is_lim_seq_const.
    - intros; reflexivity.
    - apply is_lim_seq_const.
  Qed.

  Lemma is_integral_wpt wpt:
    is_integral (wpt_fun wpt) (wpt_integral μ wpt).
  Proof.
    induction wpt using wpt_induction.
    - eapply is_integral_ext; eauto.
      rewrite (wpt_integral_proper _ wpt2 wpt1); auto.
        by symmetry.
    - apply is_integral_equiv_pos_integral.
      { intros x. rewrite wpt_indicator_spec; destruct excluded_middle_informative => //=; nra. }
      apply is_pos_integral_wpt.
      { intros x. rewrite wpt_indicator_spec; destruct excluded_middle_informative => //=; nra. }
    - rewrite wpt_integral_plus.
      eapply is_integral_ext.
      { intros x; by rewrite wpt_plus_spec. }
      apply is_integral_plus; eauto.
    - rewrite wpt_integral_scal.
      eapply is_integral_ext.
      { intros x; by rewrite wpt_scal_spec. }
      apply is_integral_scal; eauto.
  Qed.

  Lemma ex_integral_wpt wpt:
    ex_integral (wpt_fun wpt).
  Proof.
    eexists. eapply is_integral_wpt.
  Qed.

  Lemma Integral_wpt wpt:
    Integral (wpt_fun wpt) = wpt_integral μ wpt.
  Proof. apply is_integral_unique, is_integral_wpt. Qed.

  Lemma is_integral_0:
    is_integral (λ _, 0) 0.
  Proof. apply is_integral_equiv_pos_integral; first reflexivity. apply is_pos_integral_0. Qed.

  Lemma Integral_0:
    Integral (λ _, 0) = 0.
  Proof. apply is_integral_unique, is_integral_0. Qed.

  Lemma ex_integral_sum_n fn m:
    (∀ n, (n <= m)%nat → ex_integral (fn n)) →
    ex_integral (λ x, sum_n (λ n, fn n x) m).
  Proof.
    induction m.
    - intros Hex. setoid_rewrite sum_O. eauto.
    - intros Hex. setoid_rewrite sum_Sn. apply ex_integral_plus; auto.
  Qed.

  Lemma Integral_sum_n fn m:
    (∀ n, (n <= m)%nat → ex_integral (fn n)) →
    Integral (λ x, sum_n (λ n, fn n x) m) =
    sum_n (λ n, Integral (fn n)) m.
  Proof.
    induction m.
    - intros Hex. setoid_rewrite sum_O. done.
    - intros Hex. setoid_rewrite sum_Sn. rewrite /plus//=.
      rewrite Integral_plus; eauto using ex_integral_sum_n.
      f_equal; eauto.
  Qed.

  Lemma is_integral_ge0 f v:
    (∀ x, 0 <= f x) →
    is_integral f v →
    v >= 0.
  Proof.
    intros Hpos His.
    apply Rle_ge.
    eapply is_integral_mono.
    - eapply Hpos.
    - apply is_integral_0.
    - eauto.
  Qed.

  Lemma Pos_integral_ge0 f:
    (∀ x, 0 <= f x) →
    Pos_integral f >= 0.
  Proof.
    intros Hpos. rewrite /Pos_integral.
    destruct excluded_middle_informative; last nra.
    destruct excluded_middle_informative; last nra.
    apply Rle_ge. eapply (Rle_trans _ (wpt_integral μ (wpt_indicator empty_set (sigma_empty_set F)))).
    { rewrite wpt_integral_indicator measure_empty. nra. }
    destruct (completeness _) as (?&Hlub).
    apply Hlub. eexists. split; eauto.
    intros x'. rewrite wpt_indicator_spec. destruct (excluded_middle_informative) as [[]|]; auto.
  Qed.

  Lemma Integral_ge0 f:
    (∀ x, 0 <= f x) →
    Integral f >= 0.
  Proof.
    intros Hpos.
    rewrite /Integral. cut (Pos_integral (λ x, Rmax (- f x) 0) = 0).
    { intros ->. feed pose proof (Pos_integral_ge0 (λ x, Rmax (f x) 0)).
      { intros. apply Rmax_case_strong; nra. }
      nra.
    }
    rewrite -{2}Pos_integral_0. apply Pos_integral_ext. intros.
    specialize (Hpos x). apply Rmax_case_strong => //=; nra.
  Qed.

  Hint Resolve is_integral_wpt ex_integral_wpt.

  Lemma ex_integral_mono_ex f1 f2:
    (∀ x, Rabs (f1 x) <= f2 x) →
    measurable f1 →
    ex_integral f2 →
    ex_integral f1.
  Proof.
    intros Hb Hmeas (v&(?&?&?&?&?&?)).
    edestruct (is_pos_integral_mono_ex μ (λ x, Rmax (f1 x) 0) (λ x, Rmax (f2 x) 0)) as ((xp&?)&?).
    { intros ?; apply Rmax_case_strong; nra. }
    { intros x' => //=. specialize (Hb x'). move: Hb.
      apply Rabs_case; do 2 apply Rmax_case_strong; nra. }
    { apply measurable_Rmax; eauto. measurable. }
    { eauto.  }

    edestruct (is_pos_integral_mono_ex μ (λ x, Rmax (- f1 x) 0) (λ x, Rmax (f2 x) 0)) as ((xn&?)&?).
    { intros ?; apply Rmax_case_strong; nra. }
    { intros x' => //=. generalize (Hb x').
      apply Rabs_case; do 2 apply Rmax_case_strong; nra. }
    { apply measurable_Rmax; eauto; measurable. }
    { eauto.  }
    exists (xp - xn).
    split; auto. exists xp, xn.
    eauto.
  Qed.

  Lemma ex_integral_Rabs f:
    measurable f →
    ex_integral f ↔ ex_integral (λ x, Rabs (f x)).
  Proof.
    intros Hmeas.
    split.
    - intros (v&Hmeas'&(v1&v2&His1&His2&Heq)).
      assert (∀ x, Rabs (f x) = Rmax (f x) 0 + Rmax (- f x) 0) as Hequiv.
      { intros; apply Rabs_case; do 2 apply Rmax_case_strong; nra. }
      setoid_rewrite Hequiv.
      apply ex_integral_plus.
      * apply ex_integral_equiv_pos_integral; last by eexists; eauto.
        intros. apply Rmax_case_strong; nra.
      * apply ex_integral_equiv_pos_integral; last by eexists; eauto.
        intros. apply Rmax_case_strong; nra.
    - intros. eapply ex_integral_mono_ex; eauto.
      intros x. rewrite //=. reflexivity.
  Qed.

  Lemma Integral_mono_pos f1 f2:
    (∀ x, 0 <= f1 x) →
    (∀ x, f1 x <= f2 x) →
    measurable f1 →
    ex_integral f2 →
    Integral f1 <= Integral f2.
  Proof.
    intros Hpos Hmono Hmeas Hex. eapply Integral_mono; eauto.
    eapply ex_integral_mono_ex. eauto.
    { intros. rewrite Rabs_right; eauto. }
    { auto. }
    { auto. }
  Qed.

  Lemma is_integral_wpt_ae_0 wpt:
    (∀ x, 0 <= wpt_fun wpt x) →
    almost_everywhere_meas μ (λ x, wpt_fun wpt x = 0) →
    is_integral (wpt_fun wpt) 0.
  Proof.
    intros Hpos.
    eapply (wpt_pos_induction
        (λ wpt, almost_everywhere_meas μ (λ x : A, wpt_fun wpt x = 0) → is_integral (wpt_fun wpt) 0)).
    - intros wpt1 wpt2 Heq IH Hae.
      eapply is_integral_ext; last eapply IH; eauto.
      eapply almost_everywhere_meas_ext; eauto.
      intros ?. by rewrite Heq.
    - intros U Hmeas Hae.  cut (Integral (wpt_fun (wpt_indicator U Hmeas)) = 0).
      { intros <-. apply Integral_correct; auto. }
      rewrite Integral_wpt wpt_integral_indicator.
      destruct Hae as (?&His0).
      apply Rle_antisym; last by apply Rge_le, measure_nonneg.
      rewrite -His0. apply measure_mono; auto.
      intros x HU Hneg. rewrite wpt_indicator_spec in Hneg.
      destruct (excluded_middle_informative); try contradiction. simpl in Hneg; nra.
    - intros wpt1 wpt2 Hpos1 IH1 Hpos2 IH2 Hae.
      replace 0 with (0 + 0) by nra.
      eapply is_integral_ext.
      { intros x; by rewrite wpt_plus_spec. }
      apply is_integral_plus.
      * eapply IH1. eapply almost_everywhere_meas_mono; eauto.
        { apply measurable_fun_eq_0; auto. }
        intros x. rewrite wpt_plus_spec. specialize (Hpos1 x). specialize (Hpos2 x).
        nra.
      * eapply IH2. eapply almost_everywhere_meas_mono; eauto.
        { apply measurable_fun_eq_0; auto. }
        intros x. rewrite wpt_plus_spec. specialize (Hpos1 x). specialize (Hpos2 x).
        nra.
    - intros k wpt1 Hkpos Hpos1 IH1 Hae.
      replace 0 with (k * 0) by field.
      eapply is_integral_ext.
      { intros x. rewrite wpt_scal_spec. done. }
      destruct Hkpos; last first.
      { subst. setoid_rewrite Rmult_0_l. apply is_integral_0. }
      apply is_integral_scal.
      eapply IH1. eapply almost_everywhere_meas_mono; eauto.
        { apply measurable_fun_eq_0; auto. }
      intros x. rewrite wpt_scal_spec. nra.
    - auto.
  Qed.

  Lemma is_integral_pos_ae_0 f:
    measurable f →
    (∀ x, 0 <= f x) →
    almost_everywhere_meas μ (λ x, f x = 0) →
    is_integral f 0.
  Proof.
    intros Hmeas Hpos.
    edestruct (wpt_approx_measurable _ Hpos Hmeas) as (wptn&?&?&Hle&Hposn).
    intros Hae. apply is_integral_equiv_pos_integral; eauto.
    eapply is_pos_integral_mct_wpt; eauto.
    eapply is_lim_seq_ext; last eapply is_lim_seq_const.
    intros n => //=. rewrite -Integral_wpt. symmetry.
    apply is_integral_unique. apply is_integral_wpt_ae_0; eauto.
    eapply almost_everywhere_meas_mono; eauto.
    { apply measurable_fun_eq_0; auto. }
    intros x Heq0. specialize (Hle n x). specialize (Hposn n x). nra.
  Qed.

  Lemma is_integral_alt (f: A → R) v :
    (measurable f ∧
    ∃ v1 v2, is_integral (λ x, Rmax (f x) 0) v1 ∧
             is_integral (λ x, Rmax (- f x) 0) v2 ∧
             v = v1 - v2) ↔ is_integral f v.
  Proof.
    split.
    - intros (?&v1&v2&?&?&?).
      split; auto. exists v1, v2.
      split_and!; auto; apply is_integral_equiv_pos_integral; eauto;
        intros x; apply Rmax_case_strong; nra.
    - intros (Hmeas&(v1&v2&?&?&?)). split; auto.
      exists v1, v2; split_and!; auto.
      * apply is_integral_equiv_pos_integral; auto using Rmax_r.
      * apply is_integral_equiv_pos_integral; auto using Rmax_r.
  Qed.

  Lemma ex_integral_alt (f: A → R) :
    (measurable f ∧
     ex_integral (λ x, Rmax (f x) 0) ∧
     ex_integral (λ x, Rmax (- f x) 0))
    ↔ ex_integral f.
  Proof.
    split.
    - intros (Hmeas&Hex1&Hex2).
      destruct Hex1 as (v1&His1). destruct Hex2 as (v2&His2).
      exists (v1 - v2). apply is_integral_alt.
      split; auto.
      exists v1, v2; split_and!; eauto.
    - intros (Hmeas&His).
      apply is_integral_alt in His as (?&?&?&?&?&?).
      split; auto. split; eexists; eauto.
  Qed.

  Lemma Integral_alt f:
    Integral f = Integral (λ x, Rmax (f x) 0) - Integral (λ x, Rmax (- f x) 0).
  Proof.
    rewrite {1}/Integral; f_equal; symmetry; apply Integral_equiv_Pos_integral; auto using Rmax_r.
  Qed.

  Lemma is_integral_ae_0 f:
    measurable f →
    almost_everywhere_meas μ (λ x, f x = 0) →
    is_integral f 0.
  Proof.
    intros Hmeas Hae. apply is_integral_alt; split; auto.
    exists 0, 0; split_and!; last field.
    - apply is_integral_pos_ae_0.
      * apply measurable_Rmax; measurable.
      * intros; apply Rmax_case_strong; nra.
      * eapply almost_everywhere_meas_mono; eauto.
        ** apply measurable_fun_eq_0; auto.
           apply measurable_Rmax; measurable.
        ** intros x ->. apply Rmax_case_strong; auto.
    - apply is_integral_pos_ae_0.
      * apply measurable_Rmax; measurable.
      * intros; apply Rmax_case_strong; nra.
      * eapply almost_everywhere_meas_mono; eauto.
        ** apply measurable_fun_eq_0; auto.
           apply measurable_Rmax; measurable.
        ** intros x ->. apply Rmax_case_strong; auto. nra.
  Qed.

  Lemma is_integral_ae_ext f1 f2 v:
    almost_everywhere_meas μ (λ x, f1 x = f2 x) →
    measurable f2 →
    is_integral f1 v →
    is_integral f2 v.
  Proof.
    intros Hae Hmeas His.
    feed pose proof (is_integral_ae_0 (λ x, f2 x - f1 x)) as Hisdiff.
    { measurable. eauto. }
    { eapply almost_everywhere_meas_ext; eauto. split; intros; nra. }
    specialize (is_integral_plus _ _ _ _ His Hisdiff).
    rewrite Rplus_0_r. apply is_integral_ext. intros; field.
  Qed.

  Lemma ex_integral_ae_ext f1 f2:
    almost_everywhere_meas μ (λ x, f1 x = f2 x) →
    measurable f2 →
    ex_integral f1 →
    ex_integral f2.
  Proof.
    intros Hae Hmeas (v&His). exists v. eapply is_integral_ae_ext; eauto.
  Qed.

  Lemma Integral_ae_ext_weak f1 f2:
    almost_everywhere_meas μ (λ x, f1 x = f2 x) →
    measurable f2 →
    ex_integral f1 →
    Integral f1 = Integral f2.
  Proof.
    intros Hae ? Hex. symmetry. apply is_integral_unique.
    eapply is_integral_ae_ext; eauto.
    by apply Integral_correct.
  Qed.

  Lemma is_integral_levi_pos_ex fn f:
    measurable f →
    (∀ x, is_lim_seq (λ n, fn n x) (f x : R)) →
    (∀ x, ∀ n, 0 <= fn n x) →
    (∀ x, ∀ n, fn n x <= fn (S n) x) →
    (∀ n, ex_integral (fn n)) →
    bound (λ r, ∃ n, is_integral (fn n) r) →
    ex_integral f ∧ is_lim_seq (λ n, Integral (fn n)) (Integral f).
  Proof.
    intros Hmeas Hlim Hpos Hmono Hint_fn Hbounded_int.
    assert (Hfpos: ∀ x, 0 <= f x).
    { intros x. eapply is_lim_seq_pos; eauto.
      intros n. apply Rle_ge; eauto. }
    assert (Hfn_bounded_fpos: ∀ n x, fn n x <= f x).
    { intros n x.
      apply: (is_lim_seq_incr_compare (λ n, fn n x) (f x)); eauto.
    }
    assert (Hfn_meas: ∀ n, measurable (fn n)).
    { intros n. auto. }
    set (gnk_wit := λ n, constructive_indefinite_description _
                    (wpt_approx_measurable (fn n) (λ x, Hpos x n) (Hfn_meas n))).
    set (gnk := λ n, sval (gnk_wit n)).
    set (hnk := λ n k, nat_rect (λ _, weighted_partition)
                                (wpt_const 0)
                                (λ m w, wpt_max w (gnk m n)) (S k)).
    set (hn := λ n, hnk n n).
    assert (Hhnk_mono1: ∀ n k, ∀ x, wpt_fun (hnk n k) x <= wpt_fun (hnk (S n) k) x).
    {
      intros n k x. revert n. rewrite /hnk. generalize (wpt_const 0).  generalize (S k); clear k.
      intros k. induction k => //= w n.
      - reflexivity.
      - rewrite ?wpt_max_spec. apply Rmax_le_compat.
        * eapply IHk.
        * rewrite /gnk/gnk_wit. destruct constructive_indefinite_description as (?&?&?&?); eauto.
    }
    assert (Hhnk_mono2: ∀ n k, ∀ x, wpt_fun (hnk n k) x <= wpt_fun (hnk n (S k)) x).
    {
      intros n k x. revert n. rewrite /hnk. generalize (wpt_const 0).  generalize (S k); clear k.
      intros k. induction k => //= w n.
      - rewrite wpt_max_spec. apply Rmax_l.
      - rewrite ?wpt_max_spec. apply Rmax_l.
    }
    assert (Hhnk_mono: ∀ n k, (∀ n' k', (n' <= n)%nat → (k' <= k)%nat →
                                        ∀ x, wpt_fun (hnk n' k') x <= wpt_fun (hnk n k) x)).
    { intros n k n' k' Hle1 Hle2.
      revert k' k Hle2. induction Hle1.
      * intros. induction Hle2.
        ** reflexivity.
        ** etransitivity; first eauto. eapply Hhnk_mono2.
      * intros. etransitivity; first eapply IHHle1; eauto.
    }
    assert (Hhnk_gnk: ∀ n k, ∀ x, wpt_fun (gnk k n) x <= wpt_fun (hnk n k) x).
    { intros. rewrite wpt_max_spec. apply Rmax_r. }
    assert (Hhnk_ub: ∀ n k, (∀ n' k', (n' <= n)%nat → (k' <= k)%nat →
                                   ∀ x, wpt_fun (gnk k' n') x <= wpt_fun (hnk n k) x)).
    { intros ???? Hle1 Hle2 x. etransitivity; first eapply Hhnk_gnk.
      apply Hhnk_mono; eauto. }
    assert (Hgnk_bounded_fn: ∀ n k, ∀ x, wpt_fun (gnk n k) x <= fn n x).
    { rewrite /gnk/gnk_wit => n k x.
      destruct constructive_indefinite_description as (?&?&?&Hbn&?) => //=.
    }
    assert (Hgnk_bounded_f: ∀ n k, ∀ x, wpt_fun (gnk n k) x <= f x).
    { intros. transitivity (fn n x); eauto. }
    assert (Hhnk_bounded_fn: ∀ n k, ∀ x, wpt_fun (hnk n k) x <= fn k x).
    { intros n k x. rewrite /hnk.
      assert (Hle: ∀ k, wpt_fun (wpt_const 0) x <= fn k x).
      { rewrite wpt_const_spec. eauto. }
      rewrite //=. rewrite wpt_max_spec.
      apply Rmax_lub; last by eauto.
      revert Hle. generalize (wpt_const 0).
      induction k => //=.
      - intros w Hle.
        rewrite wpt_max_spec. apply Rmax_lub; eauto.
        etransitivity; first eapply IHk; eauto.
        transitivity (fn k x); eauto.
    }
    assert (Hhnk_bounded_f: ∀ n k, ∀ x, wpt_fun (hnk n k) x <= f x).
    { intros. transitivity (fn k x); eauto. }
    assert (∀ n x, 0 <= wpt_fun (hn n) x ).
    { rewrite /hn. etransitivity; last eapply Hhnk_gnk.
      rewrite /gnk. destruct (gnk_wit) as (?&?&?&?&?); eauto.
    }
    edestruct (is_pos_integral_mct_wpt_ex μ hn f).
    { auto. }
    { intros x P => //= Hloc.
      destruct Hloc as (eps&Heps).
      edestruct (Hlim x (ball (f x) (pos_div_2 eps))) as (n1&Hn1).
      { rewrite //=. apply (locally_ball _ (pos_div_2 eps)). }
      destruct (proj2_sig (gnk_wit n1)) as (Hlb&Hlim_gnk&Hbounded_gnk&?).
      destruct (Hlim_gnk x (ball (fn n1 x) (pos_div_2 (pos_div_2 eps)))) as (n2&Hn2).
      { rewrite //=. apply (locally_ball _ (pos_div_2 (pos_div_2 eps))). }
      exists (max n1 n2).
      intros n Hge.
      apply Heps.
      rewrite /ball//=/AbsRing_ball/abs/minus/plus/opp//=.
      rewrite Rabs_left1; last first.
      { rewrite /hn. specialize (Hhnk_bounded_f n n x); eauto. nra. }

      feed pose proof (Hn1 n1) as Hn1'.
      { etransitivity; last eauto. reflexivity. }
      rewrite /ball//=/AbsRing_ball/abs/minus/plus/opp//= in Hn1'.
      rewrite Rabs_left1 in Hn1'; last first.
      { specialize (Hfn_bounded_fpos n1 x). nra. }

      feed pose proof (Hn2 n) as Hn2'.
      { etransitivity; last eauto. apply Nat.le_max_r. }
      rewrite /ball//=/AbsRing_ball/abs/minus/plus/opp//= in Hn2'.
      rewrite Rabs_left1 in Hn2'; last first.
      { specialize (Hbounded_gnk n x). nra.  }

      specialize (Hbounded_gnk n x).
      specialize (Hgnk_bounded_f n n x).
      rewrite /gnk in Hgnk_bounded_f.
      specialize (Hhnk_bounded_f n n x).
      feed pose proof (Hhnk_ub n n n n1) as Hhn_ub.
      { reflexivity. }
      { etransitivity; last eauto. apply Nat.le_max_l. }
      specialize (Hhn_ub x). rewrite /hn. rewrite /gnk in Hhn_ub.
      destruct eps as (eps&hgt0) => //=.
      rewrite //= in Hn1' Hn2'.
      nra.
    }
    { eauto.  }
    { destruct Hbounded_int as (v&Hspec).
      exists v. intros r (n&<-).
      transitivity (Integral (fn n)); first eapply (is_integral_mono (λ x, wpt_fun (hn n) x) _ (fn n));
        last eauto.
      - intros x. rewrite /hn. eauto.
      - eapply is_integral_equiv_pos_integral; eauto.
        eapply is_pos_integral_wpt; eauto.
      - apply Integral_correct; eauto.
      - eapply Hspec. exists n; eauto using Integral_correct.
    }
    split.
    * apply ex_integral_equiv_pos_integral; eauto.
    * rewrite Integral_equiv_Pos_integral; eauto.
      apply (is_lim_seq_le_le (λ n, wpt_integral μ (hn n)) _ (λ n, Pos_integral f)); first split; eauto.
      { eapply (is_integral_mono (wpt_fun (hn n)) _ (fn n) _).
        * eauto.
        * apply is_integral_equiv_pos_integral; eauto.
          eapply is_pos_integral_wpt; eauto.
        * apply Integral_correct. eauto.
      }
      rewrite Integral_equiv_Pos_integral; eauto.
      eapply (is_pos_integral_mono μ (fn n) f); eauto.
      ** apply Pos_integral_correct.
         apply ex_integral_equiv_pos_integral; eauto.
      ** by apply Pos_integral_correct.
      ** apply is_lim_seq_const.
  Qed.

  Lemma is_integral_levi_ex fn f:
    measurable f →
    (∀ x, is_lim_seq (λ n, fn n x) (f x : R)) →
    (∀ x, ∀ n, fn n x <= fn (S n) x) →
    (∀ n, ex_integral (fn n)) →
    bound (λ r, ∃ n, is_integral (fn n) r) →
    ex_integral f ∧ is_lim_seq (λ n, Integral (fn n)) (Integral f).
  Proof.
    intros Hmeas Hlim Hmono Hex Hbounded_int.
    set (fn' := λ n x, fn n x - fn O x).
    set (f' := λ x, f x - fn O x).
    assert (∀ n : nat, ex_integral (fn' n)).
    { intros n. rewrite /fn'. apply ex_integral_minus; eauto. }
    edestruct (is_integral_levi_pos_ex fn' f').
    - rewrite /f'. apply measurable_minus; eauto.
    - rewrite /fn'/f' => x. eapply is_lim_seq_minus; eauto.
      * apply is_lim_seq_const.
      * rewrite //=.
    - intros x n. rewrite /fn'.
      cut (fn O x <= fn n x); first nra.
      clear -Hmono; induction n.
      * nra.
      * etransitivity; eauto.
    - rewrite /fn'; intros; apply Rplus_le_compat; eauto. reflexivity.
    - intros n. rewrite /fn'. apply ex_integral_minus; eauto.
    - destruct Hbounded_int as (v&Hbound).
      exists (v - Integral (fn O)).
      intros r (n&His).
      rewrite /fn' in His.
      assert (r = Integral (λ x, fn n x - fn O x)) as ->.
      { symmetry. apply is_integral_unique; eauto. }
      rewrite Integral_minus; eauto.
      cut (Integral (fn n) <= v); first by nra.
      eapply Hbound. exists n. apply Integral_correct; eauto.
    - assert (Hext: ∀ x : A, f' x + fn O x = f x).
      { rewrite /f' => x. nra. }
      assert (Hextn: ∀ n x, fn' n x + fn O x = fn n x).
      { rewrite /fn' => n x. nra. }
      assert (ex_integral f).
      {  eapply (ex_integral_ext (λ x, f' x + fn O x)); eauto.
         apply ex_integral_plus; eauto. }
      split; auto.
      * eapply is_lim_seq_ext.
        { intros n. apply Integral_ext; first eapply Hextn. }
        eapply is_lim_seq_ext.
        ** intros n. rewrite Integral_plus; eauto.
        ** rewrite -(Integral_ext _ _ Hext); auto using ex_integral_plus.
           rewrite Integral_plus; eauto.
           eapply is_lim_seq_plus; eauto.
           { apply is_lim_seq_const. }
           rewrite //=.
  Qed.

  Lemma ae_equal_mult_indicator_compl_0:
    ∀ f U Hmeas, measurable f → μ (compl U) = 0 →
                 almost_everywhere_meas μ (λ x, f x * wpt_fun (wpt_indicator U Hmeas) x = f x).
  Proof.
    intros g U Hmeas Hmeasg Heq0.
    eapply almost_everywhere_meas_mono; last first.
    { split; eauto.  }
    { intros x. rewrite wpt_indicator_spec.
      intros. destruct excluded_middle_informative.
      * rewrite Rmult_1_r. done.
      * contradiction.
    }
    { apply measurable_fun_eq_inv; measurable. }
  Qed.

  Lemma ae_equal_mult_indicator_compl_0':
    ∀ f U Hmeas, measurable f → μ (compl U) = 0 →
                 almost_everywhere_meas μ (λ x, f x = f x * wpt_fun (wpt_indicator U Hmeas) x).
  Proof.
    intros.
    eapply almost_everywhere_meas_ext; last eapply ae_equal_mult_indicator_compl_0; try eassumption.
    intros x. split; by symmetry; eauto.
  Qed.

  Lemma is_integral_levi_ae_ex fn f:
    measurable f →
    almost_everywhere_meas μ (λ x, is_lim_seq (λ n, fn n x) (f x : R)) →
    almost_everywhere_meas μ (λ x, ∀ n, fn n x <= fn (S n) x) →
    (∀ n, ex_integral (fn n)) →
    bound (λ r, ∃ n, is_integral (fn n) r) →
    ex_integral f ∧ is_lim_seq (λ n, Integral (fn n)) (Integral f).
  Proof.
    generalize ae_equal_mult_indicator_compl_0 => Hae.
    intros Hmeas Hlim Hmono Hex Hbound.
    specialize (almost_everywhere_meas_conj μ _ _ Hlim Hmono).
    intros (HF&Hμ0).
    apply sigma_closed_complements in HF.
    rewrite compl_involutive in HF * => HF.
    feed pose proof (is_integral_levi_ex (λ n, λ x, fn n x * wpt_fun (wpt_indicator _ HF) x)
                                         (λ x, f x * wpt_fun (wpt_indicator _ HF) x))
         as Hlevi.
    { measurable. }
    { intros x. setoid_rewrite wpt_indicator_spec.
      destruct excluded_middle_informative as [(Hlim'&?)|Hnotin].
      * setoid_rewrite Rmult_1_r. eauto.
      * setoid_rewrite Rmult_0_r. apply is_lim_seq_const.
    }
    { intros x n. rewrite wpt_indicator_spec.
      destruct excluded_middle_informative as [(Hlim'&?)|Hnotin].
      * setoid_rewrite Rmult_1_r. eauto.
      * setoid_rewrite Rmult_0_r. reflexivity.
    }
    { intros n. eapply ex_integral_ae_ext; eauto.
      { eapply almost_everywhere_meas_ext; last eapply ae_equal_mult_indicator_compl_0.
        * intros ?; split; symmetry; eauto.
        * measurable.
        * eauto.
      }
      measurable.
    }
    { destruct Hbound as (r&Hub). exists r.
      intros ? (n&His). eapply is_integral_ae_ext in His; auto.
      eapply Hub; eauto. }
    destruct Hlevi as (Hlevi_ex&Hlevi_lim).
    assert (ex_integral f).
    { eapply ex_integral_ae_ext; eauto. eapply ae_equal_mult_indicator_compl_0; measurable. }
    split; auto.
    setoid_rewrite <-(Integral_ae_ext_weak) in Hlevi_lim; eauto.
    { eapply is_lim_seq_ext; last eauto.
      intros n => //=.
      symmetry. apply Integral_ae_ext_weak; eauto.
      { eapply almost_everywhere_meas_ext; last eapply ae_equal_mult_indicator_compl_0.
        * intros ?; split; symmetry; eauto.
        * measurable.
        * eauto.
      }
      measurable.
    }
    { eapply almost_everywhere_meas_ext; last eapply ae_equal_mult_indicator_compl_0.
      * intros ?; split; symmetry; eauto.
      * measurable.
      * eauto.
    }
  Qed.

  Lemma is_integral_levi_series_ae_ex fn:
    almost_everywhere_meas μ (λ x, ex_series (λ n, fn n x)) →
    (∀ n x, 0 <= fn n x) →
    (∀ n, ex_integral (fn n)) →
    bound (λ r, ∃ n, is_integral (λ x, sum_n (λ m, fn m x) n) r) →
    ex_integral (λ x, Series (λ n, fn n x)) ∧
    is_series (λ n, Integral (fn n)) (Integral (λ x, (Series (λ n, fn n x )))).
  Proof.
    intros ? Hnonneg ??.
    destruct (is_integral_levi_ae_ex (λ n x, sum_n (λ m, fn m x) n)
                                     (λ x, Series (λ n, fn n x))).
    { apply measurable_Series; auto. }
    { eapply almost_everywhere_meas_ext; last eassumption.
      intros x.
      split.
      - intros ?%ex_series_is_lim_seq; eauto.
      - intros. eexists; eauto.
    }
    { eapply almost_everywhere_meas_True'. intros x n.
      rewrite sum_Sn. specialize (Hnonneg (S n) x).
      rewrite /plus => //=. nra.
    }
    { intros. eapply ex_integral_sum_n; intros; eauto. }
    { eauto. }
    split; eauto.
    eapply is_lim_seq_is_series; eauto.
    eapply is_lim_seq_ext; last eassumption.
    intros => //=. rewrite Integral_sum_n //=.
  Qed.

  Lemma is_integral_mct_ex fn f g:
    measurable f →
    (∀ x, is_lim_seq (λ n, fn n x) (f x : R)) →
    (∀ x, ∀ n, fn n x <= fn (S n) x) →
    (∀ x, ∀ n, Rabs (fn n x) <= g x) →
    (∀ n, ex_integral (fn n)) →
    ex_integral g →
    ex_integral f ∧ is_lim_seq (λ n, Integral (fn n)) (Integral f).
  Proof.
    intros Hmeas Hlim Hmono Hbounded Hex Hexg.
    edestruct (is_integral_levi_ex fn f); eauto.
    destruct Hexg as (v&Hisg).
    exists v.
    intros r (n&His).
    eapply (is_integral_mono (fn n) _ g); eauto.
    intros. specialize (Hbounded x n). move: Hbounded.
    apply Rabs_case; nra.
  Qed.

  Lemma is_integral_const k :
    is_integral (λ _, k) (k * μ (λ _, True)).
  Proof.
    setoid_rewrite <-(wpt_const_spec k) at 1.
    rewrite -wpt_integral_const.
    apply is_integral_wpt.
  Qed.

  Lemma ex_integral_const k :
    ex_integral (λ _, k).
  Proof. eexists. apply is_integral_const. Qed.

  Lemma Integral_const k :
    Integral (λ _, k) = (k * μ (λ _, True)).
  Proof.
    apply is_integral_unique, is_integral_const.
  Qed.

  Lemma measurable_non_ex_pos_integral_0 f:
    measurable f →
    ¬ ex_pos_integral f →
    Pos_integral f = 0.
  Proof.
    intros Hmeas Hnex. rewrite /Pos_integral.
    destruct excluded_middle_informative; auto.
    destruct excluded_middle_informative; auto.
    exfalso; apply Hnex; apply measurable_bounded_simple_ex_pos_integral; eauto.
  Qed.

  Lemma Integral_pos_mct fn f:
    measurable f →
    (∀ x, is_lim_seq (λ n, fn n x) (f x : R)) →
    (∀ x, ∀ n, 0 <= fn n x) →
    (∀ x, ∀ n, fn n x <= fn (S n) x) →
    (∀ n, ex_integral (fn n)) →
    real (Lim_seq (λ n, Integral (fn n))) = Integral f.
  Proof.
    intros Hmeas Hlim Hpos Hmono Hex.
    destruct (Classical_Prop.classic (bound (λ r, ∃ n, is_integral (fn n) r))) as [Hbound|Hunbounded].
    { feed pose proof (is_integral_levi_ex fn f) as Hlevi; eauto.
      destruct Hlevi as (Hex_f&Hlim_int).
      apply is_lim_seq_unique in Hlim_int. rewrite Hlim_int. done. }
    transitivity 0.
    - cut (Lim_seq (λ n, Integral (fn n)) = p_infty).
      { intros ->. done. }
      apply is_lim_seq_unique.
      intros P Hlocal. rewrite /Rbar_locally in Hlocal.
      destruct Hlocal as (K&HK).
      assert (∃ n, K < Integral (fn n)) as (n&HKn).
      { apply Classical_Prop.NNPP. intros Hnex.
        apply Hunbounded. exists K. intros r (n&Heqr).
        apply Rnot_lt_le. intros Hlt. apply Hnex; exists n.
        apply is_integral_unique in Heqr as ->. done. }
      exists n. intros n' Hge. apply HK.
      eapply Rlt_le_trans; first eauto. clear -Hge Hmono Hex.
      induction Hge; first reflexivity.
      etransitivity; eauto. apply Integral_mono; eauto.
    - symmetry.
      assert (∀ x, 0 <= f x).
      { intros x. eapply is_lim_seq_pos; eauto. eauto. }

      rewrite Integral_equiv_Pos_integral //.

      assert (Hneg: ¬ ex_integral f).
      { intros (v&Hexf). apply Hunbounded.
        exists v. intros r (n&Heq).
        eapply (is_integral_mono (fn n) _ f _).
        - intros x. specialize (Hlim x). eapply is_lim_seq_incr_compare in Hlim; eauto.
        - done.
        - done.
      }
      apply measurable_non_ex_pos_integral_0; auto.
      intros Hex'. apply Hneg. apply ex_integral_equiv_pos_integral; eauto.
  Qed.

  Lemma is_lim_seq_Rmin_pos r:
    0 <= r →
    is_lim_seq (λ n : nat, Rmin r (INR n)) r.
  Proof.
    intros Hle. edestruct archimed_pos as (k&?); eauto.
    intros P Hloc.
    exists (S k) => n Hle'.
    rewrite Rmin_left.
    - rewrite /Rbar_locally/locally in Hloc.
      destruct Hloc as (eps&HP). apply HP. apply ball_center.
    - transitivity (INR (S k)); first nra.
      apply le_INR. done.
  Qed.

  Lemma ex_integral_Rmin f:
    (∀ x, 0 <= f x) →
    measurable f →
    ∀ n, ex_integral (λ x, Rmin (f x) (INR n)).
  Proof.
    { intros Hpos Hmeas n. apply (ex_integral_mono_ex _ (λ x, INR n)).
      { intros x. rewrite Rabs_right; auto. apply Rmin_r.
        apply Rmin_case_strong; auto.
        intros. apply Rle_ge, pos_INR. }
      { apply measurable_Rmin; eauto. apply measurable_const. }
      { apply ex_integral_const. }
    }
  Qed.

  Lemma ex_integral_ex_finite_lim_min f:
    (∀ x, 0 <= f x) →
    measurable f →
    ex_finite_lim_seq (λ n, Integral (λ x, Rmin (f x) (INR n))) ↔
            ex_integral f.
  Proof.
    intros Hpos Hmeas.
    assert (∀ n x, 0 <= Rmin (f x) (INR n)).
    { intros => //=. apply Rmin_case_strong; auto.
      intros. apply pos_INR. }
    generalize (ex_integral_Rmin _ Hpos Hmeas) => ?.
    split.
    - intros Hbounded.
      edestruct (is_integral_levi_pos_ex (λ n, λ x, Rmin (f x) (INR n))); eauto.
      { intros x => //=. eapply is_lim_seq_Rmin_pos; eauto. }
      { intros. apply Rle_min_compat_l. apply le_INR. auto. }
      destruct Hbounded as (r&Hub). exists r. intros z (n&His).
      rewrite -(is_integral_unique _ _ His).
      eapply (is_lim_seq_incr_compare (λ n, Integral (λ x, Rmin (f x) (INR n)))); eauto.
      intros n'. apply Integral_mono; eauto.
      intros x. apply Rle_min_compat_l, le_INR; lia.
    - intros (v&Hex). exists v.
      rewrite -(is_integral_unique _ _ Hex).
      edestruct (is_integral_mct_ex (λ n, (λ x, Rmin (f x) (INR n))) f f); eauto.
      { intros x => //=.
        apply is_lim_seq_Rmin_pos; eauto. }
      { intros. apply Rle_min_compat_l, le_INR; lia. }
      { rewrite //= => ??. apply Rmin_case_strong; intros; rewrite Rabs_right; try nra; eauto.
        apply Rle_ge, pos_INR. }
      eexists; eauto.
  Qed.

  Lemma ex_integral_sup_min f:
    (∀ x, 0 <= f x) →
    measurable f →
    bound (λ r, ∃ n, Integral (λ x, Rmin (f x) (INR n)) = r) ↔
            ex_integral f.
  Proof.
    intros Hpos Hmeas.
    assert (∀ n x, 0 <= Rmin (f x) (INR n)).
    { intros => //=. apply Rmin_case_strong; auto.
      intros. apply pos_INR. }
    generalize (ex_integral_Rmin _ Hpos Hmeas) => ?.
    split.
    - intros Hbounded.
      edestruct (is_integral_levi_pos_ex (λ n, λ x, Rmin (f x) (INR n))); eauto.
      { intros x => //=. eapply is_lim_seq_Rmin_pos; eauto. }
      { intros. apply Rle_min_compat_l. apply le_INR. auto. }
      destruct Hbounded as (r&Hub). exists r. intros z (n&?).
      apply Hub. exists n. apply is_integral_unique; eauto.
    - intros (v&Hex). exists v.
      intros r (n&<-).
      rewrite -(is_integral_unique _ _ Hex).
      apply Integral_mono; eauto.
      intros; apply Rmin_l.
      eexists; eauto.
  Qed.

  Lemma is_integral_bound_measure_above f v t:
    (∀ x, 0 <= f x) →
    is_integral f v →
    0 < t →
    μ (λ x, t <= f x) <= v / t.
  Proof.
    intros Hpos His Htpos.
    apply Rnot_gt_le.
    intros Hgt.
    cut (v < Integral f).
    { intros Hlt. rewrite (is_integral_unique _ _ His) in Hlt. nra. }
    apply (Rlt_le_trans _ (t * (μ (λ x, t <= f x)))).
    { apply (Rmult_lt_reg_r (/t)).
      { apply Rinv_0_lt_compat; nra. }
      { field_simplify; try nra. }
    }
    assert (Hm: F (λ x, t <= f x)).
    { apply measurable_fun_ge. eauto. }
    transitivity (Integral (wpt_fun (wpt_scal t (wpt_indicator _ Hm)))).
    { right. rewrite Integral_wpt wpt_integral_scal wpt_integral_indicator. done. }
    apply Integral_mono; eauto.
    - intros x. rewrite wpt_scal_spec wpt_indicator_spec.
      destruct excluded_middle_informative; auto; simpl; try nra. rewrite Rmult_0_r. eauto.
    - eexists; eauto.
  Qed.

  Lemma Integral_Rabs f:
    (ex_integral f ∨ (measurable f ∧ ex_integral (λ x, Rabs (f x)))) →
    Rabs (Integral f) <= Integral (λ x, (Rabs (f x))).
  Proof.
    intros Hex.
    assert (ex_integral f).
    { destruct Hex; auto. apply ex_integral_Rabs; intuition. }
    assert (ex_integral (λ x, Rabs (f x))).
    { destruct Hex; auto.
      - apply (ex_integral_Rabs f); eauto.
      - intuition.
    }
    apply Rabs_case => ?.
    - apply Integral_mono; eauto. intros. apply Rabs_case; nra.
    - replace (- Integral f) with (-1 * Integral f) by nra.
      rewrite -Integral_scal; eauto.
      apply Integral_mono; eauto.
      * intros. apply Rabs_case; nra.
      * by apply ex_integral_scal.
  Qed.

  Lemma is_integral_ae_ge0 f v:
    almost_everywhere_meas μ (λ x, f x >= 0) →
    is_integral f v →
    v >= 0.
  Proof.
    intros Hae His.
    destruct Hae as (Hmeas&Hmeas0).
    generalize (sigma_closed_complements _ F _ Hmeas). rewrite compl_involutive => HF.
    eapply (is_integral_ae_ext _ (λ x, f x * wpt_fun (wpt_indicator _ HF) x))  in His.
    { eapply is_integral_ge0; eauto. intros. rewrite //= wpt_indicator_spec.
      destruct excluded_middle_informative as [Hc|Hnc]; simpl; nra.
    }
    - eapply ae_equal_mult_indicator_compl_0'; auto.
      eauto.
    - measurable. eauto.
  Qed.

  Lemma is_integral_ae_mono f1 v1 f2 v2:
    almost_everywhere_meas μ (λ x, f1 x <= f2 x) →
    is_integral f1 v1 →
    is_integral f2 v2 →
    v1 <= v2.
  Proof.
    intros Hle Hint1 Hint2.
    cut (0 <= v2 - v1); first by nra.
    assert (His: is_integral (λ x, f2 x - f1 x) (v2 - v1)).
    { apply is_integral_minus; auto. }
    apply is_integral_ae_ge0 in His; first nra.
    eapply almost_everywhere_meas_ext; eauto.
    intros x; split; nra.
  Qed.

  Lemma Integral_ae_mono f1 f2:
    almost_everywhere_meas μ (λ x, f1 x <= f2 x) →
    ex_integral f1 →
    ex_integral f2 →
    Integral f1 <= Integral f2.
  Proof.
    intros Hmono (v1&Heq1) (v2&Heq2).
    rewrite (is_integral_unique _ _ Heq1).
    rewrite (is_integral_unique _ _ Heq2).
    eapply is_integral_ae_mono; eauto.
  Qed.

  Lemma ex_integral_ae_mono_ex f1 f2:
    almost_everywhere_meas μ (λ x, Rabs (f1 x) <= f2 x) →
    measurable f1 →
    ex_integral f2 →
    ex_integral f1.
  Proof.
    intros Hae Hmeas Hex.
    destruct Hae as (Hmeas'&Hneg).
    generalize (sigma_closed_complements _ _ _ Hmeas') => H'.
    setoid_rewrite compl_involutive in H'.
    cut (ex_integral (λ x, f2 x * wpt_fun (wpt_indicator _ H') x)).
    {
      intros Hex_indic.
      assert (Hex': ex_integral (λ x, f1 x * wpt_fun (wpt_indicator _ H') x)).
      { eapply ex_integral_mono_ex; last eapply Hex_indic.
        * intros x => //=.
          rewrite ?wpt_indicator_spec.
          destruct excluded_middle_informative; rewrite ?Rmult_1_r ?Rmult_0_r; try nra.
          rewrite Rabs_right; nra.
        * measurable.
      }
      eapply ex_integral_ae_ext; last eapply Hex'; auto.
      apply ae_equal_mult_indicator_compl_0; eauto.
    }
    eapply ex_integral_ae_ext; eauto.
    { eapply ae_equal_mult_indicator_compl_0'; eauto. }
    measurable.
  Qed.

  Lemma ex_integral_ex_integral_over U f :
    F U →
    ex_integral f →
    ex_integral_over U f.
  Proof.
    intros Hmeas Hex.
    rewrite /ex_integral_over/is_integral_over.
    efeed pose proof (ex_integral_ae_mono_ex
                        (λ x : A, f x * (match excluded_middle_informative (U x) with | left _ => 1 | _ => 0 end))
                        (λ x, Rabs (f x))) as Hex'.
    - apply almost_everywhere_meas_True'.
      intros x. destruct (excluded_middle_informative (U x));
      rewrite ?Rmult_1_r ?Rmult_0_r; auto.
      * nra.
      * rewrite Rabs_R0. apply Rabs_pos.
    - measurable. apply measurable_indicator; auto.
    - rewrite -ex_integral_Rabs; eauto.
    - destruct Hex' as (v&?). exists v.
      split; auto.
  Qed.

End integral.

Hint Resolve is_integral_measurable ex_integral_measurable ex_integral_wpt ex_integral_const.

Arguments weighted_partition {_} _.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Coq.Logic.ChoiceFacts.

Require Import Notation.
Require Import GeneralTactics.
Require Import Truncations.
Require Import Axioms.Classical.
Require Import Axioms.Extensionality.

(* "If `x: A` implies there exists some `B x`, then there exists
   some function `Π x: A, B x`". *)
Axiom choice : Π (A: Type) (B: A -> Type),
  (Π x, ‖B x‖) -> ‖Π x, B x‖.

(* Truncation commutes across Π-abstractions *)
Corollary trunc_comm_forall : Π (A: Type) (B: A -> Type),
  (Π x, ‖B x‖) = ‖Π x, B x‖.
Proof using.
  intros *.
  extensionality; split.
  - apply choice.
  - intros H *.
    now uninhabit H.
Qed.

(* Reduction rule on choice (trivialized by proof irrelevance) *)
Lemma choice_red : forall (A: Type) (B: A -> Type) (b: Π a, B a),
  choice _ _ (λ x, |b x|) = |λ x, b x|.
Proof using.
  intros *.
  apply proof_irrelevance.
Qed.

Lemma nondep_choice : forall A B,
  (A -> ‖B‖) -> ‖A -> B‖.
Proof using.
  intros * f.
  now apply choice.
Qed.

Corollary trunc_comm_arrow : forall A B,
  (A -> ‖B‖) = ‖A -> B‖.
Proof using.
  intros.
  apply trunc_comm_forall.
Qed.

Theorem trunc_distr_arrow : forall A B,
  (‖A‖ -> ‖B‖) = ‖A -> B‖ .
Proof using.
  intros *.
  extensionality; split.
 - intros f.
    apply choice.
    intro a.
    applyc f.
    exists a.
  - intros [f] [a].
    exists (f a).
Qed.

Lemma fun_choice : forall A B (R: A -> B -> Prop),
  (forall a, exists b, R a b) ->
  exists f: A -> B, forall a, R a (f a).
Proof using.
  intros * Rltotal.
  transform Rltotal (Π x, ‖{y | R x y}‖) by
    (intros; now rewrite trunc_sig_eq_exists).
  apply choice in Rltotal.
  uninhabit Rltotal.
  define exists.
  - intro a.
    specialize (Rltotal a).
    now destruct Rltotal.
  - intros *.
    simpl.
    now destruct (Rltotal a).
Qed.

Corollary dependent_choice : forall (A: Type) (B: A -> Type) (R: forall a, B a -> Prop),
  (forall a, exists b, R a b) ->
  exists f: (forall a, B a),
    forall a, R a (f a).
Proof using.
  apply non_dep_dep_functional_choice.
  exact fun_choice.
Qed.

(* Functional choice does not require an axiom when the proof of left-totalness
   is transparent/constructive *)
Definition fun_choice_constructive : forall A B (R: A -> B -> Prop),
  (forall a, Σ b, R a b) ->
  Σ f: A -> B, forall a, R a (f a).
Proof using.
  intros * Rltotal.
  exists (λ a, projT1 (Rltotal a)).
  intro a.
  now destruct (Rltotal a).
Defined.

Lemma rel_choice : forall A B (R: A -> B -> Prop),
  (forall x, exists y, R x y) ->
  exists R': A -> B -> Prop,
    subrelation R' R /\
    forall x, exists! y, R' x y.
Proof using.
  intros * Rltotal.
  transform Rltotal (Π x, ‖{y | R x y}‖) by
    (intros; now rewrite trunc_sig_eq_exists).
  apply choice in Rltotal.
  uninhabit Rltotal.
  define exists.
  - intro a.
    specialize (Rltotal a).
    destruct exists Rltotal b.
    exact (λ x, b = x).
  - simpl.
    split.
    + unfold subrelation.
      intros * ?.
      destruct (Rltotal x).
      now subst.
    + intros *.
      follows destruct (Rltotal x).
Qed.

Theorem exists_universal_decision_procedure :
  ‖Π P, {P} + {~P}‖.
Proof using.
  apply choice.
  intro P.
  destruct classic P as H.
  - exists (left H).
  - exists (right H).
Qed.

(* Warning: this is known to conflict with impredicative set. *)
Theorem double_neg_classic_set :
  (* ((Π P, {P} + {~P}) -> False) -> False. *)
  notT (notT (Π P, {P} + {~P})).
Proof using.
  rewrite <- truncated_eq_double_neg.
  exact exists_universal_decision_procedure.
Qed.

Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Sets.Ensembles.

Definition antisymmetric {A} (R: relation A) :=
  forall x y, R x y -> R y x -> x = y.

Definition strongly_connected {A} (R: relation A) :=
  forall x y, R x y \/ R y x.

Definition total_order {A} (R: relation A) :=
  Reflexive R /\
  Transitive R /\
  antisymmetric R /\
  strongly_connected R.

Definition well_order {A} (R: relation A) :=
  total_order R /\
  forall subset: Ensemble A,
    Inhabited A subset ->
    exists least, forall x, In A subset x -> R least x.

(* Theorem ex_well_ordering : forall A,
  exists R: relation A, well_order R.
Proof using. *)


(* -*- mode: coq; mode: visual-line -*- *)
(** * Equivalences *)

Require Import
  Basics.Overture
  Basics.PathGroupoids
  Basics.Contractible
  Basics.Tactics.
Local Open Scope path_scope.

(** We now give many ways to construct equivalences.  In each case, we define an instance of the typeclass [IsEquiv] named [isequiv_X], followed by an element of the record type [Equiv] named [equiv_X].

   Whenever we need to assume, as a hypothesis, that a certain function is an equivalence, we do it by assuming separately a function and a proof of [IsEquiv].  This is more general than assuming an inhabitant of [Equiv], since the latter has an implicit coercion and an existing instance to give us the former automatically.  Moreover, implicit generalization makes it easy to assume a function and a proof of [IsEquiv]. *)

(** A word on naming: some of the lemmas about equivalences are analogues of those for paths in PathGroupoids.  We name them in an analogous way but adding [_equiv] in an appropriate place, e.g. instead of [moveR_M] we have [moveR_equiv_M].  *)

Generalizable Variables A B C f g.

(** The identity map is an equivalence. *)
Global Instance isequiv_idmap (A : Type) : IsEquiv idmap | 0 :=
  Build_IsEquiv A A idmap idmap (fun _ => 1) (fun _ => 1) (fun _ => 1).

Definition equiv_idmap (A : Type) : A <~> A := Build_Equiv A A idmap _.

Arguments equiv_idmap {A} , A.

Notation "1" := equiv_idmap : equiv_scope.

Global Instance reflexive_equiv : Reflexive Equiv | 0 := @equiv_idmap.

Arguments reflexive_equiv /.

(** The composition of equivalences is an equivalence. *)
Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g}
  : IsEquiv (compose g f) | 1000
  := Build_IsEquiv A C (compose g f)
    (compose f^-1 g^-1)
    (fun c => ap g (eisretr f (g^-1 c)) @ eisretr g c)
    (fun a => ap (f^-1) (eissect g (f a)) @ eissect f a)
    (fun a =>
      (whiskerL _ (eisadj g (f a))) @
      (ap_pp g _ _)^ @
      ap02 g
      ( (concat_A1p (eisretr f) (eissect g (f a)))^ @
        (ap_compose f^-1 f _ @@ eisadj f a) @
        (ap_pp f _ _)^
      ) @
      (ap_compose f g _)^
    ).

(* An alias of [isequiv_compose], with some arguments explicit; often convenient when type class search fails. *)
Definition isequiv_compose'
  {A B : Type} (f : A -> B) (_ : IsEquiv f)
  {C : Type} (g : B -> C) (_ : IsEquiv g)
  : IsEquiv (g o f)
  := isequiv_compose.

Definition equiv_compose {A B C : Type} (g : B -> C) (f : A -> B)
  `{IsEquiv B C g} `{IsEquiv A B f}
  : A <~> C
  := Build_Equiv A C (compose g f) _.

Definition equiv_compose' {A B C : Type} (g : B <~> C) (f : A <~> B)
  : A <~> C
  := equiv_compose g f.

Definition iff_equiv {A B : Type} (f : A <~> B)
  : A <-> B := (equiv_fun f, f^-1).

(** We put [g] and [f] in [equiv_scope] explcitly.  This is a partial work-around for https://coq.inria.fr/bugs/show_bug.cgi?id=3990, which is that implicitly bound scopes don't nest well. *)
Notation "g 'oE' f" := (equiv_compose' g%equiv f%equiv) : equiv_scope.

(* The TypeClass [Transitive] has a different order of parameters than [equiv_compose].  Thus in declaring the instance we have to switch the order of arguments. *)
Global Instance transitive_equiv : Transitive Equiv | 0 :=
  fun _ _ _ f g => equiv_compose g f.

Arguments transitive_equiv /.

Ltac change_apply_equiv_compose :=
  match goal with
  | [ |- context [ equiv_fun (?f oE ?g) ?x ] ] =>
    change ((f oE g) x) with (f (g x))
  end.

(** Anything homotopic to an equivalence is an equivalence. *)
Section IsEquivHomotopic.

  Context {A B : Type} (f : A -> B) {g : A -> B}.
  Context `{IsEquiv A B f}.
  Hypothesis h : f == g.

  Let sect := (fun b:B => (h (f^-1 b))^ @ eisretr f b).
  Let retr := (fun a:A => (ap f^-1 (h a))^ @ eissect f a).

  (* We prove the triangle identity with rewrite tactics.  Since we lose control over the proof term that way, we make the result opaque with "Qed". *)
  Let adj (a : A) : sect (g a) = ap g (retr a).
  Proof.
    unfold sect, retr.
    rewrite ap_pp. apply moveR_Vp.
    rewrite concat_p_pp, <- concat_Ap, concat_pp_p, <- concat_Ap.
    rewrite ap_V; apply moveL_Vp.
    rewrite <- ap_compose; rewrite (concat_A1p (eisretr f) (h a)).
    apply whiskerR, eisadj.
  Qed.

  (* This should not be an instance; it can cause the unifier to spin forever searching for functions to be homotopic to. *)
  Definition isequiv_homotopic : IsEquiv g
    := Build_IsEquiv _ _ g (f ^-1) sect retr adj.

  Definition equiv_homotopic : A <~> B
    := Build_Equiv _ _ g isequiv_homotopic.

End IsEquivHomotopic.

Definition isequiv_homotopic' {A B : Type} (f : A <~> B) {g : A -> B} (h : f == g)
  : IsEquiv g
  := isequiv_homotopic f h.

(** Transporting is an equivalence. *)
Section EquivTransport.

  Context {A : Type} (P : A -> Type) {x y : A} (p : x = y).

  Global Instance isequiv_transport : IsEquiv (transport P p) | 0
    := Build_IsEquiv (P x) (P y) (transport P p) (transport P p^)
    (transport_pV P p) (transport_Vp P p) (transport_pVp P p).

  Definition equiv_transport : P x <~> P y
    := Build_Equiv _ _ (transport P p) _.

End EquivTransport.

(** In all the above cases, we were able to directly construct all the structure of an equivalence.  However, as is evident, sometimes it is quite difficult to prove the adjoint law.

   The following adjointification theorem allows us to be lazy about this if we wish.  It says that if we have all the data of an (adjoint) equivalence except the triangle identity, then we can always obtain the triangle identity by modifying the datum [equiv_is_section] (or [equiv_is_retraction]).  The proof is the same as the standard categorical argument that any equivalence can be improved to an adjoint equivalence.

   As a stylistic matter, we try to avoid using adjointification in the library whenever possible, to preserve the homotopies specified by the user.  *)

Section Adjointify.

  Context {A B : Type} (f : A -> B) (g : B -> A).
  Context (isretr : f o g == idmap) (issect : g o f == idmap).

  (* This is the modified [eissect]. *)
  Let issect' := fun x =>
    ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.

  Local Definition is_adjoint' (a : A) : isretr (f a) = ap f (issect' a).
  Proof.
    unfold issect'.
    apply moveR_M1.
    repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose.
    rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)).
    repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1.
    rewrite concat_p_pp, <- ap_compose.
    rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))).
    rewrite concat_pV, concat_1p; reflexivity.
  Qed.

  (** We don't make this a typeclass instance, because we want to control when we are applying it. *)
  Definition isequiv_adjointify : IsEquiv f
    := Build_IsEquiv A B f g isretr issect' is_adjoint'.

  Definition equiv_adjointify : A <~> B
    := Build_Equiv A B f isequiv_adjointify.

End Adjointify.

Arguments isequiv_adjointify {A B}%type_scope (f g)%function_scope isretr issect.
Arguments equiv_adjointify {A B}%type_scope (f g)%function_scope isretr issect.

(** An involution is an endomap that is its own inverse. *)
Definition isequiv_involution {X : Type} (f : X -> X) (isinvol : f o f == idmap)
: IsEquiv f
  := isequiv_adjointify f f isinvol isinvol.

Definition equiv_involution {X : Type} (f : X -> X) (isinvol : f o f == idmap)
: X <~> X
  := equiv_adjointify f f isinvol isinvol.

(** Several lemmas useful for rewriting. *)
Definition moveR_equiv_M `{IsEquiv A B f} (x : A) (y : B) (p : x = f^-1 y)
  : (f x = y)
  := ap f p @ eisretr f y.

Definition moveR_equiv_M' `(f : A <~> B) (x : A) (y : B) (p : x = f^-1 y)
  : (f x = y)
  := moveR_equiv_M x y p.

Definition moveL_equiv_M `{IsEquiv A B f} (x : A) (y : B) (p : f^-1 y = x)
  : (y = f x)
  := (eisretr f y)^ @ ap f p.

Definition moveL_equiv_M' `(f : A <~> B) (x : A) (y : B) (p : f^-1 y = x)
  : (y = f x)
  := moveL_equiv_M x y p.

Definition moveR_equiv_V `{IsEquiv A B f} (x : B) (y : A) (p : x = f y)
  : (f^-1 x = y)
  := ap (f^-1) p @ eissect f y.

Definition moveR_equiv_V' `(f : A <~> B) (x : B) (y : A) (p : x = f y)
  : (f^-1 x = y)
  := moveR_equiv_V x y p.

Definition moveL_equiv_V `{IsEquiv A B f} (x : B) (y : A) (p : f y = x)
  : (y = f^-1 x)
  := (eissect f y)^ @ ap (f^-1) p.

Definition moveL_equiv_V' `(f : A <~> B) (x : B) (y : A) (p : f y = x)
  : (y = f^-1 x)
  := moveL_equiv_V x y p.

(** Equivalence preserves contractibility (which of course is trivial under univalence). *)
Lemma contr_equiv A {B} (f : A -> B) `{IsEquiv A B f} `{Contr A}
  : Contr B.
Proof.
  exists (f (center A)).
  intro y.
  apply moveR_equiv_M.
  apply contr.
Defined.

Definition contr_equiv' A {B} `(f : A <~> B) `{Contr A}
  : Contr B
  := contr_equiv A f.

(** Any two contractible types are equivalent. *)
Global Instance isequiv_contr_contr {A B : Type}
       `{Contr A} `{Contr B} (f : A -> B)
  : IsEquiv f
  := Build_IsEquiv _ _ f (fun _ => (center A))
                  (fun x => path_contr _ _)
                  (fun x => path_contr _ _)
                  (fun x => path_contr _ _).

Lemma equiv_contr_contr {A B : Type} `{Contr A} `{Contr B}
  : (A <~> B).
Proof.
  apply equiv_adjointify with (fun _ => center B) (fun _ => center A);
  intros ?; apply contr.
Defined.

(** The projection from the sum of a family of contractible types is an equivalence. *)
Global Instance isequiv_pr1 {A : Type} (P : A -> Type) `{forall x, Contr (P x)}
  : IsEquiv (@pr1 A P).
Proof.
  apply (Build_IsEquiv
           _ _ (@pr1 A P)
           (fun x => (x ; center (P x)))
           (fun x => 1)
           (fun xy => match xy with
                      | exist x y => ap (exist _ x) (contr _)
                      end)).
  intros [x y].
  rewrite <- ap_compose.
  symmetry; apply ap_const.
Defined.

Definition equiv_pr1 {A : Type} (P : A -> Type) `{forall x, Contr (P x)}
  : { x : A & P x } <~> A
  := Build_Equiv _ _ (@pr1 A P) _.

(** Assuming function extensionality, composing with an equivalence is itself an equivalence *)

Global Instance isequiv_precompose `{Funext} {A B C : Type}
  (f : A -> B) `{IsEquiv A B f}
  : IsEquiv (fun (g:B->C) => g o f) | 1000
  := isequiv_adjointify (fun (g:B->C) => g o f)
    (fun h => h o f^-1)
    (fun h => path_forall _ _ (fun x => ap h (eissect f x)))
    (fun g => path_forall _ _ (fun y => ap g (eisretr f y))).

Definition equiv_precompose `{Funext} {A B C : Type}
  (f : A -> B) `{IsEquiv A B f}
  : (B -> C) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:B->C) => g o f) _.

Definition equiv_precompose' `{Funext} {A B C : Type} (f : A <~> B)
  : (B -> C) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:B->C) => g o f) _.

Global Instance isequiv_postcompose `{Funext} {A B C : Type}
  (f : B -> C) `{IsEquiv B C f}
  : IsEquiv (fun (g:A->B) => f o g) | 1000
  := isequiv_adjointify (fun (g:A->B) => f o g)
    (fun h => f^-1 o h)
    (fun h => path_forall _ _ (fun x => eisretr f (h x)))
    (fun g => path_forall _ _ (fun y => eissect f (g y))).

Definition equiv_postcompose `{Funext} {A B C : Type}
  (f : B -> C) `{IsEquiv B C f}
  : (A -> B) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:A->B) => f o g) _.

Definition equiv_postcompose' `{Funext} {A B C : Type} (f : B <~> C)
  : (A -> B) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:A->B) => f o g) _.

(** Conversely, if pre- or post-composing with a function is always an equivalence, then that function is also an equivalence.  It's convenient to know that we only need to assume the equivalence when the other type is the domain or the codomain. *)

Definition isequiv_isequiv_precompose {A B : Type} (f : A -> B)
  (precomp := (fun (C : Type) (h : B -> C) => h o f))
  (Aeq : IsEquiv (precomp A)) (Beq : IsEquiv (precomp B))
  : IsEquiv f.
Proof.
  assert (H : forall (C D : Type)
                     (Ceq : IsEquiv (precomp C)) (Deq : IsEquiv (precomp D))
                     (k : C -> D) (h : A -> C),
                k o (precomp C)^-1 h = (precomp D)^-1 (k o h)).
  { intros C D ? ? k h.
    transitivity ((precomp D)^-1 (k o (precomp C ((precomp C)^-1 h)))).
    - transitivity ((precomp D)^-1 (precomp D (k o ((precomp C)^-1 h)))).
      + rewrite (eissect (precomp D) _); reflexivity.
      + reflexivity.
    - rewrite (eisretr (precomp C) h); reflexivity. }
  refine (isequiv_adjointify f ((precomp A)^-1 idmap) _ _).
  - intros x.
    change ((f o (precomp A)^-1 idmap) x = idmap x).
    apply ap10.
    rewrite (H A B Aeq Beq).
    change ((precomp B)^-1 (precomp B idmap) = idmap).
    apply eissect.
  - intros x.
    change ((precomp A ((precomp A)^-1 idmap)) x = idmap x).
    apply ap10, eisretr.
Qed.

(*
Definition isequiv_isequiv_postcompose {A B : Type} (f : A -> B)
  (postcomp := (fun (C : Type) (h : C -> A) => f o h))
  (feq : forall C:Type, IsEquiv (postcomp C))
  : IsEquiv f.
(* TODO *)
*)

(** Equivalences between path spaces *)

(** If [f] is an equivalence, then so is [ap f].  We are lazy and use [adjointify]. *)
Global Instance isequiv_ap `{IsEquiv A B f} (x y : A)
  : IsEquiv (@ap A B f x y) | 1000
  := isequiv_adjointify (ap f)
  (fun q => (eissect f x)^  @  ap f^-1 q  @  eissect f y)
  (fun q =>
    ap_pp f _ _
    @ whiskerR (ap_pp f _ _) _
    @ ((ap_V f _ @ inverse2 (eisadj f _)^)
      @@ (ap_compose f^-1 f _)^
      @@ (eisadj f _)^)
    @ concat_pA1_p (eisretr f) _ _
    @ whiskerR (concat_Vp _) _
    @ concat_1p _)
  (fun p =>
    whiskerR (whiskerL _ (ap_compose f f^-1 _)^) _
    @ concat_pA1_p (eissect f) _ _
    @ whiskerR (concat_Vp _) _
    @ concat_1p _).

Definition equiv_ap `(f : A -> B) `{IsEquiv A B f} (x y : A)
  : (x = y) <~> (f x = f y)
  := Build_Equiv _ _ (ap f) _.

Global Arguments equiv_ap (A B)%type_scope f%function_scope _ _ _.

Definition equiv_ap' `(f : A <~> B) (x y : A)
  : (x = y) <~> (f x = f y)
  := equiv_ap f x y.

(* TODO: Is this really necessary? *)
Definition equiv_inj `(f : A -> B) `{IsEquiv A B f} {x y : A}
  : (f x = f y) -> (x = y)
  := (ap f)^-1.

(** The inverse of an equivalence is an equivalence. *)
Global Instance isequiv_inverse {A B : Type} (f : A -> B) {feq : IsEquiv f}
  : IsEquiv f^-1 | 10000.
Proof.
  refine (Build_IsEquiv B A f^-1 f (eissect f) (eisretr f) _).
  intro b.
  apply (equiv_inj (ap f)).
(* We will prove the equality as a composite of four paths, working right to left.
  The LHS remains [ap f (eissect f (f^-1 b))] throughout the process.
  Both sides of the equation are paths of type [f (f^-1 (f (f^-1 b))) = f (f^-1 b)]. *)
  refine (_ @ _ @ _ @ _); revgoals.
  1: apply ap_compose.
  1: symmetry; apply (ap_homotopic_id (eisretr f)).
  1: symmetry; apply concat_pp_V.
  1: symmetry; apply eisadj.
Defined.

(** If the goal is [IsEquiv _^-1], then use [isequiv_inverse]; otherwise, don't pretend worry about if the goal is an evar and we want to add a [^-1]. *)
#[export]
Hint Extern 0 (IsEquiv _^-1) => apply @isequiv_inverse : typeclass_instances.

(** [Equiv A B] is a symmetric relation. *)
Theorem equiv_inverse {A B : Type} : (A <~> B) -> (B <~> A).
Proof.
  intro e.
  exists (e^-1).
  apply isequiv_inverse.
Defined.

Notation "e ^-1" := (@equiv_inverse _ _ e) : equiv_scope.

Global Instance symmetric_equiv : Symmetric Equiv | 0 := @equiv_inverse.

Arguments symmetric_equiv /.

(** Inversion respects composition *)
Definition equiv_inverse_compose {A B C} (f : A <~> B) (g : B <~> C)
  : (g oE f)^-1 == f^-1 oE g^-1.
Proof.
  intros x; reflexivity.
Defined.

(** Inversion respects homotopies *)
Definition equiv_inverse_homotopy {A B} (f g : A <~> B) (p : f == g)
  : g^-1 == f^-1.
Proof.
  intros x; refine (_ @ _ @ _).
  1:symmetry; apply (eissect f).
  1:apply ap, p.
  apply ap, eisretr.
Defined.

Definition equiv_ap_inv `(f : A -> B) `{IsEquiv A B f} (x y : B)
  : (f^-1 x = f^-1 y) <~> (x = y)
  := (@equiv_ap B A f^-1 _ x y)^-1%equiv.

Definition equiv_ap_inv' `(f : A <~> B) (x y : B)
  : (f^-1 x = f^-1 y) <~> (x = y)
  := (equiv_ap' f^-1%equiv x y)^-1%equiv.

(** If [g \o f] and [f] are equivalences, so is [g].  This is not an Instance because it would require Coq to guess [f]. *)
Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C}
  `{IsEquiv A B f} `{IsEquiv A C (g o f)}
  : IsEquiv g
  := isequiv_homotopic (compose (compose g f) f^-1)
       (fun b => ap g (eisretr f b)).

Definition cancelR_equiv {A B C} (f : A -> B) {g : B -> C}
  `{IsEquiv A B f} `{IsEquiv A C (g o f)}
  : B <~> C
  := Build_Equiv B C g (cancelR_isequiv f).

(** If [g \o f] and [g] are equivalences, so is [f]. *)
Definition cancelL_isequiv {A B C} (g : B -> C) {f : A -> B}
  `{IsEquiv B C g} `{IsEquiv A C (g o f)}
  : IsEquiv f
  := isequiv_homotopic (compose g^-1 (compose g f))
       (fun a => eissect g (f a)).

Definition cancelL_equiv {A B C} (g : B -> C) {f : A -> B}
  `{IsEquiv B C g} `{IsEquiv A C (g o f)}
  : A <~> B
  := Build_Equiv _ _ f (cancelL_isequiv g).

(** Combining these with [isequiv_compose], we see that equivalences can be transported across commutative squares. *)
Definition isequiv_commsq {A B C D}
           (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D)
           (p : k o f == g o h)
           `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k}
: IsEquiv g.
Proof.
  refine (@cancelR_isequiv _ _ _ h g _ _).
  refine (isequiv_homotopic _ p).
Defined.

Definition isequiv_commsq' {A B C D}
           (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D)
           (p : g o h == k o f)
           `{IsEquiv _ _ g} `{IsEquiv _ _ h} `{IsEquiv _ _ k}
: IsEquiv f.
Proof.
  refine (@cancelL_isequiv _ _ _ k f _ _).
  refine (isequiv_homotopic _ p).
Defined.

(** Based homotopy spaces *)

Global Instance contr_basedhomotopy `{Funext}
       {A:Type} {B : A -> Type} (f : forall x, B x)
: Contr {g : forall x, B x & f == g }.
Proof.
  refine (contr_equiv' { g : forall x, B x & f = g } _).
  srapply equiv_adjointify; intros [g h].
  - exact (g; apD10 h).
  - exact (g; path_forall _ _ h).
  - apply ap, eisretr.
  - apply ap, eissect.
Defined.

Global Instance contr_basedhomotopy' `{Funext}
       {A:Type} {B : A -> Type} (f : forall x, B x)
: Contr {g : forall x, B x & g == f }.
Proof.
  refine (contr_equiv' { g : forall x, B x & g = f } _).
  srapply equiv_adjointify; intros [g h].
  - exact (g; apD10 h).
  - exact (g; path_forall _ _ h).
  - apply ap, eisretr.
  - apply ap, eissect.
Defined.

(** The function [equiv_ind] says that given an equivalence [f : A <~> B], and a hypothesis from [B], one may always assume that the hypothesis is in the image of [e].

In fibrational terms, if we have a fibration over [B] which has a section once pulled back along an equivalence [f : A <~> B], then it has a section over all of [B].  *)

Definition equiv_ind `{IsEquiv A B f} (P : B -> Type)
  : (forall x:A, P (f x)) -> forall y:B, P y
  := fun g y => transport P (eisretr f y) (g (f^-1 y)).

Arguments equiv_ind {A B} f {_} P _ _.

Definition equiv_ind_comp `{IsEquiv A B f} (P : B -> Type)
  (df : forall x:A, P (f x)) (x : A)
  : equiv_ind f P df (f x) = df x.
Proof.
  unfold equiv_ind.
  rewrite eisadj.
  rewrite <- transport_compose.
  exact (apD df (eissect f x)).
Defined.

(** Using [equiv_ind], we define a handy little tactic which introduces a variable and simultaneously substitutes it along an equivalence. *)

Ltac equiv_intro E x :=
  match goal with
    | |- forall y, @?Q y =>
      refine (equiv_ind E Q _); intros x
  end.

(** The same, but for several variables. *)

Tactic Notation "equiv_intros" constr(E) ident(x)
  := equiv_intro E x.
Tactic Notation "equiv_intros" constr(E) ident(x) ident(y)
  := equiv_intro E x; equiv_intro E y.
Tactic Notation "equiv_intros" constr(E) ident(x) ident(y) ident(z)
  := equiv_intro E x; equiv_intro E y; equiv_intro E z.

(** A lemma that combines equivalence induction with path induction.  If [e] is an equivalence from [a = b] to [X], then to prove [forall x, P x] it is enough to prove [forall p : a = b, P (e p)], and so by path induction it suffices to prove [P (e 1)]. The idiom for using this is to first [revert b X], which allows Coq to determine the family [P]. After using this, [b] will be replaced by [a] in the goal. *)
Definition equiv_path_ind {A} {a : A} {X : A -> Type}
           (e : forall (b : A), a = b <~> X b)
           (P : forall (b : A), X b -> Type)
           (r : P a (e a 1))
  : forall (b : A) (x : X b), P b x.
Proof.
  intro b.
  srapply (equiv_ind (e b)).
  intros [].
  exact r.
Defined.

(** [equiv_composeR'], a flipped version of [equiv_compose'], is (like [concatR]) most often useful partially applied, to give the “first half” of an equivalence one is constructing and leave the rest as a subgoal. One could similarly define [equiv_composeR] as a flip of [equiv_compose], but it doesn’t seem so useful since it doesn’t leave the remaining equivalence as a subgoal. *)
Definition equiv_composeR' {A B C} (f : A <~> B) (g : B <~> C)
  := equiv_compose' g f.

(* Shouldn't this become transitivity mid ? *)
Ltac equiv_via mid :=
  apply @equiv_composeR' with (B := mid).

(** It's often convenient when constructing a chain of equivalences to use [equiv_compose'], etc.  But when we treat an [Equiv] object constructed in that way as a function, via the coercion [equiv_fun], Coq sometimes needs a little help to realize that the result is the same as ordinary composition.  This tactic provides that help. *)
Ltac ev_equiv :=
  repeat match goal with
           | [ |- context[equiv_fun (equiv_compose' ?g ?f) ?a] ] =>
             change ((equiv_compose' g f) a) with (g (f a))
           | [ |- context[equiv_fun (equiv_compose ?g ?f) ?a] ] =>
             change ((equiv_compose g f) a) with (g (f a))
           | [ |- context[equiv_fun (equiv_inverse ?f) ?a] ] =>
             change ((equiv_inverse f) a) with (f^-1 a)
         end.

(** ** Building equivalences between nested sigma and record types *)

(** The following tactic [make_equiv] builds an equivalence between two types built out of arbitrarily nested sigma and record types, not necessarily right-associated, as long as they have all the same underyling components.  This is more general than [issig] in that it doesn't just prove equivalences between a single record type and a single right-nested tower of sigma types, but less powerful in that it can't deduce the latter nested tower of sigmas automatically: you have to have both sides of the equivalence known. *)

(* Perform [intros] repeatedly, recursively destructing all possibly-nested record types. *)
Ltac decomposing_intros :=
  let x := fresh in
  intros x; cbn in x;
  try match type of x with
  | ?a = ?b => fail 1           (** Don't destruct paths *)
  | forall y:?A, ?B => fail 1   (** Don't apply functions *)
  | _ => elim x; clear x
  end;
  try decomposing_intros.

(* A multi-success version of [assumption].  That is, like [assumption], but if there are multiple hypotheses that match the type of the goal, then after choosing the first one, if a later tactic fails we can backtrack and choose another one. *)
Ltac multi_assumption :=
  multimatch goal with
    (* If we wrote [ H : ?A |- ?A ] here instead, it would prevent Coq from choosing an assumption that would require instantiating evars, which it has to do in the contr_basedpaths case below. *)
    [ H : ?A |- _ ] => exact H
  end.

(* Build an element of a possibly-nested record type out of hypotheses in the context. *)
Ltac build_record :=
  cbn; multi_assumption + (unshelve econstructor; build_record).

(* Construct an equivalence between two possibly-nested record/sigma types that differ only by associativity and permutation of their components.  We could use [Build_Equiv] and directly construct [eisadj] by decomposing to reflexivity as well, but often with large nested types it seems to be faster to adjointify. *)
Ltac make_equiv :=
  simple notypeclasses refine (equiv_adjointify _ _ _ _);
    [ decomposing_intros; build_record
    | decomposing_intros; build_record
    | decomposing_intros; exact idpath
    | decomposing_intros; exact idpath ].

(** In case anyone ever needs it, here's the version that doesn't adjointify. It's not the default, because it can be slow. *)
Ltac make_equiv_without_adjointification :=
  simple notypeclasses refine (Build_Equiv _ _ _ _);
    [ decomposing_intros; build_record |
      simple notypeclasses refine (Build_IsEquiv _ _ _ _ _ _ _);
      [ decomposing_intros; build_record
      | decomposing_intros; exact idpath
      | decomposing_intros; exact idpath
      | decomposing_intros; exact idpath ] ].

(** Here are some examples of the use of this tactic that you can uncomment and explore. *)

(**
<<
Goal forall (A : Type) (B : A -> Type) (C : forall a:A, B a -> Type) (D : forall (a:A) (b:B a), C a b -> Type),
     { ab : {a : A & B a } & { c : C ab.1 ab.2 & D ab.1 ab.2 c } }
     <~> { a : A & { bc : { b : B a & C a b } & D a bc.1 bc.2 } }.
  intros A B C D.
  make_equiv.
  Undo.
  (** Here's the eventually successful proof script produced by [make_equiv], extracted from [Info 0 make_equiv] and prettified, so you can step through it and see how the tactic works. *)
  simple notypeclasses refine (equiv_adjointify _ _ _ _).
  - (** Here begins [decomposing_intros] *)
    intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros b; cbn in b.
    intros x; cbn in x.
    elim x; clear x.
    intros c; cbn in c.
    intros d; cbn in d.
    (** Here begins [build_record] *)
    cbn; unshelve econstructor.
    { cbn; exact a. }
    { cbn; unshelve econstructor.
      { cbn; unshelve econstructor.
        { cbn; exact b. }
        { cbn; exact c. } }
      { cbn; exact d. } }
  - intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros b; cbn in b.
    intros c; cbn in c.
    intros d; cbn in d.
    cbn; unshelve econstructor.
    { cbn; unshelve econstructor.
      { cbn; exact a. }
      { cbn; exact b. } }
    { cbn; unshelve econstructor.
      { cbn; exact c. }
      { cbn; exact d. } }
  - intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros b; cbn in b.
    intros c; cbn in c.
    intros d; cbn in d.
    cbn; exact idpath.
  - intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros b; cbn in b.
    intros x; cbn in x.
    elim x; clear x.
    intros c; cbn in c.
    intros d; cbn in d.
    cbn; exact idpath.
Defined.
>>
*)

(** Here is an example illustrating the need for [multi_assumption] instead of just [assumption]. *)
(**
<<
Goal forall (A:Type) (R:A->A->Type),
    { x : A & { y : A & R x y } } <~> { xy : A * A & R (fst xy) (snd xy) }.
  intros A R.
  make_equiv.
  Undo.
  simple notypeclasses refine (equiv_adjointify _ _ _ _).
  - intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros x; cbn in x.
    elim x; clear x.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; unshelve econstructor.
    { cbn; unshelve econstructor.
      { (** [build_record] can't guess at this point that it needs to use [a1] instead of [a2], and in fact it tries [a2] first; but later on, [exact r] fails in that case, causing backtracking to this point and a re-try with [a1].  *)
        cbn; exact a1. }
      { cbn; exact a2. } }
    cbn; exact r.
  - intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; unshelve econstructor.
    { cbn; exact a1. }
    { cbn; unshelve econstructor.
      { cbn; exact a2. }
      { cbn; exact r. } }
  - intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; exact idpath.
  - intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros x; cbn in x.
    elim x; clear x.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; exact idpath.
Defined.
>>
*)

(** Some "real-world" examples where [make_equiv] simplifies things a lot include the associativity/symmetry proofs in [Types/Sigma.v], [issig_pequiv'] in [Pointed/pEquiv.v], and [loop_susp_adjoint] in [Pointed/pSusp.v]. *)

(** Now we give a version of [make_equiv] that can also prove equivalences of nested sigma- and record types that involve contracting based path-spaces on either or both sides.  The basepoint and the path don't have to appear together, but can be in arbitrarily separated parts of the nested structure.  It does this by selectively applying path-induction to based paths appearing on both sides, if needed. *)

(** We start with a version of [decomposing_intros] that is willing to destruct paths, though as a second choice. *)
Ltac decomposing_intros_with_paths :=
  let x := fresh in
  intros x; cbn in x;
  multimatch type of x with
  | _ =>
    try match type of x with
        | (** Don't destruct paths at first *)
          ?a = ?b => fail 1
        | (** Don't apply functions at first *)
          forall y:?A, ?B => fail 1
        | _ => elim x; clear x
        end;
    try decomposing_intros_with_paths
  | ?a = ?b =>
    (** Destruct paths as a second choice.  But sometimes [destruct] isn't smart enough to generalize the other hypotheses that use the free endpoint, so we manually apply [paths_ind], or its right-handed version, instead. *)
    ((move x before b; (** Ensure that [b] and [x] come first in the [forall] goal resulting from [generalize dependent], so that [paths_ind] can apply to it. *)
      revert dependent b;
      assert_fails (move b at top); (** Check that [b] was actually reverted.  (If it's a section variable that the goal depends on, [generalize dependent b] will "succeed", but actually fail to generalize the goal over [b] (since that can't be done within the section) and not clear [b] from the context.)  *)
      refine (paths_ind _ _ _)) +
     (** Try the other endpoint too. *)
     (move x before a;
      revert dependent a;
      assert_fails (move a at top);
      refine (paths_ind_r _ _ _)));
    try decomposing_intros_with_paths
  end.

(** Going the other direction, we have to be willing to insert identity paths to fill in the based path-spaces that got destructed.  In fact [econstructor] is already willing to do that, since [idpath] is the constructor of [paths].  However, our previous [build_record] won't manage to get to the point of being able to apply [econstructor] to the necessary paths, since it'll get stuck earlier on trying to find the basepoint.  Thus, we give a version of [build_record] that is willing to create existential variables ("evars") for goals that it can't solve, in hopes that a later [idpath] (produced by [econstructor]) will determine them by unification.  Note that if there are other fields that depend on the basepoint that occur before the [idpath], the evar will -- and, indeed, must -- get instantiated by them instead.  This is why [multi_assumption], above, must be willing to instantiate evars. *)
Ltac build_record_with_evars :=
  (cbn; multi_assumption + (unshelve econstructor; build_record_with_evars)) +
  (** Create a fresh evar to solve this goal *)
  (match goal with
     |- ?G => let x := fresh in evar (x : G); exact x
   end; build_record_with_evars).

(** Now here's the improved version of [make_equiv]. *)
Ltac make_equiv_contr_basedpaths :=
  simple notypeclasses refine (equiv_adjointify _ _ _ _);
    (** [solve [ unshelve TAC ]] ensures that [TAC] succeeds without leaving any leftover evars. *)
    [ decomposing_intros_with_paths; solve [ unshelve build_record_with_evars ]
    | decomposing_intros_with_paths; solve [ unshelve build_record_with_evars ]
    | decomposing_intros_with_paths; exact idpath
    | decomposing_intros_with_paths; exact idpath ].

(** As before, we give some examples. *)

(**
<<
Section Examples.
  Context (A : Type) (B : A -> Type) (a0 : A).
  Goal { a : A & { b : B a & a = a0 } } <~> B a0.
  Proof.
    make_equiv_contr_basedpaths.
    Undo.
    simple notypeclasses refine (equiv_adjointify _ _ _ _).
    - (** Here begins [decomposing_intros_with_paths] *)
      intros x; cbn in x.
      elim x; clear x.
      intros a; cbn in a.
      intros x; cbn in x.
      elim x; clear x.
      intros b; cbn in b.
      intros p; cbn in p.
      (** [decomposing_intros] wouldn't be willing to destruct [p] here, because it's a path.  But [decomposing_intros_with_paths] will try it when all else fails. *)
      move p before a.
      generalize dependent a.
      not (move a at top).
      refine (paths_ind_r _ _ _).
      intros b; cbn in b.
      (** Here begins [build_record_with_evars] *)
      exact b.
    - (** Here begins [decomposing_intros_with_paths] *)
      intros b; cbn in b.
      (** Here begins [build_record_with_evars] *)
      cbn; unshelve econstructor.
      { let x := fresh in evar (x : A); exact x. }
      cbn; unshelve econstructor.
      { (** This instantiates the evar. *)
        exact b. }
      { cbn; unshelve econstructor. }
    - intros b; cbn in b.
      exact idpath.
    - intros x; cbn in x.
      elim x; clear x.
      intros a; cbn in a.
      intros x; cbn in x.
      elim x; clear x.
      intros b; cbn in b.
      intros p; cbn in p.
      move p before a.
      generalize dependent a.
      not (move a at top).
      refine (paths_ind_r _ _ _).
      intros b; cbn in b.
      exact idpath.
  Defined.
End Examples.
>>
*)

(** Some "real-world" examples where [make_equiv_contr_basedpaths] simplifies things a lot include [hfiber_compose] in [HFiber.v], [hfiber_pullback_along] in [Limits/Pullback.v], and [equiv_Ocodeleft2plus] in [BlakersMassey.v]. *)


(** * Global type definitions. *)

Require Import CoqLib.
Require Import String.
Require Import Ascii.
Require Import HexString.

(** Type definitions used in all part of the Hilecop-Cert project. *)

(** Defines the set of strictly positive natural numbers. *)

Definition natstar := { n : nat | n > 0 }.

(** Casts a natstar into a nat. *)

Definition natstar_to_nat (ns : natstar) := proj1_sig ns.
Coercion natstar_to_nat : natstar >-> nat.

(** Defines some natstar. *)

Definition onens := exist _ 1 (gt_Sn_O 0).
Definition twons := exist _ 2 (gt_Sn_O 1).
Definition threens := exist _ 3 (gt_Sn_O 2).
Definition fourns := exist _ 4 (gt_Sn_O 3).
Definition fivens := exist _ 5 (gt_Sn_O 4).
Definition sixns := exist _ 6 (gt_Sn_O 5).
Definition sevenns := exist _ 7 (gt_Sn_O 6).
Definition eightns := exist _ 8 (gt_Sn_O 7).
Definition ninens := exist _ 9 (gt_Sn_O 8).
Definition tenns := exist _ 10 (gt_Sn_O 9).

(** ** Properties on N  *)

Coercion N.to_nat : N >-> nat.
Coercion N.of_nat : nat >-> N.

Definition N_nleb_nle (n m : N) : ((n <=? m) = false <-> ~n <= m)%N.
  split.
  intros. intro. rewrite ((proj2 (N.leb_le n m)) H0) in H.
  inversion H.
  destruct (n <=? m)%N eqn: eq_le_bool.
  intro. elimtype False. apply H.
  apply ((proj1 (N.leb_le n m)) eq_le_bool).
  reflexivity.
Defined.

Definition N_le_dec (n m : N) : ({n <= m} + {~n <= m})%N.
  destruct (n <=? m)%N eqn: eq_le_bool.
  exact (left ((proj1 (N.leb_le n m)) eq_le_bool)).
  exact (right ((proj1 (N_nleb_nle n m)) eq_le_bool)).
Defined.

Definition N_nltb_nlt (n m : N) : ((n <? m) = false <-> ~n < m)%N.
  split.
  intros. intro. rewrite ((proj2 (N.ltb_lt n m)) H0) in H.
  inversion H.
  destruct (n <? m)%N eqn: eq_le_bool.
  intro. elimtype False. apply H.
  apply ((proj1 (N.ltb_lt n m)) eq_le_bool).
  reflexivity.
Defined.

Definition N_lt_dec (n m : N) : ({n < m} + {~n < m})%N.
  destruct (n <? m)%N eqn: eq_le_bool.
  exact (left ((proj1 (N.ltb_lt n m)) eq_le_bool)).
  exact (right ((proj1 (N_nltb_nlt n m)) eq_le_bool)).
Defined.

Lemma nlt_Npos_1 : forall p, (~Npos p < 1)%N.
  destruct p; inversion 1.
Defined.

Lemma N_lt_succ_lt_pred :
  forall i j,
    (Npos i < N.succ (Npos j))%N ->
    (N.pred (Npos i) < Npos j)%N.
  intros; lia.
Defined.

(** ** Definitions and Facts about strict orders and boolean functions *)

Section StrictOrders.

  Variable A : Type.
  Variable eqA : A -> A -> Prop.
  Variable decEqA : forall x y, {eqA x y} + {~eqA x y}.

  Variable rel : A -> A -> Prop.
  Variable decRel : forall x y, {rel x y} + {~rel x y}.

  (** Defines the type of relation that are a strict order
    over a type A.
   *)

  Inductive IsStrictOrder : Prop :=
    MkStrictOrder {
        rel_irrefl : forall a, ~rel a a;
        rel_trans : forall a b c, rel a b -> rel b c -> rel a c;

        (* Irreflexivity and transitivity entail anti-symmetry. *)
        (* rel_antisym : forall a b, rel a b -> ~rel b a; *)
      }.

  (** States that two elements of type A are comparable through
      the boolean relation [rel]. *)

  Definition AreComparable (x y : A) : Prop := rel x y \/ rel y x.

  (** States that [rel] is a strict total order over a type A, that is:
    - [rel] is a strict order over type A.
    - all elements of A that are different are comparable with [rel].
   *)

  Definition IsStrictTotalOrder :=
    IsStrictOrder /\ forall x y, ~eqA x y -> AreComparable x y.

  (** States that [rel] is a strict order over the elements of a list
      [l].  *)

  Inductive IsStrictOrderOverList (l : list A) (nodupl : NoDup l) : Prop :=
    MkStrictOrderOverList {
        reloverl_irrefl : forall a, In a l -> ~rel a a;
        reloverl_trans : forall a b c, In a l -> In b l -> In c l ->
                                       rel a b -> rel b c -> rel a c;

        (* Irreflexivity and transitivity entail anti-symmetry. *)
        (* reloverl_antisym : forall a b, In a l -> In b l -> brel a b = true -> brel b a = false; *)
      }.

  (** States that [rel] is a strict total order over the elements of list [l], that is:
      - [rel] is a strict order over the elements of [l]
      - all elements of [l] that are different are comparable with [rel].
   *)

  Definition IsStrictTotalOrderOverList (l : list A) (nodupl : NoDup l) :=
    IsStrictOrderOverList l nodupl /\ forall x y, ~eqA x y -> AreComparable x y.

End StrictOrders.

(** Defines the type of Petri net arcs. *)

Inductive ArcT : Type := basic | test | inhibitor.

(** Implements the equality between two arc_t values. *)

Definition arct_eqb (a a' : ArcT) : bool :=
  match a, a' with
  | basic, basic => true
  | test, test => true
  | inhibitor, inhibitor => true
  | _, _ => false
  end.

(** Cast from ArcT to nat. *)

Definition ArcT_in_nat (a : ArcT) :=
  match a with
  | basic => 0%N
  | test => 1%N
  | inhibitor => 2%N
  end.

Coercion ArcT_in_nat : ArcT >-> N.

(** Cast from ArcT to N. *)

Definition ArcT_in_N (a : ArcT) : N :=
  match a with
  | basic => 0
  | test => 1
  | inhibitor => 2
  end.

Coercion ArcT_in_N : ArcT >-> N.

(** Defines the type of Petri net transitions. *)

Inductive TransitionT : Type := not_temporal | temporal_a_b |
                                temporal_a_a | temporal_a_inf.

(** Cast from TransitionT to nat. *)

Definition TransitionT_in_nat (t : TransitionT) :=
  match t with
  | not_temporal => 0%N
  | temporal_a_b => 1%N
  | temporal_a_a => 2%N
  | temporal_a_inf => 3%N
  end.

Coercion TransitionT_in_nat : TransitionT >-> N.

(** Cast from TransitionT to N. *)

Definition TransitionT_in_N (t : TransitionT) : N :=
  match t with
  | not_temporal => 0
  | temporal_a_b => 1
  | temporal_a_a => 2
  | temporal_a_inf => 3
  end.

Coercion TransitionT_in_N : TransitionT >-> N.

(** Implements the equality between two transition_t values. *)

Definition transt_eqb (t t' : TransitionT) : bool :=
  match t, t' with
  | not_temporal, not_temporal => true
  | temporal_a_b, temporal_a_b => true
  | temporal_a_a, temporal_a_a => true
  | temporal_a_inf, temporal_a_inf => true
  | _, _ => false
  end.

(** Defines an option type able to return error messages. *)

Inductive optionE (A : Type) : Type :=
| Success : A -> optionE A
| Err : string -> optionE A.

Arguments Success {A} a.
Arguments Err {A}.

Definition Ret (A : Type) (x : A) := Success x.

Arguments Ret {A}.

Module ErrMonadNotations.

  Notation "[| x |]" := (Success x).

  Notation "x <- e1 ; e2" := (match e1 with
                              | Err msg => Err msg
                              | Success x => e2
                              end)
                               (right associativity, at level 200).

  Notation "'do' X <- A ; B" := (match A with
                                 | Err msg => Err msg
                                 | Success X => B
                                 end)
                                  (at level 200, X name, A at level 100, B at level 200).

  Notation "'do' '|(' x , y ')|' <- e1 ; e2" :=
    (do z <- e1; let '(x, y) := z in e2)
      (right associativity, at level 200).

  Notation "'do' '|(' x , y , z ')|' <- e1 ; e2" :=
    (do a <- e1; let '(x, y, z) := a in e2)
      (right associativity, at level 200).

  Definition f (n : nat) : optionE (nat * nat * nat) :=
    [| (0, 0, 0) |].

  Definition g (n : nat) : optionE (nat * nat) :=
    do |( x, y , z )| <- f n; [| (x, y) |].

End ErrMonadNotations.

(** Converts a nat into its hexadecimal string representation. Useful
    to display variable values in error messages.  *)

Notation "$$ n" := (of_nat n) (at level 0, only parsing).

(** ** Global definitions for bool *)

Definition nullb {A : Type} := fun _ : A => false.