From Hammer Require Import Hammer.

Require Import Zquot.
From compcert Require Import Coqlib.
From compcert Require Import Zbits.
From compcert Require Import AST.
From compcert Require Import Integers.
From compcert Require Import Floats.
From compcert Require Import Values.
From compcert Require Import Memory.
From compcert Require Import Globalenvs.
From compcert Require Import Events.
From compcert Require Import Cminor.
From compcert Require Import Op.
From compcert Require Import CminorSel.
From compcert Require Import SelectOp.
From compcert Require Import SelectOpproof.
From compcert Require Import SplitLong.
From compcert Require Import SplitLongproof.
From compcert Require Import SelectLong.
From compcert Require Import SelectLongproof.
From compcert Require Import SelectDiv.

Local Open Scope cminorsel_scope.

Section Z_DIV_MUL.

Variable N: Z.
Hypothesis N_pos: N >= 0.
Variable d: Z.
Hypothesis d_pos: d > 0.

Lemma Zdiv_mul_pos:
forall m l,
l >= 0 ->
two_p (N+l) <= m * d <= two_p (N+l) + two_p l ->
forall n,
0 <= n < two_p N ->
Z.div n d = Z.div (m * n) (two_p (N + l)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.Zdiv_mul_pos".
intros m l l_pos [LO HI] n RANGE.
exploit (Z_div_mod_eq n d). auto.
set (q := n / d).
set (r := n mod d).
intro EUCL.
assert (0 <= r <= d - 1).
unfold r. generalize (Z_mod_lt n d d_pos). omega.
assert (0 <= m).
apply Zmult_le_0_reg_r with d. auto.
exploit (two_p_gt_ZERO (N + l)). omega. omega.
set (k := m * d - two_p (N + l)).
assert (0 <= k <= two_p l).
unfold k; omega.
assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
unfold k. rewrite EUCL. ring.
assert (0 <= k * n).
apply Z.mul_nonneg_nonneg; omega.
assert (k * n <= two_p (N + l) - two_p l).
apply Z.le_trans with (two_p l * n).
apply Z.mul_le_mono_nonneg_r; omega.
replace (N + l) with (l + N) by omega.
rewrite two_p_is_exp.
replace (two_p l * two_p N - two_p l)
with (two_p l * (two_p N - 1))
by ring.
apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
omega. omega.
assert (0 <= two_p (N + l) * r).
apply Z.mul_nonneg_nonneg.
exploit (two_p_gt_ZERO (N + l)). omega. omega.
omega.
assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
replace (two_p (N + l) * d - two_p (N + l))
with (two_p (N + l) * (d - 1)) by ring.
apply Z.mul_le_mono_nonneg_l.
omega.
exploit (two_p_gt_ZERO (N + l)). omega. omega.
assert (0 <= m * n - two_p (N + l) * q).
apply Zmult_le_reg_r with d. auto.
replace (0 * d) with 0 by ring.  rewrite H2. omega.
assert (m * n - two_p (N + l) * q < two_p (N + l)).
apply Zmult_lt_reg_r with d. omega.
rewrite H2.
apply Z.le_lt_trans with (two_p (N + l) * d - two_p l).
omega.
exploit (two_p_gt_ZERO l). omega. omega.
symmetry. apply Zdiv_unique with (m * n - two_p (N + l) * q).
ring. omega.
Qed.

Lemma Zdiv_unique_2:
forall x y q, y > 0 -> 0 < y * q - x <= y -> Z.div x y = q - 1.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.Zdiv_unique_2".
intros. apply Zdiv_unique with (x - (q - 1) * y). ring.
replace ((q - 1) * y) with (y * q - y) by ring. omega.
Qed.

Lemma Zdiv_mul_opp:
forall m l,
l >= 0 ->
two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
forall n,
0 < n <= two_p N ->
Z.div n d = - Z.div (m * (-n)) (two_p (N + l)) - 1.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.Zdiv_mul_opp".
intros m l l_pos [LO HI] n RANGE.
replace (m * (-n)) with (- (m * n)) by ring.
exploit (Z_div_mod_eq n d). auto.
set (q := n / d).
set (r := n mod d).
intro EUCL.
assert (0 <= r <= d - 1).
unfold r. generalize (Z_mod_lt n d d_pos). omega.
assert (0 <= m).
apply Zmult_le_0_reg_r with d. auto.
exploit (two_p_gt_ZERO (N + l)). omega. omega.
cut (Z.div (- (m * n)) (two_p (N + l)) = -q - 1).
omega.
apply Zdiv_unique_2.
apply two_p_gt_ZERO. omega.
replace (two_p (N + l) * - q - - (m * n))
with (m * n - two_p (N + l) * q)
by ring.
set (k := m * d - two_p (N + l)).
assert (0 < k <= two_p l).
unfold k; omega.
assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
unfold k. rewrite EUCL. ring.
split.
apply Zmult_lt_reg_r with d. omega.
replace (0 * d) with 0 by omega.
rewrite H2.
assert (0 < k * n). apply Z.mul_pos_pos; omega.
assert (0 <= two_p (N + l) * r).
apply Z.mul_nonneg_nonneg. exploit (two_p_gt_ZERO (N + l)); omega. omega.
omega.
apply Zmult_le_reg_r with d. omega.
rewrite H2.
assert (k * n <= two_p (N + l)).
rewrite Z.add_comm. rewrite two_p_is_exp; try omega.
apply Z.le_trans with (two_p l * n). apply Z.mul_le_mono_nonneg_r; omega.
apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
replace (two_p (N + l) * d - two_p (N + l))
with (two_p (N + l) * (d - 1))
by ring.
apply Z.mul_le_mono_nonneg_l. exploit (two_p_gt_ZERO (N + l)). omega. omega. omega.
omega.
Qed.

Lemma Zquot_mul:
forall m l,
l >= 0 ->
two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
forall n,
- two_p N <= n < two_p N ->
Z.quot n d = Z.div (m * n) (two_p (N + l)) + (if zlt n 0 then 1 else 0).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.Zquot_mul".
intros. destruct (zlt n 0).
exploit (Zdiv_mul_opp m l H H0 (-n)). omega.
replace (- - n) with n by ring.
replace (Z.quot n d) with (- Z.quot (-n) d).
rewrite Zquot_Zdiv_pos by omega. omega.
rewrite Z.quot_opp_l by omega. ring.
rewrite Z.add_0_r. rewrite Zquot_Zdiv_pos by omega.
apply Zdiv_mul_pos; omega.
Qed.

End Z_DIV_MUL.

Lemma divs_mul_params_sound:
forall d m p,
divs_mul_params d = Some(p, m) ->
0 <= m < Int.modulus /\ 0 <= p < 32 /\
forall n,
Int.min_signed <= n <= Int.max_signed ->
Z.quot n d = Z.div (m * n) (two_p (32 + p)) + (if zlt n 0 then 1 else 0).
Proof with (try discriminate). hammer_hook "SelectDivproof" "SelectDivproof.divs_mul_params_sound".
unfold divs_mul_params; intros d m' p'.
destruct (find_div_mul_params Int.wordsize
(Int.half_modulus - Int.half_modulus mod d - 1) d 32)
as [[p m] | ]...
generalize (p - 32). intro p1.
destruct (zlt 0 d)...
destruct (zlt (two_p (32 + p1)) (m * d))...
destruct (zle (m * d) (two_p (32 + p1) + two_p (p1 + 1)))...
destruct (zle 0 m)...
destruct (zlt m Int.modulus)...
destruct (zle 0 p1)...
destruct (zlt p1 32)...
intros EQ; inv EQ.
split. auto. split. auto. intros.
replace (32 + p') with (31 + (p' + 1)) by omega.
apply Zquot_mul; try omega.
replace (31 + (p' + 1)) with (32 + p') by omega. omega.
change (Int.min_signed <= n < Int.half_modulus).
unfold Int.max_signed in H. omega.
Qed.

Lemma divu_mul_params_sound:
forall d m p,
divu_mul_params d = Some(p, m) ->
0 <= m < Int.modulus /\ 0 <= p < 32 /\
forall n,
0 <= n < Int.modulus ->
Z.div n d = Z.div (m * n) (two_p (32 + p)).
Proof with (try discriminate). hammer_hook "SelectDivproof" "SelectDivproof.divu_mul_params_sound".
unfold divu_mul_params; intros d m' p'.
destruct (find_div_mul_params Int.wordsize
(Int.modulus - Int.modulus mod d - 1) d 32)
as [[p m] | ]...
generalize (p - 32); intro p1.
destruct (zlt 0 d)...
destruct (zle (two_p (32 + p1)) (m * d))...
destruct (zle (m * d) (two_p (32 + p1) + two_p p1))...
destruct (zle 0 m)...
destruct (zlt m Int.modulus)...
destruct (zle 0 p1)...
destruct (zlt p1 32)...
intros EQ; inv EQ.
split. auto. split. auto. intros.
apply Zdiv_mul_pos; try omega. assumption.
Qed.

Lemma divs_mul_shift_gen:
forall x y m p,
divs_mul_params (Int.signed y) = Some(p, m) ->
0 <= m < Int.modulus /\ 0 <= p < 32 /\
Int.divs x y = Int.add (Int.shr (Int.repr ((Int.signed x * m) / Int.modulus)) (Int.repr p))
(Int.shru x (Int.repr 31)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divs_mul_shift_gen".
intros. set (n := Int.signed x). set (d := Int.signed y) in *.
exploit divs_mul_params_sound; eauto. intros (A & B & C).
split. auto. split. auto.
unfold Int.divs. fold n; fold d. rewrite C by (apply Int.signed_range).
rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv.
rewrite Int.shru_lt_zero. unfold Int.add. apply Int.eqm_samerepr. apply Int.eqm_add.
rewrite Int.shr_div_two_p. apply Int.eqm_unsigned_repr_r. apply Int.eqm_refl2.
rewrite Int.unsigned_repr. f_equal.
rewrite Int.signed_repr. rewrite Int.modulus_power. f_equal. ring.
cut (Int.min_signed <= n * m / Int.modulus < Int.half_modulus).
unfold Int.max_signed; omega.
apply Zdiv_interval_1. generalize Int.min_signed_neg; omega. apply Int.half_modulus_pos.
apply Int.modulus_pos.
split. apply Z.le_trans with (Int.min_signed * m).
apply Z.mul_le_mono_nonpos_l. generalize Int.min_signed_neg; omega. omega.
apply Z.mul_le_mono_nonneg_r. omega. unfold n; generalize (Int.signed_range x); tauto.
apply Z.le_lt_trans with (Int.half_modulus * m).
apply Z.mul_le_mono_nonneg_r. tauto. generalize (Int.signed_range x); unfold n, Int.max_signed; omega.
apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; omega. tauto.
assert (32 < Int.max_unsigned) by (compute; auto). omega.
unfold Int.lt; fold n. rewrite Int.signed_zero. destruct (zlt n 0); apply Int.eqm_unsigned_repr.
apply two_p_gt_ZERO. omega.
apply two_p_gt_ZERO. omega.
Qed.

Theorem divs_mul_shift_1:
forall x y m p,
divs_mul_params (Int.signed y) = Some(p, m) ->
m < Int.half_modulus ->
0 <= p < 32 /\
Int.divs x y = Int.add (Int.shr (Int.mulhs x (Int.repr m)) (Int.repr p))
(Int.shru x (Int.repr 31)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divs_mul_shift_1".
intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
intros (A & B & C). split. auto. rewrite C.
unfold Int.mulhs. rewrite Int.signed_repr. auto.
generalize Int.min_signed_neg; unfold Int.max_signed; omega.
Qed.

Theorem divs_mul_shift_2:
forall x y m p,
divs_mul_params (Int.signed y) = Some(p, m) ->
m >= Int.half_modulus ->
0 <= p < 32 /\
Int.divs x y = Int.add (Int.shr (Int.add (Int.mulhs x (Int.repr m)) x) (Int.repr p))
(Int.shru x (Int.repr 31)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divs_mul_shift_2".
intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
intros (A & B & C). split. auto. rewrite C. f_equal. f_equal.
rewrite Int.add_signed. unfold Int.mulhs. set (n := Int.signed x).
transitivity (Int.repr (n * (m - Int.modulus) / Int.modulus + n)).
apply f_equal.
replace (n * (m - Int.modulus)) with (n * m +  (-n) * Int.modulus) by ring.
rewrite Z_div_plus. ring. apply Int.modulus_pos.
apply Int.eqm_samerepr. apply Int.eqm_add; auto with ints.
apply Int.eqm_sym. eapply Int.eqm_trans. apply Int.eqm_signed_unsigned.
apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl2.
apply (f_equal (fun x => n * x / Int.modulus)).
rewrite Int.signed_repr_eq. rewrite Z.mod_small by assumption.
apply zlt_false. assumption.
Qed.

Theorem divu_mul_shift:
forall x y m p,
divu_mul_params (Int.unsigned y) = Some(p, m) ->
0 <= p < 32 /\
Int.divu x y = Int.shru (Int.mulhu x (Int.repr m)) (Int.repr p).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divu_mul_shift".
intros. exploit divu_mul_params_sound; eauto. intros (A & B & C).
split. auto.
rewrite Int.shru_div_two_p. rewrite Int.unsigned_repr.
unfold Int.divu, Int.mulhu. f_equal. rewrite C by apply Int.unsigned_range.
rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega).
f_equal. rewrite (Int.unsigned_repr m).
rewrite Int.unsigned_repr. f_equal. ring.
cut (0 <= Int.unsigned x * m / Int.modulus < Int.modulus).
unfold Int.max_unsigned; omega.
apply Zdiv_interval_1. omega. compute; auto. compute; auto.
split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int.unsigned_range x); omega. omega.
apply Z.le_lt_trans with (Int.modulus * m).
apply Zmult_le_compat_r. generalize (Int.unsigned_range x); omega. omega.
apply Zmult_lt_compat_l. compute; auto. omega.
unfold Int.max_unsigned; omega.
assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Lemma divls_mul_params_sound:
forall d m p,
divls_mul_params d = Some(p, m) ->
0 <= m < Int64.modulus /\ 0 <= p < 64 /\
forall n,
Int64.min_signed <= n <= Int64.max_signed ->
Z.quot n d = Z.div (m * n) (two_p (64 + p)) + (if zlt n 0 then 1 else 0).
Proof with (try discriminate). hammer_hook "SelectDivproof" "SelectDivproof.divls_mul_params_sound".
unfold divls_mul_params; intros d m' p'.
destruct (find_div_mul_params Int64.wordsize
(Int64.half_modulus - Int64.half_modulus mod d - 1) d 64)
as [[p m] | ]...
generalize (p - 64). intro p1.
destruct (zlt 0 d)...
destruct (zlt (two_p (64 + p1)) (m * d))...
destruct (zle (m * d) (two_p (64 + p1) + two_p (p1 + 1)))...
destruct (zle 0 m)...
destruct (zlt m Int64.modulus)...
destruct (zle 0 p1)...
destruct (zlt p1 64)...
intros EQ; inv EQ.
split. auto. split. auto. intros.
replace (64 + p') with (63 + (p' + 1)) by omega.
apply Zquot_mul; try omega.
replace (63 + (p' + 1)) with (64 + p') by omega. omega.
change (Int64.min_signed <= n < Int64.half_modulus).
unfold Int64.max_signed in H. omega.
Qed.

Lemma divlu_mul_params_sound:
forall d m p,
divlu_mul_params d = Some(p, m) ->
0 <= m < Int64.modulus /\ 0 <= p < 64 /\
forall n,
0 <= n < Int64.modulus ->
Z.div n d = Z.div (m * n) (two_p (64 + p)).
Proof with (try discriminate). hammer_hook "SelectDivproof" "SelectDivproof.divlu_mul_params_sound".
unfold divlu_mul_params; intros d m' p'.
destruct (find_div_mul_params Int64.wordsize
(Int64.modulus - Int64.modulus mod d - 1) d 64)
as [[p m] | ]...
generalize (p - 64); intro p1.
destruct (zlt 0 d)...
destruct (zle (two_p (64 + p1)) (m * d))...
destruct (zle (m * d) (two_p (64 + p1) + two_p p1))...
destruct (zle 0 m)...
destruct (zlt m Int64.modulus)...
destruct (zle 0 p1)...
destruct (zlt p1 64)...
intros EQ; inv EQ.
split. auto. split. auto. intros.
apply Zdiv_mul_pos; try omega. assumption.
Qed.

Remark int64_shr'_div_two_p:
forall x y, Int64.shr' x y = Int64.repr (Int64.signed x / two_p (Int.unsigned y)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.int64_shr'_div_two_p".
intros; unfold Int64.shr'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.

Lemma divls_mul_shift_gen:
forall x y m p,
divls_mul_params (Int64.signed y) = Some(p, m) ->
0 <= m < Int64.modulus /\ 0 <= p < 64 /\
Int64.divs x y = Int64.add (Int64.shr' (Int64.repr ((Int64.signed x * m) / Int64.modulus)) (Int.repr p))
(Int64.shru x (Int64.repr 63)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divls_mul_shift_gen".
intros. set (n := Int64.signed x). set (d := Int64.signed y) in *.
exploit divls_mul_params_sound; eauto. intros (A & B & C).
split. auto. split. auto.
unfold Int64.divs. fold n; fold d. rewrite C by (apply Int64.signed_range).
rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv.
rewrite Int64.shru_lt_zero. unfold Int64.add. apply Int64.eqm_samerepr. apply Int64.eqm_add.
rewrite int64_shr'_div_two_p. apply Int64.eqm_unsigned_repr_r. apply Int64.eqm_refl2.
rewrite Int.unsigned_repr. f_equal.
rewrite Int64.signed_repr. rewrite Int64.modulus_power. f_equal. ring.
cut (Int64.min_signed <= n * m / Int64.modulus < Int64.half_modulus).
unfold Int64.max_signed; omega.
apply Zdiv_interval_1. generalize Int64.min_signed_neg; omega. apply Int64.half_modulus_pos.
apply Int64.modulus_pos.
split. apply Z.le_trans with (Int64.min_signed * m).
apply Z.mul_le_mono_nonpos_l. generalize Int64.min_signed_neg; omega. omega.
apply Z.mul_le_mono_nonneg_r. tauto. unfold n; generalize (Int64.signed_range x); tauto.
apply Z.le_lt_trans with (Int64.half_modulus * m).
apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; omega. tauto.
apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; omega. tauto.
assert (64 < Int.max_unsigned) by (compute; auto). omega.
unfold Int64.lt; fold n. rewrite Int64.signed_zero. destruct (zlt n 0); apply Int64.eqm_unsigned_repr.
apply two_p_gt_ZERO. omega.
apply two_p_gt_ZERO. omega.
Qed.

Theorem divls_mul_shift_1:
forall x y m p,
divls_mul_params (Int64.signed y) = Some(p, m) ->
m < Int64.half_modulus ->
0 <= p < 64 /\
Int64.divs x y = Int64.add (Int64.shr' (Int64.mulhs x (Int64.repr m)) (Int.repr p))
(Int64.shru' x (Int.repr 63)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divls_mul_shift_1".
intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x).
intros (A & B & C). split. auto. rewrite C.
unfold Int64.mulhs. rewrite Int64.signed_repr. auto.
generalize Int64.min_signed_neg; unfold Int64.max_signed; omega.
Qed.

Theorem divls_mul_shift_2:
forall x y m p,
divls_mul_params (Int64.signed y) = Some(p, m) ->
m >= Int64.half_modulus ->
0 <= p < 64 /\
Int64.divs x y = Int64.add (Int64.shr' (Int64.add (Int64.mulhs x (Int64.repr m)) x) (Int.repr p))
(Int64.shru' x (Int.repr 63)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divls_mul_shift_2".
intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x).
intros (A & B & C). split. auto. rewrite C. f_equal. f_equal.
rewrite Int64.add_signed. unfold Int64.mulhs. set (n := Int64.signed x).
transitivity (Int64.repr (n * (m - Int64.modulus) / Int64.modulus + n)).
apply f_equal.
replace (n * (m - Int64.modulus)) with (n * m +  (-n) * Int64.modulus) by ring.
rewrite Z_div_plus. ring. apply Int64.modulus_pos.
apply Int64.eqm_samerepr. apply Int64.eqm_add; auto with ints.
apply Int64.eqm_sym. eapply Int64.eqm_trans. apply Int64.eqm_signed_unsigned.
apply Int64.eqm_unsigned_repr_l. apply Int64.eqm_refl2.
apply (f_equal (fun x => n * x / Int64.modulus)).
rewrite Int64.signed_repr_eq. rewrite Z.mod_small by assumption.
apply zlt_false. assumption.
Qed.

Remark int64_shru'_div_two_p:
forall x y, Int64.shru' x y = Int64.repr (Int64.unsigned x / two_p (Int.unsigned y)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.int64_shru'_div_two_p".
intros; unfold Int64.shru'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.

Theorem divlu_mul_shift:
forall x y m p,
divlu_mul_params (Int64.unsigned y) = Some(p, m) ->
0 <= p < 64 /\
Int64.divu x y = Int64.shru' (Int64.mulhu x (Int64.repr m)) (Int.repr p).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.divlu_mul_shift".
intros. exploit divlu_mul_params_sound; eauto. intros (A & B & C).
split. auto.
rewrite int64_shru'_div_two_p. rewrite Int.unsigned_repr.
unfold Int64.divu, Int64.mulhu. f_equal. rewrite C by apply Int64.unsigned_range.
rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega).
f_equal. rewrite (Int64.unsigned_repr m).
rewrite Int64.unsigned_repr. f_equal. ring.
cut (0 <= Int64.unsigned x * m / Int64.modulus < Int64.modulus).
unfold Int64.max_unsigned; omega.
apply Zdiv_interval_1. omega. compute; auto. compute; auto.
split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int64.unsigned_range x); omega. omega.
apply Z.le_lt_trans with (Int64.modulus * m).
apply Zmult_le_compat_r. generalize (Int64.unsigned_range x); omega. omega.
apply Zmult_lt_compat_l. compute; auto. omega.
unfold Int64.max_unsigned; omega.
assert (64 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Section CMCONSTRS.

Variable prog: program.
Variable hf: helper_functions.
Hypothesis HELPERS: helper_functions_declared prog hf.
Let ge := Genv.globalenv prog.
Variable sp: val.
Variable e: env.
Variable m: mem.

Lemma is_intconst_sound:
forall v a n le,
is_intconst a = Some n -> eval_expr ge sp e m le a v -> v = Vint n.
Proof with (try discriminate). hammer_hook "SelectDivproof" "SelectDivproof.is_intconst_sound".
intros. unfold is_intconst in *.
destruct a... destruct o... inv H. inv H0. destruct vl; inv H5. auto.
Qed.

Lemma eval_divu_mul:
forall le x y p M,
divu_mul_params (Int.unsigned y) = Some(p, M) ->
nth_error le O = Some (Vint x) ->
eval_expr ge sp e m le (divu_mul p M) (Vint (Int.divu x y)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divu_mul".
intros. unfold divu_mul. exploit (divu_mul_shift x); eauto. intros [A B].
assert (C: eval_expr ge sp e m le (Eletvar 0) (Vint x)) by (apply eval_Eletvar; eauto).
assert (D: eval_expr ge sp e m le (Eop (Ointconst (Int.repr M)) Enil) (Vint (Int.repr M))) by EvalOp.
exploit eval_mulhu. eexact C. eexact D. intros (v & E & F). simpl in F. inv F.
exploit eval_shruimm. eexact E. instantiate (1 := Int.repr p).
intros [v [P Q]]. simpl in Q.
replace (Int.ltu (Int.repr p) Int.iwordsize) with true in Q.
inv Q. rewrite B. auto.
unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Theorem eval_divuimm:
forall le e1 x n2 z,
eval_expr ge sp e m le e1 x ->
Val.divu x (Vint n2) = Some z ->
exists v, eval_expr ge sp e m le (divuimm e1 n2) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divuimm".
unfold divuimm; intros. generalize H0; intros DIV.
destruct x; simpl in DIV; try discriminate.
destruct (Int.eq n2 Int.zero) eqn:Z2; inv DIV.
destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.divu_pow2 by eauto.
replace (Vint (Int.shru i l)) with (Val.shru (Vint i) (Vint l)).
apply eval_shruimm; auto.
simpl. erewrite Int.is_power2_range; eauto.
- destruct (Compopts.optim_for_size tt).
+ eapply eval_divu_base; eauto. EvalOp.
+ destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
* exists (Vint (Int.divu i n2)); split; auto.
econstructor; eauto. eapply eval_divu_mul; eauto.
* eapply eval_divu_base; eauto. EvalOp.
Qed.

Theorem eval_divu:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.divu x y = Some z ->
exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divu".
unfold divu; intros.
destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_divu_base; eauto.
subst. simpl in H1. rewrite Z in H1; inv H1.
TrivialExists.
+ subst. eapply eval_divuimm; eauto.
- eapply eval_divu_base; eauto.
Qed.

Lemma eval_mod_from_div:
forall le a n x y,
eval_expr ge sp e m le a (Vint y) ->
nth_error le O = Some (Vint x) ->
eval_expr ge sp e m le (mod_from_div a n) (Vint (Int.sub x (Int.mul y n))).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_mod_from_div".
unfold mod_from_div; intros.
exploit eval_mulimm; eauto. instantiate (1 := n). intros [v [A B]].
simpl in B. inv B. EvalOp.
Qed.

Theorem eval_moduimm:
forall le e1 x n2 z,
eval_expr ge sp e m le e1 x ->
Val.modu x (Vint n2) = Some z ->
exists v, eval_expr ge sp e m le (moduimm e1 n2) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_moduimm".
unfold moduimm; intros. generalize H0; intros MOD.
destruct x; simpl in MOD; try discriminate.
destruct (Int.eq n2 Int.zero) eqn:Z2; inv MOD.
destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.modu_and by eauto.
change (Vint (Int.and i (Int.sub n2 Int.one)))
with (Val.and (Vint i) (Vint (Int.sub n2 Int.one))).
apply eval_andimm. auto.
- destruct (Compopts.optim_for_size tt).
+ eapply eval_modu_base; eauto. EvalOp.
+ destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
* econstructor; split.
econstructor; eauto. eapply eval_mod_from_div.
eapply eval_divu_mul; eauto. simpl; eauto. simpl; eauto.
rewrite Int.modu_divu. auto.
red; intros; subst n2; discriminate.
* eapply eval_modu_base; eauto. EvalOp.
Qed.

Theorem eval_modu:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.modu x y = Some z ->
exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_modu".
unfold modu; intros.
destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_modu_base; eauto.
subst. simpl in H1. rewrite Z in H1; inv H1.
TrivialExists.
+ subst. eapply eval_moduimm; eauto.
- eapply eval_modu_base; eauto.
Qed.

Lemma eval_divs_mul:
forall le x y p M,
divs_mul_params (Int.signed y) = Some(p, M) ->
nth_error le O = Some (Vint x) ->
eval_expr ge sp e m le (divs_mul p M) (Vint (Int.divs x y)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divs_mul".
intros. unfold divs_mul.
assert (C: eval_expr ge sp e m le (Eletvar 0) (Vint x)) by (apply eval_Eletvar; eauto).
assert (D: eval_expr ge sp e m le (Eop (Ointconst (Int.repr M)) Enil) (Vint (Int.repr M))) by EvalOp.
exploit eval_mulhs. eexact C. eexact D. intros (v & X & F). simpl in F; inv F.
exploit eval_shruimm. eexact C. instantiate (1 := Int.repr (Int.zwordsize - 1)).
intros [v1 [Y LD]]. simpl in LD.
change (Int.ltu (Int.repr 31) Int.iwordsize) with true in LD.
simpl in LD. inv LD.
assert (RANGE: 0 <= p < 32 -> Int.ltu (Int.repr p) Int.iwordsize = true).
{ intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
assert (32 < Int.max_unsigned) by (compute; auto). omega. }
destruct (zlt M Int.half_modulus).
- exploit (divs_mul_shift_1 x); eauto. intros [A B].
exploit eval_shrimm. eexact X. instantiate (1 := Int.repr p). intros [v1 [Z LD]].
simpl in LD. rewrite RANGE in LD by auto. inv LD.
exploit eval_add. eexact Z. eexact Y. intros [v1 [W LD]].
simpl in LD. inv LD.
rewrite B. exact W.
- exploit (divs_mul_shift_2 x); eauto. intros [A B].
exploit eval_add. eexact X. eexact C. intros [v1 [Z LD]].
simpl in LD. inv LD.
exploit eval_shrimm. eexact Z. instantiate (1 := Int.repr p). intros [v1 [U LD]].
simpl in LD. rewrite RANGE in LD by auto. inv LD.
exploit eval_add. eexact U. eexact Y. intros [v1 [W LD]].
simpl in LD. inv LD.
rewrite B. exact W.
Qed.

Theorem eval_divsimm:
forall le e1 x n2 z,
eval_expr ge sp e m le e1 x ->
Val.divs x (Vint n2) = Some z ->
exists v, eval_expr ge sp e m le (divsimm e1 n2) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divsimm".
unfold divsimm; intros. generalize H0; intros DIV.
destruct x; simpl in DIV; try discriminate.
destruct (Int.eq n2 Int.zero
|| Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
+ eapply eval_shrximm; eauto. eapply Val.divs_pow2; eauto.
+ eapply eval_divs_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
+ eapply eval_divs_base; eauto. EvalOp.
+ destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
* exists (Vint (Int.divs i n2)); split; auto.
econstructor; eauto. eapply eval_divs_mul; eauto.
* eapply eval_divs_base; eauto. EvalOp.
Qed.

Theorem eval_divs:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.divs x y = Some z ->
exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divs".
unfold divs; intros.
destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_divs_base; eauto.
subst. simpl in H1.
destruct (Int.eq n2 Int.zero || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H1.
TrivialExists.
+ subst. eapply eval_divsimm; eauto.
- eapply eval_divs_base; eauto.
Qed.

Theorem eval_modsimm:
forall le e1 x n2 z,
eval_expr ge sp e m le e1 x ->
Val.mods x (Vint n2) = Some z ->
exists v, eval_expr ge sp e m le (modsimm e1 n2) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_modsimm".
unfold modsimm; intros.
exploit Val.mods_divs; eauto. intros [y [A B]].
generalize A; intros DIV.
destruct x; simpl in DIV; try discriminate.
destruct (Int.eq n2 Int.zero
|| Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
+ exploit (eval_shrximm ge sp e m (Vint i :: le) (Eletvar O)).
constructor. simpl; eauto. eapply Val.divs_pow2; eauto.
intros [v1 [X LD]]. inv LD.
econstructor; split. econstructor. eauto.
apply eval_mod_from_div. eexact X. simpl; eauto.
simpl. auto.
+ eapply eval_mods_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
+ eapply eval_mods_base; eauto. EvalOp.
+ destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
* econstructor; split.
econstructor. eauto. apply eval_mod_from_div with (x := i); auto.
eapply eval_divs_mul with (x := i); eauto.
simpl. auto.
* eapply eval_mods_base; eauto. EvalOp.
Qed.

Theorem eval_mods:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.mods x y = Some z ->
exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_mods".
unfold mods; intros.
destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_mods_base; eauto.
subst. simpl in H1.
destruct (Int.eq n2 Int.zero || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H1.
TrivialExists.
+ subst. eapply eval_modsimm; eauto.
- eapply eval_mods_base; eauto.
Qed.

Lemma eval_modl_from_divl:
forall le a n x y,
eval_expr ge sp e m le a (Vlong y) ->
nth_error le O = Some (Vlong x) ->
eval_expr ge sp e m le (modl_from_divl a n) (Vlong (Int64.sub x (Int64.mul y n))).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_modl_from_divl".
unfold modl_from_divl; intros.
exploit eval_mullimm; eauto. instantiate (1 := n). intros (v1 & A1 & B1).
assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto).
exploit eval_subl ; auto ; try apply HELPERS. exact A0. exact A1.
intros (v2 & A2 & B2).
simpl in B1; inv B1. simpl in B2; inv B2. exact A2.
Qed.

Lemma eval_divlu_mull:
forall le x y p M,
divlu_mul_params (Int64.unsigned y) = Some(p, M) ->
nth_error le O = Some (Vlong x) ->
eval_expr ge sp e m le (divlu_mull p M) (Vlong (Int64.divu x y)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divlu_mull".
intros. unfold divlu_mull. exploit (divlu_mul_shift x); eauto. intros [A B].
assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto).
exploit eval_mullhu. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1).
exploit eval_shrluimm. try apply HELPERS. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2).
simpl in B1; inv B1. simpl in B2. replace (Int.ltu (Int.repr p) Int64.iwordsize') with true in B2. inv B2.
rewrite B. assumption.
unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
assert (64 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Theorem eval_divlu:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.divlu x y = Some z ->
exists v, eval_expr ge sp e m le (divlu a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divlu".
unfold divlu; intros.
destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1.
econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* exploit Val.divlu_pow2; eauto. intros EQ; subst z. apply eval_shrluimm; auto.
* destruct (Compopts.optim_for_size tt). eapply eval_divlu_base; eauto.
destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
destruct (Int64.eq n2 Int64.zero); inv H1.
econstructor; split; eauto. econstructor. eauto. eapply eval_divlu_mull; eauto.
** eapply eval_divlu_base; eauto.
- eapply eval_divlu_base; eauto.
Qed.

Theorem eval_modlu:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.modlu x y = Some z ->
exists v, eval_expr ge sp e m le (modlu a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_modlu".
unfold modlu; intros.
destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1.
econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2 n2) as [l|] eqn:POW.
* exploit Val.modlu_pow2; eauto. intros EQ; subst z. eapply eval_andl; eauto. apply eval_longconst.
* destruct (Compopts.optim_for_size tt). eapply eval_modlu_base; eauto.
destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
destruct (Int64.eq n2 Int64.zero) eqn:Z; inv H1.
rewrite Int64.modu_divu.
econstructor; split; eauto. econstructor. eauto.
eapply eval_modl_from_divl; eauto.
eapply eval_divlu_mull; eauto.
red; intros; subst n2; discriminate Z.
** eapply eval_modlu_base; eauto.
- eapply eval_modlu_base; eauto.
Qed.

Lemma eval_divls_mull:
forall le x y p M,
divls_mul_params (Int64.signed y) = Some(p, M) ->
nth_error le O = Some (Vlong x) ->
eval_expr ge sp e m le (divls_mull p M) (Vlong (Int64.divs x y)).
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divls_mull".
intros. unfold divls_mull.
assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)).
{ constructor; auto. }
exploit eval_mullhs. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M).  intros (v1 & A1 & B1).
exploit eval_addl. auto. eexact A1. eexact A0. intros (v2 & A2 & B2).
exploit eval_shrluimm. try apply HELPERS. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3).
set (a4 := if zlt M Int64.half_modulus
then mullhs (Eletvar 0) (Int64.repr M)
else addl (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)).
set (v4 := if zlt M Int64.half_modulus then v1 else v2).
assert (A4: eval_expr ge sp e m le a4 v4).
{ unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. }
exploit eval_shrlimm. try apply HELPERS. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5).
exploit eval_addl. auto. eexact A5. eexact A3. intros (v6 & A6 & B6).
assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true).
{ intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
assert (64 < Int.max_unsigned) by (compute; auto). omega. }
simpl in B1; inv B1.
simpl in B2; inv B2.
simpl in B3; rewrite RANGE in B3 by omega; inv B3.
destruct (zlt M Int64.half_modulus).
- exploit (divls_mul_shift_1 x); eauto. intros [A B].
simpl in B5; rewrite RANGE in B5 by auto; inv B5.
simpl in B6; inv B6.
rewrite B; exact A6.
- exploit (divls_mul_shift_2 x); eauto. intros [A B].
simpl in B5; rewrite RANGE in B5 by auto; inv B5.
simpl in B6; inv B6.
rewrite B; exact A6.
Qed.

Theorem eval_divls:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.divls x y = Some z ->
exists v, eval_expr ge sp e m le (divls a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divls".
unfold divls; intros.
destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
simpl in H1.
destruct (Int64.eq n2 Int64.zero
|| Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* destruct (Int.ltu l (Int.repr 63)) eqn:LT.
** exploit Val.divls_pow2; eauto. intros EQ. eapply eval_shrxlimm; eauto.
** eapply eval_divls_base; eauto.
* destruct (Compopts.optim_for_size tt). eapply eval_divls_base; eauto.
destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
destruct (Int64.eq n2 Int64.zero
|| Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
econstructor; split; eauto. econstructor. eauto.
eapply eval_divls_mull; eauto.
** eapply eval_divls_base; eauto.
- eapply eval_divls_base; eauto.
Qed.

Theorem eval_modls:
forall le a b x y z,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
Val.modls x y = Some z ->
exists v, eval_expr ge sp e m le (modls a b) v /\ Val.lessdef z v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_modls".
unfold modls; intros.
destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
simpl in H1.
destruct (Int64.eq n2 Int64.zero
|| Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* destruct (Int.ltu l (Int.repr 63)) eqn:LT.
**destruct x; simpl in H1; try discriminate.
destruct (Int64.eq n2 Int64.zero
|| Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone) eqn:D; inv H1.
assert (Val.divls (Vlong i) (Vlong n2) = Some (Vlong (Int64.divs i n2))).
{ simpl; rewrite D; auto. }
exploit Val.divls_pow2; eauto. intros EQ.
set (le' := Vlong i :: le).
assert (A: eval_expr ge sp e m le' (Eletvar O) (Vlong i)) by (constructor; auto).
exploit eval_shrxlimm; eauto. intros (v1 & A1 & B1). inv B1.
econstructor; split.
econstructor. eauto. eapply eval_modl_from_divl. eexact A1. reflexivity.
rewrite Int64.mods_divs. auto.
**eapply eval_modls_base; eauto.
* destruct (Compopts.optim_for_size tt). eapply eval_modls_base; eauto.
destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
destruct (Int64.eq n2 Int64.zero
|| Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
econstructor; split; eauto. econstructor. eauto.
rewrite Int64.mods_divs.
eapply eval_modl_from_divl; auto.
eapply eval_divls_mull; eauto.
** eapply eval_modls_base; eauto.
- eapply eval_modls_base; eauto.
Qed.

Theorem eval_divf:
forall le a b x y,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
exists v, eval_expr ge sp e m le (divf a b) v /\ Val.lessdef (Val.divf x y) v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divf".
intros until y. unfold divf. destruct (divf_match b); intros.
- unfold divfimm. destruct (Float.exact_inverse n2) as [n2' | ] eqn:EINV.
+ inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
repeat (econstructor; eauto).
destruct x; simpl; auto. erewrite Float.div_mul_inverse; eauto.
+ TrivialExists.
- TrivialExists.
Qed.

Theorem eval_divfs:
forall le a b x y,
eval_expr ge sp e m le a x ->
eval_expr ge sp e m le b y ->
exists v, eval_expr ge sp e m le (divfs a b) v /\ Val.lessdef (Val.divfs x y) v.
Proof. hammer_hook "SelectDivproof" "SelectDivproof.eval_divfs".
intros until y. unfold divfs. destruct (divfs_match b); intros.
- unfold divfsimm. destruct (Float32.exact_inverse n2) as [n2' | ] eqn:EINV.
+ inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
repeat (econstructor; eauto).
destruct x; simpl; auto. erewrite Float32.div_mul_inverse; eauto.
+ TrivialExists.
- TrivialExists.
Qed.

End CMCONSTRS.


Require Import Reals Psatz Omega Fourier.
From stdpp Require Import tactics list.
From discprob.basic Require Import seq_ext.
From discprob.measure Require Export integral dynkin borel isomorphism.
Require Import ClassicalEpsilon.

Definition product_sigma {A B: Type} (F1: sigma_algebra A) (F2: sigma_algebra B) :=
  minimal_sigma (λ UV, ∃ U V, F1 U ∧ F2 V ∧ UV ≡ (λ ab, U (fst ab) ∧ V (snd ab))).

Instance product_measurable_space (A B: Type)
       {F1: measurable_space A} {F2: measurable_space B}:
  measurable_space (A * B).
Proof. econstructor. apply product_sigma; eapply measurable_space_sigma. Defined.

Definition left_section {A B: Type} (E: A * B → Prop) (a: A) : B → Prop :=
  λ b, E (a, b).

Definition right_section {A B: Type} (E: A * B → Prop) (b: B) : A → Prop :=
  λ a, E (a, b).

Global Instance left_section_proper {A B}:
  Proper (@eq_prop (A * B) ==> eq ==> eq_prop) left_section.
Proof. intros U U' Heq ?? ->. rewrite /left_section; split; eapply Heq. Qed.

Global Instance right_section_proper {A B}:
  Proper (@eq_prop (A * B) ==> eq ==> eq_prop) right_section.
Proof. intros U U' Heq ?? ->. rewrite /right_section; split; eapply Heq. Qed.

Lemma disjointF_left_section {A B: Type} (Us: nat → A * B → Prop) x:
  disjointF Us →
  disjointF (λ j : nat, left_section (Us j) x).
Proof.
  intros Hdisj. rewrite /left_section.
  intros i j Hneq y (Hin1&Hin2).
  eapply Hdisj; eauto.
Qed.

Lemma disjointF_right_section {A B: Type} (Us: nat → A * B → Prop) x:
  disjointF Us →
  disjointF (λ j : nat, right_section (Us j) x).
Proof.
  intros Hdisj. rewrite /right_section.
  intros i j Hneq y (Hin1&Hin2).
  eapply Hdisj; eauto.
Qed.

Definition left_section_sigma {A B: Type} (F2: sigma_algebra B) (a: A)
  : sigma_algebra (A * B).
Proof.
  refine {| sigma_sets := (λ UV, F2 (left_section UV a)) |}.
  - intros UV UV' Heq. by setoid_rewrite Heq.
  - eapply sigma_proper; last apply sigma_full.
    firstorder.
  - intros P. intros HF.
    eapply sigma_proper; last eapply sigma_closed_complements; eauto.
    firstorder.
  - intros Ps. intros HF.
    eapply sigma_proper; last eapply sigma_closed_unions; last first.
    { intros i. eapply (HF i). }
    firstorder.
Defined.

Definition right_section_sigma {A B: Type} (F2: sigma_algebra A) (a: B)
  : sigma_algebra (A * B).
Proof.
  refine {| sigma_sets := (λ UV, F2 (right_section UV a)) |}.
  - intros UV UV' Heq. by setoid_rewrite Heq.
  - eapply sigma_proper; last apply sigma_full.
    firstorder.
  - intros P. intros HF.
    eapply sigma_proper; last eapply sigma_closed_complements; eauto.
    firstorder.
  - intros Ps. intros HF.
    eapply sigma_proper; last eapply sigma_closed_unions; last first.
    { intros i. eapply (HF i). }
    firstorder.
Defined.

Lemma left_section_measurable {A B: Type} {F1 F2} (E: A * B → Prop) x:
  product_sigma F1 F2 E →
  F2 (left_section E x).
Proof.
  revert E.
  cut (le_prop (product_sigma F1 F2) (left_section_sigma F2 x)).
  { intros Hle. eapply Hle; eauto. }
  apply minimal_sigma_lub.
  intros UV (U&V&?&?&->).
  rewrite //=.
  rewrite /left_section//=.
  destruct (Classical_Prop.classic (U x)).
  - eapply sigma_proper; eauto.
    firstorder.
  - eapply sigma_proper; last eapply sigma_empty_set.
    firstorder.
Qed.

Lemma right_section_measurable {A B: Type} {F1 F2} (E: A * B → Prop) x :
  product_sigma F1 F2 E →
  F1 (right_section E x).
Proof.
  revert E.
  cut (le_prop (product_sigma F1 F2) (right_section_sigma F1 x)).
  { intros Hle. eapply Hle; eauto. }
  apply minimal_sigma_lub.
  intros UV (U&V&?&?&->).
  rewrite //=.
  rewrite /left_section//=.
  destruct (Classical_Prop.classic (V x)).
  - eapply sigma_proper; eauto.
    firstorder.
  - eapply sigma_proper; last eapply sigma_empty_set.
    firstorder.
Qed.

Lemma fun_left_measurable {A B C: Type}
      {F1: measurable_space A} {F2: measurable_space B} {F3: measurable_space C}
      (f : A * B → C) x:
  measurable f →
  measurable (λ y, f (x, y)).
Proof.
  intros Hmeas U HU.
  eapply sigma_proper; last eapply (left_section_measurable (fun_inv f U) x).
  - firstorder.
  - eapply Hmeas in HU. eapply HU.
Qed.

Lemma fun_right_measurable {A B C: Type}
      {F1: measurable_space A} {F2: measurable_space B} {F3: measurable_space C}
      (f : A * B → C) y:
  measurable f →
  measurable (λ x, f (x, y)).
Proof.
  intros Hmeas U HU.
  eapply sigma_proper; last eapply (right_section_measurable (fun_inv f U) y).
  - firstorder.
  - eapply Hmeas in HU. eapply HU.
Qed.

Lemma pair_measurable {A B C: Type}
      {F1: measurable_space A} {F2: measurable_space B} {F3: measurable_space C}
      (f : A → B) (g: A → C):
  measurable f →
  measurable g →
  measurable (λ x, (f x, g x)).
Proof.
  intros Hmeasf Hmeasg.
  apply sigma_measurable_generating_sets.
  intros ? (U&V&HU&HV&->).
  rewrite /fun_inv//=.
  assert ((λ a, U (f a) ∧ V (g a)) ≡ fun_inv f U ∩ fun_inv g V) as ->.
  { intuition. }
  apply sigma_closed_pair_intersect; eauto.
Qed.

Section product_measure.
  Context {A B: Type}.
  Context {F1: measurable_space A} {F2: measurable_space B}.
  Context (μ: measure A) (ν: measure B).

  Lemma wpt_indicator_left_section (U: A * B → Prop) Hmeas x:
    (∀ y, wpt_fun (wpt_indicator U Hmeas) (x, y) =
          wpt_fun (wpt_indicator (left_section U x) (left_section_measurable _ _ Hmeas)) y).
  Proof. intros y. rewrite ?wpt_indicator_spec/left_section//=. Qed.

  Lemma wpt_indicator_right_section (U: A * B → Prop) Hmeas y:
    (∀ x, wpt_fun (wpt_indicator U Hmeas) (x, y) =
          @wpt_fun _ F1 (wpt_indicator (right_section U y) (right_section_measurable _ _ Hmeas)) x).
  Proof. intros x. rewrite ?wpt_indicator_spec/right_section//=. Qed.

  Lemma measure_left_section_rectangle (U: A → Prop) (V: B → Prop) (x: A) (Hmeas: F1 U):
    ν (left_section (λ x, U (fst x) ∧ V (snd x)) x) =
    ν V * (wpt_fun (wpt_indicator U Hmeas) x).
  Proof.
    rewrite /left_section wpt_indicator_spec.
    destruct (excluded_middle_informative).
    * rewrite Rmult_1_r. apply measure_proper.
      split; intuition.
    * rewrite Rmult_0_r. etransitivity; last eapply measure_empty.
      apply measure_proper. split.
      ** intros (?&?); intuition.
      ** inversion 1.
  Qed.

  Lemma measure_right_section_rectangle (U: A → Prop) (V: B → Prop) (y: B) (Hmeas: F2 V):
    μ (right_section (λ x, U (fst x) ∧ V (snd x)) y) =
    μ U * (wpt_fun (wpt_indicator V Hmeas) y).
  Proof.
    rewrite /right_section wpt_indicator_spec.
    destruct (excluded_middle_informative).
    * rewrite Rmult_1_r. apply measure_proper.
      split; intuition.
    * rewrite Rmult_0_r. etransitivity; last eapply (@measure_empty A).
      apply (measure_proper _ μ). split.
      ** intros (?&?); intuition.
      ** inversion 1.
  Qed.

  Lemma measurable_measure_left U:
    product_sigma F1 F2 U →
    measurable (λ x : A, ν (left_section U x)).
  Proof.
    intros HU.
    set (F := (λ U, product_sigma F1 F2 U ∧ measurable (λ x, ν (left_section U x)))).
    cut (eq_prop (product_sigma F1 F2) F).
    { intros Heq. destruct (Heq U) as (Himpl1&Himpl2); eauto.
      destruct (Himpl1); eauto. }
    apply le_prop_antisym; last first.
    { intros ? (?&?); eauto. }
    assert (HFproper: Proper (eq_prop ==> iff) F).
    { intros ?? Heq. rewrite /F. setoid_rewrite Heq. auto. }
    assert (HFfull: F (λ _, True)).
    { split; first apply sigma_full.
      assert ((λ _ : A * B, True) ≡ (λ x : A * B, (λ _ :A , True) (fst x) ∧ (λ _ :B , True) (snd x)))
             as Heq.
      { split; auto. }
      eapply measurable_ext.
      { intros x. apply measure_proper. by rewrite Heq.  }
      eapply measurable_ext.
      { intros x. rewrite (measure_left_section_rectangle (λ _, True) (λ _, True)). done. }
      measurable.
      apply wpt_fun_measurable.
    }
    assert (HFset_minus: ∀ P Q, F P → F Q → Q ⊆ P → F (set_minus P Q)).
    {
      intros P Q (HP&?) (HQ&?) Hsub.
      rewrite /F; split; first (apply sigma_closed_set_minus; auto).
      assert (∀ x, ν (left_section (set_minus P Q) x) =
                   ν (left_section P x) - ν (left_section Q x)) as Heq.
      { intros x. rewrite -measure_set_minus; eauto using left_section_measurable.
        clear -Hsub. firstorder.
      }
      setoid_rewrite Heq.
      measurable.
    }
    assert (HF_closed_unions : ∀ Ps, (∀ i, F (Ps i)) → (∀ i, Ps i ⊆ Ps (S i)) → F (unionF Ps)).
    { intros Ps HPs Hmono. split.
      * apply sigma_closed_unions. intros i.
        destruct (HPs i); eauto.
      * assert (∀ x, ν (left_section (unionF Ps) x) =
                     Lim_seq (λ i, ν (left_section (Ps i) x))) as Heq.
        { intros x.  symmetry.
          cut (is_lim_seq (λ i, ν (left_section (Ps i) x)) (ν (left_section (unionF Ps) x))).
          { intros Heq. apply is_lim_seq_unique in Heq.
            rewrite Heq => //=. }
          assert (eq_prop (left_section (unionF Ps) x) (unionF (λ i, left_section (Ps i) x))) as ->.
          { clear. firstorder. }
          apply measure_incr_seq; eauto.
          * intros i. specialize (HPs i) as (?&?). eapply left_section_measurable; eauto.
          * clear -Hmono. firstorder.
        }
        setoid_rewrite Heq.
        apply measurable_Lim'.
        intros i. destruct (HPs i); eauto.
    }
    set (pi := (λ UV, ∃ U V, F1 U ∧ F2 V ∧ UV ≡ (λ ab, U (fst ab) ∧ V (snd ab)))).
    assert (Hpiproper: Proper (eq_prop ==> iff) pi).
    { intros ?? Heq. rewrite /pi. by setoid_rewrite Heq. }
    assert (Hpiclosed: ∀ P Q, pi P → pi Q → pi (P ∩ Q)).
    { intros P Q HP HQ.
      destruct HP as (A1&B1&?&?&HequivP).
      destruct HQ as (A2&B2&?&?&HequivQ).
      exists (A1 ∩ A2). exists (B1 ∩ B2).
      split_and!; try apply sigma_closed_pair_intersect; eauto.
      { rewrite HequivP HequivQ; clear; firstorder. }
    }
    set (pi' := mkPiSystem _ pi Hpiproper Hpiclosed).
    assert (eq_prop (product_sigma F1 F2) (minimal_sigma pi')) as ->.
    { apply le_prop_antisym.
      - apply minimal_sigma_lub.
        intros ? (U'&V'&?&?&->).
        apply minimal_sigma_ub; do 2 eexists; split_and!; eauto.
      - apply minimal_sigma_lub.
        intros ? (U'&V'&?&?&->).
        apply minimal_sigma_ub; do 2 eexists; split_and!; eauto.
    }
    set (F' := mkDynkin _ F HFproper HFfull HFset_minus HF_closed_unions).
    transitivity F'; last by rewrite //=.
    assert (le_prop (minimal_dynkin pi') F') as <-.
    { apply minimal_dynkin_lub. intros ? (U'&V'&?&?&->). rewrite /F'//=.
      split; eauto.
      * apply minimal_sigma_ub; do 2 eexists; split_and!; eauto.
      * eapply measurable_ext.
        { intros x'. rewrite measure_left_section_rectangle. done. }
        measurable. apply wpt_fun_measurable.
    }
    rewrite pi_sigma_equiv_dynkin. done.
  Qed.

  Lemma measurable_measure_right V:
    product_sigma F1 F2 V →
    measurable (λ x : B, μ (right_section V x)).
  Proof.
    intros HU.
    set (F := (λ U, product_sigma F1 F2 U ∧ measurable (λ x, μ (right_section U x)))).
    cut (eq_prop (product_sigma F1 F2) F).
    { intros Heq. destruct (Heq V) as (Himpl1&Himpl2); eauto.
      destruct (Himpl1); eauto. }
    apply le_prop_antisym; last first.
    { intros ? (?&?); eauto. }
    assert (HFproper: Proper (eq_prop ==> iff) F).
    { intros ?? Heq. rewrite /F. setoid_rewrite Heq. auto. }
    assert (HFfull: F (λ _, True)).
    { split; first apply sigma_full.
      assert ((λ _ : A * B, True) ≡ (λ x : A * B, (λ _ :A , True) (fst x) ∧ (λ _ :B , True) (snd x)))
             as Heq.
      { split; auto. }
      eapply measurable_ext.
      { intros x. apply measure_proper. by rewrite Heq.  }
      eapply measurable_ext.
      { intros x. rewrite (measure_right_section_rectangle (λ _, True) (λ _, True)). done. }
      measurable.
      apply wpt_fun_measurable.
    }
    assert (HFset_minus: ∀ P Q, F P → F Q → Q ⊆ P → F (set_minus P Q)).
    {
      intros P Q (HP&?) (HQ&?) Hsub.
      rewrite /F; split; first (apply sigma_closed_set_minus; auto).
      assert (∀ x, μ (right_section (set_minus P Q) x) =
                   μ (right_section P x) - μ (right_section Q x)) as Heq.
      { intros x. rewrite -measure_set_minus; eauto using right_section_measurable.
        clear -Hsub. firstorder.
      }
      setoid_rewrite Heq.
      measurable.
    }
    assert (HF_closed_unions : ∀ Ps, (∀ i, F (Ps i)) → (∀ i, Ps i ⊆ Ps (S i)) → F (unionF Ps)).
    { intros Ps HPs Hmono. split.
      * apply sigma_closed_unions. intros i.
        destruct (HPs i); eauto.
      * assert (∀ x, μ (right_section (unionF Ps) x) =
                     Lim_seq (λ i, μ (right_section (Ps i) x))) as Heq.
        { intros x.  symmetry.
          cut (is_lim_seq (λ i, μ (right_section (Ps i) x)) (μ (right_section (unionF Ps) x))).
          { intros Heq. apply is_lim_seq_unique in Heq.
            rewrite Heq => //=. }
          assert (eq_prop (right_section (unionF Ps) x) (unionF (λ i, right_section (Ps i) x))) as ->.
          { clear. firstorder. }
          apply measure_incr_seq; eauto.
          * intros i. specialize (HPs i) as (?&?). eapply right_section_measurable; eauto.
          * clear -Hmono. firstorder.
        }
        setoid_rewrite Heq.
        apply measurable_Lim'.
        intros i. destruct (HPs i); eauto.
    }
    set (pi := (λ UV, ∃ U V, F1 U ∧ F2 V ∧ UV ≡ (λ ab, U (fst ab) ∧ V (snd ab)))).
    assert (Hpiproper: Proper (eq_prop ==> iff) pi).
    { intros ?? Heq. rewrite /pi. by setoid_rewrite Heq. }
    assert (Hpiclosed: ∀ P Q, pi P → pi Q → pi (P ∩ Q)).
    { intros P Q HP HQ.
      destruct HP as (A1&B1&?&?&HequivP).
      destruct HQ as (A2&B2&?&?&HequivQ).
      exists (A1 ∩ A2). exists (B1 ∩ B2).
      split_and!; try apply sigma_closed_pair_intersect; eauto.
      { rewrite HequivP HequivQ; clear; firstorder. }
    }
    set (pi' := mkPiSystem _ pi Hpiproper Hpiclosed).
    assert (eq_prop (product_sigma F1 F2) (minimal_sigma pi')) as ->.
    { apply le_prop_antisym.
      - apply minimal_sigma_lub.
        intros ? (U'&V'&?&?&->).
        apply minimal_sigma_ub; do 2 eexists; split_and!; eauto.
      - apply minimal_sigma_lub.
        intros ? (U'&V'&?&?&->).
        apply minimal_sigma_ub; do 2 eexists; split_and!; eauto.
    }
    set (F' := mkDynkin _ F HFproper HFfull HFset_minus HF_closed_unions).
    transitivity F'; last by rewrite //=.
    assert (le_prop (minimal_dynkin pi') F') as <-.
    { apply minimal_dynkin_lub. intros ? (U'&V'&?&?&->). rewrite /F'//=.
      split; eauto.
      * apply minimal_sigma_ub; do 2 eexists; split_and!; eauto.
      * eapply measurable_ext.
        { intros x'. rewrite measure_right_section_rectangle. done. }
        measurable. apply wpt_fun_measurable.
    }
    rewrite pi_sigma_equiv_dynkin. done.
  Qed.

  Lemma  product_measure_additivity1 (Us : nat → A * B → Prop):
    (∀ i : nat, (product_sigma F1 F2) (Us i)) →
    disjointF Us →
    is_series (λ n : nat, Integral μ (λ x : A, ν (left_section (Us n) x)))
        (Integral μ (λ x : A, ν (left_section (unionF Us) x))).
  Proof.
    intros HUs Hdisj.
    rewrite /is_series.
    assert (∀ n', ex_integral μ (λ x : A, ν (left_section (Us n') x))).
    { intros n'. apply (ex_integral_mono_ex _ _ (λ x, ν (λ _, True))).
      * intros x. rewrite Rabs_right; last auto.
        apply measure_mono; auto.
        { eapply left_section_measurable; eauto. }
        { clear. firstorder. }
      * apply measurable_measure_left. auto.
      * apply ex_integral_const.
    }
    cut (is_lim_seq (sum_n (λ n : nat, Integral μ (λ x : A, ν (left_section (Us n) x))))
                    (Integral μ (λ x, ν (left_section (unionF Us) x)))); first by auto.
    {
      eapply is_lim_seq_ext.
      { intros. apply Integral_sum_n. intros n' Hle; eauto. }
      edestruct (is_integral_levi_pos_ex μ) as (?&His); last eapply His.
      { apply measurable_measure_left. auto. }
      { intros x. rewrite //=.
        eapply measure_additivity; eauto.
        * intros i. eapply left_section_measurable; eauto.
        * intros i j Hneq z Hfalse.
          eapply Hdisj; eauto.
      }
      {
        intros x n => //=. induction n => //=.
        - rewrite sum_O. by apply Rge_le.
        - rewrite sum_Sn => //=. rewrite /plus//=.
          specialize (measure_nonneg ν (left_section (Us (S n)) x)).
          nra.
      }
      {
        intros x n => //=. rewrite sum_Sn. rewrite /plus//=.
        specialize (measure_nonneg ν (left_section (Us (S n)) x)).
        nra.
      }
      { intros n. apply ex_integral_sum_n; eauto. }
      {
        exists (μ (λ _, True) * ν (λ _, True)).
        intros ? (n&His).
        eapply (is_integral_mono μ _ _ (λ x_, ν (λ _, True))); eauto.
        { intros; rewrite //=. rewrite -measure_sum_n_additivity.
          * apply measure_mono; last by done; auto.
            ** apply sigma_closed_range_union. intros.
               eapply left_section_measurable; eauto.
            ** auto.
          * intros; eapply left_section_measurable; eauto.
          * apply disjointF_left_section; eauto.
        }
        rewrite Rmult_comm.
        apply is_integral_const.
      }
    }
  Qed.

  Lemma  product_measure_additivity2 (Us : nat → A * B → Prop):
    (∀ i : nat, (product_sigma F1 F2) (Us i)) →
    disjointF Us →
    is_series (λ n : nat, Integral ν (λ x : B, μ (right_section (Us n) x)))
        (Integral ν (λ x : B, μ (right_section (unionF Us) x))).
  Proof.
    intros HUs Hdisj.
    rewrite /is_series.
    assert (∀ n', ex_integral ν (λ x : B, μ (right_section (Us n') x))).
    { intros n'. apply (ex_integral_mono_ex _ _ (λ x, μ (λ _, True))).
      * intros x. rewrite Rabs_right; last auto.
        apply measure_mono; auto.
        { eapply right_section_measurable; eauto. }
        { clear. firstorder. }
      * apply measurable_measure_right. auto.
      * apply ex_integral_const.
    }
    cut (is_lim_seq (sum_n (λ n : nat, Integral ν (λ x : B, μ (right_section (Us n) x))))
                    (Integral ν (λ x, μ (right_section (unionF Us) x)))); first by auto.
    {
      eapply is_lim_seq_ext.
      { intros. apply Integral_sum_n. intros n' Hle; eauto. }
      edestruct (is_integral_levi_pos_ex ν) as (?&His); last eapply His.
      { apply measurable_measure_right. auto. }
      { intros x. rewrite //=.
        eapply measure_additivity; eauto.
        * intros i. eapply right_section_measurable; eauto.
        * intros i j Hneq z Hfalse.
          eapply Hdisj; eauto.
      }
      {
        intros x n => //=. induction n => //=.
        - rewrite sum_O. by apply Rge_le.
        - rewrite sum_Sn => //=. rewrite /plus//=.
          specialize (measure_nonneg μ (right_section (Us (S n)) x)).
          nra.
      }
      {
        intros x n => //=. rewrite sum_Sn. rewrite /plus//=.
        specialize (measure_nonneg μ (right_section (Us (S n)) x)).
        nra.
      }
      { intros n. apply ex_integral_sum_n; eauto. }
      {
        exists (μ (λ _, True) * ν (λ _, True)).
        intros ? (n&His).
        eapply (is_integral_mono _ _ _ (λ x_, μ (λ _, True))); eauto.
        { intros; rewrite //=. rewrite -measure_sum_n_additivity.
          * apply measure_mono; last by done; auto.
            ** apply sigma_closed_range_union. intros.
               eapply right_section_measurable; eauto.
            ** auto.
          * intros; eapply right_section_measurable; eauto.
          * apply disjointF_right_section; auto.
        }
        apply is_integral_const.
      }
    }
  Qed.

  Definition product_measure : measure (A * B).
  Proof.
    refine {| measure_fun := λ UV, Integral μ (λ x, ν (left_section UV x)) |}.
    - abstract (intros UV UV' Heq; setoid_rewrite Heq; done).
    - abstract (intros; apply Integral_ge0; intros; apply Rge_le; auto).
    - assert (∀ x : A, left_section (empty_set : A * B → Prop) x ≡ ∅) as Heq by auto.
      abstract (setoid_rewrite Heq; setoid_rewrite measure_empty; apply Integral_0).
    - apply product_measure_additivity1.
  Defined.

  Definition product_measure_alt : measure (A * B).
  Proof.
    refine {| measure_fun := λ UV, Integral ν (λ x, μ (right_section UV x)) |}.
    - abstract (intros UV UV' Heq; setoid_rewrite Heq; done).
    - abstract (intros; apply Integral_ge0; intros; apply Rge_le; auto).
    - assert (∀ x : B, right_section (empty_set : A * B → Prop) x ≡ ∅) as Heq by auto.
      abstract (setoid_rewrite Heq; setoid_rewrite measure_empty; apply Integral_0).
    - apply product_measure_additivity2.
  Defined.

  Lemma product_measure_equiv UV:
    product_sigma F1 F2 UV →
    product_measure UV = product_measure_alt UV.
  Proof.
    eapply pi_measure_equiv.
    - split.
      * intros ?? Heq. setoid_rewrite Heq. done.
      * intros P Q (U1&V1&?&?&Heq1) (U2&V2&?&?&Heq2).
        exists (U1 ∩ U2), (V1 ∩ V2).
        split_and!; auto.
        rewrite Heq1 Heq2. clear; firstorder.
    - rewrite //=.
    - rewrite //=. rewrite /left_section/right_section ?Integral_const. nra.
    - intros ? (U&V&HU&HV&->).
      rewrite //=. rewrite /left_section/right_section //=.
      assert (∀ x, (λ x : A, ν (λ b : B, U x ∧ V b)) x =
                   ν V * wpt_fun (wpt_indicator _ HU) x) as Heq.
      { intros x. rewrite wpt_indicator_spec. destruct excluded_middle_informative => //=.
        * rewrite Rmult_1_r. apply measure_proper; split; intros; intuition.
        * rewrite Rmult_0_r. rewrite -(measure_empty _ ν).
          apply measure_proper; split.
          ** intuition.
          ** inversion 1.
      }
      setoid_rewrite Heq. rewrite Integral_scal; last apply ex_integral_wpt.
      rewrite Integral_wpt wpt_integral_indicator.
      assert (∀ x, (λ x : B, μ (λ a : A, U a ∧ V x)) x =
                   μ U * wpt_fun (wpt_indicator _ HV) x) as Heq'.
      { intros x. rewrite wpt_indicator_spec. destruct excluded_middle_informative => //=.
        * rewrite Rmult_1_r. apply measure_proper; split; intros; intuition.
        * rewrite Rmult_0_r. rewrite -(measure_empty _ μ).
          apply measure_proper; split.
          ** intuition.
          ** inversion 1.
      }
      setoid_rewrite Heq'. rewrite Integral_scal; last apply ex_integral_wpt.
      rewrite Integral_wpt wpt_integral_indicator.
      nra.
  Qed.

End product_measure.

Definition swap {A1 A2: Type} (a: A1 * A2) := (snd a, fst a).

Lemma swap_measurable {A1 A2} {F1: measurable_space A1} {F2: measurable_space A2}:
  measurable (@swap A1 A2).
Proof.
  apply sigma_measurable_generating_sets.
  intros ? (V&U&HV&HU&->).
  apply minimal_sigma_ub.
  exists U, V; split_and!; eauto.
  firstorder.
Qed.

Lemma swap_is_pt_iso {A1 A2} {F1: measurable_space A1} {F2: measurable_space A2} (μ1: measure A1) (μ2: measure A2):
  is_pt_iso (@swap A1 A2) (product_measure μ1 μ2) (product_measure μ2 μ1).
Proof.
  split.
  - intros (?&?) (?&?); inversion 1; subst; eauto.
  - intros (a2&a1); exists (a1,a2); auto.
  - intros U HU. eapply sigma_proper; last first.
    { eapply swap_measurable; eauto. }
    rewrite /fun_img/fun_inv//=. clear. intros (x2&x1); split.
    * intros ((?&?)&HU&Heq). inversion Heq; subst. auto.
    * rewrite //=. intros. exists (x1, x2); split; auto.
  - apply swap_measurable.
  - intros U HU.
    rewrite [a in a = _]product_measure_equiv //=.
    apply Integral_ext => y.
    apply measure_proper.
    intros z. clear. split.
    * firstorder.
    * intros ((?&?)&?&Heq). inversion Heq. subst. firstorder.
  - intros U HU.
    rewrite [a in a = _]product_measure_equiv //=.
Qed.

Section fubini_tonelli_lr.

  Context {A B: Type}.
  Context {F1: measurable_space A} {F2: measurable_space B}.
  Context (μ: measure A) (ν: measure B).

  Definition wpt_proj2 (wpt: weighted_partition (@product_measurable_space A B _ _)) (x: A)
    : weighted_partition F2.
  Proof.
    refine (wpt_indicator_scal_list (map (λ rU, (fst rU, left_section (snd rU) x)) wpt) _).
    abstract (intros r U (rU&Heq&Hin)%in_map_iff;
                inversion Heq; subst; eapply (@left_section_measurable _ _ F1); eauto;
                specialize (In_wpt_snd_measurable _ _ Hin) => //= ).
  Defined.

  Lemma wpt_proj2_spec wpt x y:
    wpt_fun (wpt_proj2 wpt x) y = wpt_fun wpt (x, y).
  Proof.
    rewrite /wpt_proj2.
    edestruct (@wpt_indicator_scal_list_spec2) as [(Hneg&->)|Hcase].
    { specialize (wpt_map_snd_disjoint wpt).
      generalize (wpt_list wpt). clear. induction l.
      * rewrite //=. intros. econstructor.
      * rewrite //=. inversion 1 as [|?? Hdisj]; subst.
        econstructor; last eauto.
        intros z (Hin1&Hin2).
        apply (Hdisj (x, z)).
        split; auto.
        apply union_list_inv in Hin2 as (V&Hin&?).
        apply in_map_iff in Hin as ((?&?)&?&Hin). subst.
        apply in_map_iff in Hin as ((?&V')&Heq&?); subst. inversion Heq; subst.
        eapply (union_list_intro _ _ V'); eauto.
        apply in_map_iff. exists (r, V'); auto.
    }
    - exfalso. destruct (partition_union (wpt_part wpt) (x, y)) as (UV&?&?); first done.
      eapply (Hneg (wpt_fun wpt (x, y)) (left_section UV x)).
      * apply in_map_iff. exists (wpt_fun wpt (x, y), UV) => //=.
        split; eauto. apply wpt_fun_eq1; eauto.
      * auto.
    - destruct Hcase as (r&U&Hin&HU&->).
      symmetry. apply in_map_iff in Hin.
      destruct Hin as ((r'&U')&Heq&Hin). rewrite //= in Hin.
      inversion Heq; subst.
      eapply wpt_fun_eq2; eauto.
  Qed.

  Lemma tonelli_lr_measurable_wpt wpt:
    measurable (λ x, Integral ν (λ y, @wpt_fun _ (product_measurable_space A B) wpt (x, y))).
  Proof.
    induction wpt using wpt_induction.
    - eapply measurable_proper; eauto.
      intros x. apply Integral_ext; eauto.
    - setoid_rewrite wpt_indicator_left_section => //=.
      setoid_rewrite Integral_wpt.
      setoid_rewrite wpt_integral_indicator.
      apply measurable_measure_left. auto.
    - eapply measurable_ext.
      { intros x. symmetry. setoid_rewrite wpt_plus_spec at 1. rewrite Integral_plus. done.
        * setoid_rewrite <-wpt_proj2_spec. apply ex_integral_wpt.
        * setoid_rewrite <-wpt_proj2_spec. apply ex_integral_wpt.
      }
      apply measurable_plus; eauto.
    - eapply measurable_ext.
      { intros x. symmetry. setoid_rewrite wpt_scal_spec at 1. rewrite Integral_scal. done.
        setoid_rewrite <-wpt_proj2_spec. apply ex_integral_wpt.
      }
      apply measurable_scal; eauto.
  Qed.

  Lemma tonelli_lr_pos_measurable (f: A * B → R):
    (∀ x, 0 <= f x) →
    measurable f →
    measurable (λ x : A, Integral ν (λ y, f (x, y))).
  Proof.
    intros Hpos Hmeas.
    edestruct (wpt_approx_measurable _ Hpos Hmeas) as (wptn&?&?&?&?).
    assert (∀ x, (λ x : A, Integral ν (λ y : B, f (x, y))) x =
                 (λ x : A, Lim_seq (λ n, Integral ν (wpt_fun (wpt_proj2 (wptn n) x)))) x) as Heq.
    { intros x. symmetry.
      apply Integral_pos_mct; eauto.
      { eapply (fun_left_measurable _ _); eauto. }
      { intros. rewrite //=. setoid_rewrite wpt_proj2_spec. eauto.  }
      { intros. rewrite ?wpt_proj2_spec; eauto. }
      { intros. rewrite ?wpt_proj2_spec; eauto. }
    }
    setoid_rewrite Heq.
    apply measurable_Lim'.
    intros n. eapply measurable_ext; last eapply (tonelli_lr_measurable_wpt (wptn n)).
    intros x => //=. apply Integral_ext => ?. by rewrite wpt_proj2_spec.
  Qed.

  Lemma tonelli_lr_measurable (f: A * B → R):
    measurable f →
    measurable (λ x : A, Integral ν (λ y, f (x, y))).
  Proof.
    intros. rewrite /Integral.
    eapply measurable_ext.
    { intros x. rewrite -?Integral_equiv_Pos_integral; eauto using Rmax_r. }
    { apply measurable_plus; last (apply measurable_opp).
      - eapply (tonelli_lr_pos_measurable (λ x, Rmax (f x) 0)); eauto using Rmax_r.
        apply measurable_Rmax; measurable.
      - eapply (tonelli_lr_pos_measurable (λ x, Rmax (-f x) 0)); eauto using Rmax_r.
        apply measurable_Rmax; measurable.
    }
  Qed.

  Lemma ex_integral_left_section_measure U:
    product_sigma F1 F2 U →
    ex_integral μ (λ x : A, ν (left_section U x)).
  Proof.
    intros Hsigma.
    apply (ex_integral_mono_ex _ _ (λ x, ν (λ _, True))).
    { intros x. rewrite Rabs_right; auto.
      apply measure_mono; eauto using left_section_measurable; done. }
    { by apply measurable_measure_left. }
    { apply ex_integral_const. }
  Qed.

  Lemma ex_integral_left_wpt (wpt: weighted_partition (product_measurable_space A B)) x:
    ex_integral ν (λ y, wpt_fun wpt (x, y)).
  Proof.
    eapply (ex_integral_ext _ (wpt_fun (wpt_proj2 wpt x))).
    { intros ?. by rewrite wpt_proj2_spec. }
    apply ex_integral_wpt.
  Qed.

  Hint Resolve ex_integral_left_wpt.

  Lemma tonelli_lr_integral_wpt (wpt : weighted_partition (product_measurable_space A B)):
    is_integral μ (λ x, Integral ν (λ y, wpt_fun wpt (x, y)))
                (Integral (product_measure μ ν) (wpt_fun wpt)).
  Proof.
    induction wpt as [wpt1 wpt2 Heq| | | ] using wpt_induction.
    - eapply is_integral_ext.
      { intros x. eapply Integral_ext => y. rewrite -(Heq (x, y)). done. }
      rewrite -(Integral_ext _ (wpt_fun wpt1) (wpt_fun wpt2)) //.
    - rewrite Integral_wpt wpt_integral_indicator //=.
      setoid_rewrite wpt_indicator_left_section.
      setoid_rewrite Integral_wpt. setoid_rewrite wpt_integral_indicator.
      apply Integral_correct, ex_integral_left_section_measure.
      done.
    - rewrite Integral_wpt wpt_integral_plus.
      setoid_rewrite wpt_plus_spec.
      eapply is_integral_ext.
      { intros x. rewrite Integral_plus; eauto. }
      apply is_integral_plus; rewrite -Integral_wpt; done.
    - rewrite Integral_wpt wpt_integral_scal.
      setoid_rewrite wpt_scal_spec.
      eapply is_integral_ext.
      { intros x. rewrite Integral_scal; eauto. }
      apply is_integral_scal; rewrite -Integral_wpt; done.
  Qed.

  Global Instance is_lim_seq_Proper:
    Proper (pointwise_relation _ eq ==> eq ==> iff) is_lim_seq.
  Proof.
    intros ?? Heq ?? Heq'. split; subst; apply is_lim_seq_ext; done.
  Qed.

  Global Instance Lim_seq_Proper:
    Proper (pointwise_relation _ eq ==> eq) Lim_seq.
  Proof.
    intros ?? Heq. apply Lim_seq_ext; eauto.
  Qed.

  Lemma tonelli_lr_Integral_wpt (wpt : weighted_partition (product_measurable_space A B)):
    Integral μ (λ x, Integral ν (λ y, wpt_fun wpt (x, y))) =
                (Integral (product_measure μ ν) (wpt_fun wpt)).
  Proof.
    apply is_integral_unique, tonelli_lr_integral_wpt.
  Qed.

  Lemma fubini_lr_pos_integral_aux (f: A * B → R):
    (∀ x, 0 <= f x) →
    measurable f →
    ex_integral (product_measure μ ν) f →
    almost_everywhere_meas μ (λ x, ex_integral ν (λ y, f (x, y))) →
    is_integral μ (λ x, Integral ν (λ y, f (x, y)))
                (Integral (product_measure μ ν) f).
  Proof.
    intros Hpos Hmeas Hae Hex.
    edestruct (wpt_approx_measurable _ Hpos Hmeas) as (wptn&?&?&?&?).
    feed pose proof (is_integral_mct_ex (product_measure μ ν) (λ n, wpt_fun (wptn n)) f f)
      as Hmct; eauto using ex_integral_wpt.
    { intros x n. rewrite Rabs_right; eauto. }
    destruct Hmct as (_&His).
    generalize His => His_alt.
    setoid_rewrite <-tonelli_lr_Integral_wpt in His.
    feed pose proof (is_integral_levi_ae_ex μ (λ n, λ x, Integral ν (λ y, (wpt_fun (wptn n) (x, y))))
                                        (λ x, Integral ν (λ y, f (x, y)))) as Hlevi; eauto.
    { apply tonelli_lr_measurable; eauto. }
    { eapply almost_everywhere_meas_mono; eauto.
      { measurable; eauto.
        * intros n. apply tonelli_lr_measurable_wpt.
        * eapply measurable_comp; first apply tonelli_lr_measurable; eauto.
          eapply measurable_Finite.
      }
      intros x Hbound.
      eapply is_integral_mct_ex; eauto.
      intros. rewrite Rabs_right; eauto.
    }
    { apply almost_everywhere_meas_everywhere.
      intros. apply Integral_mono; eauto using ex_integral_wpt. }
    { intros; eexists; eapply tonelli_lr_integral_wpt. }
    { exists (Integral (product_measure μ ν) f).  intros r (n&His_r).
      apply is_integral_unique in His_r as <-.
      eapply is_lim_seq_incr_compare in His; eauto.
      { intros n'.  rewrite ?tonelli_lr_Integral_wpt.
        eapply Integral_mono; eauto using ex_integral_wpt. }
    }
    destruct Hlevi as (Hex'&His').
    eauto.
    cut ((Integral μ (λ x : A, Integral ν (λ y : B, f (x, y)))) =
         (Integral (product_measure μ ν) f)).
    { intros <-. by apply Integral_correct. }
    apply is_lim_seq_unique in His.
    apply is_lim_seq_unique in His'. congruence.
  Qed.

  Lemma fubini_lr_pos_integral_ae (f: A * B → R):
    (∀ x, 0 <= f x) →
    measurable f →
    ex_integral (product_measure μ ν) f →
    almost_everywhere_meas μ (λ x, ex_integral ν (λ y, f (x, y))).
  Proof.
    intros Hpos Hmeas Hex.
    assert (Himp: ∀ P Q : Prop, P ∧ (P → Q) → P ∧ Q) by intuition.
    assert (∀ i,
        measurable (λ x : A, Integral ν (λ y : B, Rmin (f (x, y)) (INR i)))).
    {
      intros i.
      apply (tonelli_lr_measurable (λ ab, Rmin (f ab) (INR i))).
      apply measurable_Rmin; measurable.
    }
    apply Himp.
    split.
    { apply sigma_closed_complements.
      eapply (sigma_proper _ F1
              (λ x, ex_finite_lim_seq (λ n, Integral ν (λ y, Rmin (f (x, y)) (INR n))))).
      { intros x. rewrite -ex_integral_ex_finite_lim_min; eauto.
        eapply fun_left_measurable; eauto. }
      measurable.
    }
    intros HF.
    apply Rle_antisym; last apply Rge_le, measure_nonneg.
    apply Rnot_gt_le. intros Hgt.
    destruct Hex as (v&His).
    feed pose proof (is_integral_ge0 (product_measure μ ν) f v); eauto.

    cut (∀ k, F1 (unionF (λ n x, INR (S k) <= Integral ν (λ y, Rmin (f (x, y)) (INR n)))) ∧
              μ (unionF (λ n x, INR (S k) <= Integral ν (λ y, Rmin (f (x, y)) (INR n))))
              <= (v + 1) / INR (S k)).
    { intros Hsmall.
      edestruct (archimed_cor1 (μ (compl (λ x : A, ex_integral ν (λ y : B, f (x, y)))) / (v + 1))) as
          (n&Hr1&Hr2).
      { apply Rdiv_lt_0_compat; auto.
        nra. }
      destruct n as [| n]; first by omega.
      destruct (Hsmall n) as (Hmeas'&Hsize).
      cut (μ (compl (λ x : A, ex_integral ν (λ y : B, f (x, y)))) <=
           μ (unionF (λ n0 (x : A), INR (S n) <= Integral ν (λ y : B, Rmin (f (x, y)) (INR n0))))).
      { intros Hle.
        apply (Rmult_lt_compat_r (v + 1)) in Hr1; last by nra.
        field_simplify in Hr1; try nra.
        feed pose proof (pos_INR' (S n)); auto. nra.
      }
      clear -HF Hpos Hmeas Hmeas'.
      apply measure_mono; auto.
      intros x Hneg.
      apply Classical_Pred_Type.not_all_not_ex.
      intros Hall.
      apply Hneg. apply ex_integral_sup_min; eauto.
      { eapply fun_left_measurable; eauto. }
      exists (INR (S n)).
      intros ? (?&<-).
      left. apply Rnot_le_gt. eauto.
    }
    intros k. apply Himp.
    split.
    { apply sigma_closed_unions => i; apply measurable_fun_ge; eauto. }
    intros Hmeas'.
    feed pose proof (ex_integral_Rmin (product_measure μ ν) f) as Hex; eauto.
    assert (Hlen: ∀ n , μ (λ x, INR (S k) <= Integral ν (λ y : B, Rmin (f (x, y)) (INR n)))
                         <= (v + 1) / INR (S k)).
    {
      intros n.
      specialize (Hex n).
      destruct Hex as (v'&His').
      assert (v' <= v + 1).
      { transitivity v; last nra.
        unshelve (eapply (is_integral_mono _ _ _ _ _ _ His')); eauto.
        intros => //=. apply Rmin_l. }
      transitivity (v' / INR (S k)); last first.
      { rewrite /Rdiv. apply Rmult_le_compat_r; auto. left.
        apply Rinv_0_lt_compat. apply pos_INR'. lia. }
      apply is_integral_bound_measure_above; auto.
      - intros. apply Rge_le, Integral_ge0. intros; apply Rmin_case_strong; eauto using pos_INR.
      - rewrite -(is_integral_unique _ _ _ His').
        apply (fubini_lr_pos_integral_aux (λ x, Rmin (f x) (INR n))).
        * intros. apply Rmin_case_strong; eauto using pos_INR.
        * apply measurable_Rmin; measurable.
        * apply ex_integral_Rmin; eauto.
        * apply almost_everywhere_meas_everywhere. intros x.
          apply ex_integral_Rmin; eauto.
          eapply fun_left_measurable; eauto.
      - apply pos_INR'; lia.
    }
    eapply (is_lim_seq_le _ _ (Finite _) (Finite _)); last eapply is_lim_seq_const.
    { intros n. apply Hlen. }
    apply measure_incr_seq.
    - intros n. apply measurable_fun_ge; eauto.
    - intros i x Hle. etransitivity; eauto.
      apply Integral_mono; eauto.
      * intros. apply Rle_min_compat_l, le_INR. omega.
      * apply ex_integral_Rmin; eauto.
        eapply fun_left_measurable; eauto.
      * apply ex_integral_Rmin; eauto.
        eapply fun_left_measurable; eauto.
  Qed.

  Lemma fubini_lr_pos_integral (f: A * B → R):
    (∀ x, 0 <= f x) →
    ex_integral (product_measure μ ν) f →
    is_integral μ (λ x, Integral ν (λ y, f (x, y)))
                (Integral ((product_measure μ ν)) f).
  Proof.
    intros Hpos Hex.
    apply fubini_lr_pos_integral_aux; eauto.
    apply fubini_lr_pos_integral_ae; eauto.
  Qed.

  Lemma fubini_lr_pos_Integral (f: A * B → R):
    (∀ x, 0 <= f x) →
    ex_integral (product_measure μ ν) f →
    Integral μ (λ x, Integral ν (λ y, f (x, y))) =
                (Integral ((product_measure μ ν)) f).
  Proof.
    intros Hpos Hex.
    apply is_integral_unique, fubini_lr_pos_integral; eauto.
  Qed.

  Lemma fubini_lr_integral (f: A * B → R):
    ex_integral (product_measure μ ν) f →
    is_integral μ (λ x, Integral ν (λ y, f (x, y)))
                (Integral ((product_measure μ ν)) f).
  Proof.
    intros Hex.
    cut (ex_integral μ (λ x, Integral ν (λ y, f (x, y))) ∧
         (Integral μ (λ x, Integral ν (λ y, f (x, y))) = Integral (product_measure μ ν) f)).
    { intros (Hex'&His). rewrite -His. apply Integral_correct; eauto. }
    assert (Himp: ∀ P Q : Prop, P ∧ (P → Q) → P ∧ Q) by intuition.
    apply Himp; clear Himp; split.
    - apply ex_integral_Rabs.
      { apply tonelli_lr_measurable. destruct Hex. eapply is_integral_measurable; eauto. }
      feed pose proof (fubini_lr_pos_integral_ae (λ x, Rabs (f x))); eauto.
      { measurable. eauto. }
      { apply ex_integral_Rabs in Hex; eauto. }
      eapply (ex_integral_ae_mono_ex _ _ (λ x, Integral ν (λ y, Rabs (f (x, y))))).
      {
        eapply almost_everywhere_meas_mono; last eauto.
        { apply measurable_fun_le_inv.
          * apply measurable_Rabs, measurable_Rabs. apply tonelli_lr_measurable.
            eauto.
          * apply (tonelli_lr_measurable (λ x, Rabs (f x))).
            measurable. eauto.
        }
        intros x Hex'. rewrite Rabs_right; last eauto.
        apply Integral_Rabs.
        right; split; eauto.
        eapply fun_left_measurable; eauto.
      }
      * apply measurable_Rabs.
        apply tonelli_lr_measurable; eauto.
      * eexists. eapply (fubini_lr_pos_integral_aux (λ x, Rabs (f x))); eauto.
        { apply measurable_Rabs; eauto. }
        { apply ex_integral_Rabs in Hex; eauto. }
    - rewrite [a in _ = a]Integral_alt.
      apply ex_integral_alt in Hex as (?&?&?).
      feed pose proof (fubini_lr_pos_integral (λ x, Rmax (f x) 0)) as Hfb1; eauto using Rmax_r.
      feed pose proof (fubini_lr_pos_integral (λ x, Rmax (- f x) 0)) as Hfb2; eauto using Rmax_r.
      rewrite -(is_integral_unique _ _ _ Hfb1).
      rewrite -(is_integral_unique _ _ _ Hfb2).
      rewrite -Integral_minus; try (eexists; eauto).
      feed pose proof (fubini_lr_pos_integral_ae (λ x, Rmax (f x) 0)) as Hfb1';
        eauto using Rmax_r.
      feed pose proof (fubini_lr_pos_integral_ae (λ x, Rmax (- f x) 0)) as Hfb2';
        eauto using Rmax_r.
      generalize (almost_everywhere_meas_conj _ _ _ Hfb1' Hfb2').
      intros Hae. apply Integral_ae_ext_weak; last first.
      { apply measurable_minus; eauto. }
      eapply almost_everywhere_meas_mono; last eapply Hae.
      { apply measurable_fun_eq_inv; eauto.
        * apply tonelli_lr_measurable; auto.
        * apply measurable_minus; eauto.
      }
      intros x (Hex1&Hex2).
      rewrite -Integral_minus; eauto.
      apply Integral_ext.
      intros y. do 2 apply Rmax_case_strong; nra.
  Qed.

  Lemma fubini_lr_integral_ae (f: A * B → R):
    ex_integral (product_measure μ ν) f →
    almost_everywhere_meas μ (λ x, ex_integral ν (λ y, f (x, y))).
  Proof.
    intros Hex.
    feed pose proof (fubini_lr_pos_integral_ae (λ x, Rabs (f x))); eauto.
    { measurable. eauto. }
    { apply ex_integral_Rabs in Hex; eauto. }
    eapply almost_everywhere_meas_ext; eauto.
    intros x. symmetry. apply ex_integral_Rabs. eapply fun_left_measurable; eauto with *.
  Qed.

  Lemma fubini_lr_Integral (f: A * B → R):
    ex_integral (product_measure μ ν) f →
    Integral μ (λ x, Integral ν (λ y, f (x, y))) = (Integral ((product_measure μ ν)) f).
  Proof.
    intros. eapply is_integral_unique, fubini_lr_integral; auto.
  Qed.

  Lemma tonelli_lr_integral (f: A * B → R):
    (∀ x, 0 <= f x) →
    measurable f  →
    almost_everywhere_meas μ (λ x, ex_integral ν (λ y, f (x, y))) →
    ex_integral μ (λ x, Integral ν (λ y, f (x, y))) →
    ex_integral (product_measure μ ν) f.
  Proof.
    intros Hpos Hmeas Hae Hex.
    apply ex_integral_sup_min; eauto.
    destruct Hex as (v&His).
    exists v. intros ? (n&<-).
    rewrite -(is_integral_unique _ _ _ His).
    rewrite -fubini_lr_Integral; last first.
    { apply ex_integral_Rmin; eauto. }
    apply Integral_ae_mono.
    { eapply almost_everywhere_meas_mono; eauto.
      { apply measurable_fun_le_inv; eauto.
        apply (tonelli_lr_measurable (λ x, Rmin (f x) (INR n))).
        measurable. }
      intros x Hex. apply Integral_mono; eauto using ex_integral_Rmin.
      intros. apply Rmin_l.
    }
    { eexists. eapply (fubini_lr_integral (λ x, Rmin (f x) (INR n))), ex_integral_Rmin; eauto. }
    { eexists; eauto. }
  Qed.

End fubini_tonelli_lr.

Section fubini_tonelli_rl.
  Context {A B: Type}.
  Context {F1: measurable_space A} {F2: measurable_space B}.
  Context (μ: measure A) (ν: measure B).

  Lemma tonelli_rl_measurable (f: A * B → R):
    measurable f →
    measurable (λ y : B, Integral μ (λ x, f (x, y))).
  Proof.
    intros Hmeas. eapply (measurable_ext _ (λ y : B, Integral μ (λ x, f (swap (y, x))))).
    { rewrite //=. }
    apply (tonelli_lr_measurable _ (λ x, f (swap x))).
    eapply (measurable_comp); eauto.
    apply swap_measurable.
  Qed.

  Lemma ex_integral_swap (f: A * B → R) :
    ex_integral (product_measure μ ν) f →
    ex_integral (product_measure ν μ) (λ x : B * A, f (swap x)).
  Proof.
    eapply ex_integral_iso; first apply swap_is_pt_iso.
  Qed.

  Lemma fubini_rl_integral_ae (f: A * B → R):
    ex_integral (product_measure μ ν) f →
    almost_everywhere_meas ν (λ y, ex_integral μ (λ x, f (x, y))).
  Proof.
    intros Hex.
    feed pose proof (fubini_lr_integral_ae ν μ (λ x, f (swap x))).
    { by apply ex_integral_swap. }
    eapply almost_everywhere_meas_ext; eauto.
    intros x. rewrite /swap//=.
  Qed.

  Lemma fubini_rl_integral (f: A * B → R):
    ex_integral (product_measure μ ν) f →
    is_integral ν (λ y, Integral μ (λ x, f (x, y)))
                (Integral ((product_measure μ ν)) f).
  Proof.
    intros Hex. eapply (is_integral_ext _ (λ y, Integral μ (λ x, f (swap (y, x))))).
    { rewrite //=. }
    feed pose proof (fubini_lr_integral ν μ (λ x, f (swap x))) as Hfub.
    { by eapply ex_integral_swap. }
    rewrite (Integral_iso swap _ (product_measure μ ν)) in Hfub; eauto.
    { apply swap_is_pt_iso. }
  Qed.

  Lemma tonelli_rl_integral (f: A * B → R):
    (∀ x, 0 <= f x) →
    measurable f →
    almost_everywhere_meas ν (λ y, ex_integral μ (λ x, f (x, y))) →
    ex_integral ν (λ y, Integral μ (λ x, f (x, y))) →
    ex_integral (product_measure μ ν) f.
  Proof.
    intros.
    eapply (ex_integral_iso _ ((product_measure ν μ))).
    { apply swap_is_pt_iso. }
    eapply (tonelli_lr_integral ν μ); eauto.
    eapply measurable_comp; eauto.
    eapply (iso_measurable (product_measure ν μ)); eapply swap_is_pt_iso.
  Qed.

End fubini_tonelli_rl.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    Proof of Huffman algorithm: Cover.v

    Definition of a cover for a tree and some properties

    Definitions: cover
                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Export BTree.
From Huffman Require Export Permutation.
Require Import ArithRing.

Section Cover.
Variable A : Type.
Variable eqA_dec : forall a b : A, {a = b} + {a <> b}.
Variable empty : A.

(*
  A list of trees is a cover of a tree if all the trees in the
  list delimit a frontier in the tree
*)
Inductive cover : list (btree A) -> btree A -> Prop :=
  | cover_one : forall t, cover (t :: nil) t
  | cover_node :
      forall l1 l2 t1 t2 t3,
      permutation l1 (t1 :: t2 :: l2) ->
      cover (node t1 t2 :: l2) t3 -> cover l1 t3.
Hint Constructors cover : core.

(* Covers are compatible with permutation *)
Theorem cover_permutation :
 forall t l1 l2, cover l1 t -> permutation l1 l2 -> cover l2 t.
Proof using.
intros t l1 l2 H; generalize l2; elim H; clear H t l1 l2; auto.
intros t l2 H; rewrite (permutation_one_inv _ _ _ H); auto.
intros l1 l2 t1 t2 t3 H H0 H1 l0 H2.
apply cover_node with (2 := H0).
apply permutation_trans with (2 := H).
apply permutation_sym; auto.
Qed.

(* A trivial way to cover a node *)
Theorem cover_cons_l :
 forall t1 t2 l1, cover l1 t1 -> cover (t2 :: l1) (node t2 t1).
intros t1 t2 l1 H; elim H; clear t1 l1 H; simpl in |- *; auto.
intros t; apply cover_node with (l2 := nil (A:=btree A)) (t1 := t2) (t2 := t);
 auto.
intros l1 l2 t1 t0 t3 H H0 H1.
apply cover_node with (l2 := t2 :: l2) (t1 := t1) (t2 := t0); auto.
apply permutation_trans with (t2 :: t1 :: t0 :: l2); auto.
apply permutation_trans with (t1 :: t2 :: t0 :: l2); auto.
apply cover_permutation with (1 := H1); auto.
Qed.

(* A cover cannot be empty *)
Theorem cover_not_nil : forall l t, cover l t -> l <> nil.
Proof using.
intros l t H; case H; simpl in |- *; auto.
intros t0; discriminate.
intros l1 l2 t1 t2 t3 H0 H1; red in |- *; intros H2;
 absurd (length l1 = length (t1 :: t2 :: l2)); auto.
rewrite H2; simpl in |- *; intros; discriminate.
apply permutation_length with (1 := H0); auto.
Qed.

(* A non empty list is a cover of something *)
Theorem one_cover_ex :
 forall l : list (btree A), l <> nil -> exists t : btree A, cover l t.
Proof using.
intros l; elim l; simpl in |- *; auto.
intros H; case H; auto.
intros a l0; case l0; auto.
intros H H0; exists a; auto.
intros b l1 H H0; case H.
red in |- *; intros; discriminate.
intros x H1; exists (node a x).
apply cover_cons_l; auto.
Qed.

(* Subtrees of the cover are subtrees of the tree *)
Theorem cover_in_inb_inb :
 forall l t1 t2 t3, cover l t1 -> In t2 l -> inb t3 t2 -> inb t3 t1.
Proof using.
intros l t1 t2 t3 H; generalize t2 t3; elim H; clear H l t1 t2 t3;
 auto with datatypes.
simpl in |- *; intros t t2 t3 [H1| H1]; auto.
rewrite H1; auto.
case H1.
intros l1 l2 t1 t2 t3 H H0 H1 t0 t4 H2 H3.
cut (In t0 (t1 :: t2 :: l2)); auto.
simpl in |- *; intros [H4| [H4| H4]]; auto with datatypes.
apply (H1 (node t1 t2)); simpl in |- *; auto.
rewrite H4; auto.
apply (H1 (node t1 t2)); simpl in |- *; auto.
rewrite H4; auto.
apply (H1 t0); simpl in |- *; auto.
apply permutation_in with (1 := H); simpl in |- *; auto.
Qed.

(* Trees of the cover are subtrees of the tree *)
Theorem cover_in_inb : forall l t1 t2, cover l t1 -> In t2 l -> inb t2 t1.
Proof using.
intros l t1 t2 H H0; apply cover_in_inb_inb with (1 := H) (2 := H0); auto.
Qed.

Let cover_inv_leaf_aux :
  forall t l, cover l t -> forall a : A, t = leaf a -> l = leaf a :: nil.
Proof using.
intros t l H; elim H; simpl in |- *; auto.
intros t0 a H0; apply f_equal2 with (f := cons (A:=btree A)); auto.
intros.
generalize (H2 a H3); intros; discriminate.
Qed.

(* Covers of a leaf are singleton lists *)
Theorem cover_inv_leaf :
 forall (a : A) l, cover l (leaf a) -> l = leaf a :: nil.
Proof using.
intros a l H; (apply cover_inv_leaf_aux with (t := leaf a); auto).
Qed.

(* Singleton cover are composed of the tree *)
Theorem cover_one_inv : forall t1 t2, cover (t1 :: nil) t2 -> t1 = t2.
Proof using.
intros t1 t2 H; inversion H; auto.
absurd (length (t1 :: nil) = length (t0 :: t3 :: l2)).
simpl in |- *; intros; discriminate.
apply permutation_length with (1 := H0); auto.
Qed.

Lemma cover_inv_app_aux :
  forall t t1 t2 l,
  cover l t ->
  t = node t1 t2 ->
  l = node t1 t2 :: nil \/
  (exists l1 : _,
     (exists l2 : _, (cover l1 t1 /\ cover l2 t2) /\ permutation l (l1 ++ l2))).
Proof using.
intros t t1 t2 l H; elim H.
intros t0 Ht0; rewrite Ht0; auto with datatypes.
intros l1 l2 t0 t3 t4 H0 H1 H2 H3; right.
case H2; auto.
intros H4.
exists (t1 :: nil); exists (t2 :: nil); simpl in |- *; repeat (split; auto).
injection H4; intros H5 H6 H7; rewrite <- H5; rewrite <- H6; rewrite <- H7;
 auto.
clear H2 H3; intros (l3, (l4, ((Hl1, Hl2), Hl3))).
case (in_app_or l3 l4 (node t0 t3)).
apply permutation_in with (1 := Hl3); auto with datatypes.
intros H2; case in_ex_app with (1 := H2).
intros l5 (l6, Hl5).
exists (t0 :: t3 :: l5 ++ l6); exists l4; repeat (split; auto).
apply cover_node with (l2 := l5 ++ l6) (t1 := t0) (t2 := t3); auto.
apply cover_permutation with (1 := Hl1).
rewrite Hl5.
apply permutation_trans with (node t0 t3 :: l6 ++ l5); auto.
apply (permutation_app_swap _ l5 (node t0 t3 :: l6)).
apply permutation_trans with (1 := H0).
simpl in |- *; repeat apply permutation_skip.
apply permutation_inv with (a := node t0 t3).
apply permutation_trans with (1 := Hl3).
rewrite Hl5; auto.
change
  (permutation ((l5 ++ node t0 t3 :: l6) ++ l4)
     ((node t0 t3 :: l5 ++ l6) ++ l4)) in |- *.
apply permutation_app_comp; auto.
apply permutation_trans with ((node t0 t3 :: l6) ++ l5); auto.
simpl in |- *; auto.
intros H2; case in_ex_app with (1 := H2).
intros l5 (l6, Hl5).
exists l3; exists (t0 :: t3 :: l5 ++ l6); repeat (split; auto).
apply cover_node with (l2 := l5 ++ l6) (t1 := t0) (t2 := t3); auto.
apply cover_permutation with (1 := Hl2).
rewrite Hl5.
apply permutation_trans with (node t0 t3 :: l6 ++ l5); auto.
apply (permutation_app_swap _ l5 (node t0 t3 :: l6)).
apply permutation_trans with (1 := H0).
apply permutation_trans with ((t0 :: t3 :: l5 ++ l6) ++ l3); auto.
simpl in |- *; repeat apply permutation_skip.
apply permutation_inv with (a := node t0 t3).
apply permutation_trans with (1 := Hl3).
rewrite Hl5.
apply permutation_trans with ((l5 ++ node t0 t3 :: l6) ++ l3); auto.
change
  (permutation ((l5 ++ node t0 t3 :: l6) ++ l3)
     ((node t0 t3 :: l5 ++ l6) ++ l3)) in |- *; auto.
apply permutation_app_comp; auto.
apply permutation_trans with ((node t0 t3 :: l6) ++ l5); auto.
simpl in |- *; auto.
Qed.

(* A cover on a node can be splitted in two *)
Theorem cover_inv_app :
 forall t1 t2 l,
 cover l (node t1 t2) ->
 l = node t1 t2 :: nil \/
 (exists l1 : _,
    (exists l2 : _, (cover l1 t1 /\ cover l2 t2) /\ permutation l (l1 ++ l2))).
Proof using.
intros t1 t2 l H; apply cover_inv_app_aux with (t := node t1 t2); auto.
Qed.

(* Covers of the direct subtrees generate a cover of the whole tree *)
Theorem cover_app :
 forall t1 t2 l1 l2,
 cover l1 t1 -> cover l2 t2 -> cover (l1 ++ l2) (node t1 t2).
Proof using.
intros t1 t2 l1 l2 H1; generalize t2 l2; elim H1; clear t1 t2 l1 l2 H1;
 simpl in |- *; auto.
intros t t2 l2 H; apply cover_cons_l; auto.
intros l1 l2 t1 t2 t3 H H0 H1 t0 l0 H2.
apply cover_node with (l2 := l2 ++ l0) (t1 := t1) (t2 := t2); auto.
apply permutation_trans with ((t1 :: t2 :: l2) ++ l0); auto.
Qed.

(* A cover gives a direct account of the number of the tree *)
Theorem cover_number_of_nodes :
 forall t l,
 cover l t ->
 number_of_nodes t =
 fold_left (fun x y => x + number_of_nodes y) l 0 + pred (length l).
Proof using.
intros t l H; elim H; clear H t l; simpl in |- *; auto.
intros l1 l2 t1 t2 t3 H H0 H1.
apply trans_equal with (1 := H1).
rewrite fold_left_permutation with (2 := H); simpl in |- *; auto.
rewrite permutation_length with (1 := H); simpl in |- *; auto.
rewrite fold_left_init with (h := S); simpl in |- *; auto.
intros a b1 b2; repeat rewrite plus_assoc_reverse.
apply f_equal2 with (f := plus); auto; apply plus_comm.
Qed.

(* A local function to compute all covers of a certain length *)
Fixpoint all_cover_aux (l : list (btree A)) (n : nat) {struct n} : list (btree A) :=
  match n with
  | O => nil
  | S n1 =>
      flat_map
        (fun l1 =>
         match l1 with
         | nil => nil
         | a :: nil => a :: nil
         | a :: b :: l2 => all_cover_aux (node a b :: l2) n1
         end) (all_permutations l)
  end.

(* A function to compute all covers *)
Definition all_cover l := all_cover_aux l (length l).

(* The local function generates covers of a given length *)
Theorem all_cover_aux_cover :
 forall (n : nat) l t, n = length l -> In t (all_cover_aux l n) -> cover l t.
Proof using.
intros n; elim n; simpl in |- *; auto.
intros l t H H0; elim H0.
intros n0 H l t H0 H1.
case in_flat_map_ex with (1 := H1); clear H1.
intros x; case x; clear x.
simpl in |- *; intros (H1, H2); case H2.
intros b x; case x; clear x.
simpl in |- *; intros (H1, [H2| H2]).
rewrite <- H2.
rewrite permutation_one_inv with (a := b) (l := l); auto.
apply all_permutations_permutation; auto.
case H2.
intros b1 l1 (H1, H2).
apply cover_node with (l2 := l1) (t1 := b) (t2 := b1); auto.
apply permutation_sym; apply all_permutations_permutation; auto.
apply H; auto.
apply eq_add_S; apply trans_equal with (1 := H0).
apply trans_equal with (length (b :: b1 :: l1)); auto.
apply permutation_length.
apply permutation_sym; apply all_permutations_permutation; auto.
Qed.

(* The list of all covers contain only covers *)
Theorem all_cover_cover : forall l t, In t (all_cover l) -> cover l t.
Proof using.
intros l t H; apply all_cover_aux_cover with (n := length l); auto.
Qed.

(* A cover of a given length is in the local list *)
Theorem cover_all_cover_aux :
 forall (n : nat) l t, n = length l -> cover l t -> In t (all_cover_aux l n).
intros n; elim n; simpl in |- *; auto.
intros l; case l; simpl in |- *; auto.
intros t H H0; inversion H0.
generalize (permutation_nil_inv _ _ (permutation_sym _ _ _ H1)); intros;
 discriminate.
intros; discriminate.
intros n0 H l t H0 H1; inversion H1.
simpl in |- *; auto.
apply in_flat_map with (t1 :: t2 :: l2); auto.
apply H; auto.
apply eq_add_S; apply trans_equal with (1 := H0).
apply trans_equal with (length (t1 :: t2 :: l2)); auto.
apply permutation_length; auto.
apply permutation_all_permutations; auto.
apply permutation_sym; auto.
Qed.

(* A cover is in the list of all covers *)
Theorem cover_all_cover : forall l t, cover l t -> In t (all_cover l).
Proof using.
intros l t H; unfold all_cover in |- *; apply cover_all_cover_aux; auto.
Qed.

(* Covers are decidable *)
Definition cover_dec :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l t, {cover l t} + {~ cover l t}.
intros H l t; case (In_dec (btree_dec _ H) t (all_cover l)).
intros H1; left; apply all_cover_cover; auto.
intros H1; right; Contradict H1; apply cover_all_cover; auto.
Defined.

(* All the leaves of the tree gives a cover to the tree. *)
Theorem cover_all_leaves :
 forall t : btree A, cover (map (fun x : A => leaf x) (all_leaves t)) t.
Proof using.
intros t; elim t; simpl in |- *; auto.
intros b H b0 H0; rewrite map_app.
apply cover_app; auto.
Qed.

End Cover.
Arguments cover [A].
Hint Constructors cover : core.