Require Import Reals.

Theorem IRsubset :
 forall yl yu zl zu : R,
 (zl <= yl)%R -> (yu <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= y <= zu)%R.
Proof.
intros yl yu zl zu Hzl Hzu y (Hyl,Hyu).
split.
apply Rle_trans with (1 := Hzl) (2 := Hyl).
apply Rle_trans with (1 := Hyu) (2 := Hzu).
Qed.

Theorem IRplus :
 forall xl xu yl yu zl zu : R,
 (zl <= xl + yl)%R -> (xu + yu <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x + y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rplus_le_compat with (1 := Hxl) (2 := Hyl).
apply Rplus_le_compat with (1 := Hxu) (2 := Hyu).
Qed.

Theorem IRopp :
 forall yl yu zl zu : R,
 (zl <= -yu)%R -> (-yl <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= -y <= zu)%R.
Proof.
intros yl yu zl zu Hzl Hzu y (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Ropp_le_contravar with (1 := Hyu).
apply Ropp_le_contravar with (1 := Hyl).
Qed.

Theorem IRminus :
 forall xl xu yl yu zl zu : R,
 (zl <= xl - yu)%R -> (xu - yl <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x - y <= zu)%R.
Proof.
unfold Rminus.
intros xl xu yl yu zl zu Hzl Hzu x y Hx Hy.
apply IRplus with (1 := Hzl) (2 := Hzu) (3 := Hx).
apply IRopp with (3 := Hy) ; auto with real.
Qed.

Lemma monotony_1p :
 forall a x y : R, (0 <= a)%R -> (x <= y)%R -> (a * x <= a * y)%R.
Proof.
auto with real.
Qed.

Lemma monotony_2p :
 forall a x y : R, (0 <= a)%R -> (x <= y)%R -> (x * a <= y * a)%R.
Proof.
auto with real.
Qed.

Lemma monotony_1n :
 forall a x y : R, (a <= 0)%R -> (x <= y)%R -> (a * y <= a * x)%R.
Proof.
auto with real.
Qed.

Lemma monotony_2n :
 forall a x y : R, (a <= 0)%R -> (x <= y)%R -> (y * a <= x * a)%R.
Proof.
intros a x y Ha H.
rewrite Rmult_comm. rewrite (Rmult_comm x).
apply Rge_le.
auto with real.
Qed.

Theorem IRmult_pp :
 forall xl xu yl yu zl zu : R,
 (0 <= xl)%R -> (0 <= yl)%R ->
 (zl <= xl * yl)%R -> (xu * yu <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (xl * y)%R.
exact (monotony_1p _ _ _ Hx Hyl).
exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxl).
apply Rle_trans with (x * yu)%R.
exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyu).
exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy (Rle_trans _ _ _ Hyl Hyu)) Hxu).
Qed.

Theorem IRmult_po :
 forall xl xu yl yu zl zu : R,
 (0 <= xl)%R -> (yl <= 0)%R -> (0 <= yu)%R ->
 (zl <= xu * yl)%R -> (xu * yu <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy1 Hy2 Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (x * yl)%R.
exact (monotony_2n _ _ _ Hy1 Hxu).
exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyl).
apply Rle_trans with (x * yu)%R.
exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyu).
exact (monotony_2p _ _ _ Hy2 Hxu).
Qed.

Theorem IRmult_pn :
 forall xl xu yl yu zl zu : R,
 (0 <= xl)%R -> (yu <= 0)%R ->
 (zl <= xu * yl)%R -> (xl * yu <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (xu * y)%R.
exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx (Rle_trans _ _ _ Hxl Hxu)) Hyl).
exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxu).
apply Rle_trans with (x * yu)%R.
exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyu).
exact (monotony_2n _ _ _ Hy Hxl).
Qed.

Theorem IRmult_op :
 forall xl xu yl yu zl zu : R,
 (xl <= 0)%R -> (0 <= xu)%R -> (0 <= yl)%R ->
 (zl <= xl * yu)%R -> (xu * yu <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx1 Hx2 Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (xl * y)%R.
exact (monotony_1n _ _ _ Hx1 Hyu).
exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxl).
apply Rle_trans with (xu * y)%R.
exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxu).
exact (monotony_1p _ _ _ Hx2 Hyu).
Qed.

Theorem IRmult_oo :
 forall xl xu yl yu zl zu : R,
 (xl <= 0)%R -> (0 <= xu)%R -> (yl <= 0)%R -> (0 <= yu)%R ->
 (zl <= xu * yl)%R -> (zl <= xl * yu)%R ->
 (xl * yl <= zu)%R -> (xu * yu <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx1 Hx2 Hy1 Hy2 Hzl1 Hzl2 Hzu1 Hzu2 x y (Hxl,Hxu) (Hyl,Hyu).
case (Rlt_le_dec 0 x) ; intro H.
generalize (Rlt_le _ _ H). clear H. intro H.
split.
apply Rle_trans with (1 := Hzl1).
apply Rle_trans with (x * yl)%R.
exact (monotony_2n _ _ _ Hy1 Hxu).
exact (monotony_1p _ _ _ H Hyl).
apply Rle_trans with (2 := Hzu2).
apply Rle_trans with (x * yu)%R.
exact (monotony_1p _ _ _ H Hyu).
exact (monotony_2p _ _ _ Hy2 Hxu).
split.
apply Rle_trans with (1 := Hzl2).
apply Rle_trans with (x * yu)%R.
exact (monotony_2p _ _ _ Hy2 Hxl).
exact (monotony_1n _ _ _ H Hyu).
apply Rle_trans with (2 := Hzu1).
apply Rle_trans with (x * yl)%R.
exact (monotony_1n _ _ _ H Hyl).
exact (monotony_2n _ _ _ Hy1 Hxl).
Qed.

Theorem IRmult_on :
 forall xl xu yl yu zl zu : R,
 (xl <= 0)%R -> (0 <= xu)%R -> (yu <= 0)%R ->
 (zl <= xu * yl)%R -> (xl * yl <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx1 Hx2 Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (xu * y)%R.
exact (monotony_1p _ _ _ Hx2 Hyl).
exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxu).
apply Rle_trans with (xl * y)%R.
exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxl).
exact (monotony_1n _ _ _ Hx1 Hyl).
Qed.

Theorem IRmult_np :
 forall xl xu yl yu zl zu : R,
 (xu <= 0)%R -> (0 <= yl)%R ->
 (zl <= xl * yu)%R -> (xu * yl <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (x * yu)%R.
exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy (Rle_trans _ _ _ Hyl Hyu)) Hxl).
exact (monotony_1n _ _ _ (Rle_trans _ _ _ Hxu Hx) Hyu).
apply Rle_trans with (xu * y)%R.
exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxu).
exact (monotony_1n _ _ _ Hx Hyl).
Qed.

Theorem IRmult_no :
 forall xl xu yl yu zl zu : R,
 (xu <= 0)%R -> (yl <= 0)%R -> (0 <= yu)%R ->
 (zl <= xl * yu)%R -> (xl * yl <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy1 Hy2 Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (x * yu)%R.
exact (monotony_2p _ _ _ Hy2 Hxl).
exact (monotony_1n _ _ _ (Rle_trans _ _ _ Hxu Hx) Hyu).
apply Rle_trans with (x * yl)%R.
exact (monotony_1n _ _ _ (Rle_trans _ _ _ Hxu Hx) Hyl).
exact (monotony_2n _ _ _ Hy1 Hxl).
Qed.

Theorem IRmult_nn :
 forall xl xu yl yu zl zu : R,
 (xu <= 0)%R -> (yu <= 0)%R ->
 (zl <= xu * yu)%R -> (xl * yl <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_trans with (xu * y)%R.
exact (monotony_1n _ _ _ Hx Hyu).
exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxu).
apply Rle_trans with (xl * y)%R.
exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxl).
exact (monotony_1n _ _ _ (Rle_trans _ _ _ (Rle_trans _ _ _ Hxl Hxu) Hx) Hyl).
Qed.

Inductive interval_sign (xl xu : R) : Set :=
  | Nsign : (xu <= 0)%R -> interval_sign xl xu
  | Msign : (xl <= 0)%R -> (0 <= xu)%R -> interval_sign xl xu
  | Psign : (0 <= xl)%R -> interval_sign xl xu.

Lemma interval_sign_correct :
 forall xl xu : R, (xl <= xu)%R -> interval_sign xl xu.
Proof.
intros xl xu H.
case (Rlt_le_dec xu 0); intro H0.
exact (Nsign _ _ (Rlt_le _ _ H0)).
case (Rlt_le_dec xl 0); intro H1.
exact (Msign _ _ (Rlt_le _ _ H1) H0).
exact (Psign _ _ H1).
Qed.

Lemma Rmin_trans :
 forall a b c : R, (c <= Rmin a b)%R -> (c <= a)%R /\ (c <= b)%R.
Proof.
intros a b c H.
split.
exact (Rle_trans _ _ _ H (Rmin_l _ _)).
exact (Rle_trans _ _ _ H (Rmin_r _ _)).
Qed.

Lemma Rmax_trans :
 forall a b c : R, (Rmax a b <= c)%R -> (a <= c)%R /\ (b <= c)%R.
Proof.
intros a b c H.
split.
exact (Rle_trans _ _ _ (RmaxLess1 _ _) H).
exact (Rle_trans _ _ _ (RmaxLess2 _ _) H).
Qed.

Lemma IRmult_minmax :
 forall xl xu yl yu zl zu : R,
 (zl <= Rmin (Rmin (xl * yl) (xl * yu)) (Rmin (xu * yl) (xu * yu)))%R ->
 (Rmax (Rmax (xl * yl) (xl * yu)) (Rmax (xu * yl) (xu * yu)) <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hzl Hzu x y Hx Hy.
decompose [and] (Rmin_trans _ _ _ Hzl).
decompose [and] (Rmin_trans _ _ _ H).
decompose [and] (Rmin_trans _ _ _ H0).
clear Hzl H H0.
decompose [and] (Rmax_trans _ _ _ Hzu).
decompose [and] (Rmax_trans _ _ _ H).
decompose [and] (Rmax_trans _ _ _ H0).
clear Hzu H H0.
case (interval_sign_correct _ _ (Rle_trans _ _ _ (proj1 Hx) (proj2 Hx))) ;
case (interval_sign_correct _ _ (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy))) ; intros.
apply IRmult_nn with xl xu yl yu ; assumption.
apply IRmult_no with xl xu yl yu ; assumption.
apply IRmult_np with xl xu yl yu ; assumption.
apply IRmult_on with xl xu yl yu ; assumption.
apply IRmult_oo with xl xu yl yu ; assumption.
apply IRmult_op with xl xu yl yu ; assumption.
apply IRmult_pn with xl xu yl yu ; assumption.
apply IRmult_po with xl xu yl yu ; assumption.
apply IRmult_pp with xl xu yl yu ; assumption.
Qed.

Lemma Rle_Rinv_pos :
 forall x y : R,
 (0 < x)%R -> (x <= y)%R ->
 (/y <= /x)%R.
Proof.
intros x y Hx H.
apply Rle_Rinv with (1 := Hx) (3 := H).
apply Rlt_le_trans with (1 := Hx) (2 := H).
Qed.

Lemma Rle_Rinv_neg :
 forall x y : R,
 (y < 0)%R -> (x <= y)%R ->
 (/y <= /x)%R.
Proof.
intros x y Hy H.
apply Ropp_le_cancel.
repeat rewrite Ropp_inv_permute.
apply Rle_Rinv_pos.
apply Ropp_0_gt_lt_contravar with (1 := Hy).
apply Ropp_le_contravar with (1 := H).
exact (Rlt_not_eq _ _ Hy).
exact (Rlt_not_eq _ _ (Rle_lt_trans _ _ _ H Hy)).
Qed.

Lemma IRinv_p :
 forall yl yu zl zu : R,
 (0 < yl)%R ->
 (zl <= /yu)%R -> (/yl <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= /y <= zu)%R.
Proof.
intros yl yu zl zu Hy Hzl Hzu y (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
apply Rle_Rinv_pos with (2 := Hyu).
exact (Rlt_le_trans _ _ _ Hy Hyl).
exact (Rle_Rinv_pos _ _ Hy Hyl).
Qed.

Lemma IRinv_n :
 forall yl yu zl zu,
 (yu < 0)%R ->
 (zl <= /yu)%R -> (/yl <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= /y <= zu)%R.
Proof.
intros yl yu zl zu Hy Hzl Hzu y (Hyl,Hyu).
apply IRsubset with (1 := Hzl) (2 := Hzu).
split.
exact (Rle_Rinv_neg _ _ Hy Hyu).
apply Rle_Rinv_neg with (2 := Hyl).
exact (Rle_lt_trans _ _ _ Hyu Hy).
Qed.

Lemma IRinv_disj :
 forall yl yu zl zu : R,
 (yu < 0)%R \/ (0 < yl)%R ->
 (zl <= /yu)%R -> (/yl <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= /y <= zu)%R.
Proof.
intros yl yu zl zu [Hy2|Hy1] Hzl Hzu y Hy.
exact (IRinv_n _ _ _ _ Hy2 Hzl Hzu _ Hy).
exact (IRinv_p _ _ _ _ Hy1 Hzl Hzu _ Hy).
Qed.

Lemma IRdiv_minmax :
 forall xl xu yl yu zl zu : R,
 (yu < 0)%R \/ (yl > 0)%R ->
 (zl <= Rmin (Rmin (xl / yu) (xl / yl)) (Rmin (xu / yu) (xu / yl)))%R ->
 (Rmax (Rmax (xl / yu) (xl / yl)) (Rmax (xu / yu) (xu / yl)) <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x / y <= zu)%R.
Proof.
unfold Rdiv.
intros xl xu yl yu zl zu H Hzl Hzu x y Hx Hy.
apply (IRmult_minmax _ _ (/yu) (/yl) _ _ Hzl Hzu _ (/y) Hx).
apply (IRinv_disj _ _ (/yu) (/yl) H) with (3 := Hy) ; auto with real.
Qed.

Lemma IRdiv_aux_p :
 forall yl yu y : R,
 (0 < yl)%R -> (yl <= y <= yu)%R ->
 (0 <= / yl)%R /\ (0 <= / yu)%R /\ (yl <> 0)%R /\ (yu <> 0)%R /\ (/ yu <= /y <= / yl)%R.
Proof.
intros yl yu y Hyl Hy.
split. left.
apply Rinv_0_lt_compat.
exact Hyl.
split. left.
apply Rinv_0_lt_compat.
exact (Rlt_le_trans _ _ _ Hyl (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy))).
split.
apply Rgt_not_eq.
exact Hyl.
split.
apply Rgt_not_eq.
exact (Rlt_le_trans _ _ _ Hyl (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy))).
split.
exact (Rle_Rinv_pos _ _ (Rlt_le_trans _ _ _ Hyl (proj1 Hy)) (proj2 Hy)).
exact (Rle_Rinv_pos _ _ Hyl (proj1 Hy)).
Qed.

Theorem IRdiv_pp :
 forall xl xu yl yu zl zu : R,
 (0 <= xl)%R ->
 (0 < yl)%R ->
 (yu * zl <= xl)%R ->
 (xu <= yl * zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x / y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hxl Hyl Hzl Hzu x y Hx Hy.
generalize (IRdiv_aux_p _ _ _ Hyl Hy).
intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))).
unfold Rdiv.
apply IRmult_pp with (1 := Hxl) (2 := Hy2) (5 := Hx) (6 := Hy5).
replace zl with (yu * zl * / yu)%R.
exact (monotony_2p _ _ _ Hy2 Hzl).
field. exact Hy4.
replace zu with (yl * zu * / yl)%R.
exact (monotony_2p _ _ _ Hy1 Hzu).
field. exact Hy3.
Qed.

Theorem IRdiv_op :
 forall xl xu yl yu zl zu : R,
 (xl <= 0)%R ->
 (0 <= xu)%R ->
 (0 < yl)%R ->
 (yl * zl <= xl)%R ->
 (xu <= yl * zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x / y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hxl Hxu Hyl Hzl Hzu x y Hx Hy.
generalize (IRdiv_aux_p _ _ _ Hyl Hy).
intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))).
unfold Rdiv.
apply IRmult_op with (1 := Hxl) (2 := Hxu) (3 := Hy2) (6 := Hx) (7 := Hy5).
replace zl with (yl * zl * / yl)%R.
exact (monotony_2p _ _ _ Hy1 Hzl).
field. exact Hy3.
replace zu with (yl * zu * / yl)%R.
exact (monotony_2p _ _ _ Hy1 Hzu).
field. exact Hy3.
Qed.

Theorem IRdiv_np :
 forall xl xu yl yu zl zu : R,
 (xu <= 0)%R ->
 (0 < yl)%R ->
 (yl * zl <= xl)%R ->
 (xu <= yu * zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x / y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hxu Hyl Hzl Hzu x y Hx Hy.
generalize (IRdiv_aux_p _ _ _ Hyl Hy).
intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))).
unfold Rdiv.
apply IRmult_np with (1 := Hxu) (2 := Hy2) (5 := Hx) (6 := Hy5).
replace zl with (yl * zl * / yl)%R.
exact (monotony_2p _ _ _ Hy1 Hzl).
field. exact Hy3.
replace zu with (yu * zu * / yu)%R.
exact (monotony_2p _ _ _ Hy2 Hzu).
field. exact Hy4.
Qed.

Lemma IRdiv_aux_n :
 forall yl yu y : R,
 (yu < 0)%R -> (yl <= y <= yu)%R ->
 (/ yl <= 0)%R /\ (/ yu <= 0)%R /\ (yl <> 0)%R /\ (yu <> 0)%R /\ (/ yu <= /y <= / yl)%R.
Proof.
intros yl yu y Hyu Hy.
split. left.
apply Rinv_lt_0_compat.
exact (Rle_lt_trans _ _ _ (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy)) Hyu).
split. left.
apply Rinv_lt_0_compat.
exact Hyu.
split.
apply Rlt_not_eq.
exact (Rle_lt_trans _ _ _ (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy)) Hyu).
split.
apply Rlt_not_eq.
exact Hyu.
split.
exact (Rle_Rinv_neg _ _ Hyu (proj2 Hy)).
exact (Rle_Rinv_neg _ _ (Rle_lt_trans _ _ _ (proj2 Hy) Hyu) (proj1 Hy)).
Qed.

Theorem IRdiv_pn :
 forall xl xu yl yu zl zu : R,
 (0 <= xl)%R ->
 (yu < 0)%R ->
 (xu <= yu * zl)%R ->
 (yl * zu <= xl)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x / y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hxl Hyu Hzl Hzu x y Hx Hy.
generalize (IRdiv_aux_n _ _ _ Hyu Hy).
intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))).
unfold Rdiv.
apply IRmult_pn with (1 := Hxl) (2 := Hy1) (5 := Hx) (6 := Hy5).
replace zl with (yu * zl * / yu)%R.
exact (monotony_2n _ _ _ Hy2 Hzl).
field. exact Hy4.
replace zu with (yl * zu * / yl)%R.
exact (monotony_2n _ _ _ Hy1 Hzu).
field. exact Hy3.
Qed.

Theorem IRdiv_on :
 forall xl xu yl yu zl zu : R,
 (xl <= 0)%R ->
 (0 <= xu)%R ->
 (yu < 0)%R ->
 (xu <= yu * zl)%R ->
 (yu * zu <= xl)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x / y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hxl Hxu Hyu Hzl Hzu x y Hx Hy.
generalize (IRdiv_aux_n _ _ _ Hyu Hy).
intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))).
unfold Rdiv.
apply IRmult_on with (1 := Hxl) (2 := Hxu) (3 := Hy1) (6 := Hx) (7 := Hy5).
replace zl with (yu * zl * / yu)%R.
exact (monotony_2n _ _ _ Hy2 Hzl).
field. exact Hy4.
replace zu with (yu * zu * / yu)%R.
exact (monotony_2n _ _ _ Hy2 Hzu).
field. exact Hy4.
Qed.

Theorem IRdiv_nn :
 forall xl xu yl yu zl zu : R,
 (xu <= 0)%R ->
 (yu < 0)%R ->
 (xu <= yl * zl)%R ->
 (yu * zu <= xl)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x / y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hxu Hyu Hzl Hzu x y Hx Hy.
generalize (IRdiv_aux_n _ _ _ Hyu Hy).
intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))).
unfold Rdiv.
apply IRmult_nn with (1 := Hxu) (2 := Hy1) (5 := Hx) (6 := Hy5).
replace zl with (yl * zl * / yl)%R.
exact (monotony_2n _ _ _ Hy1 Hzl).
field. exact Hy3.
replace zu with (yu * zu * / yu)%R.
exact (monotony_2n _ _ _ Hy2 Hzu).
field. exact Hy4.
Qed.

Theorem IRsquare_o :
 forall yl yu zl zu : R,
 (yl <= 0)%R -> (0 <= yu)%R -> (zl <= 0)%R ->
 (yl * yl <= zu)%R -> (yu * yu <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= y * y <= zu)%R.
Proof.
intros yl yu zl zu Hy1 Hy2 Hzl Hzu1 Hzu2 y (Hyl,Hyu).
split.
fold (Rsqr y).
apply Rle_trans with 0%R ; auto with real.
case (Rlt_le_dec 0 y) ; intro H.
generalize (Rlt_le _ _ H). clear H. intro H.
apply Rle_trans with (yu * yu)%R ; auto with real.
apply Rle_trans with (2 := Hzu1).
apply Rle_trans with (y * yl)%R.
exact (monotony_1n _ _ _ H Hyl).
exact (monotony_2n _ _ _ Hy1 Hyl).
Qed.

Theorem IRsqrt :
 forall yl yu zl zu : R,
 match (Rlt_le_dec 0 zl) with
 | left _ => (zl * zl <= yl)%R
 | right _ => (0 <= yl)%R
 end -> (0 <= zu)%R -> (yu <= zu * zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= sqrt y <= zu)%R.
Proof.
intros yl yu zl zu.
case (Rlt_le_dec 0 zl) ; intros Hzl1 Hzl2 Hzu1 Hzu2 y (Hyl,Hyu).
assert (H1: (zl * zl <= y)%R).
apply Rle_trans with (1 := Hzl2) (2 := Hyl).
assert (H2: (0 <= y)%R).
apply Rle_trans with (2 := H1).
exact (Rle_0_sqr _).
split.
rewrite <- (sqrt_square zl).
apply sqrt_le_1. 3: exact H1.
exact (Rle_0_sqr _).
exact H2.
exact (Rlt_le _ _ Hzl1).
rewrite <- (sqrt_square zu). 2: exact Hzu1.
apply sqrt_le_1.
exact H2.
exact (Rle_0_sqr _).
apply Rle_trans with (1 := Hyu) (2 := Hzu2).
split.
apply Rle_trans with (1 := Hzl1).
apply sqrt_positivity.
apply Rle_trans with (1 := Hzl2) (2 := Hyl).
rewrite <- (sqrt_square zu). 2: exact Hzu1.
apply sqrt_le_1.
apply Rle_trans with (1 := Hzl2) (2 := Hyl).
exact (Rle_0_sqr _).
apply Rle_trans with (1 := Hyu) (2 := Hzu2).
Qed.

Theorem IRcompose :
 forall xl xu yl yu zl zu : R,
 (-1 <= xl)%R -> (-1 <= yl)%R ->
 (zl <= xl + yl + xl * yl)%R -> (xu + yu + xu * yu <= zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= x + y + x * y <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
replace (x + y + x * y)%R with ((1 + x) * (1 + y) - 1)%R. 2: ring.
assert (H : (1 + zl <= (1 + x) * (1 + y) <= 1 + zu)%R).
assert (H0 : (0 = 1 + -1)%R). ring.
assert (Hc : forall a b : R, ((1 + a) * (1 + b) = 1 + (a + b + a * b))%R).
intros a b. ring.
assert (Hi : forall a b c : R, (a <= b)%R -> (b <= c)%R -> (1 + a <= 1 + b <= 1 + c)%R).
intros a b c H1 H2. split.
apply Rplus_le_compat_l with (1 := H1).
apply Rplus_le_compat_l with (1 := H2).
apply IRmult_pp with (1 + xl)%R (1 + xu)%R (1 + yl)%R (1 + yu)%R.
rewrite H0. apply Rplus_le_compat_l with (1 := Hx).
rewrite H0. apply Rplus_le_compat_l with (1 := Hy).
rewrite Hc. apply Rplus_le_compat_l with (1 := Hzl).
rewrite Hc. apply Rplus_le_compat_l with (1 := Hzu).
apply Hi with (1 := Hxl) (2 := Hxu).
apply Hi with (1 := Hyl) (2 := Hyu).
assert (H0 : forall a : R, (a = (1 + a) + -1)%R).
intros a. ring.
split.
rewrite (H0 zl). exact (Rplus_le_compat_r _ _ _ (proj1 H)).
rewrite (H0 zu). exact (Rplus_le_compat_r _ _ _ (proj2 H)).
Qed.

Theorem IRcompose_inv :
 forall xl xu yl yu zl zu : R,
 (-1 <= xl)%R -> (-1 < yl)%R ->
 (yu + zl + yu * zl <= xl)%R -> (xu <= yl + zu + yl * zu)%R ->
 forall x y : R,
 (xl <= x <= xu)%R -> (yl <= y <= yu)%R ->
 (zl <= (x - y) / (1 + y) <= zu)%R.
Proof.
intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu).
assert (H0: (0 = 1 + -1)%R). ring.
assert (Hc: (0 < 1 + yl)%R).
rewrite H0.
apply Rplus_lt_compat_l with (1 := Hy).
replace ((x - y) / (1 + y))%R with ((1 + x) / (1 + y) - 1)%R.
assert (H : (1 + zl <= (1 + x) / (1 + y) <= 1 + zu)%R).
assert (Hi : forall a b c : R, (a <= b)%R -> (b <= c)%R -> (1 + a <= 1 + b <= 1 + c)%R).
intros a b c H1 H2. split.
apply Rplus_le_compat_l with (1 := H1).
apply Rplus_le_compat_l with (1 := H2).
destruct (IRdiv_aux_p _ _ _ Hc (Hi _ _ _ Hyl Hyu))%R as (H1, (H2, (H3, (H4, H5)))).
unfold Rdiv.
apply IRmult_pp with (2 := H2) (5 := Hi _ _ _ Hxl Hxu) (6 := H5).
rewrite H0. apply Rplus_le_compat_l with (1 := Hx).
replace (1 + zl)%R with ((1 + zl) * (1 + yu) * /(1 + yu))%R.
apply monotony_2p with (1 := H2).
replace ((1 + zl) * (1 + yu))%R with (1 + (yu + zl + yu * zl))%R. 2: ring.
apply Rplus_le_compat_l with (1 := Hzl).
field. exact H4.
replace (1 + zu)%R with ((1 + zu) * (1 + yl) * /(1 + yl))%R.
apply monotony_2p with (1 := H1).
replace ((1 + zu) * (1 + yl))%R with (1 + (yl + zu + yl * zu))%R. 2: ring.
apply Rplus_le_compat_l with (1 := Hzu).
field. exact H3.
replace zl with (1 + zl + -1)%R. 2: ring.
replace zu with (1 + zu + -1)%R. 2: ring.
unfold Rminus.
split ; apply Rplus_le_compat_r.
exact (proj1 H).
exact (proj2 H).
field.
apply Rgt_not_eq.
unfold Rgt.
apply Rlt_le_trans with (1 := Hc).
apply Rplus_le_compat_l with (1 := Hyl).
Qed.

Theorem IRabs_p :
 forall yl yu zl zu : R,
 (0 <= yl)%R ->
 (zl <= yl)%R -> (yu <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= Rabs y <= zu)%R.
Proof.
intros yl yu zl zu Hy Hzl Hzu y Hylu.
rewrite Rabs_pos_eq.
apply IRsubset with (1 := Hzl) (2 := Hzu) (3 := Hylu).
apply Rle_trans with (1 := Hy) (2 := proj1 Hylu).
Qed.

Theorem IRabs_o :
 forall yl yu zl zu : R,
 (zl <= 0)%R -> (-yl <= zu)%R -> (yu <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= Rabs y <= zu)%R.
Proof.
intros yl yu zl zu Hzl Hzu1 Hzu2 y (Hyl,Hyu).
split.
apply Rle_trans with (1 := Hzl) (2 := Rabs_pos y).
unfold Rabs. case Rcase_abs ; intro H.
apply Rle_trans with (2 := Hzu1).
apply Ropp_le_contravar with (1 := Hyl).
apply Rle_trans with (1 := Hyu) (2 := Hzu2).
Qed.

Theorem IRabs_n :
 forall yl yu zl zu : R,
 (yu <= 0)%R ->
 (zl <= -yu)%R -> (-yl <= zu)%R ->
 forall y : R,
 (yl <= y <= yu)%R ->
 (zl <= Rabs y <= zu)%R.
Proof.
intros yl yu zl zu Hy Hzl Hzu y Hylu.
rewrite Rabs_left1.
apply IRopp with (1 := Hzl) (2 := Hzu) (3 := Hylu).
apply Rle_trans with (1 := proj2 Hylu) (2 := Hy).
Qed.


(*|
###############################################################
How to prove ``False`` from obviously contradictory assumptions
###############################################################

:Link: https://stackoverflow.com/q/29286679
|*)

(*|
Question
********

Suppose I want to prove following Theorem:
|*)

Theorem succ_neq_zero : forall n m: nat, S n = m -> 0 = m -> False.
Abort. (* .none *)

(*|
This one is trivial since ``m`` cannot be both successor and zero, as
assumed. However I found it quite tricky to prove it, and I don't know
how to make it without an auxiliary lemma:
|*)

Lemma succ_neq_zero_lemma : forall n : nat, O = S n -> False.
Proof. intros. inversion H. Qed.

Theorem succ_neq_zero : forall n m : nat, S n = m -> 0 = m -> False.
Proof.
  intros. symmetry in H.
  apply (succ_neq_zero_lemma n). transitivity m.
  - assumption.
  - assumption.
Qed.

(*|
I am pretty sure there is a better way to prove this. What is the best
way to do it?
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

You just need to substitute for ``m`` in the first equation:
|*)

Reset Initial. (* .none *)
Theorem succ_neq_zero : forall n m : nat, S n = m -> 0 = m -> False.
Proof.
  intros n m H1 H2. rewrite <- H2 in H1. inversion H1.
Qed.

(*|
----

**A:** Or a bit more concise yet still explicit:
|*)

Reset Initial. (* .none *)
Theorem succ_neq_zero : forall n m : nat, S n = m -> 0 = m -> False.
Proof.
  intros n m H <-. discriminate H.
Qed.

(*| less explicit works too: |*)

Reset Initial. (* .none *)
Theorem succ_neq_zero : forall n m : nat, S n = m -> 0 = m -> False.
Proof.
  intros. subst. discriminate.
Qed.

(*|
Answer (Gilles 'SO- stop being evil')
*************************************

There's a very easy way to prove it:
|*)

Reset Initial. (* .none *)
Theorem succ_neq_zero : forall n m : nat, S n = m -> 0 = m -> False.
Proof.
  congruence.
Qed.

(*|
The ``congruence`` tactic is a decision procedure for ground
equalities on uninterpreted symbols. It's complete for uninterpreted
symbols and for constructors, so in cases like this one, it can prove
that the equality ``0 = m`` is impossible.
|*)

(*|
Answer (larsr)
**************

It might be useful to know how congruence works.

To prove that two terms constructed by different constructors are in
fact different, just create a function that returns ``True`` in one
case and ``False`` in the other cases, and then use it to prove ``True
= False``. I think this is explained in `Coq'Art
<https://www.labri.fr/perso/casteran/CoqArt/>`__
|*)

Example not_congruent : 0 <> 1.
Proof.
  intros C. (* now our goal is 'False' *)
  pose (fun m => match m with 0 => True | S _ => False end) as f.
  assert (Contra: f 1 = f 0) by (rewrite C; reflexivity).
  now replace False with True by Contra.
Qed.


(** This module defines substitution of closed terms into open terms,
and substitution of a single closed type into an open type.  *)

From Coq Require Export List.

From Rattus Require Export RawSyntax.

(* Substitution in types *)
Fixpoint tsubst (j : index) (A : type) (B : type) : type :=
  match A with
  | TypeVar k  => if j =? k
                  then B
                  else TypeVar k
  | Times A1 A2    => Times (tsubst j A1 B) (tsubst j A2 B)
  | Plus A1 A2    => Plus (tsubst j A1 B) (tsubst j A2 B)
  | Arrow A1 A2    => Arrow (tsubst j A1 B) (tsubst j A2 B)
  | Delay A'       => Delay (tsubst j A' B)
  | Box A'       => Box (tsubst j A' B)
  | Fix A'       => Fix (tsubst (S j) A' B)
  | _          => A
  end.

(* = Terms = *)

Definition sub := list (option term).

Definition sub_lookup (g : sub) i :=
  match nth_error g i with
    | Some (Some t) => Some t
    | _ => None
  end.

Fixpoint sub_app (g : sub) (t : term) : term :=
  match t with
  | var j    => match sub_lookup g j with
                | Some t => t
                | None => var j
                end
  | abs t'   => abs (sub_app (None::g) t')
  | letin t1 t2 => letin (sub_app g t1) (sub_app (None::g) t2)
  | app t1 t2 => app (sub_app g t1) (sub_app g t2)
  | pair t1 t2 => pair (sub_app g t1) (sub_app g t2)
  | pr1 t'=> pr1 (sub_app g t')
  | pr2 t'=> pr2 (sub_app g t')
  | in1 t'=> in1 (sub_app g t')
  | in2 t'=> in2 (sub_app g t')
  | case t1 t2 t3 => case (sub_app g t1) (sub_app (None :: g) t2) (sub_app (None :: g) t3)
  | delay  t' => delay (sub_app g t')
  | adv  t' => adv (sub_app g t')
  | box  t'  => box (sub_app g t')
  | unbox  t' => unbox (sub_app g t')
  | into t'=> into (sub_app g t')
  | out t'=> out (sub_app g t')

  | fixp t'=> fixp (sub_app (None::g) t')
  | unit => unit
  | natlit n => natlit n
  | add t1 t2 => add (sub_app g t1) (sub_app g t2)
  | ref l => ref l
  end.

Import ListNotations.

(* substitute u into t *)
Definition sub_term (t u : term) : term := sub_app [ Some u ] t.

Inductive sub_empty : sub -> Prop :=
| sub_empty_nil : sub_empty nil
| sub_empty_cons g : sub_empty g -> sub_empty (None :: g).

#[global] Hint Constructors sub_empty : core.

Lemma sub_empty_app t g : sub_empty g -> sub_app g t = t.
Proof.
  generalize dependent g. induction t;intros;simpl;f_equal;eauto.

  generalize dependent g. generalize dependent (var i).
  induction i;intros; inversion H; simpl; eauto.
Qed.


Load "list.v".

Fixpoint fold {X Y:Type} (f: X -> Y -> Y) (l:list X) (b:Y)
                         : Y :=
  match l with
  | nil    => b
  | h :: t => f h (fold f t b)
  end.

Compute fold (fun x y => x + y) [1;2;3] 0.
Check fold (fun x y => x + y) [1;2;3] 0. (* X = Y *)

Compute fold cons [1;2;3] []. (* X = nat, Y = list nat *)
Check fold cons [1;2;3] [].
Check cons.


Require Import Coq.Logic.Classical.

Section Classical_Predicates.

(* Reset Initial *)

Variables A B : Set.

(* These are essentially just functions in Coq *)
Variables P Q : A -> Prop.

(* We can also use Relations between elements of a set or sets. *)
Variable R : A -> B -> Prop.

(* to say that all elements of A have a property P we write *)
Lemma allAhaveP : forall x:A, P x.
Admitted.

Variable PP : Prop.

(* All of A have property PP possibly containing x:A *)
Lemma allAhavePP : forall x:A, PP.
Admitted.

(* Any element of A which has P also has Q, a clever student is also funny :) *)
Lemma allAwPalsoQ : forall x:A, P x -> Q x.
Admitted.

(* If all A have P, all A with P also have Q, then all A have Q. *)
Lemma allAhaveQ : (forall  x:A, P x) -> (forall x:A, P x -> Q x) -> forall x:A, Q x.
Proof.
intros H1 H2.
intro a.
apply H2.
apply H1.
Qed.

Lemma ex_from_forall : (exists x:A, P x) <-> ~ forall x:A, ~ P x.
Proof.
split.
(* proving -> *)
intro ex.
intro H.
destruct ex as [a p].
assert (npa : ~ (P a)).
apply H.
apply npa.
apply p.
(* proving <- *)
intro H.
apply NNPP.
intro nex.
apply H.
intros a p.
apply nex.
exists a.
exact p.
Qed.

End Classical_Predicates.

(* Parno's 2008 HotSec paper *)

Section Cuckoo.

(* we have sets Person, Computers, TPMs *)
Variables P C T : Set.

(* Properties of P's *)
Variables TrustedPerson  : P -> Prop.

(* Properties of C's *)
Variables TrustedC PhysSecure : C -> Prop.

(* Properties of TPMs *)
Variables TrustedT : T -> Prop.

(* Relations of P and C *)
Variables SaysSecure : P -> C -> Prop.

(* Relations of T and C *)
Variables On : T -> C -> Prop.

(* Relations of C and T *)
Variables CompSaysOn : C -> T -> Prop.

(* Relevant axioms of the trusted system are encoded here *)

(* If a trusted person says so, it is so ... *)
Hypothesis rule1 : forall (p:P) (c:C), TrustedPerson p /\ SaysSecure p c -> PhysSecure c.

(* A TPM on an insecure system can't be trusted *)
Hypothesis rule2 : forall (t:T) (c:C), On t c /\ ~PhysSecure c -> ~TrustedT t.

(* A TPM on a secure system is a trusted *)
Hypothesis rule3 : forall (t:T) (c:C), On t c /\ PhysSecure c -> TrustedT t.

(* A computer with a trusted TPM can be trusted *)
Hypothesis rule4 : forall (t:T) (c:C), On t c /\ TrustedT t -> TrustedC c.

(* A computer with an untrusted TPM can't be trusted *)
Hypothesis rule5 : forall (t:T) (c:C), On t c /\ ~TrustedT t -> ~TrustedC c.

(* The TPM indicated by the computer is the computers TPM. *)
Hypothesis rule6 : forall (c:C) (t:T), CompSaysOn c t -> On t c.

(* Now we encode the assumptions we make about the trust establishment *)

Variable alice : P. (* Alice *)
Variable c : C. (* Alice's computer *)
Variable m : C. (* Adversaries machien *)
Variable tpmm : T. (* Adversaries tpmm *)

(* Alice trusts herself *)
Hypothesis ass1 : TrustedPerson alice.
(* Alice says her computer is secure *)
Hypothesis ass2 : SaysSecure alice c.
(* Adversary controls TPMm on M *)
Hypothesis ass3 : On tpmm m.
(* M is not secure *)
Hypothesis ass4 : ~PhysSecure m.
(* Malware causes Alice's computer to say that TPMm is installed *)
Hypothesis ass5 : CompSaysOn c tpmm.

(* computer C is secure *)
Theorem CisSecure : TrustedPerson alice /\ SaysSecure alice c -> PhysSecure c.
Proof.
  apply rule1.
Qed.

(* Provable with all assumptions ... *)
Theorem PhysSecureC :
  TrustedPerson alice /\
  SaysSecure alice c /\
  On tpmm m /\
  ~PhysSecure m /\
  CompSaysOn c tpmm -> TrustedC c.
Proof.
  intro H.
  assert (TrustedPerson alice /\ SaysSecure alice c -> PhysSecure c).
    - intro H0. apply rule1 in H0. exact H0.
    - Abort.

(* TPM is on C *)
Theorem TPMmONc : PhysSecure c /\ CompSaysOn c tpmm -> On tpmm c.
Proof.
  intro H.
  destruct H.
  apply rule6 in H0.
  exact H0.
Qed.

(* This lets us know that tpmm is on c *)
Lemma TonC : CompSaysOn c tpmm -> On tpmm c.
Proof.
  apply rule6.
Qed.

(* tpmm is trusted *)
Lemma TPM_trusted : On tpmm c /\ PhysSecure c -> TrustedT tpmm.
Proof.
  apply rule3.
Qed.

(* C is trusted *)
Lemma C_trusted : On tpmm c /\ TrustedT tpmm -> TrustedC c.
Proof.
  apply rule4.
Qed.

(* TPM can't be trusted *)
Lemma TPM_not_trusted : On tpmm m /\ ~PhysSecure m -> ~TrustedT tpmm.
Proof.
  apply rule2.
Qed.

Lemma C_not_trusted : On tpmm c /\ ~TrustedT tpmm -> ~TrustedC c.
Proof.
  apply rule5.
Qed.

(* C_trusted and C_not_trusted ! *)

End Cuckoo.


Require Import BigO.Notation.
Require Import BigO.Util.DecField.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.vectorspace.
Require Import MathClasses.interfaces.orders.

Section BigThetaReflexive.
  Context `{SemiNormedSpace K V}.
  Context `{SemiNormedSpace K W}.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.

  Lemma big_Theta_refl : reflexive (V → W) big_Theta.
    unfold reflexive.
    intros f.
    unfold big_Theta.
    split.
    { (* big_O x x *)
      unfold big_O.
      exists 1. (* our constant k *)
      split.
       - exact zero_lt_one_dec.
       - exists 1. (* our constant *)
        intros.
        split.
         * exact zero_lt_one_dec.
         * intros n' one_leq_n.
           rewrite left_identity.
           apply reflexivity.
    }

    { (* big_Omega x x *)
      unfold big_Omega.
      exists 1. (* our constant *)
      split.
       - exact zero_lt_one_dec.
       - exists 1. (* our constant *)
         split.
         * exact zero_lt_one_dec.
         * intros n' one_leq_n.
           now rewrite left_identity.
    }
  Qed.
End BigThetaReflexive.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

(* No helper lemma needed. *)
Theorem theorem0 : forall (v : natural) (w : natural) (x : natural) (y : natural) (z : lst),
  eq (drop (Succ v) (drop (Succ w) (Cons x (Cons y z)))) (drop (Succ v) (drop w (Cons x z))).
Proof.
intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
  - intros. reflexivity.
  - rewrite H. induction w.
    + rewrite H. rewrite H. reflexivity.
    + reflexivity.
Qed.


Require Import ZArith.

Module NaiveLang.
  Definition expr := (nat -> option Z) -> Prop.
  Definition context := expr -> Prop.
  Definition impp (e1 e2 : expr) : expr := fun st => e1 st -> e2 st.
  Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
  Definition orp  (e1 e2 : expr) : expr := fun st => e1 st \/ e2 st.
  Definition falsep : expr := fun st => False.
  Definition coq_prop (P: Prop): expr := fun _ => P.

  Definition join : (nat -> option Z) -> (nat -> option Z) -> (nat -> option Z) -> Prop :=
    fun x y z =>
      forall p: nat,
       (exists v, x p = Some v /\ y p = None /\ z p = Some v) \/
       (exists v, x p = None /\ y p = Some v /\ z p = Some v) \/
       (x p = None /\ y p = None /\ z p = None).
  Definition sepcon (e1 e2 : expr) : expr := fun st =>
    exists st1 st2, join st1 st2 st /\ e1 st1 /\ e2 st2.
  Definition wand (e1 e2 : expr) : expr := fun st =>
    forall st1 st2, join st st1 st2 -> e1 st1 -> e2 st2.
  Definition emp : expr := fun st =>
    forall p, st p = None.
  Definition corable (e: expr): Prop := forall s1 s2, e s1 <-> e s2.

  Definition provable (e : expr) : Prop := forall st, e st.
End NaiveLang.

Require Import interface_5.

Module NaiveRule.
  Include DerivedNames (NaiveLang).
  Lemma modus_ponens :
    forall x y : expr, provable (impp x y) -> provable x -> provable y.
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom1 : forall x y : expr, provable (impp x (impp y x)).
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom2 : forall x y z : expr,
      provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z))).
  Proof. unfold provable, impp. auto. Qed.

  Lemma andp_intros :
    forall x y : expr, provable (impp x (impp y (andp x y))).
  Proof. unfold provable, impp, andp. auto. Qed.

  Lemma andp_elim1 : forall x y : expr, provable (impp (andp x y) x).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma andp_elim2 : forall x y : expr, provable (impp (andp x y) y).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma orp_intros1 : forall x y : expr, provable (impp x (orp x y)).
  Proof. unfold provable, impp, orp. auto. Qed.

  Lemma orp_intros2 : forall x y : expr, provable (impp y (orp x y)).
  Proof. unfold provable, impp, orp. auto. Qed.

  Lemma orp_elim : forall x y z : expr,
      provable (impp (impp x z) (impp (impp y z) (impp (orp x y) z))).
  Proof. unfold provable, impp, orp. tauto. Qed.

  Lemma falsep_elim : forall x : expr, provable (impp falsep x).
  Proof. unfold provable, impp, falsep. destruct 1. Qed.

  Lemma peirce_law : forall x y: expr, provable (impp (impp (impp x y) x) x).
  Proof. unfold provable, impp. intros; tauto. Qed.

  Lemma coq_prop_intros : (forall P : Prop, P -> provable (coq_prop P)) .
  Proof. unfold provable, coq_prop. intros; tauto. Qed.

  Lemma coq_prop_elim : (forall (P : Prop) (x : expr), (P -> provable x) -> provable (impp (coq_prop P) x)) .
  Proof. unfold provable, impp, coq_prop. intros; auto. Qed.

  Lemma coq_prop_impp : (forall P Q : Prop, provable (impp (impp (coq_prop P) (coq_prop Q)) (coq_prop (P -> Q)))) .
  Proof. unfold provable, impp, coq_prop. intros; auto. Qed.

  Axiom sepcon_comm: forall x y, provable (iffp (sepcon x y) (sepcon y x)).
  Axiom sepcon_assoc: forall x y z,
      provable (iffp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)).
  Axiom sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
  Axiom sepcon_emp : (forall x : expr, provable (iffp (sepcon x emp) x)) .
  Axiom falsep_sepcon_left : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
  Axiom orp_sepcon_left : (forall x y z : expr, provable (impp (sepcon (orp x y) z) (orp (sepcon x z) (sepcon y z)))) .
  Axiom corable_coq_prop : (forall P : Prop, corable (coq_prop P)) .
  Axiom corable_preserved' : (forall x y : expr, provable (iffp x y) -> corable x -> corable y) .
  Axiom corable_andp_sepcon1 : (forall x y z : expr, corable x -> provable (iffp (sepcon (andp x y) z) (andp x (sepcon y z)))) .
  Axiom wand_sepcon_adjoint : (forall x y z : expr, provable (impp (sepcon x y) z) <-> provable (impp x (wand y z))) .
End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Module Solver := IPSolver NaiveLang.
Import T.
Import Solver.

Require Import ExportSolvers.Normalize.

Notation "|--  x" := (provable x) (at level 71, no associativity) : syntax.
Notation "'!!' e" := (coq_prop e) (at level 25) : syntax.
Notation "x && y" := (andp x y) (at level 40, left associativity) : syntax.
Notation "x <--> y" := (iffp x y) (at level 60, no associativity) : syntax.
Notation "x --> y" := (impp x y) (at level 55, right associativity) : syntax.
Notation "x * y" := (sepcon x y) (at level 40, left associativity) : syntax.

Module Normalize := ExportTactic T.
Import Normalize.
Local Open Scope syntax.
Goal forall x y z (P: Prop), |-- (!! P && x) * y * z --> (!! P && x) * (!! P && y) * (!! P && z).
Proof.
  intros.
  repeat normalize.
Abort.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                Computing a BDT coding the prime implicants               *)
(*      (also called minimal solutions) of a function given by its BDT      *)
(*                                                                          *)
(*            Algorithm designed by A.Rauzy of LaBRI Bordeaux               *)
(*                    restricted to monotonic functions                     *)
(*                                                                          *)
(****************************************************************************)
(*                                 Primes.v                                 *)
(****************************************************************************)

Require Import Prelude_BDT.
Require Import CanonBDDs.rauzy.algorithme1.Boolean_functions.
Require Import CanonBDDs.rauzy.algorithme1.BDTs.
Require Import Prelude_Paths.
Require Import Prelude_Implicants.
Require Import Prelude_Primes.
Require Import Operator_W.
Require Import Monotony.

(*--------------------------------------------------------------------------*)
(*                Specification of procedures computing Primes
   An algorithm A is correct iff A(b) is Sound and Complete with respect to b
   for all BDT b. Notation: (Sound b A(b))/\(Complete b A(b))               *)
(*--------------------------------------------------------------------------*)

Definition Sound (b1 b2 : BDT) :=
  forall p : Path, Solution p b2 -> Prime p (Fun b1).
Definition Complete (b1 b2 : BDT) :=
  forall p : Path, Prime p (Fun b1) -> Solution p b2.
Definition Correct (b1 b2 : BDT) := Sound b1 b2 /\ Complete b1 b2.

Hint Unfold Correct.

(*---------       Needed properties of the specification         ------------*)

Lemma LC2_S_fac1 :
 forall p1 b1 : BDT,
 Sound b1 p1 ->
 forall b2 b3 : BDT,
 W_sound p1 b2 b3 -> forall p : Path, Solution p b3 -> Prime p (Fun b1).
Proof.
intros p1 b1 Def_p1 b2 b3 Def_b3 p Def_p.
unfold W_sound in Def_b3.
unfold Sound in Def_p1.
apply Def_p1; elim (Def_b3 p Def_p); trivial with arith.
Qed.

Lemma LC2_C_fac1 :
 forall pb1 b1 : BDT,
 Complete b1 pb1 ->
 forall b2 b3 : BDT,
 W_complete pb1 b2 b3 ->
 forall p : Path,
 Prime p (Fun b1) ->
 ~ Implicant p (Fun b2) -> exists p' : Path, Solution p' b3 /\ Divides p' p.
Proof.
intros pb1 b1 Def_pb1 b2 b3 Def_b3 p H1p H2p.
unfold W_complete in Def_b3.
unfold Complete in Def_pb1.
exact (Def_b3 p (Def_pb1 p H1p) H2p).
Qed.

Lemma Zero_complete : forall b : BDT, OBDT b -> Complete b Zero -> b = Zero.
Proof.
intros b Hb.
elim (eq_BDT_decidable b Zero); intro Cas.
elim Cas; trivial with arith.
unfold Complete in |- *; intro H.
elim (Prime_exists b Hb Cas); intros p Def_p.
absurd (Solution p Zero); [ exact (No_solution_Zero p) | exact (H p Def_p) ].
Qed.

(*--------------------------------------------------------------------------*)
(*                  Rauzy's solution for A based on Operaor W               *)
(*
        A(Zero)= Zero                               (E1)
        A(One) = One                                (E2)
        A(Node(i,l,r)) = Node(i,W(A(l),r),A(r))     (E3)
                                                                            *)
(*--------------------------------------------------------------------------*)

(*--------------        Correctness equations E1 and E2        --------------*)

Lemma BDT2_of_Zero : Sound Zero Zero /\ Complete Zero Zero.
Proof.
split.
(* Soundness *)
unfold Sound in |- *.
intros p H_absurde.
absurd (Solution p Zero); [ exact (No_solution_Zero p) | assumption ].
(* Completeness *)
unfold Complete in |- *; simpl in |- *.
intros p H_absurde.
absurd (Prime p FALSE); [ exact (No_prime_FALSE p) | assumption ].
Qed.

Lemma BDT2_of_One : Sound One One /\ Complete One One.
Proof.
split.
(* Soundness *)
unfold Sound in |- *.
intros p Def_p; unfold Prime in |- *.
split.
apply Implicants_TRUE.
apply Solution_OBDT_ordered with One; trivial with arith.
intros p' H1_p' H2_p'.
rewrite (Solution_of_One_is_Nil p Def_p).
exact (Nil_divides_all p').
(* Completeness *)
unfold Complete in |- *; simpl in |- *.
intros p Def_p.
rewrite (Nil_only_prime_of_TRUE p Def_p).
exact Sol_One.
Qed.

(*---------------------------------------------------------------------------*)
(*----------            Correctness of equation E3               ------------*)
(*---------------------------------------------------------------------------*)

Section Case_recursion.

Variable i : nat.
Variable l r : BDT.

Hypothesis HO : OBDT (Node i l r).
Hint Resolve HO.

Variable pl pr : BDT.

Hypothesis HOpl : OBDT pl.
Hint Resolve HOpl.

Hypothesis HOpr : OBDT pr.
Hint Resolve HOpr.

Hypothesis HDpl : Dim pl <= Dim l.
Hint Resolve HDpl.

Hypothesis HDpr : Dim pr <= Dim r.
Hint Resolve HDpr.

Variable w : BDT.

Hypothesis HOw : OBDT w.
Hint Resolve HOw.

Hypothesis HDw : Dim w <= Dim pl.
Hint Resolve HDw.

(*--------   Proof of the correctness of the optimisation    -------*)
(*                   No need to check left=right                    *)

Lemma Result_Ordered :
 Correct l pl -> Correct r pr -> W_correct pl r w -> OBDT (Node i w pr).
Proof.
intros HCpl HCpr HCw.
apply order_node; auto with arith.
apply gt_le_trans with (Dim l);
 [ elim (dim_node_dim_sons i l r); auto with arith
 | apply le_trans with (Dim pl); auto with arith ].
apply gt_le_trans with (Dim r);
 [ elim (dim_node_dim_sons i l r); auto with arith | auto with arith ].
(*---- ~w=pr -----*)
unfold not in |- *; intro Habsurde.
elim (LT1 w HOw); intro Hcas.
   (* Case w = Zero  *)
absurd (OBDT (Node i l r)); auto with arith.
apply Contra with (l = r);
 [ intro H; clear H | apply ordered_node_neq_sons with i; auto with arith ].
apply (trans_equal (A:=BDT)) with Zero.
apply Zero_complete;
 [ elim (ordered_node_ordered_sons i l r HO); trivial with arith | idtac ].
elim (LP2 pl HOpl); [ elim HCpl; auto with arith | idtac ].
pattern Zero at 2 in |- *; elim Hcas.
elim (Zero_complete r);
 [ elim HCw; trivial with arith
 | elim (ordered_node_ordered_sons i l r HO); trivial with arith
 | elim Hcas; rewrite Habsurde; elim HCpr; trivial with arith ].
symmetry  in |- *; apply Zero_complete;
 [ elim (ordered_node_ordered_sons i l r HO); trivial with arith
 | elim Hcas; rewrite Habsurde; elim HCpr; trivial with arith ].
   (* Case w=/=Zero *)
elim Hcas; intros p Def_p.
absurd (Implicant p (Fun r)).
elim HCw; unfold W_sound in |- *; intros HCSw HCCw.
elim (HCSw p Def_p); trivial with arith.
apply Prime_implicant.
elim HCpr; unfold Sound in |- *; intros HCSpr HCCpr.
apply HCSpr; elim Habsurde; assumption.
Qed.

Lemma Soundness_right :
 Sound l pl ->
 Sound r pr ->
 W_sound pl r w ->
 forall p : Path, Solution p pr -> Prime p (Fun (Node i l r)).
Proof.
intros HSpl HSpr HSw p Def_p.
unfold Sound in HSpr.
unfold Prime in |- *; split.
(*  Implicant *)
apply L10; [ idtac | auto with arith ].
apply Gt_dim_out_of_solution with pr; [ assumption | auto with arith | idtac ].
apply gt_le_trans with (Dim r);
 [ elim (dim_node_dim_sons i l r HO); trivial with arith | auto with arith ].
(*  Smallest  *)
intros p' H1p' H2p'.
elim (HSpr p Def_p); intros Hp_Impl Hp_Smallest.
apply Hp_Smallest; [ idtac | assumption ].
apply (L5 i l r p' H1p').
apply L80 with p; [ assumption | idtac ].
apply Gt_dim_out_of_solution with pr; [ assumption | auto with arith | idtac ].
apply gt_le_trans with (Dim r);
 [ elim (dim_node_dim_sons i l r HO); trivial with arith | auto with arith ].
Qed.

Lemma Soundness_left_impl :
 Sound l pl ->
 W_sound pl r w ->
 forall tl : Path,
 Solution tl w ->
 forall p : Path, p = Cons i tl -> Implicant p (Fun (Node i l r)).
Proof.
intros HSpl HSw tl Def_tl p Def_p.
rewrite Def_p; apply (L2 i l r HO tl).
apply Prime_implicant.
exact (LC2_S_fac1 pl l HSpl r w HSw tl Def_tl).
apply gt_le_trans with (Dim w);
 [ idtac | apply Head_of_solution_le_dim; auto with arith ].
apply gt_le_trans with (Dim l);
 [ elim (dim_node_dim_sons i l r HO); trivial with arith
 | apply le_trans with (Dim pl); auto with arith ].
Qed.

Lemma Soundness_left_smallest_order :
 forall tl : Path, Solution tl w -> Ordered (Cons i tl).
Proof.
intros tl Def_tl.
apply Cons_ordered; [ exact (Solution_OBDT_ordered w tl Def_tl HOw) | idtac ].
apply gt_le_trans with (Dim l);
 [ elim (dim_node_dim_sons i l r HO); trivial with arith
 | apply le_trans with (Dim w);
    [ exact (Head_of_solution_le_dim tl w Def_tl HOw)
    | apply le_trans with (Dim pl); auto with arith ] ].
Qed.

Lemma Soundness_left_smallest_in :
 Correct l pl ->
 Correct r pr ->
 W_correct pl r w ->
 forall tl : Path,
 Solution tl w ->
 forall p : Path,
 p = Cons i tl ->
 forall p' : Path,
 Implicant p' (Fun (Node i l r)) -> Divides p' p -> Of i p' -> Divides p p'.
Proof.
intros HCpl HCpr HCw tl Def_tl p Def_p.
elim HCpl; intros HCSpl HCCpl.
elim HCpr; intros HCSpr HCCpr.
elim HCw; intros HCSw HCCw.
intros p' H1p' H2p' Hi.
rewrite Def_p.
elim (Tail_exists_with_dim_head i w pr) with p p';
 [ intros tl' Def_p'; rewrite Def_p'
 | exact (Result_Ordered HCpl HCpr HCw)
 | rewrite Def_p; auto with arith
 | elim (inv_Implicant p' (Fun (Node i l r)) H1p'); auto with arith
 | assumption
 | assumption ].
apply Divides_tail_divides_cons;
 elim (LC2_S_fac1 pl l HCSpl r w HCSw tl Def_tl); intros H1tl H2tl.
apply H2tl; [ apply (L40 i l r HO tl'); elim Def_p'; assumption | idtac ].
apply Divides_cons_divides_tail with i;
 [ elim Def_p'; elim (inv_Implicant p' (Fun (Node i l r)) H1p');
    trivial with arith
 | exact (Soundness_left_smallest_order tl Def_tl)
 | elim Def_p'; elim Def_p; assumption ].
Qed.

Lemma Soundness_left_smallest_out :
 Monotonic (Fun (Node i l r)) ->
 Correct l pl ->
 Correct r pr ->
 W_correct pl r w ->
 forall tl : Path,
 Solution tl w ->
 forall p : Path,
 p = Cons i tl ->
 forall p' : Path,
 Implicant p' (Fun (Node i l r)) -> Divides p' p -> ~ Of i p' -> Divides p p'.
Proof.
intros Hmon HCpl HCpr HCw tl Def_tl p Def_p.
elim HCpl; intros HCSpl HCCpl.
elim HCpr; intros HCSpr HCCpr.
elim HCw; intros HCSw HCCw.
intros p' H1p' H2p' Hi.
absurd (Implicant tl (Fun r)).
unfold W_sound in HCSw.
elim (HCSw tl Def_tl); trivial with arith.
apply (L9 p');
 [ apply (L8 p' tl i); [ elim Def_p; assumption | assumption ]
 | idtac
 | exact (Solution_OBDT_ordered w tl Def_tl HOw)
 | exact (L5 i l r p' H1p' Hi) ].
elim (LC2_S_fac1 pl l HCSpl r w HCSw tl Def_tl); intros H1tl H2tl.
apply H2tl;
 [ idtac | apply (L8 p' tl i); [ elim Def_p; assumption | assumption ] ].
apply (L15 i l r HO Hmon); [ idtac | exact (L5 i l r p' H1p' Hi) ].
apply (Pth_ord9 i tl);
 [ exact (Soundness_left_smallest_order tl Def_tl)
 | elim (inv_Implicant p' (Fun (Node i l r)) H1p'); trivial with arith
 | apply (L8 p' tl i); [ elim Def_p; assumption | assumption ] ].
Qed.

Lemma Soundness_left :
 Monotonic (Fun (Node i l r)) ->
 Correct l pl ->
 Correct r pr ->
 W_correct pl r w ->
 forall tl : Path,
 Solution tl w ->
 forall p : Path, p = Cons i tl -> Prime p (Fun (Node i l r)).
Proof.
intros Hmon HCpl HCpr HCw tl Def_tl p Def_p.
elim HCpl; intros HCSpl HCCpl.
elim HCpr; intros HCSpr HCCpr.
elim HCw; intros HCSw HCCw.
unfold Sound in HCSpr.
unfold Prime in |- *; split.
(*----- Implicant -----*)
exact (Soundness_left_impl HCSpl HCSw tl Def_tl p Def_p).
(*----- Smallest  -----*)
intros p' H1p' H2p'.
elim (Of_path_dec p' i); intro Hi.
          (*   i in p'   *)
exact
 (Soundness_left_smallest_in HCpl HCpr HCw tl Def_tl p Def_p p' H1p' H2p' Hi).
          (*  i out of p'  *)
exact
 (Soundness_left_smallest_out Hmon HCpl HCpr HCw tl Def_tl p Def_p p' H1p'
    H2p' Hi).
Qed.

Lemma Soundness :
 Monotonic (Fun (Node i l r)) ->
 Correct l pl ->
 Correct r pr -> W_correct pl r w -> Sound (Node i l r) (Node i w pr).
Proof.
intros Hmon HCpl HCpr HCw.
elim HCpl; intros HCSpl HCCpl.
elim HCpr; intros HCSpr HCCpr.
elim HCw; intros HCSw HCCw.
unfold Sound in |- *.
intros p Def_p.
elim (p_inv_Solution p (Node i w pr) Def_p).
(*  Case right (Solution p pr) *)
intro Cas_def_p.
exact (Soundness_right HCSpl HCSpr HCSw p Cas_def_p).
(*  Case left p=(Cons i tl) /\ (Solution tl w) *)
simple induction 1; intro tl; simple induction 1; intros H1tl H2tl; clear H0.
exact (Soundness_left Hmon HCpl HCpr HCw tl H1tl p H2tl).
Qed.

Lemma Completness :
 Correct l pl ->
 Correct r pr -> W_correct pl r w -> Complete (Node i l r) (Node i w pr).
Proof.
intros HCpl HCpr HCw.
elim HCpl; intros HCSpl HCCpl.
elim HCpr; intros HCSpr HCCpr.
elim HCw; intros HCSw HCCw.
unfold Complete in |- *.
intros p Def_p.
elim (Of_path_dec p i); intro Hi.
(*----- Case  (Of i p) -----*)
elim (L4bis i l r HO p Def_p Hi); intro tl; simple induction 1;
 intros H1tl H2tl; clear H.
rewrite H1tl; apply Sol_Left.
elim (LC2_C_fac1 pl l HCCpl r w HCCw tl H2tl);
 [ intro tl'; simple induction 1; intros H1tl' H2tl'; clear H
 | apply (L12 i l r); elim H1tl; exact Def_p ].
elim (Ordered_paths_eq tl' (Solution_OBDT_ordered w tl' H1tl' HOw) tl);
 [ exact H1tl'
 | elim (inv_Implicant tl (Fun l) (Prime_implicant tl (Fun l) H2tl));
    trivial with arith
 | exact H2tl'
 | idtac ].
elim H2tl; intros H2tl_impl H2tl_smallest; clear H2tl.
apply H2tl_smallest;
 [ exact
    (Prime_implicant tl' (Fun l) (LC2_S_fac1 pl l HCSpl r w HCSw tl' H1tl'))
 | exact H2tl' ].
(*---- Case ~(Of i p) ------*)
apply Sol_Right.
unfold Complete in HCCpr; apply HCCpr.
exact (L5bis i l r p Def_p Hi).
Qed.

Lemma Correctness :
 Monotonic (Fun (Node i l r)) ->
 Correct l pl ->
 Correct r pr -> W_correct pl r w -> Correct (Node i l r) (Node i w pr).
Proof.
intros Hmon HCpl HCpr HCw.
unfold Correct in |- *; split.
exact (Soundness Hmon HCpl HCpr HCw).
exact (Completness HCpl HCpr HCw).
Qed.

End Case_recursion.

(*--------------------------------------------------------------------------*)
(*             Proof-programming of the algorithm computing a BDT           *)
(*        coding the primes of a boolean function defined by its BDT        *)
(*--------------------------------------------------------------------------*)

Theorem Existence_BDT2 :
 forall b1 : BDT,
 OBDT b1 ->
 Monotonic (Fun b1) ->
 {b2 : BDT | OBDT b2 /\ Dim b2 <= Dim b1 /\ Correct b1 b2}.
Proof.
(*----- Structural recursion on b1  ----*)
simple induction b1; clear b1.
intros.
(*---- if b1 = Zero  then b2 = Zero ----*)
exists Zero.
split;
 [ trivial with arith | split; [ trivial with arith | exact BDT2_of_Zero ] ].
intros.
(*---- if b1 = One  then b2 = One  ----*)
exists One.
split; [ trivial with arith | split; [ trivial with arith | exact BDT2_of_One ] ].
(*---- if b1 = (Node i1 h1 l1) then  .... *)
intros i1 l1 Hrec_l1 r1 Hrec_r1 Node_orded Node_monotonic.
elim Hrec_l1;
 [ intros Prm_l1 Def_Prm_l1; clear Hrec_l1
 | elim (ordered_node_ordered_sons i1 l1 r1 Node_orded); trivial with arith
 | elim (Mon_node_Mon_sons i1 l1 r1 Node_orded Node_monotonic);
    trivial with arith ].
elim Def_Prm_l1; intro HO_Prm_l1.
simple induction 1; intros HD_Prm_l1 HCorr_Prm_l1; clear H.
elim Hrec_r1;
 [ intros Prm_r1 Def_Prm_r1; clear Hrec_r1
 | elim (ordered_node_ordered_sons i1 l1 r1 Node_orded); trivial with arith
 | elim (Mon_node_Mon_sons i1 l1 r1 Node_orded Node_monotonic);
    trivial with arith ].
elim Def_Prm_r1; intro HO_Prm_r1.
simple induction 1; intros HD_Prm_r1 HCorr_Prm_r1; clear H.
clear Def_Prm_r1; clear Def_Prm_l1.
elim (Existence_Op_W Prm_l1 r1);
 [ intros Prm_l1_W_r1 Correctness_W
 | assumption
 | elim (ordered_node_ordered_sons i1 l1 r1 Node_orded); trivial with arith
 | elim (Mon_node_Mon_sons i1 l1 r1 Node_orded Node_monotonic);
    trivial with arith ].
elim Correctness_W; intro HO_Prm_l1_W_r1.
simple induction 1; intros HD_Prm_l1_W_r1 HCorr_Prm_l1_W_r1; clear H.
clear Correctness_W.
   (*   ..... b2 = (Node i1 Prm_l1_W_r1 Prm_r1)  ... *)
exists (Node i1 Prm_l1_W_r1 Prm_r1); split.
exact
 (Result_Ordered i1 l1 r1 Node_orded Prm_l1 Prm_r1 HO_Prm_l1 HO_Prm_r1
    HD_Prm_l1 HD_Prm_r1 Prm_l1_W_r1 HO_Prm_l1_W_r1 HD_Prm_l1_W_r1
    HCorr_Prm_l1 HCorr_Prm_r1 HCorr_Prm_l1_W_r1).
split;
 [ auto with arith
 | exact
    (Correctness i1 l1 r1 Node_orded Prm_l1 Prm_r1 HO_Prm_l1 HO_Prm_r1
       HD_Prm_l1 HD_Prm_r1 Prm_l1_W_r1 HO_Prm_l1_W_r1 HD_Prm_l1_W_r1
       Node_monotonic HCorr_Prm_l1 HCorr_Prm_r1 HCorr_Prm_l1_W_r1) ].
Qed.


Require Import Omega.

Lemma nat_eps (P : nat -> Prop) :
  (forall n, { P n } + { ~ P n }) ->
  (exists n, P n) ->
  { n | P n }.
Proof.
  intros HPdec Hex.
  refine (@Fix _
    (fun n m => S m = n /\ (forall m, m < n -> ~ P m)) _
    (fun n => (forall m, m < n -> ~ P m) -> { n | P n })
    (fun n eps HnP =>
      if HPdec n then exist _ n _
      else eps (S n) _ _) 0 _); eauto.
  - destruct Hex as [ n HP ]. intros m.
    remember (n - m) as p. generalize dependent m.
    induction p as [ | p ]; intros m Heqp; constructor; intros ? [? HnP]; subst.
    + destruct (HnP n); eauto; omega.
    + apply IHp. omega.
  - split; eauto. intros m ?. destruct (Nat.eq_dec n m); subst; eauto.
    apply HnP. omega.
  - intros m ?. destruct (Nat.eq_dec n m); subst; eauto.
    apply HnP. omega.
  - intros ? ?. omega.
Defined.

Theorem eps A (P : A -> Prop) (f : nat -> A) :
  (forall x, exists n, f n = x) ->
  (forall x, { P x } + { ~ P x }) ->
  (exists x, P x) ->
  { x | P x }.
Proof.
  intros Hsurj HPdec Hex.
  destruct (nat_eps (fun n => P (f n))); eauto.
  - intros. apply HPdec.
  - destruct Hex as [ x ]. destruct (Hsurj x). subst. eauto.
Defined.


Require Import Frap.

(*
 *
 * Modeling a full-feature Imperative programming language to allow us to reason about imperative programs in Coq
 *
 *)

(*
 * 1: Our imperative language constructs and syntax.
 *)

(* natural number expression *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| ReadMem (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Times (e1 e2 : exp)
| DivBy2 (e1: exp).

(* Those were the expressions of numeric type.  Here are the Boolean
 * expressions. *)
Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

(* Heap allows for pointer/index based access *)
Definition heap := fmap nat nat.
(* Values of variables (almost like the stack) *)
Definition valuation := fmap var nat.
(* An assertion allows us to check the state of the program
   on the heap and valuation, and see if it conforms with
   some desired property *)
Definition assertion := heap -> valuation -> Prop.

(* The statements in our language, these do not have a value themselves
   but can have side effects (can make changes to the heap or valuation) *)
Inductive cmd :=
| Skip
| AssignVar (x : var) (e : exp)
| AssignMem (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)
(* Think of this more as an annotation
   something we will add to our programs that help us analyze them. *)
| Assert (a : assertion).

(* BEGIN syntax macros that won't be explained *)
(* These allow us to override Coq's syntax with our own *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (ReadMem e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Times : cmd_scope.
Notation "e / '2'" := (DivBy2 e) (at level 70) : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | ReadMem dst' => AssignMem dst' src
  | Var dst' => AssignVar dst' src
  | _ => AssignVar "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'_if_' b '_then_' then_ '_else_' else_ '_done_'" := (If_ b then_ else_) (at level 75, b at level 0).
Notation "{{ I }} '_while_' b '_loop_' body '_done_'" := (While_ I b body) (at level 75).
Notation "'assert' {{ I }}" := (Assert I) (at level 75).
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := Init.Nat.sub : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.

(* Finite map notation: *)
(* <map> $? <key> -> Some <value> or None if key is not in the map *)
(* <map> $! <key> -> <value> or 0 if key is not in the map *)
(* <map> $+ (<key>, <value>) adds (key, value) to the map *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
(* END macros *)

(*
 * End of 1
 *)

(*
 * 2: The semantics of our programming languages: we are explaining
 *    to coq what each construct in our programming language mean
 *)

(* Interpreters for nat and bool expression *)
Fixpoint eval_div2 (n: nat): nat :=
  match n with
  | 0 => 0
  | S n =>
    match n with
    | 0 => 0 (* 1 / 2 = 0 *)
    | S n => 1 + eval_div2 n
    end
  end.

Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | ReadMem e1 => h $! eval e1 h v
  | Plus e1 e2 => eval e1 h v + eval e2 h v
  | Minus e1 e2 => eval e1 h v - eval e2 h v
  | Times e1 e2 => eval e1 h v * eval e2 h v
  | DivBy2 e => eval_div2 (eval e h v)
  end.
Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
  | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
end.

(* This is different than the previous problems
   We will go through something like this in lab 3. *)
(* This is one way of encoding what is called small step semantics.
   Instead of using an interpreter, which has several drawbacks, including problematic
   requirements on termination, we can use an inductive relation, to specify the meaning of the program
   one statement at a time (hence small-step). *)
(* This is an inductive relation of type (heap * valuation * cmd) -> (heap * valuation * cmd)
   in other words, it *relates* two tuples together, each made out of a heap, valuation and a command
   from our imperative language. If two such tuples are related, it means that if we are given
   a program state matching the first tuple, a valid single step of execution of our programming language
   will give us back a new step, matching the second tuple. *)
(* One important advantage this kind of modeling has over interpreters is that this is a relation,
   as opposed to a function (in the case of interpreters). This means that a single program state may
   be related to several next-step states, which helps model things like non-determinism, randomized algorithms,
   concurrency, and parallelism. *)
Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
(* Assign a value to a variable gives us a new valuation with the new value of the variable *)
(* Notice the use of Skip as the command in the next step. This indicates that this assignment
   statement has been consumed completely. Do not worry about sequencing or composing commands together
   other rules here will acheive that *)
| StAssign : forall h v x e,
  step (h, v, AssignVar x e) (h, v $+ (x, eval e h v), Skip)
(* AssignMem does not change the valuation, but it changes the heap *)
| StWrite : forall h v e1 e2,
  step (h, v, AssignMem e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)

(* Sequencing base case: if we have sequence (c1; c2) and c1 is skip,
   then we can immediately go to c2. *)
| StStepSkip : forall h v c,
  step (h, v, Seq Skip c) (h, v, c)
(* Sequencing recursive case: if we have sequence (c1; c2) and c1 gets us to c1'
   then we can go to (c1'; c2), and any effects c1 had on heap and valuation are carried through. *)
| StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
  step (h1, v1, c1) (h2, v2, c1')
  -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)

(* If statement execution depends on the value of its condition *)
| StIfTrue : forall h v b c1 c2,
  beval b h v = true
  -> step (h, v, If_ b c1 c2) (h, v, c1)
| StIfFalse : forall h v b c1 c2,
  beval b h v = false
  -> step (h, v, If_ b c1 c2) (h, v, c2)

(* While loop also depends on the value of its condition *)
| StWhileFalse : forall I h v b c,
  beval b h v = false
  -> step (h, v, While_ I b c) (h, v, Skip)
| StWhileTrue : forall I h v b c,
  beval b h v = true
  (* This is sometimes called loop unwinding, a loop with a true condition
     is equivalent to executing the body once, then going back to the loop *)
  -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))

(* Finally, asserts have no effect, and are equivalent to skips *)
| StAssert : forall h v (a : assertion),
  a h v -> step (h, v, Assert a) (h, v, Skip).