Require Import Reals Psatz Omega Fourier.
From stdpp Require Import tactics list.
From discprob.basic Require Import seq_ext.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
From discprob.measure Require Export dynkin borel integral.
Require Import ClassicalEpsilon.

(*
Lemma img_compl {A B: Type} (f: A → B) (U: A → Prop):
  (∀ x y, f x = f y → x = y) →
    eq_prop (fun_img f (compl U))
            (compl (fun_img f U)).
Proof.
  intros Hinj z. split.
  * intros (x&Hcomp&Heq').
    intros (x'&?&?).
    assert (x' = x).
    { apply Hinj. congruence. }
    subst. eapply Hcomp. eauto.
  * intros Hcomp.
    eexists.
    destruct Hunion as (i&Hi). exists i.
    eexists; split; eauto.
  * intros (i&(x&Hi&Heq)).
    exists x. split; auto. exists i; done.
Qed.
*)

Record is_pt_hom {A1 A2} {F1 : sigma_algebra A1} {F2: sigma_algebra A2}
       (f: A1 → A2) (μ1: measure F1) (μ2: measure F2) : Prop :=
  {
    pt_hom_sigma:
      ∀ U, F2 U → F1 (fun_inv f U);
    pt_hom_meas:
      ∀ U, F2 U → μ2 U = μ1 (fun_inv f U)
  }.

Record is_pt_img_hom {A1 A2} {F1 : sigma_algebra A1} {F2: sigma_algebra A2}
       (f: A1 → A2) (μ1: measure F1) (μ2: measure F2) : Prop :=
  {
    pt_img_hom_sigma:
      ∀ U, F1 U → F2 (fun_img f U);
    pt_img_hom_meas:
      ∀ U, F1 U → μ1 U = μ2 (fun_img f U)
  }.

Record is_pt_iso {A1 A2} {F1 : sigma_algebra A1} {F2: sigma_algebra A2}
       (f: A1 → A2) (μ1: measure F1) (μ2: measure F2) : Prop :=
  { pt_iso_inj: ∀ x y, f x = f y → x = y;
    pt_iso_surj: ∀ y, ∃ x, f x = y;
    pt_iso_sigma1:
      ∀ U, F1 U → F2 (fun_img f U);
    pt_iso_sigma2:
      ∀ U, F2 U → F1 (fun_inv f U);
    pt_iso_meas1:
      ∀ U, F1 U → μ1 U = μ2 (fun_img f U);
    pt_iso_meas2:
      ∀ U, F2 U → μ2 U = μ1 (fun_inv f U)
  }.

Lemma is_pt_hom_comp {A1 A2 A3} {F1 : sigma_algebra A1} {F2 : sigma_algebra A2} {F3: sigma_algebra A3}
      (f1: A1 → A2) (f2 : A2 → A3) (μ1: measure F1) (μ2: measure F2) (μ3: measure F3):
  is_pt_hom f1 μ1 μ2 →
  is_pt_hom f2 μ2 μ3 →
  is_pt_hom (λ x, f2 (f1 x)) μ1 μ3.
Proof.
  intros Hhom1 Hhom2.
  split.
  - intros. eapply measurable_comp; eauto.
    * intros ?. eapply pt_hom_sigma; eauto.
    * intros ?. eapply pt_hom_sigma; eauto.
  - intros U HU.
    rewrite (pt_hom_meas _ _ _ Hhom2) //.
    rewrite (pt_hom_meas _ _ _ Hhom1) //.
    eapply pt_hom_sigma; eauto.
Qed.

Lemma is_pt_hom_id {A} {F: sigma_algebra A} (μ : measure F) :
  is_pt_hom id μ μ.
Proof.
  split; rewrite //=.
Qed.

Lemma is_pt_img_hom_inl {A1 A2} {F1 : sigma_algebra A1} {F2 : sigma_algebra A2}
      (μ1: measure F1) (μ2: measure F2):
  is_pt_img_hom inl μ1 (disjoint_sum_measure μ1 μ2).
Proof.
  split.
  - intros U ?. split; eauto.
    * eapply sigma_proper; eauto.
      clear; firstorder.
    * eapply (sigma_proper _ _ _ empty_set).
      ** clear; firstorder.
      ** apply sigma_empty_set.
  - rewrite //=. intros U HF. rewrite -[a in a = _](Rplus_0_r).
    f_equal.
    * apply measure_proper. clear; firstorder.
    * symmetry. erewrite <-measure_empty; first apply measure_proper.
      clear; firstorder.
Qed.

Lemma is_pt_img_hom_inr {A1 A2} {F1 : sigma_algebra A1} {F2 : sigma_algebra A2}
      (μ1: measure F1) (μ2: measure F2):
  is_pt_img_hom inr μ2 (disjoint_sum_measure μ1 μ2).
Proof.
  split.
  - intros U ?. split; eauto.
    * eapply (sigma_proper _ _ _ empty_set).
      ** clear; firstorder.
      ** apply sigma_empty_set.
    * eapply sigma_proper; eauto.
      clear; firstorder.
  - rewrite //=. intros U HF. rewrite -[a in a = _](Rplus_0_l).
    f_equal.
    * symmetry. erewrite <-measure_empty; first apply measure_proper.
      clear; firstorder.
    * apply measure_proper. clear; firstorder.
Qed.

Lemma measurable_inl {A1 A2} {F1: sigma_algebra A1} {F2: sigma_algebra A2}:
  measurable inl F1 (disjoint_sum_sigma F1 F2).
Proof. intros ? (?&?); done. Qed.

Lemma measurable_inr {A1 A2} {F1: sigma_algebra A1} {F2: sigma_algebra A2}:
  measurable inr F2 (disjoint_sum_sigma F1 F2).
Proof. intros ? (?&?); done. Qed.

Lemma is_pt_hom_sum {A1 A2 A1' A2'} F1 F2 F1' F2'
      (μ1: measure F1) (μ2: measure F2) (μ1': measure F1') (μ2': measure F2')
      (f1: A1 → A1') (f2: A2 → A2'):
  is_pt_hom f1 μ1 μ1' →
  is_pt_hom f2 μ2 μ2' →
  is_pt_hom (λ x : A1 + A2, match x with
                            | inl x1 => inl (f1 x1)
                            | inr x2 => inr (f2 x2)
                            end)
            (disjoint_sum_measure μ1 μ2) (disjoint_sum_measure μ1' μ2').
Proof.
  intros Hhom1 Hom2.
  split.
  - intros U (?&?). split.
    * eapply (sigma_proper _ _ _ (fun_inv f1 (fun_inv inl U))).
      { split; clear; firstorder. }
      eapply pt_hom_sigma; eauto.
    * eapply (sigma_proper _ _ _ (fun_inv f2 (fun_inv inr U))).
      { split; clear; firstorder. }
      eapply pt_hom_sigma; eauto.
  - intros U (?&?); rewrite //=. f_equal.
    * erewrite pt_hom_meas; eauto.
    * erewrite pt_hom_meas; eauto.
Qed.

Lemma is_pt_hom_sum_swap {A1 A2} F1 F2
      (μ1: measure F1) (μ2: measure F2):
  is_pt_hom (λ x : A1 + A2, match x with
                            | inl x1 => inr x1
                            | inr x2 => inl x2
                            end)
            (disjoint_sum_measure μ1 μ2) (disjoint_sum_measure μ2 μ1).
Proof.
  split.
  - intros U (?&?). split; auto.
  - intros U (?&?). rewrite //=. rewrite Rplus_comm. f_equal.
Qed.

Lemma is_pt_hom_sum_assoc {A1 A2 A3} F1 F2 F3
      (μ1: measure F1) (μ2: measure F2) (μ3: measure F3):
        is_pt_hom (λ x : (A1 + A2) + A3,
                         match x with
                         | inl (inl x1) => inl x1
                         | inl (inr x2) => inr (inl x2)
                         | inr x3 => inr (inr x3)
                         end)
                  (disjoint_sum_measure (disjoint_sum_measure μ1 μ2) μ3)
                  (disjoint_sum_measure μ1 (disjoint_sum_measure μ2 μ3)).
Proof.
  split.
  - intros U (?&(?&?)). split; auto. split; auto.
  - intros U (?&(?&?)). rewrite //=. rewrite Rplus_assoc. f_equal.
Qed.

Lemma is_pt_img_hom_sum {A1 A2 A1' A2'} F1 F2 F1' F2'
      (μ1: measure F1) (μ2: measure F2) (μ1': measure F1') (μ2': measure F2')
      (f1: A1 → A1') (f2: A2 → A2'):
  is_pt_img_hom f1 μ1 μ1' →
  is_pt_img_hom f2 μ2 μ2' →
  is_pt_img_hom (λ x : A1 + A2, match x with
                            | inl x1 => inl (f1 x1)
                            | inr x2 => inr (f2 x2)
                            end)
            (disjoint_sum_measure μ1 μ2) (disjoint_sum_measure μ1' μ2').
Proof.
  intros Hhom1 Hom2.
  split.
  - intros U (?&?). split.
    * eapply (sigma_proper _ _ _ (fun_img f1 (fun_inv inl U))).
      { intros z; split; clear; try (firstorder; done).
        intros x. firstorder. destruct x; try firstorder. congruence.  }
      eapply pt_img_hom_sigma; eauto.
    * eapply (sigma_proper _ _ _ (fun_img f2 (fun_inv inr U))).
      { intros z; split; clear; try (firstorder; done).
        intros x. firstorder. destruct x; try firstorder. congruence.  }
      eapply pt_img_hom_sigma; eauto.
  - intros U (?&?); rewrite //=. f_equal.
    * erewrite pt_img_hom_meas; eauto.
      { apply measure_proper.
        { intros z; split; clear; try (firstorder; done).
          intros x. firstorder. destruct x; try firstorder. congruence.  }
      }
    * erewrite pt_img_hom_meas; eauto.
      { apply measure_proper.
        { intros z; split; clear; try (firstorder; done).
          intros x. firstorder. destruct x; try firstorder. congruence.  }
      }
Qed.

Lemma is_pt_img_hom_sum_swap {A1 A2} F1 F2
      (μ1: measure F1) (μ2: measure F2):
  is_pt_img_hom (λ x : A1 + A2, match x with
                            | inl x1 => inr x1
                            | inr x2 => inl x2
                            end)
            (disjoint_sum_measure μ1 μ2) (disjoint_sum_measure μ2 μ1).
Proof.
  split.
  - intros U (?&?). split; auto.
    * eapply sigma_proper; eauto.
      intros z. clear; split.
      ** intros ([|]&?&Heq); inversion Heq; subst; eauto.
      ** firstorder.
    * eapply sigma_proper; eauto.
      intros z. clear; split.
      ** intros ([|]&?&Heq); inversion Heq; subst; eauto.
      ** firstorder.
  - rewrite //=. intros U (?&?). rewrite Rplus_comm; f_equal.
    * apply measure_proper.
      intros z. clear; split.
      ** firstorder.
      ** intros ([|]&?&Heq); inversion Heq; subst; eauto.
    * apply measure_proper.
      intros z. clear; split.
      ** firstorder.
      ** intros ([|]&?&Heq); inversion Heq; subst; eauto.
Qed.

Lemma is_pt_img_hom_sum_assoc {A1 A2 A3} F1 F2 F3
      (μ1: measure F1) (μ2: measure F2) (μ3: measure F3):
        is_pt_img_hom (λ x : (A1 + A2) + A3,
                         match x with
                         | inl (inl x1) => inl x1
                         | inl (inr x2) => inr (inl x2)
                         | inr x3 => inr (inr x3)
                         end)
                  (disjoint_sum_measure (disjoint_sum_measure μ1 μ2) μ3)
                  (disjoint_sum_measure μ1 (disjoint_sum_measure μ2 μ3)).
Proof.
  split.
  - intros U ((?&?)&?); split; auto.
    * eapply sigma_proper; eauto.
      intros z. clear; split.
      ** intros ([[|]|]&?&Heq); inversion Heq; subst; eauto.
      ** firstorder.
    * split.
      ** eapply sigma_proper; eauto.
         intros z. clear; split.
         *** intros ([[|]|]&?&Heq); inversion Heq; subst; eauto.
         *** firstorder.
      ** eapply sigma_proper; eauto.
         intros z. clear; split.
         *** intros ([[|]|]&?&Heq); inversion Heq; subst; eauto.
         *** firstorder.
  - intros U ((?&?)&?).
    rewrite //=. rewrite Rplus_assoc. f_equal; [| f_equal].
    * apply measure_proper.
      intros z. clear; split.
      ** firstorder.
      ** intros ([[|]|]&?&Heq); inversion Heq; subst; eauto.
    * apply measure_proper.
      intros z. clear; split.
      ** firstorder.
      ** intros ([[|]|]&?&Heq); inversion Heq; subst; eauto.
    * apply measure_proper.
      intros z. clear; split.
      ** firstorder.
      ** intros ([[|]|]&?&Heq); inversion Heq; subst; eauto.
Qed.

Lemma is_pt_img_hom_comp {A1 A2 A3} {F1 : sigma_algebra A1} {F2 : sigma_algebra A2}
      {F3: sigma_algebra A3}
      (f1: A1 → A2) (f2 : A2 → A3) (μ1: measure F1) (μ2: measure F2) (μ3: measure F3):
  is_pt_img_hom f1 μ1 μ2 →
  is_pt_img_hom f2 μ2 μ3 →
  is_pt_img_hom (λ x, f2 (f1 x)) μ1 μ3.
Proof.
  intros Hhom1 Hhom2.
  assert (∀ U, fun_img (λ x, f2 (f1 x)) U ≡ fun_img f2 (fun_img f1 U)) as Hequiv.
  { clear; firstorder. }
  split.
  - intros. rewrite Hequiv.
    apply Hhom2, Hhom1; eauto.
  - intros U HU.
    rewrite (pt_img_hom_meas _ _ _ Hhom1) //.
    rewrite (pt_img_hom_meas _ _ _ Hhom2) //.
    * rewrite Hequiv; eauto.
    * eapply pt_img_hom_sigma; eauto.
Qed.

Lemma is_pt_img_hom_id {A} {F: sigma_algebra A} (μ : measure F) :
  is_pt_img_hom id μ μ.
Proof.
  split; rewrite //=.
  * intros U HFU. eapply sigma_proper; eauto; clear; firstorder.
  * intros U HFU. eapply measure_proper; clear; firstorder.
Qed.

Lemma is_pt_hom_ae {A1 A2} {F1: sigma_algebra A1} {F2: sigma_algebra A2}
      (μ1: measure F1) (μ2: measure F2) f U:
  is_pt_hom f μ1 μ2 →
  almost_everywhere_meas μ2 U → almost_everywhere_meas μ1 (λ a, U (f a)).
Proof.
  intros Hhom (Hm&Heq0).
  assert (Hequiv: eq_prop (compl (λ a : A1, U (f a))) (fun_inv f (compl U))).
  { clear; firstorder. }
  split.
  - eapply pt_hom_sigma in Hm; eauto.
    eapply sigma_proper; eauto.
  - rewrite Hequiv. rewrite -Heq0.
    symmetry; eapply pt_hom_meas; eauto.
Qed.

Section iso_props.

  Context {A1 A2: Type}.
  Context {F1 : sigma_algebra A1}.
  Context {F2 : sigma_algebra A2}.
  Context (μ1: measure F1).
  Context (μ2: measure F2).
  Context (f: A1 → A2).

  Lemma is_pt_iso_inv_hom:
    is_pt_hom f μ1 μ2 →
    (∃ f', is_pt_hom f' μ2 μ1 ∧
      (∀ x, f (f' x) = x) ∧ (∀ y, f' (f y) = y)) →
    is_pt_iso f μ1 μ2.
  Proof.
    intros Hhom (f'&Hhom'&Hrl&Hlr).
    assert (∀ U, F1 U → fun_img f U ≡ fun_inv f' U) as Hequiv.
    { intros U HF x. rewrite /fun_img/fun_inv; split.
      * intros (y&HU&Hf). rewrite -Hf Hlr. done.
      * intros HU. exists (f' x); split; eauto.
    }
    split.
    - intros x y Heq. rewrite -(Hlr x) -(Hlr y).
      by f_equal.
    - intros y. exists (f' y). done.
    - intros U HF. rewrite Hequiv; eauto.
      eapply pt_hom_sigma; eauto.
    - eapply pt_hom_sigma; eauto.
    - intros U HU. rewrite Hequiv //. eapply pt_hom_meas; eauto.
    - eapply pt_hom_meas; eauto.
  Qed.

  Lemma is_pt_iso_bij_hom:
    is_pt_hom f μ1 μ2 →
    is_pt_img_hom f μ1 μ2 →
    (∀ x y, f x = f y → x = y) →
    (∀ y, ∃ x, f x = y) →
    is_pt_iso f μ1 μ2.
  Proof.
    intros Hhom Himg_hom Hinj Hsurj.
    split; eauto.
    - eapply pt_img_hom_sigma; eauto.
    - eapply pt_hom_sigma; eauto.
    - eapply pt_img_hom_meas; eauto.
    - eapply pt_hom_meas; eauto.
  Qed.

  Context (Hiso: is_pt_iso f μ1 μ2).

  Lemma is_pt_hom_iso:
    is_pt_hom f μ1 μ2.
  Proof.
    split.
    - eapply pt_iso_sigma2; eauto.
    - eapply pt_iso_meas2; eauto.
  Qed.

  Lemma is_pt_img_hom_iso:
    is_pt_img_hom f μ1 μ2.
  Proof.
    split.
    - eapply pt_iso_sigma1; eauto.
    - eapply pt_iso_meas1; eauto.
  Qed.

  Definition iso_inv : A2 → A1.
  Proof.
    intros a2. specialize (pt_iso_surj _ _ _ Hiso a2) => Hex.
    apply constructive_indefinite_description in Hex as (x&?). exact x.
  Defined.

  Lemma iso_inv_img U:
    fun_img iso_inv U ≡ fun_inv f U.
  Proof.
    intros x. rewrite /fun_img/fun_inv/iso_inv; split.
    - intros (y&HU&?). destruct constructive_indefinite_description. congruence.
    - intros HU. exists (f x); split; eauto.
      destruct constructive_indefinite_description. eapply pt_iso_inj; eauto.
  Qed.

  Lemma img_iso_inv U:
    fun_img f U ≡ fun_inv iso_inv U.
  Proof.
    intros x. rewrite /fun_img/fun_inv/iso_inv; split.
    - intros (y&HU&?). destruct constructive_indefinite_description as (y'&?).
      assert (y = y').
      { eapply pt_iso_inj; eauto. congruence. }
      intros; subst; eauto.
    - intros HU.
      destruct constructive_indefinite_description as (x'&?).
      exists x'; split; eauto.
  Qed.

  Lemma iso_measurable: measurable f F1 F2.
  Proof. intros U ?; eapply pt_iso_sigma2; eauto. Qed.

  Lemma iso_inv_iso: is_pt_iso iso_inv μ2 μ1.
  Proof.
    split.
    - intros x y. rewrite /iso_inv. do 2 destruct constructive_indefinite_description; congruence.
    - intros x. exists (f x).
      rewrite /iso_inv; destruct constructive_indefinite_description.
      eapply pt_iso_inj; eauto.
    - intros U HU. rewrite iso_inv_img. eapply pt_iso_sigma2; eauto.
    - intros U HU. rewrite -img_iso_inv. eapply pt_iso_sigma1; eauto.
    - intros U HU. rewrite iso_inv_img. eapply pt_iso_meas2; eauto.
    - intros U HU. rewrite -img_iso_inv. eapply pt_iso_meas1; eauto.
  Qed.

  Lemma iso_inv_rinv x: f (iso_inv x) = x.
  Proof.
    rewrite /iso_inv; destruct constructive_indefinite_description; eauto.
  Qed.

  Lemma iso_inv_linv x: iso_inv (f x) = x.
  Proof.
    rewrite /iso_inv; destruct constructive_indefinite_description as (?&Heq); eauto.
    eapply pt_iso_inj in Heq; eauto.
  Qed.

  Lemma iso_ae (U: A2 → Prop) :
    almost_everywhere_meas μ2 U → almost_everywhere_meas μ1 (λ a, U (f a)).
  Proof. intros. eapply is_pt_hom_ae; eauto. apply is_pt_hom_iso. Qed.

  Lemma iso_ae_img (U: A1 → Prop) :
    almost_everywhere_meas μ1 U → almost_everywhere_meas μ2 (fun_img f U).
  Proof.
    intros (Hm&Heq0).
    assert (Hequiv: eq_prop (compl (fun_img f U)) (fun_img f (compl U))).
    { split.
      * intros Hcomp. edestruct (pt_iso_surj f _ _ Hiso x) as (y&?).
        eexists. split; eauto. intros HU. apply Hcomp. eexists; eauto.
      * intros (x1&Hcomp&Hf).
        intros Hcomp'. apply Hcomp. destruct (Hcomp') as (x1'&HU&?).
        subst.
        assert (x1 = x1') as ->; eauto.
        { eapply pt_iso_inj; eauto.  }
    }
    split.
    - eapply pt_iso_sigma1 in Hm; eauto.
      eapply sigma_proper; eauto.
    - rewrite Hequiv. rewrite -Heq0.
      symmetry; eapply pt_iso_meas1; eauto.
  Qed.

End iso_props.

Lemma is_pt_iso_id {A} (F: sigma_algebra A) (μ: measure F):
  is_pt_iso id μ μ.
Proof.
  apply is_pt_iso_bij_hom.
  - apply is_pt_hom_id.
  - apply is_pt_img_hom_id.
  - auto.
  - intros; eexists; eauto.
Qed.

Lemma is_pt_iso_sum_swap {A1 A2} F1 F2
      (μ1: measure F1) (μ2: measure F2):
    is_pt_iso (λ x : A1 + A2, match x with
                              | inl x1 => inr x1
                              | inr x2 => inl x2
                              end)
            (disjoint_sum_measure μ1 μ2) (disjoint_sum_measure μ2 μ1).
Proof.
  apply is_pt_iso_bij_hom.
  - apply is_pt_hom_sum_swap.
  - apply is_pt_img_hom_sum_swap.
  - intros [|] [|]; auto; try congruence.
  -  intros [a2|a1].
     * exists (inr a2); eauto.
     * exists (inl a1); eauto.
Qed.

Lemma is_pt_iso_sum_assoc {A1 A2 A3} F1 F2 F3
      (μ1: measure F1) (μ2: measure F2) (μ3: measure F3):
        is_pt_iso (λ x : (A1 + A2) + A3,
                         match x with
                         | inl (inl x1) => inl x1
                         | inl (inr x2) => inr (inl x2)
                         | inr x3 => inr (inr x3)
                         end)
                  (disjoint_sum_measure (disjoint_sum_measure μ1 μ2) μ3)
                  (disjoint_sum_measure μ1 (disjoint_sum_measure μ2 μ3)).
Proof.
  apply is_pt_iso_bij_hom.
  - apply is_pt_hom_sum_assoc.
  - apply is_pt_img_hom_sum_assoc.
  - intros [[|]|] [[|]|]; auto; try congruence.
  - intros [a1|[a2|a3]].
    * by exists (inl (inl a1)).
    * by exists (inl (inr a2)).
    * by exists (inr a3).
Qed.

Arguments iso_inv_iso {_ _ _ _ _ _} _ _.
Arguments iso_inv {_ _ _ _ _ _} _ _.

Section wpt.
  Context {A1 A2: Type}.
  Context {F1 : sigma_algebra A1}.
  Context {F2 : sigma_algebra A2}.
  Context (μ1: measure F1).
  Context (μ2: measure F2).
  Context (f: A1 → A2).

  Context (Hiso: is_pt_iso f μ1 μ2).

  Lemma wpt_iso_aux1 (wpt: weighted_partition F1):
    ∀ (r : R) (U : A2 → Prop),
      In (r, U) (map (λ rU : R * (A1 → Prop), (rU.1, fun_img f rU.2)) wpt) → F2 U.
  Proof.
    intros r U Hin. apply in_map_iff in Hin as ((r'&U')&Heq&Hin).
    inversion Heq; subst. eapply pt_iso_sigma1; eauto.
    by apply In_wpt_snd_measurable in Hin.
  Qed.

  Definition wpt_iso (wpt : weighted_partition F1) : weighted_partition F2 :=
    wpt_indicator_scal_list (map (λ rU, (fst rU, fun_img f (snd rU))) wpt) (wpt_iso_aux1 wpt).

  Lemma wpt_iso_spec wpt x:
    wpt_fun (wpt_iso wpt) (f x) = wpt_fun wpt x.
  Proof.
    symmetry.
    rewrite /wpt_iso.
    feed pose proof (@wpt_indicator_scal_list_spec2 _ F2 _ (wpt_iso_aux1 wpt)) as Hindc.
    { rewrite map_map //=.
      assert (Hdisj: ## map snd wpt).
      { rewrite wpt_partition_spec1. apply partition_disjoint. }
      revert Hdisj. generalize (wpt_list wpt).
      clear -Hiso. induction l.
      * intros. rewrite //=. econstructor.
      * intros. rewrite //=. econstructor.
        ** inversion Hdisj as [| ?? Hdisj']; subst.
           intros z (Hin1&Hin2).
           apply union_list_inv in Hin2 as (U'&Hin_list&Hz).
           destruct Hin1 as (a1&?&?).
           eapply Hdisj'.
           { split; eauto. apply in_map_iff in Hin_list as ((?&U'')&?&?).
             apply (union_list_intro _ _ U''); subst.
             * apply in_map_iff. eexists; split; eauto. done.
             * destruct Hz as (?&?&Heq). eapply pt_iso_inj in Heq; eauto. subst.
               eauto.
           }
        ** eapply IHl. inversion Hdisj; eauto.
    }
    specialize (Hindc (f x)).
    destruct Hindc as [Hc1|Hc2].
    - destruct Hc1 as (Hnin&Hval).
      exfalso. destruct (partition_union (wpt_part wpt) x) as (U&Hin&HU); first done.
      eapply (Hnin (wpt_fun wpt x) (fun_img f U)).
      { apply in_map_iff. exists (wpt_fun wpt x, U); split; eauto.
        apply wpt_fun_eq1; eauto. }
      eexists; eauto.
    - destruct Hc2 as (r&U&Hin&HU&->).
      apply in_map_iff in Hin.
      destruct Hin as ((r'&U')&Heq&Hin').
      inversion Heq; subst.
      eapply wpt_fun_eq2; eauto.
      destruct HU as (x'&HU'&Heq').
      eapply pt_iso_inj in Heq'; eauto.
      congruence.
  Qed.

  Lemma wpt_integral_iso wpt:
    wpt_integral μ2 (wpt_iso wpt) = wpt_integral μ1 wpt.
  Proof.
    symmetry.
    induction wpt using wpt_induction.
    - transitivity (wpt_integral μ1 wpt1).
      { eapply wpt_integral_proper; eauto. by symmetry. }
      rewrite IHwpt1.
      apply wpt_integral_proper.
      intros x.
      edestruct (pt_iso_surj _ _ _ Hiso x).
      subst. rewrite ?wpt_iso_spec. done.
    - rewrite /wpt_iso//=.
      rewrite ?wpt_integral_plus ?wpt_integral_scal ?wpt_integral_indicator measure_empty.
      ring_simplify. eapply pt_iso_meas1; eauto.
    - rewrite ?wpt_integral_plus IHwpt1 IHwpt2 -wpt_integral_plus.
      apply wpt_integral_proper.
      intros z.
      edestruct (pt_iso_surj _ _ _ Hiso z).
      subst. rewrite wpt_iso_spec ?wpt_plus_spec; f_equal; apply wpt_iso_spec.
    - rewrite wpt_integral_scal IHwpt.
      symmetry. transitivity (wpt_integral μ2 (wpt_scal k (wpt_iso wpt))).
      { apply wpt_integral_proper; intros z.
        edestruct (pt_iso_surj _ _ _ Hiso z). subst.
        rewrite wpt_iso_spec.
        rewrite ?wpt_scal_spec. f_equal.
        symmetry; apply wpt_iso_spec.
      }
      rewrite wpt_integral_scal; f_equal.
  Qed.
End wpt.

Arguments wpt_iso {_ _ _ _ _ _} _ _ _.

Section integral1.
  Context {A1 A2: Type}.
  Context {F1 : sigma_algebra A1}.
  Context {F2 : sigma_algebra A2}.
  Context (f: A1 → A2).
  Context (μ1: measure F1).
  Context (μ2: measure F2).
  Context (Hiso: is_pt_iso f μ1 μ2).

  Lemma is_pos_integral_iso g v:
    is_pos_integral μ2 g v → is_pos_integral μ1 (λ x, g (f x)) v.
  Proof.
    rewrite /is_pos_integral. intros (Hmeas&Hlub).
    split.
    - eapply measurable_comp; eauto. eapply iso_measurable; eauto.
    - split.
      * intros ? (wpt&Hspec&<-).
        apply Hlub. exists (wpt_iso f Hiso wpt); split.
        ** intros x.
           edestruct (pt_iso_surj _ _ _ Hiso x). subst.
           rewrite wpt_iso_spec. eauto.
        ** apply wpt_integral_iso.
      * intros b Hub. eapply Hlub.
        intros ? (wpt&Hspec&<-).
        apply Hub. exists (wpt_iso (iso_inv _ Hiso) (iso_inv_iso _ Hiso) wpt).
        split.
        ** intros x. destruct (pt_iso_surj _ _ _ (iso_inv_iso _ Hiso) x).
           subst. rewrite wpt_iso_spec iso_inv_rinv. eauto.
        ** apply wpt_integral_iso.
  Qed.

  Lemma is_integral_iso' g v:
    is_integral μ2 g v → is_integral μ1 (λ x, g (f x)) v.
  Proof.
    intros (Hm&(v1&v2&Hp1&Hp2&Heq)).
    split.
    { eapply measurable_comp; eauto. eapply iso_measurable; eauto. }
    exists v1, v2; split_and!; eauto.
    - by apply is_pos_integral_iso in Hp1.
    - by apply is_pos_integral_iso in Hp2.
  Qed.
End integral1.

Section integral2.
  Context {A1 A2: Type}.
  Context {F1 : sigma_algebra A1}.
  Context {F2 : sigma_algebra A2}.
  Context (f: A1 → A2).
  Context (μ1: measure F1).
  Context (μ2: measure F2).
  Context (Hiso: is_pt_iso f μ1 μ2).

  Lemma is_integral_iso g v:
    is_integral μ2 g v ↔ is_integral μ1 (λ x, g (f x)) v.
  Proof.
    split.
    - by apply is_integral_iso'.
    - intros His. eapply is_integral_iso' in His.
      { setoid_rewrite (iso_inv_rinv) in His; eauto. }
      apply iso_inv_iso.
  Qed.

  Lemma ex_integral_iso g:
    ex_integral μ2 g ↔ ex_integral μ1 (λ x, g (f x)).
  Proof.
    split; intros (v&His); exists v; by apply is_integral_iso.
  Qed.

  Lemma Pos_integral_iso g:
    (∀ x, 0 <= g x) →
    measurable g F2 (borel R_UniformSpace) →
    Pos_integral μ1 (λ x, g (f x)) = Pos_integral μ2 g.
  Proof.
    intros Hpos Hmeas.
    destruct (Classical_Prop.classic (ex_pos_integral μ2 g)) as [Hex|Hnex].
    { destruct Hex as (v&His).
      transitivity v.
      * apply is_pos_integral_unique. apply is_integral_equiv_pos_integral; eauto.
        apply is_integral_iso; eauto.
        apply is_integral_equiv_pos_integral; eauto.
      * symmetry. apply is_pos_integral_unique. done.
    }
    rewrite [a in _ = a]measurable_non_ex_pos_integral_0; eauto.
    apply measurable_non_ex_pos_integral_0.
    * eapply measurable_comp; eauto. eapply iso_measurable; eauto.
    * intros Hex. apply ex_integral_equiv_pos_integral in Hex; eauto.
      apply ex_integral_iso in Hex. apply Hnex. by apply ex_integral_equiv_pos_integral.
  Qed.

  Lemma Integral_iso g:
    measurable g F2 (borel R_UniformSpace) →
    Integral μ1 (λ x, g (f x)) = Integral μ2 g.
  Proof.
    intros Hmeas.
    rewrite /Integral.
    f_equal.
    - eapply (Pos_integral_iso (λ x, Rmax (g x) 0)); eauto using Rmax_r.
      measurable.
    - eapply (Pos_integral_iso (λ x, Rmax (- g x) 0)); eauto using Rmax_r.
      measurable.
  Qed.

End integral2.

Lemma sub_sigma_closed {A: Type} (F: sigma_algebra A) (U: A → Prop) :
  ∀ Ps, (∀ i : nat, ∃ V' : A → Prop, F V' ∧ (∀ x : {x : A | U x}, Ps i x ↔ V' (projT1 x)))
        → ∃ V' : A → Prop, F V' ∧ (∀ x : {x : A | U x}, unionF Ps x ↔ V' (projT1 x)).
Proof.
  intros Ps HPs.
  unshelve eexists.
  { eapply (@unionF _ nat). intros i a. specialize (HPs i).
    apply constructive_indefinite_description in HPs as (V'&?).
    exact (V' a).
  }
  split.
  * apply sigma_closed_unions => i.
    rewrite //=. destruct constructive_indefinite_description; intuition.
  * intros x. split.
    ** intros (i&?). exists i => //=.
       destruct constructive_indefinite_description; firstorder.
    ** intros (i&Hi). exists i.
       destruct (HPs i) as (?&?). intuition.
       edestruct constructive_indefinite_description in Hi. firstorder.
Qed.

Definition sub_sigma {A: Type} (F: sigma_algebra A) (U : A → Prop) : sigma_algebra (sig U).
  refine ({| sigma_sets := λ V : (sig U → Prop), ∃ V' : A → Prop,
                               F V' ∧ (∀ x : sig U, V x ↔ V' (projT1 x)) |}).
  - abstract firstorder.
  - abstract (exists (λ x, True); split; auto).
  - intros P (V'&HFV'&HV'). exists (compl V'); split; auto.
    abstract firstorder.
  - apply sub_sigma_closed.
Defined.

Definition sub_measure {A: Type} {F: sigma_algebra A} (μ: measure F) U (HU: F U)
  : measure (sub_sigma F U).
  refine {| measure_fun := λ A, μ (λ x, ∃ Hp, A (exist _ x Hp)) |}.
  - intros V V' Heq.
    apply measure_proper.
    intros x. split.
    * intros (HP&?). exists HP. by apply Heq.
    * intros (HP&?). exists HP. by apply Heq.
  - intros; apply measure_nonneg.
  - rewrite -(measure_empty _ μ). apply measure_proper.
    intros x; split.
    * intros (?&[]).
    * inversion 1.
  - intros Ps HFsub Hdisj.
    set (Ps' := λ i, λ x, ∃ Hp : U x, Ps i (exist _ x Hp)).
    assert (Heq: ∀ i, Ps' i ≡ (λ x, ∃ Hp, Ps i (exist _ x Hp))).
    { intros i. split.
      - intros (?&?). eexists; eauto.
      - intros (?&?). eexists; eauto.
    }
    assert (Heq_unionF: unionF Ps' ≡ (λ x, ∃ Hp, unionF Ps (exist _ x Hp))).
    { intros x; split.
      * intros (i&(?&?)); eexists; exists i; eauto.
      * intros (i&(?&?)); eexists; exists i; eauto.
    }
    eapply is_series_ext.
    { intros n. rewrite -Heq. done. }
    rewrite -Heq_unionF.
    apply measure_additivity.
    * intros i. rewrite /Ps'.
      destruct (HFsub i) as (V'&?&?). eapply (sigma_proper _ _ (V' ∩ U)); eauto.
      intros z. split.
      ** intros (HP&HU'). exists HU'. eapply H0 => //=.
      ** intros (?&?). eexists; eauto. eapply (H0 (exist _ _ x)). eauto.
    * clear -Hdisj. intros i j Hneq x (Hin1&Hin2).
      destruct Hin1 as (HU1&HP1).
      destruct Hin2 as (HU2&HP2).
      assert (HU1 = HU2).
      { apply classical_proof_irrelevance. }
      subst. eapply (Hdisj i j Hneq); split; eauto.
Defined.

Record is_mod0_iso {A1 A2} {F1 : sigma_algebra A1} {F2: sigma_algebra A2}
       (U1 : A1 → Prop) (U2 : A2 → Prop)
       (f: sig U1 → sig U2) (μ1: measure F1) (μ2: measure F2) : Prop :=
  {
    mod0_iso_ae1: almost_everywhere_meas μ1 U1;
    mod0_iso_ae2: almost_everywhere_meas μ2 U2;
    mod0_iso_is_iso: is_pt_iso f
                       (sub_measure μ1 U1 (almost_everywhere_meas_meas μ1 _ mod0_iso_ae1))
                       (sub_measure μ2 U2 (almost_everywhere_meas_meas μ2 _ mod0_iso_ae2))
  }.

Record is_mod0_hom {A1 A2} {F1 : sigma_algebra A1} {F2: sigma_algebra A2}
       (U1 : A1 → Prop) (U2 : A2 → Prop)
       (f: sig U1 → sig U2) (μ1: measure F1) (μ2: measure F2) : Prop :=
  {
    mod0_hom_ae1: almost_everywhere_meas μ1 U1;
    mod0_hom_ae2: almost_everywhere_meas μ2 U2;
    mod0_hom_is_hom: is_pt_hom f
                       (sub_measure μ1 U1 (almost_everywhere_meas_meas μ1 _ mod0_hom_ae1))
                       (sub_measure μ2 U2 (almost_everywhere_meas_meas μ2 _ mod0_hom_ae2))
  }.

Record is_mod0_embedding {A1 A2} {F1: sigma_algebra A1} {F2: sigma_algebra A2}
       (f : A1 → A2) (μ1: measure F1) (μ2: measure F2) : Prop :=
  {
    mod0_embedding_ae: almost_everywhere_meas μ2 (fun_img f (λ _, True));
    mod0_embedding_inj: ∀ x y, f x = f y → x = y;
    mod0_embedding_hom: is_pt_hom f μ1 μ2;
    mod0_embedding_img_hom: is_pt_img_hom f μ1 μ2
  }.

Lemma almost_everywhere_meas_inter_measure
      {A: Type} {F: sigma_algebra A} {μ1: measure F} (U1 U2: A → Prop) (HF: F U2):
   almost_everywhere_meas μ1 U1 →
   μ1 U2 = μ1 (U2 ∩ U1).
Proof.
  intros Hae. rewrite -(compl_involutive U1) -set_minus_union_complement.
  destruct Hae as (?&Heq0).
  apply Rle_antisym.
  * etransitivity; last first.
    { apply Rge_le, measure_set_minus'; eauto. }
    rewrite Heq0. nra.
  * apply measure_mono; eauto; clear; firstorder.
Qed.

Lemma is_pt_hom_ae_sval {A: Type} {F: sigma_algebra A} (μ1: measure F) (U1: A → Prop) (HU: F U1)
  (Hae: almost_everywhere_meas μ1 U1):
  is_pt_hom sval (sub_measure μ1 U1 HU) μ1.
Proof.
  split.
  - intros U HF. exists U; split; eauto.
  - intros U HF. rewrite //=.
    rewrite (almost_everywhere_meas_inter_measure _ _ _ Hae); eauto.
    apply measure_proper. intros x; split.
      * intros (?&HU1). exists HU1; eauto.
      * intros (?&?). split; eauto.
Qed.

Lemma is_pt_img_hom_ae_sval {A: Type} {F: sigma_algebra A} (μ1: measure F) (U1: A → Prop) (HU: F U1)
  (Hae: almost_everywhere_meas μ1 U1):
  is_pt_img_hom sval (sub_measure μ1 U1 HU) μ1.
Proof.
  split.
  - intros U (V&?&Hequiv). eapply (sigma_proper _ _ _ (U1 ∩ V)); eauto.
    intros z; split.
    ** intros (x&?&<-). split.
       *** destruct x; eauto.
       *** by apply Hequiv.
    ** intros (HU1&HV). exists (exist _ _ HU1); split; eauto.
       apply Hequiv => //=.
  - intros U HF. rewrite //=.
    apply measure_proper.
    split.
    * intros (Hp&?). exists (exist _ _ Hp); split; eauto.
    * intros ((z&Hpf)&?&?). subst => //=. exists Hpf; auto.
Qed.

Lemma mod0_embedding_sigma_inv {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
  (μ1: measure F1) (μ2: measure F2) f U:
    is_mod0_embedding f μ1 μ2 →
    F2 U →
    F1 (fun_inv f U).
Proof.
  intros Hmod. eapply pt_hom_sigma; eauto. apply mod0_embedding_hom. eauto.
Qed.

Lemma mod0_embedding_sigma_img {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
  (μ1: measure F1) (μ2: measure F2) f U:
    is_mod0_embedding f μ1 μ2 →
    F1 U →
    F2 (fun_img f U).
Proof.
  intros Hmod. eapply pt_img_hom_sigma; eauto. apply mod0_embedding_img_hom. eauto.
Qed.

Lemma mod0_embedding_meas_inv {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
  (μ1: measure F1) (μ2: measure F2) f U:
    is_mod0_embedding f μ1 μ2 →
    F2 U →
    μ1 (fun_inv f U) = μ2 U.
Proof.
  intros Hmod. symmetry. eapply pt_hom_meas; eauto. apply mod0_embedding_hom. done.
Qed.

Lemma mod0_embedding_meas_img {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
  (μ1: measure F1) (μ2: measure F2) f U:
    is_mod0_embedding f μ1 μ2 →
    F1 U →
    μ2 (fun_img f U) = μ1 U.
Proof.
  intros Hmod. symmetry. eapply pt_img_hom_meas; eauto. apply mod0_embedding_img_hom. done.
Qed.

Lemma mod0_embedding_meas_full {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
      (μ1: measure F1) (μ2: measure F2) f:
    is_mod0_embedding f μ1 μ2 →
    μ1 (λ _, True) = μ2 (λ _, True).
Proof.
  intros He. transitivity (μ1 (fun_inv f (λ _, True))).
  { apply measure_proper. clear; split; intros; firstorder. }
  apply mod0_embedding_meas_inv; eauto.
Qed.

Lemma mod0_embedding_ae_inv  {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
      (μ1: measure F1) (μ2: measure F2) f U:
    is_mod0_embedding f μ1 μ2 →
    almost_everywhere_meas μ2 U →
    almost_everywhere_meas μ1 (fun_inv f U).
Proof.
  intros Hmod (HF&Hmea).
  assert (F1 (compl (fun_inv f U))).
  { apply sigma_closed_complements. eapply mod0_embedding_sigma_inv; eauto.
    apply sigma_closed_complements in HF. rewrite compl_involutive in HF *. done. }
  split; auto.
  apply compl_meas_0_full; auto.
  erewrite mod0_embedding_meas_inv; eauto; last first.
  { apply sigma_closed_complements in HF. rewrite compl_involutive in HF *. done. }
  transitivity (μ2 (λ _, True)).
  { apply almost_everywhere_meas_meas_full. split; eauto. }
  symmetry; eapply mod0_embedding_meas_full; eauto.
Qed.

Lemma mod0_embedding_ae_img  {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
      (μ1: measure F1) (μ2: measure F2) f U:
    is_mod0_embedding f μ1 μ2 →
    almost_everywhere_meas μ1 U →
    almost_everywhere_meas μ2 (fun_img f U).
Proof.
  intros Hmod (HF&Hmea).
  assert (F2 (compl (fun_img f U))).
  { apply sigma_closed_complements. eapply mod0_embedding_sigma_img; eauto.
    apply sigma_closed_complements in HF. rewrite compl_involutive in HF *. done. }
  split; auto.
  apply compl_meas_0_full; auto.
  erewrite mod0_embedding_meas_img; eauto; last first.
  { apply sigma_closed_complements in HF. rewrite compl_involutive in HF *. done. }
  transitivity (μ1 (λ _, True)).
  { apply almost_everywhere_meas_meas_full. split; eauto. }
  eapply mod0_embedding_meas_full; eauto.
Qed.

Lemma fun_img_comp {A B C: Type} (f1: A → B) (f2: B → C) U:
  fun_img (λ x, f2 (f1 x)) U ≡ fun_img f2 (fun_img f1 U).
Proof.
  intros z. split; firstorder.
Qed.

Lemma is_mod0_embedding_id {A} {F : sigma_algebra A} (μ: measure F):
  is_mod0_embedding id μ μ.
Proof.
  assert (Hequiv: ∀ U : (A → Prop), fun_img id U ≡ U).
  { intros U. rewrite /fun_img. clear. split; firstorder. }
  split.
  - rewrite Hequiv. apply almost_everywhere_meas_True.
  - done.
  - apply is_pt_hom_id.
  - apply is_pt_img_hom_id.
Qed.

Lemma is_mod0_embedding_comp {A1 A2 A3}
      {F1 : sigma_algebra A1} {F2 : sigma_algebra A2} {F3: sigma_algebra A3}
      (f1: A1 → A2) (f2 : A2 → A3) (μ1: measure F1) (μ2: measure F2) (μ3: measure F3):
  is_mod0_embedding f1 μ1 μ2 →
  is_mod0_embedding f2 μ2 μ3 →
  is_mod0_embedding (λ x, f2 (f1 x)) μ1 μ3.
Proof.
  intros Hhom1 Hhom2.
  split.
  - rewrite fun_img_comp.
    eapply (mod0_embedding_ae_img); eauto.
    eapply (mod0_embedding_ae_img); eauto.
  - intros x y Heq.
    eapply mod0_embedding_inj; eauto.
    eapply mod0_embedding_inj; eauto.
  - eapply is_pt_hom_comp; eauto using mod0_embedding_hom.
  - eapply is_pt_img_hom_comp; eauto using mod0_embedding_img_hom.
Qed.

Section mod0_props.

  Context {A1 A2: Type}.
  Context {F1 : sigma_algebra A1}.
  Context {F2 : sigma_algebra A2}.
  Context (μ1: measure F1).
  Context (μ2: measure F2).

  Lemma is_mod0_iso_inv_hom U1 U2 f:
    is_mod0_hom U1 U2 f μ1 μ2 →
    (∃ f', is_mod0_hom U2 U1 f' μ2 μ1 ∧
      (∀ x, f (f' x) = x) ∧ (∀ y, f' (f y) = y)) →
    is_mod0_iso U1 U2 f μ1 μ2.
  Proof.
    intros Hhom (f'&Hhom'&Hrl&Hlr).
    unshelve (econstructor).
    - eapply mod0_hom_ae1; eauto.
    - eapply mod0_hom_ae2; eauto.
    - apply is_pt_iso_inv_hom.
      * apply mod0_hom_is_hom.
      * exists f'. split.
        ** assert (mod0_hom_ae2 U1 U2 f μ1 μ2 Hhom =
                   mod0_hom_ae1 U2 U1 f' μ2 μ1 Hhom') as -> by apply classical_proof_irrelevance.
           assert (mod0_hom_ae1 U1 U2 f μ1 μ2 Hhom =
                   mod0_hom_ae2 U2 U1 f' μ2 μ1 Hhom') as -> by apply classical_proof_irrelevance.
           eapply (mod0_hom_is_hom _ _ _ _ _ Hhom').
        ** split; eauto.
  Qed.

  Lemma is_mod0_iso_common_embedding U1 U2 f:
    is_mod0_iso U1 U2 f μ1 μ2 →
    (∃ (G: sigma_algebra (sig U1)) (μ: measure G),
        is_mod0_embedding sval μ μ1 ∧ is_mod0_embedding (λ x, sval (f x)) μ μ2).
  Proof.
    intros Hiso.
    eexists.
    exists (sub_measure μ1 U1 (almost_everywhere_meas_meas μ1 _ (mod0_iso_ae1 _ _ _ _ _ Hiso))).
    split.
    * split.
      ** eapply almost_everywhere_meas_ext; last first.
         { eapply mod0_iso_ae1; eauto. }
         rewrite /fun_img. intros x.
         split.
         *** intros HU. exists (exist _ _ HU); split; auto.
         *** intros ((?&?)&(?&?)); eauto. subst => //=.
      ** intros. by apply sval_inj_pi.
      ** apply is_pt_hom_ae_sval. eapply mod0_iso_ae1; eauto.
      ** apply is_pt_img_hom_ae_sval. eapply mod0_iso_ae1; eauto.
    * split.
      ** eapply almost_everywhere_meas_ext; last first.
         { eapply mod0_iso_ae2; eauto. }
         rewrite /fun_img. intros x.
         split.
         *** intros HU.
             exists (iso_inv f (mod0_iso_is_iso _ _ _ _ _ Hiso) (exist _ _ HU)).
             rewrite iso_inv_rinv. done.
         *** intros (?&?&<-). destruct (f _) => //=.
      ** intros ?? ?%sval_inj_pi.
         destruct Hiso; eapply pt_iso_inj; eauto.
      ** eapply is_pt_hom_comp.
         *** eapply is_pt_hom_iso. eapply (mod0_iso_is_iso _ _ _ _ _ Hiso).
         *** apply is_pt_hom_ae_sval. eapply mod0_iso_ae2; eauto.
      ** eapply is_pt_img_hom_comp.
         *** eapply is_pt_img_hom_iso. eapply (mod0_iso_is_iso _ _ _ _ _ Hiso).
         *** apply is_pt_img_hom_ae_sval. eapply mod0_iso_ae2; eauto.
  Qed.

  Lemma is_mod0_iso_common_embedding':
    (∃ U1 U2 f, is_mod0_iso U1 U2 f μ1 μ2) →
    (∃ B (G : sigma_algebra B) (μ: measure G) f1 f2, is_mod0_embedding f1 μ μ1 ∧
                                                     is_mod0_embedding f2 μ μ2).
  Proof.
    intros (U1&U2&f&Hmod).
    edestruct (is_mod0_iso_common_embedding) as (?&?&?&?); eauto.
    do 5 eexists; split; eauto.
  Qed.

  Definition common_embedding {B} (f1: B → A1) (f2: B → A2) :
    {x : A1 | fun_img f1 (λ _ : B, True) x} → {x : A2 | fun_img f2 (λ _: B, True) x} :=
    (λ X : {x : A1 | fun_img f1 (λ _ : B, True) x},
           match X with
           | exist z Hex =>
             match constructive_indefinite_description (λ x : B, True ∧ f1 x = z) Hex with
             | exist b (conj H _) =>
               f2 b ↾ ex_intro (λ x : B, True ∧ f2 x = f2 b) b (conj H (erefl (f2 b)))
             end
           end).

  Lemma common_embedding_is_mod0_iso
        B (G : sigma_algebra B) (μ: measure G) f1 f2:
    is_mod0_embedding f1 μ μ1 →
    is_mod0_embedding f2 μ μ2 →
    is_mod0_iso (fun_img f1 (λ _, True)) (fun_img f2 (λ _, True))
                (common_embedding f1 f2) μ1 μ2.
  Proof.
    intros Hmod1 Hmod2. rewrite /common_embedding.
    unshelve (econstructor).
    * eapply mod0_embedding_ae; eauto.
    * eapply mod0_embedding_ae; eauto.
    * split.
      ** intros (x&?) (y&?).
         destruct constructive_indefinite_description as (?&(?&?)) => //=.
         destruct constructive_indefinite_description as (?&(?&?)) => //=.
         subst. inversion 1. apply sval_inj_pi => //=. f_equal.
         eapply mod0_embedding_inj; eauto.
      ** intros (y&(b&(?&Heq))).
         unshelve (eexists).
         { exists (f1 b). eexists; eauto. }
         rewrite //=.
         destruct constructive_indefinite_description as (?&(?&?)) => //=.
         subst. apply sval_inj_pi => //=. f_equal.
         eapply (mod0_embedding_inj f1); eauto.
      ** intros U (V&?&HVspec).
         exists (fun_img f2 (fun_inv f1 V)). split.
         *** eapply pt_img_hom_sigma; first eapply mod0_embedding_img_hom; eauto.
             eapply pt_hom_sigma; first eapply mod0_embedding_hom; eauto.
         *** intros (?&?). rewrite //=.
             split.
             **** intros ((?&Himg)&Hspec).
                  destruct constructive_indefinite_description as (x1&?&Heq).
                  destruct Hspec as (?&Heq').
                  subst. exists x1; split; eauto.
                  ***** rewrite /fun_inv. by eapply (HVspec (exist _ _ Himg)).
                  ***** inversion Heq'. done.
             **** intros (b&Hinv&?). subst.
                  rewrite /fun_inv in Hinv.
                  unshelve (eexists (exist _ (f1 b) _)).
                  { eexists; eauto. }
                  split.
                  ***** eapply HVspec => //=.
                  ***** destruct constructive_indefinite_description as (?&?&?).
                  apply sval_inj_pi => //=.
                  f_equal. eapply (mod0_embedding_inj f1); eauto.
      ** intros U (V&?&HVspec).
         exists (fun_img f1 (fun_inv f2 V)). split.
         *** eapply pt_img_hom_sigma; first eapply mod0_embedding_img_hom; eauto.
             eapply pt_hom_sigma; first eapply mod0_embedding_hom; eauto.
         *** intros (?&?). rewrite //=.
             split.
             **** rewrite /fun_inv.
                  destruct constructive_indefinite_description as (x1&?&Heq).
                  subst. rewrite /fun_img. intros HU. exists x1; split; eauto.
                  eapply HVspec in HU. eauto.
             **** rewrite /fun_inv.
                  intros (b&Hinv&?). subst.
                  destruct constructive_indefinite_description as (x1&?&Heq).
                  eapply HVspec. rewrite //=. cut (x1 = b); intros; subst; eauto.
                  eapply (mod0_embedding_inj f1); eauto.
      ** intros U (V&?&HVspec). rewrite //=.
         transitivity (μ (fun_inv f1 V)).
         { erewrite <-pt_hom_meas; eauto; last first.
           { eapply mod0_embedding_hom; eauto. }
           rewrite [a in _ = a](almost_everywhere_meas_inter_measure _ _ _
                                                                (mod0_embedding_ae _ _ _ Hmod1))
           //.
           apply measure_proper. intros x.
           split.
           - intros (HP&?). split; auto. eapply (HVspec (exist _ _ HP)). eauto.
           - intros (HV&HU). exists HU. apply HVspec. eauto. }
         transitivity (μ2 (fun_img f2 (fun_inv f1 V))).
         { apply pt_img_hom_meas; eauto.
           * apply mod0_embedding_img_hom; eauto.
           * eapply pt_hom_sigma; first eapply mod0_embedding_hom; eauto.
         }
         eapply measure_proper.
         intros x. split.
         *** intros (z&Hinv&Heq).
             subst. unshelve (eexists).
             { exists z. eauto. }
             rewrite /fun_inv in Hinv.
             unshelve (eexists).
             { exists (f1 z). eexists; eauto. }
             split.
             **** eapply HVspec; eauto.
             **** destruct constructive_indefinite_description as (x1&?&Heq).
                  apply sval_inj_pi => //=.
                  f_equal.
                  eapply (mod0_embedding_inj f1); eauto.
         *** rewrite /fun_img => //=. intros ((x'&?&Heq)&Hspec).
             subst. eexists; split; eauto.
             destruct Hspec as ((?&?)&HU&?).
             destruct constructive_indefinite_description as (x1&?&Heq).
             subst. rewrite /fun_inv.
             inversion H0. subst.
             assert (x' = x1).
             { eapply (mod0_embedding_inj f2); eauto. }
             subst. eapply HVspec in HU. eauto.
      ** intros U (V&?&HVspec). rewrite //=.
         transitivity (μ (fun_inv f2 V)).
         { erewrite <-pt_hom_meas; eauto; last first.
           { eapply mod0_embedding_hom; eauto. }
           rewrite [a in _ = a](almost_everywhere_meas_inter_measure _ _ _
                                                                (mod0_embedding_ae _ _ _ Hmod2))
           //.
           apply measure_proper. intros x.
           split.
           - intros (HP&?). split; auto. eapply (HVspec (exist _ _ HP)). eauto.
           - intros (HV&HU). exists HU. apply HVspec. eauto. }
         transitivity (μ1 (fun_img f1 (fun_inv f2 V))).
         { apply pt_img_hom_meas; eauto.
           * apply mod0_embedding_img_hom; eauto.
           * eapply pt_hom_sigma; first eapply mod0_embedding_hom; eauto.
         }
         eapply measure_proper.
         intros x. split.
         *** intros (z&Hinv&Heq).
             subst. unshelve (eexists).
             { exists z. eauto. }
             rewrite /fun_inv in Hinv.
             rewrite /fun_inv.
             destruct constructive_indefinite_description as (x1&?&Heq).
             eapply HVspec => //=.
             assert (x1 = z).
             { eapply (mod0_embedding_inj f1); eauto. }
             subst. eauto.
         *** intros (Hpf&Hinv).
             rewrite /fun_inv in Hinv.
             rewrite /fun_inv.
             destruct constructive_indefinite_description as (x1&?&Heq).
             rewrite /fun_img. eexists. split; eauto. eapply HVspec in Hinv.
             rewrite //= in Hinv.
  Qed.

  Lemma common_embedding_is_mod0_iso':
    (∃ B (G : sigma_algebra B) (μ: measure G) f1 f2, is_mod0_embedding f1 μ μ1 ∧
                                                     is_mod0_embedding f2 μ μ2) →
    (∃ U1 U2 f, is_mod0_iso U1 U2 f μ1 μ2).
  Proof.
    - intros (B&G&μ&f1&f2&Hmod1&Hmod2).
      exists (fun_img f1 (λ _, True)), (fun_img f2 (λ _, True)).
      eexists.
      eapply common_embedding_is_mod0_iso; eauto.
  Qed.

  Section pullback.
  Context {C: Type}.
  Context (G: sigma_algebra C).
  Context (μ: measure G).
  Context (f1: A1 → C).
  Context (f2: A2 → C).
  Context (Hmod1: is_mod0_embedding f1 μ1 μ).
  Context (Hmod2: is_mod0_embedding f2 μ2 μ).

  Definition mod0_pullback : Type := { bs: A1 * A2 | f1 (fst bs) = f2 (snd bs) }.

  Lemma mod0_pullback_sigma_top:
    G (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1)
               (λ _ : mod0_pullback, True)).
  Proof.
    rewrite //=.
    specialize (mod0_embedding_ae _ _ _ Hmod1) => Hae1.
    apply almost_everywhere_meas_meas in Hae1.
    specialize (mod0_embedding_ae _ _ _ Hmod2) => Hae2.
    apply almost_everywhere_meas_meas in Hae2.
    eapply sigma_proper; last first.
    { eapply sigma_closed_pair_intersect; [ apply Hae1 | apply Hae2 ]. }
    intros z. split.
    * intros (((a1&a2)&Heqa)&HU&Heq').
      split.
      ** exists a1. eauto.
      ** exists a2. rewrite //= in Heq'. rewrite //= in Heqa. split; congruence.
    * intros (Hf1&Hf2). destruct Hf1 as (a1&(?&Heq1)). destruct Hf2 as (a2&(?&Heq2)).
      subst. symmetry in Heq2. exists (exist _ (a1, a2) Heq2). split; eauto.
  Qed.

  Lemma mod0_pullback_sigma_compl U:
    G (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1) U)
    → G (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1) (compl U)).
  Proof.
    intros HG%sigma_closed_complements.
    eapply sigma_proper; last first.
    { apply sigma_closed_pair_intersect.
      - apply HG.
      - apply mod0_pullback_sigma_top.
    }
    intros z. split.
    * intros (((a1&a2)&hpf)&Hcomp&Heq').
      split.
      {
        intros (((a1'&a2')&hpf')&?&Heq'').
        eapply Hcomp.
        assert (exist _ _ hpf = exist _ _ hpf') as ->; eauto.
        apply sval_inj_pi => //=. f_equal.
        ** eapply (mod0_embedding_inj f1); eauto.
           rewrite //= in Heq' Heq''. congruence.
        ** eapply (mod0_embedding_inj f2); eauto.
           clear -Heq' Heq'' hpf hpf'. rewrite //= in Heq' Heq''.
           rewrite //= in hpf hpf'. congruence.
      }
      { eexists; split; eauto. }
    * intros (Hcomp&Himg).
      destruct Himg as (x&?&Heq).
      exists x. split; auto.
      intros HU. eapply Hcomp. eexists; split; eauto.
  Qed.

  Lemma mod0_pullback_sigma_union Ps:
    (∀ i : nat, G (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1) (Ps i)))
    → G (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1) (unionF Ps)).
  Proof.
    intros HPs%sigma_closed_unions.
    rewrite img_union. done.
  Qed.

  Definition mod0_pullback_sigma : sigma_algebra mod0_pullback.
  Proof.
    unshelve (econstructor).
    - intros U. exact (G (fun_img (λ x, f1 (fst (sval x))) U)).
    - intros U U' Heq. rewrite /fun_img.
      assert (eq_prop (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1) U')
                      (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1) U))
             as ->; eauto.
      intros z; rewrite /fun_img; split.
      * intros (x&HU&Heq'). exists x. split; eauto. eapply Heq. done.
      * intros (x&HU&Heq'). exists x. split; eauto. eapply Heq. done.
    - apply mod0_pullback_sigma_top.
    - apply mod0_pullback_sigma_compl.
    - apply mod0_pullback_sigma_union.
  Defined.

  Definition mod0_pullback_measure: measure mod0_pullback_sigma.
  Proof.
    unshelve (econstructor).
    - intros U. apply (μ1 (fun_img (λ x, (fst (sval x))) U)).
    - intros U U' Heq.
      assert (eq_prop (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, (sval x).1) U')
                      (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, (sval x).1) U))
             as ->; eauto.
      intros z; rewrite /fun_img; split.
      * intros (x&HU&Heq'). exists x. split; eauto. eapply Heq. done.
      * intros (x&HU&Heq'). exists x. split; eauto. eapply Heq. done.
    - rewrite //=.
    - rewrite //=. etransitivity; first (apply measure_proper); last apply measure_empty.
      intros z. split.
      * intros (?&[]&?).
      * inversion 1.
    - rewrite //= => Us Hin Hdisj.
      setoid_rewrite img_union.
      eapply measure_additivity.
      * intros i. specialize (Hin i).
        eapply pt_hom_sigma in Hin; last (eapply (mod0_embedding_hom _ _ _ Hmod1); eauto).
        eapply sigma_proper; last eapply Hin.
        intros z; split.
        ** intros (?&?&?). eexists; split; eauto. f_equal; done.
        ** rewrite /fun_inv. intros (?&?&?).
           eexists; split; eauto. eapply (mod0_embedding_inj); eauto.
      * intros i j Hneq x (Hin1&Hin2).
        destruct Hin1 as (((a1&a2)&Hpf)&?&Heq).
        destruct Hin2 as (((a1'&a2')&Hpf')&?&Heq').
        assert (a1' = a1).
        { rewrite //= in Heq Heq'. congruence. }
        subst.
        assert (a2' = a2).
        { eapply (mod0_embedding_inj f2); eauto. clear -Hpf Hpf'. rewrite //= in Hpf Hpf'.
          congruence. }
        subst.
        eapply (Hdisj i j); eauto. split; eauto.
        assert (Hpf = Hpf') as ->; eauto.
        { apply classical_proof_irrelevance. }
  Defined.

  Lemma mod0_pullback_embedding1_hom:
    is_pt_hom (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, (sval x).1) mod0_pullback_measure μ1.
  Proof.
    assert (Hequiv: ∀ U, F1 U →
                 eq_prop (fun_img f1 U ∩ fun_img f2 (λ _ : A2, True))
                         (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1)
                                  (fun_inv (λ x, (sval x).1) U))).
    { intros ?? z. split.
        - intros (Himg1&Himg2).
          destruct Himg1 as (x1&HU&Heq1).
          destruct Himg2 as (x2&?&Heq2).
          subst. symmetry in Heq2.
          rewrite /fun_inv//=. exists (exist _ (x1, x2) Heq2) => //=; split; eauto.
        - intros (((x1&x2)&Hpf)&?&Heqz).
          split.
          * eexists; eauto.
          * exists x2; eauto. split; auto. clear -Hpf Heqz. rewrite //= in Hpf Heqz.
            congruence.
    }
    assert (∀ U, F1 U → mod0_pullback_sigma (fun_inv (λ x, (sval x).1) U)).
    {
      intros U HF. rewrite //=. rewrite -Hequiv; eauto.
      eapply sigma_closed_pair_intersect.
      - eapply mod0_embedding_sigma_img; eauto.
      - eapply mod0_embedding_sigma_img; eauto.
    }
    split; auto.
    intros U HU. symmetry. rewrite //=.
    transitivity (μ1 (U ∩ fun_inv f1 (fun_img f2 (λ _, True)))).
    { apply measure_proper.
      intros z; split.
      - intros (((x1&x2)&Hpf)&Hin&Heqz).
        rewrite //= in Hin Heqz.
        subst. split.
        * rewrite /fun_inv//= in Hin.
        * rewrite /fun_inv//=. eexists. eauto.
      - intros (HU'&(x1&?&Hpf)). symmetry in Hpf.
        exists (exist _ (z, x1) Hpf) => //=.
    }
    symmetry; apply almost_everywhere_meas_inter_measure; eauto.
    eapply mod0_embedding_ae_inv; eauto.
    eapply mod0_embedding_ae_img; eauto.
  Qed.

  Lemma mod0_pullback_embedding1_img_hom:
    is_pt_img_hom (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, (sval x).1) mod0_pullback_measure μ1.
  Proof.
    split; auto.
    rewrite //=. intros U HF.
    eapply (mod0_embedding_sigma_inv) in HF; last eapply Hmod1.
    eapply sigma_proper; eauto.
    intros z. split.
    - intros (((x1&x2)&Hpf)&HU&Heq1).
      subst. eexists; split; eauto.
    - intros (((x1&x2)&Hpf)&HU&Heq1).
      subst. eexists; split; eauto => //=.
      rewrite //= in Heq1. eapply mod0_embedding_inj; eauto.
  Qed.

  Lemma mod0_pullback_embedding1:
    is_mod0_embedding (λ x, (fst (sval x))) mod0_pullback_measure μ1.
  Proof.
    split.
    - eapply (almost_everywhere_meas_ext _ (fun_inv f1 (fun_img f2 (λ _, True)))); last first.
      {
        eapply mod0_embedding_ae_inv; eauto.
        eapply mod0_embedding_ae_img; eauto.
      }
      intros x. split.
      * intros (x'&?&Hpf).
        symmetry in Hpf.
        exists (exist _ (x, x') Hpf).
        split; eauto.
      * intros ((?&x')&?&Hpf).
        subst. rewrite //=. eexists; split; eauto.
    - intros ((a1&a2)&Hpf) ((a1'&a2')&Hpf'). rewrite //= => ?; subst.
      apply sval_inj_pi => //=. f_equal.
      rewrite //= in Hpf Hpf'.
      eapply mod0_embedding_inj; eauto. congruence.
    - apply mod0_pullback_embedding1_hom.
    - apply mod0_pullback_embedding1_img_hom.
  Qed.

  Lemma mod0_pullback_embedding2_hom:
    is_pt_hom (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, (sval x).2) mod0_pullback_measure μ2.
  Proof.
    assert (Hequiv: ∀ U, F2 U →
                 eq_prop (fun_img f2 U ∩ fun_img f1 (λ _ : A1, True))
                         (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f2 (sval x).2)
                                  (fun_inv (λ x, (sval x).2) U))).
    { intros ?? z. split.
        - intros (Himg1&Himg2).
          destruct Himg1 as (x1&HU&Heq1).
          destruct Himg2 as (x2&?&Heq2).
          subst.
          rewrite /fun_inv//=. exists (exist _ (x2, x1) Heq2) => //=; split; eauto.
        - intros (((x1&x2)&Hpf)&?&Heqz).
          split.
          * eexists; eauto.
          * exists x1; eauto. split; auto. clear -Hpf Heqz. rewrite //= in Hpf Heqz.
            congruence.
    }
    assert (Hequiv':
              ∀ U, eq_prop (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f2 (sval x).2) U)
                           (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, f1 (sval x).1) U)).
    { intros U z.  split.
      - intros (x&?&Hf2). eexists; split ;eauto.
        destruct x as (?&Heq). rewrite //= in Hf2 *. congruence.
      - intros (x&?&Hf1). eexists; split ;eauto.
        destruct x as (?&Heq). rewrite //= in Hf1 *. congruence.
    }
    assert (∀ U, F2 U → mod0_pullback_sigma (fun_inv (λ x, (sval x).2) U)).
    {
      intros U HF. rewrite //=. rewrite -Hequiv' -Hequiv; eauto.
      eapply sigma_closed_pair_intersect.
      - eapply mod0_embedding_sigma_img; eauto.
      - eapply mod0_embedding_sigma_img; eauto.
    }
    split; auto.
    intros U HU. symmetry. rewrite //=.
    transitivity (μ (fun_img f2 U)); last first.
    { apply mod0_embedding_meas_img; eauto. }
    symmetry.
    specialize (mod0_embedding_ae _ _ _ Hmod1) => Hae.
    erewrite almost_everywhere_meas_inter_measure; eauto; last first.
    { eapply mod0_embedding_sigma_img; eauto. }
    erewrite <-(mod0_embedding_meas_inv _ _ _ _ _ _ Hmod1); last first.
    { apply sigma_closed_pair_intersect.
      - eapply mod0_embedding_sigma_img; eauto.
      - eapply mod0_embedding_sigma_img; eauto.
    }
    apply measure_proper.
    intros x1. split.
    - rewrite /fun_inv.
      intros (Himg2&Himg1).
      destruct Himg2 as (x2&?&Heq).
      symmetry in Heq.
      exists (exist _ (x1, x2) Heq). split; eauto.
    - intros (((x1'&x2')&Hpf)&?&Heq).
      rewrite //= in Heq. subst.
      eexists.
      * eexists; eauto.
      * eexists; eauto.
  Qed.

  Lemma mod0_pullback_embedding2_img_hom:
    is_pt_img_hom (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2}, (sval x).2) mod0_pullback_measure μ2.
  Proof.
    assert (∀ U : {bs : A1 * A2 | f1 bs.1 = f2 bs.2} → Prop,
               mod0_pullback_sigma U → F2 (fun_img (λ x : {bs : A1 * A2 | f1 bs.1 = f2 bs.2},
                                                          (sval x).2) U)).
    {
      rewrite //=. intros U HF.
      eapply (mod0_embedding_sigma_inv) in HF; last eapply Hmod2.
      eapply sigma_proper; eauto.
      {
        intros z. split.
        - intros (((x1&x2)&Hpf)&HU&Heq1).
          subst. eexists; split; eauto.
        - intros (((x1&x2)&Hpf)&HU&Heq1).
          subst. eexists; split; eauto => //=.
          rewrite //= in Heq1. eapply mod0_embedding_inj; eauto.
          rewrite //= in Hpf HU. congruence.
      }
    }
    split; auto.
    - rewrite //= => U HG.
      erewrite <-mod0_embedding_meas_img; eauto; last first.
      { eapply mod0_pullback_embedding1_img_hom. eauto. }
      symmetry.
      erewrite <-mod0_embedding_meas_img; eauto.
      apply measure_proper.
      intros z; split.
      * intros (x2&Himg&?).
        destruct Himg as (((x1&x2')&Hpf)&Heq1&Heq2).
        exists x1. rewrite /fun_img; split.
        **  exists (exist _ (x1, x2') Hpf).
            rewrite //=.
        ** subst. rewrite //=.
      * intros (x1&Himg&?).
        destruct Himg as (((x1'&x2)&Hpf)&Heq1&Heq2).
        exists x2. rewrite /fun_img; split.
        **  exists (exist _ (x1', x2) Hpf).
            rewrite //=.
        ** subst. rewrite //=.
  Qed.

  Lemma mod0_pullback_embedding2:
    is_mod0_embedding (λ x, (snd (sval x))) mod0_pullback_measure μ2.
  Proof.
    split.
    - eapply (almost_everywhere_meas_ext _ (fun_inv f2 (fun_img f1 (λ _, True)))); last first.
      {
        eapply mod0_embedding_ae_inv; eauto.
        eapply mod0_embedding_ae_img; eauto.
      }
      intros x. split.
      * intros (x'&?&Hpf).
        exists (exist _ (x', x) Hpf).
        split; eauto.
      * intros ((?&x')&?&Hpf).
        subst. rewrite //=. eexists; split; eauto.
    - intros ((a1&a2)&Hpf) ((a1'&a2')&Hpf'). rewrite //= => ?; subst.
      apply sval_inj_pi => //=. f_equal.
      rewrite //= in Hpf Hpf'.
      eapply mod0_embedding_inj; eauto. congruence.
    - apply mod0_pullback_embedding2_hom.
    - apply mod0_pullback_embedding2_img_hom.
  Qed.
  End pullback.

  Lemma mod0_embedding_scal p f1:
    is_mod0_embedding f1 μ1 μ2 →
    is_mod0_embedding f1 (scal_measure p μ1) (scal_measure p μ2).
  Proof.
    intros Hmod.
    split.
    - destruct (mod0_embedding_ae _ _ _ Hmod) as (?&Heq). split; auto.
      rewrite //= Heq. nra.
    - intros x y ?. eapply mod0_embedding_inj; eauto.
    - split.
      * intros. eapply mod0_embedding_sigma_inv; eauto.
      * intros U H => //=. erewrite mod0_embedding_meas_inv; eauto.
    - split.
      * intros. eapply mod0_embedding_sigma_img; eauto.
      * intros U H => //=. erewrite mod0_embedding_meas_img; eauto.
  Qed.

  Lemma mod0_embedding_sum
    {A1' A2': Type}
    {F1' : sigma_algebra A1'}
    {F2' : sigma_algebra A2'}
    (μ1': measure F1')
    (μ2': measure F2')
    f1 f2:
    is_mod0_embedding f1 μ1 μ1' →
    is_mod0_embedding f2 μ2 μ2' →
    is_mod0_embedding (λ x, match x with
                            | inl x1 => inl (f1 x1)
                            | inr x2 => inr (f2 x2)
                            end)
                      (disjoint_sum_measure μ1 μ2) (disjoint_sum_measure μ1' μ2').
  Proof.
    intros Hmod1 Hmod2.
    assert (Hequiv1: compl (fun_img f1 (λ _ : A1, True)) ≡
                     fun_inv inl (compl
                                    (fun_img (λ x : A1 + A2, match x with
                                                             | inl x1 => inl (f1 x1)
                                                             | inr x2 => inr (f2 x2)
                                                             end)
                                             (λ _ : A1 + A2, True)))).
    {
      intros z. split.
      * intros Hcomp. rewrite /fun_inv//=. intros Hfalse.
        apply Hcomp. destruct Hfalse as ([a1|a2]&?&?); last done.
        exists a1. split; eauto. congruence.
      * rewrite /fun_inv. intros Hcomp.
        intros Hfalse. destruct Hfalse as (a1&?&?).
        eapply Hcomp. exists (inl a1). subst. split; auto.
    }
    assert (Hequiv2: compl (fun_img f2 (λ _ : A2, True)) ≡
                     fun_inv inr (compl
                                    (fun_img (λ x : A1 + A2, match x with
                                                             | inl x1 => inl (f1 x1)
                                                             | inr x2 => inr (f2 x2)
                                                             end)
                                             (λ _ : A1 + A2, True)))).
    {
      intros z. split.
      * intros Hcomp. rewrite /fun_inv//=. intros Hfalse.
        apply Hcomp. destruct Hfalse as ([a1|a2]&?&?); first done.
        exists a2. split; eauto. congruence.
      * rewrite /fun_inv. intros Hcomp.
        intros Hfalse. destruct Hfalse as (a1&?&?).
        eapply Hcomp. exists (inr a1). subst. split; auto.
    }
    split.
    - split.
      * split.
        ** rewrite -Hequiv1.
           apply sigma_closed_complements.
           eapply mod0_embedding_sigma_img; eauto.
        ** rewrite -Hequiv2.
           apply sigma_closed_complements.
           eapply mod0_embedding_sigma_img; eauto.
      * rewrite //=. rewrite -Hequiv1 -Hequiv2.
        destruct (mod0_embedding_ae _ _ _ Hmod1) as (?&->).
        destruct (mod0_embedding_ae _ _ _ Hmod2) as (?&->).
        nra.
    - intros [|] [|]; inversion 1 as [Heq]; f_equal; eapply mod0_embedding_inj; eauto.
    - apply is_pt_hom_sum; eauto using mod0_embedding_hom.
    - apply is_pt_img_hom_sum; eauto using mod0_embedding_img_hom.
  Qed.

  Lemma is_pt_iso_mod0_embedding f:
    is_pt_iso f μ1 μ2 →
    is_mod0_embedding f μ1 μ2.
  Proof.
    intros Hiso.
    split.
    - eapply iso_ae_img; eauto.
    - intros; eapply pt_iso_inj; eauto.
    - by apply is_pt_hom_iso.
    - by apply is_pt_img_hom_iso.
  Qed.

End mod0_props.

(*
Record mod0_iso {A1 A2} {F1 : sigma_algebra A1} {F2: sigma_algebra A2}
       (μ1: measure F1) (μ2: measure F2) :=
  {
    mod0_iso_s1: A1 → Prop;
    mod0_iso_s2: A2 → Prop;
    mod0_iso_ae1: almost_everywhere_meas μ1 mod0_iso_s1;
    mod0_iso_ae2: almost_everywhere_meas μ2 mod0_iso_s2;
    mod0_iso_fun :> sig mod0_iso_s1 → sig mod0_iso_s2;
    mod0_iso_is_iso: is_pt_iso mod0_iso_fun
                       (sub_measure μ1 mod0_iso_s1 (almost_everywhere_meas_meas μ1 _ mod0_iso_ae1))
                       (sub_measure μ2 mod0_iso_s2 (almost_everywhere_meas_meas μ2 _ mod0_iso_ae2))
  }.

Arguments mod0_iso_s1 {_ _ _ _ _ _} _.
Arguments mod0_iso_s2 {_ _ _ _ _ _} _.
*)
Arguments mod0_iso_ae1 {_ _ _ _ _ _ _ _} _.
Arguments mod0_iso_ae2 {_ _ _ _ _ _ _ _} _.
(*
Arguments mod0_iso_fun {_ _ _ _ _ _} _.
*)
Arguments mod0_iso_is_iso {_ _ _ _ _ _ _ _ _} _.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Constructions of ordered types, for use with the [FSet] functors
  for finite sets and the [FMap] functors for finite maps. *)

Require Import FSets.
Require Import Coqlib.
Require Import Maps.
Require Import Integers.

(** The ordered type of positive numbers *)

Module OrderedPositive <: OrderedType.

Definition t := positive.
Definition eq (x y: t) := x = y.
Definition lt := Plt.

Lemma eq_refl : forall x : t, eq x x.
Proof (@refl_equal t).
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof (@sym_equal t).
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof (@trans_equal t).
Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof Plt_trans.
Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof Plt_ne.
Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
  intros. destruct (Pos.compare x y) as [] eqn:E.
  apply EQ. red. apply Pos.compare_eq_iff. assumption.
  apply LT. assumption.
  apply GT. apply Pos.compare_gt_iff. assumption.
Defined.

Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := peq.

End OrderedPositive.

(** The ordered type of machine integers *)

Module OrderedInt <: OrderedType.

Definition t := int.
Definition eq (x y: t) := x = y.
Definition lt (x y: t) := Int.unsigned x < Int.unsigned y.

Lemma eq_refl : forall x : t, eq x x.
Proof (@refl_equal t).
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof (@sym_equal t).
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof (@trans_equal t).
Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.
  unfold lt; intros. omega.
Qed.
Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof.
  unfold lt,eq; intros; red; intros. subst. omega.
Qed.
Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
  intros. destruct (zlt (Int.unsigned x) (Int.unsigned y)).
  apply LT. auto.
  destruct (Int.eq_dec x y).
  apply EQ. auto.
  apply GT.
  assert (Int.unsigned x <> Int.unsigned y).
    red; intros. rewrite <- (Int.repr_unsigned x) in n. rewrite <- (Int.repr_unsigned y) in n. congruence.
  red. omega.
Defined.

Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := Int.eq_dec.

End OrderedInt.

(** Indexed types (those that inject into [positive]) are ordered. *)

Module OrderedIndexed(A: INDEXED_TYPE) <: OrderedType.

Definition t := A.t.
Definition eq (x y: t) := x = y.
Definition lt (x y: t) := Plt (A.index x) (A.index y).

Lemma eq_refl : forall x : t, eq x x.
Proof (@refl_equal t).
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof (@sym_equal t).
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof (@trans_equal t).

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.
  unfold lt; intros. eapply Plt_trans; eauto.
Qed.

Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof.
  unfold lt; unfold eq; intros.
  red; intro. subst y. apply Plt_strict with (A.index x). auto.
Qed.

Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
  intros. case (OrderedPositive.compare (A.index x) (A.index y)); intro.
  apply LT. exact l.
  apply EQ. red; red in e. apply A.index_inj; auto.
  apply GT. exact l.
Defined.

Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }.
Proof.
  intros. case (peq (A.index x) (A.index y)); intros.
  left. apply A.index_inj; auto.
  right; red; unfold eq; intros; subst. congruence.
Defined.

End OrderedIndexed.

(** The product of two ordered types is ordered. *)

Module OrderedPair (A B: OrderedType) <: OrderedType.

Definition t := (A.t * B.t)%type.

Definition eq (x y: t) :=
  A.eq (fst x) (fst y) /\ B.eq (snd x) (snd y).

Lemma eq_refl : forall x : t, eq x x.
Proof.
  intros; split; auto.
Qed.

Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
  unfold eq; intros. intuition auto.
Qed.

Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof.
  unfold eq; intros. intuition eauto.
Qed.

Definition lt (x y: t) :=
  A.lt (fst x) (fst y) \/
  (A.eq (fst x) (fst y) /\ B.lt (snd x) (snd y)).

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.
  unfold lt; intros.
  elim H; elim H0; intros.

  left. apply A.lt_trans with (fst y); auto.

  left.  elim H1; intros.
  case (A.compare (fst x) (fst z)); intro.
  assumption.
  generalize (A.lt_not_eq H2); intro. elim H5.
  apply A.eq_trans with (fst z). auto. auto.
  generalize (@A.lt_not_eq (fst z) (fst y)); intro.
  elim H5. apply A.lt_trans with (fst x); auto.
  apply A.eq_sym; auto.

  left. elim H2; intros.
  case (A.compare (fst x) (fst z)); intro.
  assumption.
  generalize (A.lt_not_eq H1); intro. elim H5.
  apply A.eq_trans with (fst x).
  apply A.eq_sym. auto. auto.
  generalize (@A.lt_not_eq (fst y) (fst x)); intro.
  elim H5. apply A.lt_trans with (fst z); auto.
  apply A.eq_sym; auto.

  right. elim H1; elim H2; intros.
  split. apply A.eq_trans with (fst y); auto.
  apply B.lt_trans with (snd y); auto.
Qed.

Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof.
  unfold lt, eq, not; intros.
  elim H0; intros.
  elim H; intro.
  apply (@A.lt_not_eq _ _ H3 H1).
  elim H3; intros.
  apply (@B.lt_not_eq _ _ H5 H2).
Qed.

Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
  intros.
  case (A.compare (fst x) (fst y)); intro.
  apply LT. red. left. auto.
  case (B.compare (snd x) (snd y)); intro.
  apply LT. red. right. tauto.
  apply EQ. red. tauto.
  apply GT. red. right. split. apply A.eq_sym. auto. auto.
  apply GT. red. left. auto.
Defined.

Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }.
Proof.
  unfold eq; intros.
  case (A.eq_dec (fst x) (fst y)); intros.
  case (B.eq_dec (snd x) (snd y)); intros.
  left; auto.
  right; intuition.
  right; intuition.
Defined.

End OrderedPair.


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

Require Import XRbase.
Require Import XRbasic_fun.
Require Import Even.
Require Import Div2.
Require Import ArithRing.

Local Open Scope Z_scope.
Local Open Scope XR_scope.

Lemma minus_neq_O : forall n i:nat, (i < n)%nat -> (n - i)%nat <> 0%nat.
Proof.
  intros; red; intro.
  cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
  intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
    elim (lt_irrefl _ H).
  set (R := fun n m:nat => (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
  cut
    ((forall n m:nat, R n m) ->
      forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
  intro; apply H1.
  apply nat_double_ind.
  unfold R; intros; inversion H2; reflexivity.
  unfold R; intros; simpl in H3; assumption.
  unfold R; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
    assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
  unfold R; intros; apply H1; assumption.
Qed.

Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat.
Proof.
  set (R := fun m n:nat => (n <= m)%nat -> (m - n <= m)%nat).
  cut
    ((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
  intro; apply H.
  apply nat_double_ind.
  unfold R; intros; simpl; apply le_n.
  unfold R; intros; simpl; apply le_n.
  unfold R; intros; simpl; apply le_trans with n.
  apply H0; apply le_S_n; assumption.
  apply le_n_Sn.
  unfold R; intros; apply H; assumption.
Qed.

Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat.
Proof.
  intros n m; pattern n, m; apply nat_double_ind;
    [ intros; rewrite <- minus_n_O; assumption
      | intros; elim (lt_n_O _ H)
      | intros; simpl; apply H; apply lt_S_n; assumption ].
Qed.

Lemma even_odd_cor :
  forall n:nat,  exists p : nat, n = (2 * p)%nat \/ n = S (2 * p).
Proof.
  intro.
  assert (H := even_or_odd n).
  exists (div2 n).
  assert (H0 := even_odd_double n).
  elim H0; intros.
  elim H1; intros H3 _.
  elim H2; intros H4 _.
  replace (2 * div2 n)%nat with (double (div2 n)).
  elim H; intro.
  left.
  apply H3; assumption.
  right.
  apply H4; assumption.
  unfold double;ring.
Qed.

  (* 2m <= 2n => m<=n *)
Lemma le_double : forall m n:nat, (2 * m <= 2 * n)%nat -> (m <= n)%nat.
Proof.
  intros; apply INR_le.
  assert (H1 := le_INR _ _ H).
  do 2 rewrite mult_INR in H1.
  apply Rmult_le_reg_l with (INR 2).
  replace (INR 2) with (IZR 2).
  unfold IZR.
  unfold IPR.
  unfold IPR_2.
  pattern R0; rewrite <- Rplus_0_l.
  apply Rplus_lt_compat.
  exact Rlt_0_1.
  exact Rlt_0_1.
  reflexivity.
  assumption.
Qed.

(** Here, we have the euclidian division *)
(** This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *)
Lemma euclidian_division :
  forall x y:R,
    y <> R0 ->
    exists k : Z, (exists r : R, x = IZR k * y + r /\ R0 <= r < Rabs y).
Proof.
  intros.
  set
    (k0 :=
      match Rcase_abs y with
	| left _ => (1 - up (x / - y))%Z
	| right _ => (up (x / y) - 1)%Z
      end).
  exists k0.
  exists (x - IZR k0 * y).
  split.
  unfold Rminus.
  rewrite (Rplus_comm x).
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  reflexivity.
  unfold k0; case (Rcase_abs y) as [Hlt|Hge].
  assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl;
    unfold Rminus.
  replace (- ((R1 + - IZR (up (x / - y))) * y)) with
    ((IZR (up (x / - y)) - R1) * y).
  2:{
    unfold Rminus.
    rewrite Rmult_plus_distr_r.
    rewrite Rmult_plus_distr_r.
    rewrite Ropp_plus_distr.
    rewrite <- Ropp_mult_distr_l.
    rewrite Rmult_1_l.
    rewrite Rplus_comm.
    rewrite Ropp_mult_distr_l.
    rewrite Ropp_involutive.
    reflexivity.
  }
  split.
  apply Rmult_le_reg_l with (/ - y).
  apply Rinv_0_lt_compat.
  rewrite <- Ropp_0.
  apply Ropp_lt_contravar. exact Hlt.
  rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
  rewrite Ropp_mult_distr_r.
  rewrite Rmult_assoc.
  repeat rewrite Ropp_mult_distr_r_reverse.
  rewrite <- Ropp_mult_distr_l.
  rewrite Rinv_r.
  rewrite <- Ropp_mult_distr_r.
  rewrite Rmult_1_r.
  rewrite Ropp_involutive.
  apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
  rewrite Rplus_0_r; unfold Rdiv; pattern (/ - y) at 4;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].

  unfold Rminus.
  repeat rewrite Rplus_assoc.
  apply Rplus_le_compat_l.
  pattern (-(x*/-y)) at 1;rewrite <- Rplus_0_r.
  rewrite Ropp_inv_permute.
  repeat rewrite Rplus_assoc.
  apply Rplus_le_compat_l.
  apply Rplus_le_reg_l with ((x*/y)).
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  rewrite Rplus_0_r.
  rewrite Rplus_comm.
  apply Rplus_le_reg_l with (IZR (up (x * / - y))).
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  unfold IZR at 2.
  unfold IPR.
  unfold Rminus in H0.
  unfold Rdiv in H0.
  rewrite <- Ropp_inv_permute in H0.
  rewrite <- Ropp_mult_distr_r in H0.
  rewrite Ropp_involutive in H0.
  rewrite <- Ropp_inv_permute.
  rewrite <- Ropp_mult_distr_r.
  apply H0.
  exact H.
  exact H.
  exact H.
  exact H.

  rewrite (Rabs_left _ Hlt).
  apply Rmult_lt_reg_l with (/ - y).
  apply Rinv_0_lt_compat.
  rewrite <- Ropp_0.
  apply Ropp_lt_contravar.
  exact Hlt.
  rewrite <- Rinv_l_sym.
  rewrite (Rmult_comm (/ - y)).
  rewrite Rmult_plus_distr_r.
  rewrite <- Ropp_inv_permute.
  2:assumption.
  rewrite Ropp_mult_distr_r.
  rewrite Rmult_assoc.
  repeat rewrite Ropp_mult_distr_r_reverse.
  rewrite <- Ropp_mult_distr_l.
  rewrite <- Rinv_r_sym.
  rewrite <- Ropp_mult_distr_r.
  rewrite Rmult_1_r.
  2:assumption.
  apply Rplus_lt_reg_l with (IZR (up (x / - y)) - R1).
  replace (IZR (up (x / - y)) - R1 + R1) with (IZR (up (x / - y))).
  2:{
    unfold Rminus.
    rewrite Rplus_assoc.
    rewrite Rplus_opp_l.
    rewrite Rplus_0_r.
    reflexivity.
  }
  replace (IZR (up (x / - y)) - R1 + (- (x * / y) + - (IZR (up (x / - y)) - R1)))
    with (- (x * / y)).
  2:{
    unfold Rminus.
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm (- R1)).
    repeat rewrite Rplus_assoc.
    rewrite Ropp_plus_distr.
    rewrite Ropp_involutive.
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    rewrite Rplus_comm.
    repeat rewrite Rplus_assoc.
	rewrite Rplus_opp_l.
	rewrite Rplus_0_r.
    reflexivity.
  }
  unfold Rminus.
  rewrite Ropp_involutive.
  unfold IZR at 3.
  unfold IPR.
  repeat rewrite Rplus_assoc.
  rewrite (Rplus_comm (-R1)).
  repeat rewrite Rplus_assoc.
  rewrite (Rplus_comm R1).
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_r.
  rewrite Rplus_comm.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_r.
  elim H0.
  intros H1 _.
  unfold Rdiv in H1.
  rewrite <- Ropp_inv_permute in H1.
  rewrite <- Ropp_mult_distr_r in H1.
  unfold Rdiv.
  rewrite <- Ropp_inv_permute.
  rewrite <- Ropp_mult_distr_r.
  exact H1.
  assumption.
  assumption.
  apply Ropp_neq_0_compat; assumption.
  assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl;
    cut (R0 < y).
  intro; unfold Rminus;
    replace (- ((IZR (up (x / y)) + -(R1)) * y)) with ((R1 - IZR (up (x / y))) * y).
    2:{
rewrite Ropp_mult_distr_l.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
unfold Rminus.
rewrite Rplus_comm.
reflexivity.
}
  split.
  apply Rmult_le_reg_l with (/ y).
  apply Rinv_0_lt_compat.
assumption.
  rewrite Rmult_0_r.
rewrite (Rmult_comm (/ y)).
rewrite Rmult_plus_distr_r.
rewrite Ropp_mult_distr_l.
    rewrite Rmult_assoc.
rewrite <- Rinv_r_sym.
      rewrite Rmult_1_r.
2:assumption.
      apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y).
	rewrite Rplus_0_r.
unfold Rdiv.
	  replace
	    (IZR (up (x * / y)) - x * / y + (x * / y + - (IZR (up (x * / y)) + - IZR 1))) with R1.
2:{
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
unfold Rminus.
repeat rewrite Rplus_assoc.
rewrite Rplus_comm.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_l.
rewrite Rplus_comm.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_l.
reflexivity.
}
 elim H0; intros _ H2; unfold Rdiv in H2;
	      exact H2.
  rewrite (Rabs_right _ Hge).
apply Rmult_lt_reg_l with (/ y).
  apply Rinv_0_lt_compat. assumption.
  rewrite <- (Rinv_l_sym _ H).
rewrite (Rmult_comm (/ y)).
    rewrite Rmult_plus_distr_r.
rewrite Ropp_mult_distr_l.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
rewrite Rmult_assoc.
rewrite <- Rinv_r_sym.
rewrite Rmult_1_r.
2:assumption.
      apply Rplus_lt_reg_l with (IZR (up (x / y)) - R1).
	replace (IZR (up (x / y)) - R1 + R1) with (IZR (up (x / y))).

2:{
unfold Rminus.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
}
	  replace (IZR (up (x / y)) - R1 + (x * / y + (- IZR (up (x / y)) + IZR 1))) with (x * / y).
2:{
unfold Rminus.
repeat rewrite Rplus_assoc.
rewrite (Rplus_comm (-R1)).
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_r.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
}
elim H0; unfold Rdiv;
	      intros H2 _; exact H2.
  destruct (total_order_T R0 y) as [[Hlt|Heq]|Hgt].
  assumption.
  elim H; symmetry ; exact Heq.
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hge Hgt)).
Qed.

Lemma tech8 : forall n i:nat, (n <= S n + i)%nat.
Proof.
  intros; induction  i as [| i Hreci].
  replace (S n + 0)%nat with (S n); [ apply le_n_Sn | ring ].
  replace (S n + S i)%nat with (S (S n + i)).
  apply le_S; assumption.
  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR.
repeat rewrite Rplus_assoc.
reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal80.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
Cons n x.

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ (Succ Zero))))).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil)))) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).


Add LoadPath "../general".

Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import dd_fc.
Require Import PeanoNat.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Global Parameter V : Set.

Parameter eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* In this file we define two calculi based on multisets for the propositonal modal logic
   GL. The first one, called MGL, is the main calculus for GL. The second one, named PSMGL,
   is essentially the calculus MGL with further restrictions on the application of the
   rules. In other words, the calculus PSMGL is a proof-search oriented version of MGL. *)

(* Definitions Language *)

(* First, let us define the propositional formulae we use here. *)

Inductive MPropF (W : Set) : Type :=
 | Var : W -> MPropF W
 | Bot : MPropF W
 | Imp : MPropF W -> MPropF W -> MPropF W
 | Box : MPropF W -> MPropF W
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A → B" := (Imp A B) (at level 16, right associativity) : My_scope.
Notation "⊥" := Bot (at level 0)  : My_scope.

Lemma eq_dec_form : forall x y : MPropF V, {x = y}+{x <> y}.
Proof.
induction x.
- intros. destruct y.
  * pose (eq_dec_propvar v w). destruct s. left. subst. reflexivity.
    right. intro. inversion H. apply n. symmetry in H1. assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * left. reflexivity.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx y). destruct s. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption.
Qed.

Fixpoint size_form (A : MPropF V) : nat :=
match A with
 | # P => 1
 | Bot _ => 1
 | Imp B C => 1 + (size_form B) + (size_form C)
 | Box B => 1 + (size_form B)
end.

(* Now, we can prove that some properties of formulae hold. *)

Definition is_atomicT {V : Set} (A : MPropF V) : Type :=
                  (existsT2 (P : V), A = # P) + (A = Bot V).

Definition is_boxedT {V : Set} (A : MPropF V) : Type :=
                  exists (B : MPropF V), A = Box B.

Definition is_primeT {V : Set} (A : MPropF V) : Type :=
                  is_atomicT A + is_boxedT A.

(* We can define some types of lists formulae. For example, we can define
   lists of formulae which contain only propositional variables, or
   boxed formulae, or a combination of both. These are useful to define
   the rules. *)

Definition is_Atomic {V : Set} (Γ : list (MPropF V)) : Prop :=
    forall (A : MPropF V), (In A Γ) -> ((exists (P : V), A = # P) \/ (A = Bot V)).

Definition is_Boxed_list {V : Set} (Γ : list (MPropF V)) : Prop :=
    forall (A : MPropF V), (In A Γ) -> (exists (B : MPropF V), A = Box B).

Definition is_Prime {V : Set} (Γ : list (MPropF V)) : Prop :=
    forall (A : MPropF V), (In A Γ) ->
    (exists (B : MPropF V), A = Box B) \/ (exists (P : V), A = # P) \/ (A = Bot V).

(* With these properties we can define restrictions of univ_gen_ext on
   formulae. *)

Definition atom_gen_ext {V : Set} := univ_gen_ext (fun x => (@is_atomicT V x)).

Definition nobox_gen_ext {V : Set} := univ_gen_ext (fun x => (@is_boxedT V x) -> False).

Definition prim_gen_ext {V : Set} := univ_gen_ext (fun x => (@is_primeT V x)).

(* Some lemmas about gen_ext. *)

Lemma nobox_gen_ext_injective : forall (l0 l1 l : list (MPropF V)), (is_Boxed_list l0) -> (is_Boxed_list l1) ->
                                (nobox_gen_ext l0 l) -> (nobox_gen_ext l1 l) -> l1 = l0.
Proof.
intros l0 l1 l Hl0 Hl1 gen. generalize dependent l1.
induction gen.
- intros. inversion X. reflexivity.
- intros. inversion X.
  * subst. assert (l0 = l). apply IHgen. intro. intros. apply Hl0. apply in_cons. assumption.
    intro. intros. apply Hl1. apply in_cons. assumption. assumption. rewrite H. reflexivity.
  * subst. exfalso. apply H1. apply Hl0. apply in_eq.
- intros. apply IHgen. intro. intros. apply Hl0. assumption.
  intro. intros. apply Hl1. assumption. inversion X.
  subst. exfalso. apply p. apply Hl1. apply in_eq. subst. assumption.
Qed.

(* The next definitions help to define the combination of a list of boxed
   formulae and the unboxing of all the formulae in that list. *)

Definition unBox_formula {V : Set} (A : MPropF V) : MPropF V :=
  match A with
              | # P => # P
              | Bot _ => Bot _
              | A → B => A → B
              | Box A => A
              end
.

Fixpoint XBoxed_list {V : Set} (Γ : list (MPropF V)) : list (MPropF V):=
  match Γ with
  | [ ] => [ ]
  | h :: t => (unBox_formula h :: h :: XBoxed_list t)
  end
.

Fixpoint top_boxes (l : list (MPropF V)) : list (MPropF V) :=
match l with
  | nil => nil
  | h :: t => match h with
                | Box A => (Box A) :: top_boxes t
                | _ => top_boxes t
              end
end.

(* Now that we have defined these, we can prove some properties about them. *)

Lemma XBox_app_distrib {V : Set} :
  forall (l1 l2: list (MPropF V)), XBoxed_list (l1 ++ l2) = (XBoxed_list l1) ++ (XBoxed_list l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l with (l:=l2). simpl. reflexivity.
- intro l2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma subl_of_boxl_is_boxl {V : Set}:
  forall (l1 l2: list (MPropF V)), (incl l1 l2) -> (is_Boxed_list l2) -> (is_Boxed_list l1).
Proof.
intros. unfold is_Boxed_list. intros. apply H in H1. apply H0 in H1.
destruct H1. exists x. assumption.
Qed.

Lemma tl_of_boxl_is_boxl {V : Set}:
  forall (h : MPropF V) (t l : list (MPropF V)) (H: l = h :: t),
         (is_Boxed_list l) -> (is_Boxed_list t).
Proof.
intros. unfold is_Boxed_list. intros. assert (Hyp: In A l).
rewrite H. simpl. right. apply H1. apply H0 in Hyp. destruct Hyp.
exists x. assumption.
Qed.

Lemma list_preserv_XBoxed_list : forall (l : list (MPropF V)), incl l (XBoxed_list l).
Proof.
induction l.
- simpl. unfold incl. intros. inversion H.
- simpl. unfold incl. intros. inversion H.
  * subst. apply in_cons. apply in_eq.
  * apply in_cons. apply in_cons. apply IHl. assumption.
Qed.

Lemma is_box_is_in_boxed_list : forall l (A : MPropF V), In A l -> is_Boxed_list l -> (exists B, Box B = A).
Proof.
induction l.
- intros. inversion H.
- intros. inversion H.
  + subst. unfold is_Boxed_list in H0. pose (H0 A).
    apply e in H. destruct H. exists x. symmetry. assumption.
  + apply IHl. assumption. unfold is_Boxed_list. intros. unfold is_Boxed_list in H0.
    pose (H0 A0). apply e. apply in_cons. assumption.
Qed.

Lemma top_boxes_distr_app : forall (l1 l2 : list (MPropF V)),
      top_boxes (l1 ++ l2) = (top_boxes l1) ++ (top_boxes l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct a ; try apply IHl1.
  simpl. rewrite IHl1. reflexivity.
Qed.

Lemma box_in_top_boxes : forall l1 l2 A, existsT2 l3 l4, top_boxes (l1 ++ Box A :: l2) = l3 ++ Box A :: l4.
Proof.
intros. exists (top_boxes l1). exists (top_boxes l2). rewrite top_boxes_distr_app. auto.
Qed.

Lemma is_Boxed_list_top_boxes : forall l, is_Boxed_list (top_boxes l).
Proof.
intros. induction l.
- simpl. intro. intros. inversion H.
- intro. destruct a.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. destruct H.
    * exists a. auto.
    * apply IHl. assumption.
Qed.

Lemma nobox_gen_ext_top_boxes : forall l, nobox_gen_ext (top_boxes l) l.
Proof.
induction l.
- simpl. apply univ_gen_ext_refl.
- destruct a.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_cons. assumption.
Qed.

(* Finally, we can define the rules which constitute our calculi. We gather
   them in cacluli in a definition appearing later.

   We start by giving the rules common to both calculi. *)

Inductive IdPRule {V : Set} : rlsT (rel (list (MPropF V))) :=
  | IdPRule_I : forall (P : V) (Γ0 Γ1 Δ0 Δ1 : list (MPropF V)),
          IdPRule [] (pair (Γ0 ++ # P :: Γ1) (Δ0 ++ # P :: Δ1))
.

Inductive IdBRule {V : Set} : rlsT (rel (list (MPropF V))) :=
  | IdBRule_I : forall A Γ0 Γ1 Δ0 Δ1,
          IdBRule [] (pair (Γ0 ++ Box A :: Γ1) (Δ0 ++ Box A :: Δ1))
.

Inductive BotLRule {V : Set} : rlsT (rel (list (MPropF V))) :=
  | BotLRule_I : forall Γ0 Γ1 Δ,
          BotLRule [] (pair (Γ0 ++ (Bot V) :: Γ1) Δ)
.

Inductive ImpRRule {V : Set} : rlsT (rel (list (MPropF V))) :=
  | ImpRRule_I : forall A B Γ0 Γ1 Δ0 Δ1,
          ImpRRule [(pair (Γ0 ++ A :: Γ1) (Δ0 ++ B :: Δ1))]
                    (pair (Γ0 ++ Γ1) (Δ0 ++ (A → B) :: Δ1))
.

Inductive ImpLRule {V : Set} : rlsT (rel (list (MPropF V))) :=
  | ImpLRule_I : forall A B Γ0 Γ1 Δ0 Δ1,
          ImpLRule ((pair (Γ0 ++ Γ1) (Δ0 ++ A :: Δ1)) ::
                     [(pair (Γ0 ++ B :: Γ1) (Δ0 ++ Δ1))])
                    (pair (Γ0 ++ (A → B) :: Γ1) (Δ0 ++ Δ1))
.

(* Then we turn to the distinctive rules of each calculus.

   The next rule contains arbitrary weakening. It will be a crucial
   rule of the MGL calculus. *)

Inductive GLRRule {V : Set} : rlsT (rel (list (MPropF V))) :=
  | GLRRule_I : forall A BΓ Γ0 Δ0 Δ1,
          (is_Boxed_list BΓ) -> (* have MS of boxed formulae prem L*)
          (nobox_gen_ext BΓ Γ0) -> (* extend BΓ in Γ0, the L of the ccl *)
         GLRRule [(pair ((XBoxed_list BΓ) ++ [Box A]) [A])] (pair Γ0 (Δ0 ++ Box A :: Δ1))
.

(* At last we can define our calculus GLS and its proof-search version PSGLS. *)

Inductive GLS_rules {V : Set} : rlsT (rel (list (MPropF V))) :=
  | IdP : forall ps c, IdPRule ps c -> GLS_rules ps c
  | BotL : forall ps c, BotLRule ps c -> GLS_rules ps c
  | ImpR : forall ps c, ImpRRule ps c -> GLS_rules ps c
  | ImpL : forall ps c, ImpLRule ps c -> GLS_rules ps c
  | GLR : forall ps c, GLRRule ps c -> GLS_rules ps c
.

Inductive PSGLS_rules {V : Set} : rlsT (rel (list (MPropF V))) :=
  | PSIdP : forall ps c, IdPRule ps c -> PSGLS_rules ps c
  | PSIdB : forall ps c, IdBRule ps c -> PSGLS_rules ps c
  | PSBotL : forall ps c, BotLRule ps c -> PSGLS_rules ps c
  | PSImpR : forall ps c, ImpRRule ps c ->
                          PSGLS_rules ps c
  | PSImpL : forall ps c, ImpLRule ps c ->
                          PSGLS_rules ps c
  | PSGLR : forall ps c, (IdPRule [] c -> False) ->
                       (IdBRule [] c -> False) ->
                       (BotLRule [] c -> False) ->
                       GLRRule ps c ->
                         PSGLS_rules ps c
.

(* We can show that the rule IdB is derivable in GLS. *)

Lemma Id_all_form : forall (A : MPropF V) l0 l1 l2 l3,
          derrec (@GLS_rules V) (fun _ => False) (l0 ++ A :: l1, l2 ++ A :: l3).
Proof.
assert (DersNilF: dersrec (GLS_rules (V:=V)) (fun _ : rel (list (MPropF V)) => False) []).
apply dersrec_nil.

induction A.
- intros. assert (IdPRule [] (l0 ++ # w :: l1, l2 ++ # w :: l3)). apply IdPRule_I. apply IdP in H.
  pose (derI (rules:=GLS_rules (V:=V)) (prems:=fun _ : rel (list (MPropF V)) => False) (ps:=[])
  (l0 ++ # w :: l1, l2 ++ # w :: l3) H DersNilF). assumption.
- intros. assert (BotLRule [] (l0 ++ ⊥ V :: l1, l2 ++ ⊥ V :: l3)). apply BotLRule_I. apply BotL in H.
  pose (derI (rules:=GLS_rules (V:=V)) (prems:=fun _ : rel (list (MPropF V)) => False) (ps:=[])
  (l0 ++ ⊥ V :: l1, l2 ++ ⊥ V :: l3) H DersNilF). assumption.
- intros. assert (ImpRRule [(l0 ++ A1 :: A1 → A2 :: l1, l2 ++ A2 :: l3)] (l0 ++ A1 → A2 :: l1, l2 ++ A1 → A2 :: l3)).
  apply ImpRRule_I. apply ImpR in H.
  assert (ImpLRule [((l0 ++ [A1]) ++ l1, l2 ++ A1 :: A2 :: l3); ((l0 ++ [A1]) ++ A2 :: l1, l2 ++ A2 :: l3)] ((l0 ++ [A1]) ++ A1 → A2 :: l1, l2 ++ A2 :: l3)).
  apply ImpLRule_I. repeat rewrite <- app_assoc in H0. simpl in H0. apply ImpL in H0.
  pose (IHA1 l0 l1 l2 (A2 :: l3)). pose (IHA2 (l0 ++ [A1]) l1 l2 l3). repeat rewrite <- app_assoc in d0. simpl in d0.
  pose (dlCons d0 DersNilF). pose (dlCons d d1).
  pose (derI (rules:=GLS_rules (V:=V)) (prems:=fun _ : rel (list (MPropF V)) => False) (ps:=[(l0 ++ A1 :: l1, l2 ++ A1 :: A2 :: l3); (l0 ++ A1 :: A2 :: l1, l2 ++ A2 :: l3)])
  (l0 ++ A1 :: A1 → A2 :: l1, l2 ++ A2 :: l3) H0 d2). pose (dlCons d3 DersNilF).
  pose (derI (rules:=GLS_rules (V:=V)) (prems:=fun _ : rel (list (MPropF V)) => False) (ps:=[(l0 ++ A1 :: A1 → A2 :: l1, l2 ++ A2 :: l3)])
  (l0 ++ A1 → A2 :: l1, l2 ++ A1 → A2 :: l3) H d4). assumption.
- intros. assert (GLRRule [(XBoxed_list (top_boxes (l0 ++ Box A :: l1)) ++ [Box A], [A])] (l0 ++ Box A :: l1, l2 ++ Box A :: l3)).
  apply GLRRule_I. apply is_Boxed_list_top_boxes. rewrite top_boxes_distr_app. simpl. apply univ_gen_ext_combine.
  apply nobox_gen_ext_top_boxes. apply univ_gen_ext_cons. apply nobox_gen_ext_top_boxes.
  rewrite top_boxes_distr_app in X. simpl in X. rewrite XBox_app_distrib in X. simpl in X.
  repeat rewrite <- app_assoc in X. simpl in X.
  pose (IHA (XBoxed_list (top_boxes l0)) (Box A :: XBoxed_list (top_boxes l1) ++ [Box A]) [] []).
  simpl in d. pose (dlCons d DersNilF). apply GLR in X.
  pose (derI (rules:=GLS_rules (V:=V)) (prems:=fun _ : rel (list (MPropF V)) => False) (ps:=[(XBoxed_list (top_boxes l0) ++ A :: Box A :: XBoxed_list (top_boxes l1) ++ [Box A], [A])])
  (l0 ++ Box A :: l1, l2 ++ Box A :: l3) X d0). assumption.
Qed.