From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Require Import Ranalysis2.
Local Open Scope R_scope.

Theorem derivable_pt_lim_div :
forall (f1 f2:R -> R) (x l1 l2:R),
derivable_pt_lim f1 x l1 ->
derivable_pt_lim f2 x l2 ->
f2 x <> 0 ->
derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)).
Proof. hammer_hook "Ranalysis3" "Ranalysis3.derivable_pt_lim_div".
intros f1 f2 x l1 l2 H H0 H1.
cut (derivable_pt f2 x);
[ intro X | unfold derivable_pt; exists l2; exact H0 ].
assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1).
elim H2; clear H2; intros eps_f2 H2.
unfold div_fct.
assert (H3 := derivable_continuous_pt _ _ X).
unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3;
unfold limit_in in H3; unfold dist in H3.
simpl in H3; unfold R_dist in H3.
elim (H3 (Rabs (f2 x) / 2));
[ idtac
| unfold Rdiv; change (0 < Rabs (f2 x) * / 2);
apply Rmult_lt_0_compat;
[ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
clear H3; intros alp_f2 H3.
cut
(forall x0:R,
Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2).
intro H4.
cut (forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)).
intro H5.
cut
(forall a:R,
Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)).
intro Maj.
unfold derivable_pt_lim; intros.
elim (H (Rabs (eps * f2 x / 8)));
[ idtac
| unfold Rdiv; change (0 < Rabs (eps * f2 x * / 8));
apply Rabs_pos_lt; repeat apply prod_neq_R0;
[ red; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6)
| assumption
| apply Rinv_neq_0_compat; discrR ] ].
intros alp_f1d H7.
case (Req_dec (f1 x) 0); intro.
case (Req_dec l1 0); intro.

cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d));
[ intro
| repeat apply Rmin_pos;
[ apply (cond_pos eps_f2)
| elim H3; intros; assumption
| apply (cond_pos alp_f1d) ] ].
exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10).
simpl; intros.
assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)).
assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)).
assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)).
assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)).
assert (H17 := H7 _ H11 H15).
rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ].
apply Rle_lt_trans with
(Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
unfold Rminus.
rewrite <-
(Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
.
apply Rabs_4.
repeat rewrite Rabs_mult.
apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
cut
(Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
eps / 4).
cut
(Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
eps / 4).
intros.
apply Rlt_4; assumption.
rewrite H8.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite H8.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite H9.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite <- Rabs_mult.
apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2);
try assumption || apply H2.
apply H14.
apply Rmin_2; assumption.
right; symmetry ; apply quadruple_var.

assert (H10 := derivable_continuous_pt _ _ X).
unfold continuity_pt in H10.
unfold continue_in in H10.
unfold limit1_in in H10.
unfold limit_in in H10.
unfold dist in H10.
simpl in H10.
unfold R_dist in H10.
elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
clear H10; intros alp_f2t2 H10.
cut
(forall a:R,
Rabs a < alp_f2t2 ->
Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
intro H11.
cut (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)).
intro.
exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12).
simpl.
intros.
assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
clear H14 H15 H16.
rewrite formule; try assumption.
apply Rle_lt_trans with
(Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
unfold Rminus.
rewrite <-
(Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
.
apply Rabs_4.
repeat rewrite Rabs_mult.
apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
cut
(Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
eps / 4).
cut
(Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
eps / 4).
intros.
apply Rlt_4; assumption.
rewrite H8.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite H8.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite <- Rabs_mult.
apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite <- Rabs_mult.
apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
right; symmetry ; apply quadruple_var.
apply H2; assumption.
repeat apply Rmin_pos.
apply (cond_pos eps_f2).
apply (cond_pos alp_f1d).
elim H3; intros; assumption.
elim H10; intros; assumption.
intros.
elim H10; intros.
case (Req_dec a 0); intro.
rewrite H14; rewrite Rplus_0_r.
unfold Rminus; rewrite Rplus_opp_r.
rewrite Rabs_R0.
apply Rabs_pos_lt.
unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc.
repeat apply prod_neq_R0; try assumption.
now apply Rgt_not_eq.
apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption].
apply H13.
split.
apply D_x_no_cond; assumption.
replace (x + a - x) with a; [ assumption | ring ].
change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc;
repeat apply prod_neq_R0.
red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
assumption.
assumption.
apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption].

case (Req_dec l1 0); intro.
case (Req_dec l2 0); intro.
elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
[ idtac
| apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc;
repeat apply prod_neq_R0 ;
[ assumption
| assumption
| now apply Rgt_not_eq
| apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ].
intros alp_f2d H12.
cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)).
intro.
exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11).
simpl.
intros.
assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
clear H15 H16.
rewrite formule; try assumption.
apply Rle_lt_trans with
(Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
unfold Rminus.
rewrite <-
(Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
.
apply Rabs_4.
repeat rewrite Rabs_mult.
apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
cut
(Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
eps / 4).
cut
(Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
eps / 4).
intros.
apply Rlt_4; assumption.
rewrite H10.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite <- Rabs_mult.
apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite H9.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite <- Rabs_mult.
apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac.
apply H2; assumption.
apply Rmin_2; assumption.
right; symmetry ; apply quadruple_var.
apply H2; assumption.
repeat apply Rmin_pos.
apply (cond_pos eps_f2).
elim H3; intros; assumption.
apply (cond_pos alp_f1d).
apply (cond_pos alp_f2d).

elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
[ idtac
| apply Rabs_pos_lt; unfold Rsqr, Rdiv;
repeat apply prod_neq_R0 ;
[ assumption..
| now apply Rgt_not_eq
| apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ].
intros alp_f2d H11.
assert (H12 := derivable_continuous_pt _ _ X).
unfold continuity_pt in H12.
unfold continue_in in H12.
unfold limit1_in in H12.
unfold limit_in in H12.
unfold dist in H12.
simpl in H12.
unfold R_dist in H12.
elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
intros alp_f2c H13.
cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))).
intro.
exists
(mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c)))
H14).
simpl; intros.
assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
clear H16 H17 H18 H19.
cut
(forall a:R,
Rabs a < alp_f2c ->
Rabs (f2 (x + a) - f2 x) <
Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
intro.
rewrite formule; try assumption.
apply Rle_lt_trans with
(Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
unfold Rminus.
rewrite <-
(Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
.
apply Rabs_4.
repeat rewrite Rabs_mult.
apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
cut
(Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
eps / 4).
cut
(Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
eps / 4).
intros.
apply Rlt_4; assumption.
rewrite <- Rabs_mult.
apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite <- Rabs_mult.
apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite H9.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite <- Rabs_mult.
apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
right; symmetry ; apply quadruple_var.
apply H2; assumption.
intros.
case (Req_dec a 0); intro.
rewrite H17; rewrite Rplus_0_r.
unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0.
apply Rabs_pos_lt.
unfold Rdiv, Rsqr.
repeat rewrite Rinv_mult_distr; try assumption.
repeat apply prod_neq_R0; try assumption.
red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6).
apply Rinv_neq_0_compat; discrR.
apply Rinv_neq_0_compat; assumption.
apply Rinv_neq_0_compat; assumption.
discrR.
apply prod_neq_R0; [ discrR | assumption ].
elim H13; intros.
apply H19.
split.
apply D_x_no_cond; assumption.
replace (x + a - x) with a; [ assumption | ring ].
repeat apply Rmin_pos.
apply (cond_pos eps_f2).
elim H3; intros; assumption.
apply (cond_pos alp_f1d).
apply (cond_pos alp_f2d).
elim H13; intros; assumption.
change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
apply Rabs_pos_lt.
unfold Rsqr, Rdiv.
repeat rewrite Rinv_mult_distr; try assumption || discrR.
repeat apply prod_neq_R0; try assumption.
red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6).
apply Rinv_neq_0_compat; discrR.
apply Rinv_neq_0_compat; assumption.
apply Rinv_neq_0_compat; assumption.
apply prod_neq_R0; [ discrR | assumption ].

case (Req_dec l2 0); intro.
assert (H11 := derivable_continuous_pt _ _ X).
unfold continuity_pt in H11.
unfold continue_in in H11.
unfold limit1_in in H11.
unfold limit_in in H11.
unfold dist in H11.
simpl in H11.
unfold R_dist in H11.
elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
clear H11; intros alp_f2t2 H11.
elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
intros alp_f2d H12.
cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))).
intro.
exists
(mkposreal
(Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13).
simpl.
intros.
cut
(forall a:R,
Rabs a < alp_f2t2 ->
Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
intro.
assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
clear H15 H17 H18 H21.
rewrite formule; try assumption.
apply Rle_lt_trans with
(Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
unfold Rminus.
rewrite <-
(Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
.
apply Rabs_4.
repeat rewrite Rabs_mult.
apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
cut
(Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
eps / 4).
cut
(Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
eps / 4).
intros.
apply Rlt_4; assumption.
rewrite H10.
unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
rewrite Rabs_R0; rewrite Rmult_0_l.
apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
rewrite <- Rabs_mult.
apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite <- Rabs_mult.
apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite <- Rabs_mult.
apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
right; symmetry ; apply quadruple_var.
apply H2; assumption.
intros.
case (Req_dec a 0); intro.
rewrite H17; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r;
rewrite Rabs_R0.
apply Rabs_pos_lt.
unfold Rdiv; rewrite Rinv_mult_distr; try discrR || assumption.
unfold Rsqr.
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6)).
elim H11; intros.
apply H19.
split.
apply D_x_no_cond; assumption.
replace (x + a - x) with a; [ assumption | ring ].
repeat apply Rmin_pos.
apply (cond_pos eps_f2).
elim H3; intros; assumption.
apply (cond_pos alp_f1d).
apply (cond_pos alp_f2d).
elim H11; intros; assumption.
apply Rabs_pos_lt.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr; try discrR || assumption.
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
apply Rabs_pos_lt.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr; try discrR || assumption.
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).

elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
intros alp_f2d H11.
assert (H12 := derivable_continuous_pt _ _ X).
unfold continuity_pt in H12.
unfold continue_in in H12.
unfold limit1_in in H12.
unfold limit_in in H12.
unfold dist in H12.
simpl in H12.
unfold R_dist in H12.
elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
intros alp_f2c H13.
elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
intros alp_f2t2 H14.
cut
(0 <
Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
(Rmin alp_f2c alp_f2t2)).
intro.
exists
(mkposreal
(Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
(Rmin alp_f2c alp_f2t2)) H15).
simpl.
intros.
assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)).
assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)).
assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
clear H17 H18 H19 H20 H21.
cut
(forall a:R,
Rabs a < alp_f2t2 ->
Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
cut
(forall a:R,
Rabs a < alp_f2c ->
Rabs (f2 (x + a) - f2 x) <
Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
intros.
rewrite formule; try assumption.
apply Rle_lt_trans with
(Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
unfold Rminus.
rewrite <-
(Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
.
apply Rabs_4.
repeat rewrite Rabs_mult.
apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
cut
(Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
eps / 4).
cut
(Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
eps / 4).
intros.
apply Rlt_4; assumption.
rewrite <- Rabs_mult.
apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite <- Rabs_mult.
apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite <- Rabs_mult.
apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
rewrite <- Rabs_mult.
apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
apply H2; assumption.
apply Rmin_2; assumption.
right; symmetry ; apply quadruple_var.
apply H2; assumption.
intros.
case (Req_dec a 0); intro.
rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r;
rewrite Rabs_R0; apply Rabs_pos_lt.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
apply prod_neq_R0; [ discrR | assumption ].
apply prod_neq_R0; [ discrR | assumption ].
assumption.
elim H13; intros.
apply H20.
split.
apply D_x_no_cond; assumption.
replace (x + a - x) with a; [ assumption | ring ].
intros.
case (Req_dec a 0); intro.
rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r;
rewrite Rabs_R0; apply Rabs_pos_lt.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
discrR.
assumption.
elim H14; intros.
apply H20.
split.
unfold D_x, no_cond; split.
trivial.
apply Rminus_not_eq_right.
replace (x + a - x) with a; [ assumption | ring ].
replace (x + a - x) with a; [ assumption | ring ].
repeat apply Rmin_pos.
apply (cond_pos eps_f2).
elim H3; intros; assumption.
apply (cond_pos alp_f1d).
apply (cond_pos alp_f2d).
elim H13; intros; assumption.
elim H14; intros; assumption.
change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))); apply Rabs_pos_lt.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr; try discrR || assumption.
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H14; rewrite H14 in H6; elim (Rlt_irrefl _ H6)).
change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)));
apply Rabs_pos_lt.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6)).
apply prod_neq_R0; [ discrR | assumption ].
apply prod_neq_R0; [ discrR | assumption ].
assumption.
apply Rabs_pos_lt.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr;
[ idtac | discrR | assumption ].
repeat apply prod_neq_R0;
assumption ||
(apply Rinv_neq_0_compat; assumption) ||
(apply Rinv_neq_0_compat; discrR) ||
(red; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6)).
intros.
unfold Rdiv.
apply Rmult_lt_reg_l with (Rabs (f2 (x + a))).
apply Rabs_pos_lt; apply H2.
apply Rlt_le_trans with (Rmin eps_f2 alp_f2).
assumption.
apply Rmin_l.
rewrite <- Rinv_r_sym.
apply Rmult_lt_reg_l with (Rabs (f2 x)).
apply Rabs_pos_lt; assumption.
rewrite Rmult_1_r.
rewrite (Rmult_comm (Rabs (f2 x))).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_r.
apply Rmult_lt_reg_l with (/ 2).
apply Rinv_0_lt_compat; prove_sup0.
repeat rewrite (Rmult_comm (/ 2)).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_r_sym.
rewrite Rmult_1_r.
unfold Rdiv in H5; apply H5.
replace (x + a - x) with a.
assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption.
ring.
discrR.
apply Rabs_no_R0; assumption.
apply Rabs_no_R0; apply H2.
assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption.
intros.
assert (H6 := H4 a H5).
rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6.
rewrite Ropp_minus_distr in H6.
assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6).
apply Rplus_lt_reg_l with (- Rabs (f2 a) + Rabs (f2 x) / 2).
rewrite Rplus_assoc.
rewrite <- double_var.
do 2 rewrite (Rplus_comm (- Rabs (f2 a))).
rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
unfold Rminus in H7; assumption.
intros.
case (Req_dec x x0); intro.
rewrite <- H5; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
unfold Rdiv; apply Rmult_lt_0_compat;
[ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
elim H3; intros.
apply H7.
split.
unfold D_x, no_cond; split.
trivial.
assumption.
assumption.
Qed.

Lemma derivable_pt_div :
forall (f1 f2:R -> R) (x:R),
derivable_pt f1 x ->
derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x.
Proof. hammer_hook "Ranalysis3" "Ranalysis3.derivable_pt_div".
unfold derivable_pt.
intros f1 f2 x X X0 H.
elim X; intros.
elim X0; intros.
exists ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)).
apply derivable_pt_lim_div; assumption.
Qed.

Lemma derivable_div :
forall f1 f2:R -> R,
derivable f1 ->
derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2).
Proof. hammer_hook "Ranalysis3" "Ranalysis3.derivable_div".
unfold derivable; intros f1 f2 X X0 H x.
apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)).
Qed.

Lemma derive_pt_div :
forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x)
(pr2:derivable_pt f2 x) (na:f2 x <> 0),
derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) =
(derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x).
Proof. hammer_hook "Ranalysis3" "Ranalysis3.derive_pt_div".
intros.
assert (H := derivable_derive f1 x pr1).
assert (H0 := derivable_derive f2 x pr2).
assert
(H1 := derivable_derive (f1 / f2)%F x (derivable_pt_div _ _ _ pr1 pr2 na)).
elim H; clear H; intros l1 H.
elim H0; clear H0; intros l2 H0.
elim H1; clear H1; intros l H1.
rewrite H; rewrite H0; apply derive_pt_eq_0.
assert (H3 := proj2_sig pr1).
unfold derive_pt in H; rewrite H in H3.
assert (H4 := proj2_sig pr2).
unfold derive_pt in H0; rewrite H0 in H4.
apply derivable_pt_lim_div; assumption.
Qed.


Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Setoids.Setoid
        Coq.Arith.PeanoNat
        Coq.omega.Omega
        Coq.setoid_ring.Ring
        Coq.setoid_ring.Ring_theory
        Matrix
        DenseMatrix
        MyHelpers.

Section A.
  Variable ME : MatrixElem.
  Add Field Afield : MEfield.
  Notation DM := (Mt (ME := ME) (Matrix := DenseMatrix)).
  Existing Instance DenseMatrix.

  Lemma get_then_fill {m n}: forall M: DM m n,
      M @= (Mfill (fun i j => M@[i, j]) : DM m n).
  Proof.
    intros.
    unfold "@=".
    intros.
    rewrite Mfill_correct; auto.
  Qed.

  Lemma op_then_get {m n}: forall A B : DM m n, forall op i j,
        i < m -> j < n ->
      (Melementwise_op op A B)@[i, j] = op (A@[i, j]) (B@[i, j]).
  Proof.
    intros.
    rewrite Melementwise_op_correct; auto.
  Qed.

  Lemma split_terms {m n}: forall A B: DM m n, forall op f,
        @Restricted_Eq _ m n (fun i j => f((Melementwise_op op A B)@[i, j])) ((fun i j => f(op (A@[i, j]) (B@[i, j])))).
  Proof.
    intros.
    unfold Restricted_Eq.
    intros.
    rewrite op_then_get; auto.
  Qed.

  Lemma Mfill_and_matrix {m n}: forall A: DM m n, forall f op,
      Melementwise_op op (Mfill f) A @= (Mfill (fun i j => op (f i j) (A@[i, j]))).
  Proof.
    intros.
    unfold "@=".
    intros.
    rewrite Mfill_correct; auto.
    rewrite Melementwise_op_correct; auto.
    rewrite Mfill_correct; auto.
  Qed.

  Lemma matrix_and_Mfill {m n}: forall A: DM m n, forall f op,
      Melementwise_op op A (Mfill f) @= (Mfill (fun i j => op (A@[i, j]) (f i j))).
  Proof.
    intros.
    unfold "@=".
    intros.
    rewrite Mfill_correct; auto.
    rewrite Melementwise_op_correct; auto.
    rewrite Mfill_correct; auto.
  Qed.

  Lemma Mfill_and_Mfill: forall m n: nat, forall f g op,
      Melementwise_op op (@Mfill ME _ m n g) (Mfill f) @= (Mfill (fun i j => op (g i j) (f i j))).
  Proof.
    intros.
    unfold "@=".
    intros.
    rewrite Mfill_correct; auto.
    rewrite Melementwise_op_correct; auto.
    rewrite Mfill_correct; auto.
    rewrite Mfill_correct; auto.
  Qed.

  Lemma M_and_M_and_M {m n}: forall A B C: DM m n, forall op1 op2,
        Melementwise_op op1 (Melementwise_op op2 A B) C @= Mfill (fun i j => op1 (op2 (A@[i, j]) (B@[i, j])) (C@[i, j])).
  Proof.
    intros.
    unfold "@="; intros.
    rewrite Melementwise_op_correct; auto.
    rewrite Melementwise_op_correct; auto.
    rewrite Mfill_correct; auto.
  Qed.

  Lemma M_and_M_and_M2 {m n}: forall A B C: DM m n, forall op1 op2,
        Melementwise_op op1 A (Melementwise_op op2 B C) @= Mfill (fun i j => op1 (A@[i, j]) (op2 (B@[i, j]) (C@[i, j]))).
  Proof.
    intros.
    unfold "@="; intros.
    rewrite Melementwise_op_correct; auto.
    rewrite Melementwise_op_correct; auto.
    rewrite Mfill_correct; auto.
  Qed.

  (*Definition is_variable {A} (_:A) := True.
  Ltac check_if_var :=
    match goal with
    | [x:_ |- _] =>
      match goal with
      | [|- is_variable x] => try constructor
      end
    end.

  Lemma M_and_M_and_M' {m n}: forall A B C: DM m n, forall op1 op2,
        is_variable A -> is_variable B -> is_variable C -> Melementwise_op op1 (Melementwise_op op2 A B) C @= Mfill (fun i j => op1 (op2 (A@[i, j]) (B@[i, j])) (C@[i, j])).
  Proof.
    intros.
    apply M_and_M_and_M.
  Qed.

  Lemma M_and_M_and_M2' {m n}: forall A B C: DM m n, forall op1 op2,
        is_variable A -> is_variable B -> is_variable C -> Melementwise_op op1 A (Melementwise_op op2 B C) @= Mfill (fun i j => op1 (A@[i, j]) (op2 (B@[i, j]) (C@[i, j]))).
  Proof.
    intros.
    apply M_and_M_and_M2.
  Qed.

  Hint Rewrite @M_and_M_and_M' @M_and_M_and_M2' using check_if_var: MOPT.*)

  Ltac MOPT :=
    match goal with
    | [ |- context[Melementwise_op _ (Melementwise_op _ ?A ?B) ?C]] =>
      tryif (is_variable A; is_variable B; is_variable C) then rewrite (M_and_M_and_M A B C) else fail 0
    | [ |- context[Melementwise_op _ ?A (Melementwise_op _ ?B ?C)]] =>
      tryif (is_variable A; is_variable B; is_variable C) then rewrite (M_and_M_and_M2 A B C) else fail 0
    | [ |- context[Melementwise_op _ (Mfill _) ?A]] => tryif (is_variable A) then rewrite (Mfill_and_matrix A) else fail 0
    | [ |- context[Melementwise_op _ ?A (Mfill _)]] => tryif (is_variable A) then rewrite (matrix_and_Mfill A) else fail 0
    | _ => rewrite Mfill_and_Mfill
    end.

  Theorem test {n}: forall A B C D E F: DM n n,
     (A @+ B @+ C) @+ (D @+ E @- F) @+ (A @+ A @+ B) @= A.
  Proof.
    intros.

    repeat MOPT.
  Admitted.

End A.


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep Platform.Malloc Platform.Bags.
Import W_W_Bag.

(** * Queue ADT *)

Definition ifZero (n : nat) (p1 p2 : W) := n = 0 -> p1 = p2.

Inductive focusOnFront : Prop := FF.
Inductive focusOnBack : Prop := FB.

Hint Constructors focusOnFront focusOnBack.

Module Type QUEUE.
  Parameter queue : bag -> W -> HProp.
  Parameter llist : bag -> nat -> W -> W -> HProp.
  Parameter lseg : bag -> nat -> W -> W -> HProp.

  Axiom queue_extensional : forall b p, HProp_extensional (queue b p).
  Axiom llist_extensional : forall b n fr ba, HProp_extensional (llist b n fr ba).
  Axiom lseg_extensional : forall b n fr ba, HProp_extensional (lseg b n fr ba).

  Axiom lseg_extensional' : forall ba n b b' fr,
    b %= b'
    -> lseg b n fr ba ===> lseg b' n fr ba.

  Axiom llist_extensional' : forall ba n b b' fr,
    b %= b'
    -> llist b n fr ba ===> llist b' n fr ba.

  Axiom queue_fwd : forall b p,
    queue b p
    ===> Ex fr, Ex ba, Ex n, [| freeable p 2 |] * (p ==*> fr, ba) * llist b n fr ba.

  Axiom queue_bwd : forall b p,
    (Ex fr, Ex ba, Ex n, [| freeable p 2 |] * (p ==*> fr, ba) * llist b n fr ba)
    ===> queue b p.

  Axiom llist_empty_fwd : forall b n (fr : W) ba,
    fr = 0
    -> llist b n fr ba ===> [| b %= empty |] * [| n = O |].

  Axiom llist_empty_bwd : forall b n (fr : W) ba,
    fr = 0
    -> [| b %= empty |] * [| n = O |] ===> llist b n fr ba.

  Axiom llist_nonempty_fwd : forall ba n (fr : W) b,
    fr <> 0
    -> focusOnFront
    -> llist b n fr ba ===> Ex n', Ex v1, Ex v2, Ex p, [| n = S n' |] * [| (v1, v2) %in b |] * [| freeable fr 3 |] * (fr ==*> v1, v2, p) * [| ifZero n' fr ba |] * llist (b %- (v1, v2)) n' p ba.

  Axiom llist_end_fwd : forall ba n (fr : W) b,
    fr <> 0
    -> focusOnBack
    -> llist b n fr ba ===> Ex n', Ex v1, Ex v2, [| n = S n' |] * [| (v1, v2) %in b |] * lseg (b %- (v1, v2)) n' fr ba * [| ba <> 0 |] * [| freeable ba 3 |] * (ba ==*> v1, v2, $0).

  Axiom llist_nonempty_fwd_b : forall b n fr ba,
    ~(b %= empty)
    -> focusOnFront
    -> llist b n fr ba ===> [| fr <> 0 |] * Ex n', Ex v1, Ex v2, Ex p, [| n = S n' |] * [| (v1, v2) %in b |]
      * (fr ==*> v1, v2, p) * [| freeable fr 3 |] * [| ifZero n' fr ba |] * llist (b %- (v1, v2)) n' p ba.

  Axiom llist_nonempty_bwd : forall b n (fr ba : W),
    fr <> 0
    -> focusOnFront
    -> (Ex n', Ex v1, Ex v2, Ex p, [| n = S n' |] * [| (v1, v2) %in b |]
      * (fr ==*> v1, v2, p) * [| freeable fr 3 |] * [| ifZero n' fr ba |] * llist (b %- (v1, v2)) n' p ba) ===> llist b n fr ba.

  Axiom llist_end_bwd : forall (ba : W) n (fr : W) b,
    fr <> 0
    -> focusOnBack
    -> (Ex v1, Ex v2, Ex v1', Ex v2', Ex n', Ex p,
      [| n = S (S n') |] * [| (v1', v2') %in b |] * [| (v1, v2) %in b %- (v1', v2')|]
      * lseg (b %- (v1, v2) %- (v1', v2')) n' fr p
      * [| p <> 0 |] * [| freeable p 3 |] * (p ==*> v1, v2, ba)
      * [| ba <> 0 |] * [| freeable ba 3 |] * (ba ==*> v1', v2', $0))
    ===> llist b n fr ba.
End QUEUE.

Module Queue : QUEUE.
  Open Scope Sep_scope.

  Fixpoint llist (b : bag) (n : nat) (fr ba : W) : HProp :=
    match n with
      | O => [| fr = 0 /\ b %= empty |]
      | S n' => [| fr <> 0 |] * Ex v1, Ex v2, Ex p, [| (v1, v2) %in b |] * (fr ==*> v1, v2, p) * [| freeable fr 3 |] * [| ifZero n' fr ba |] * llist (b %- (v1, v2)) n' p ba
    end.

  Fixpoint lseg (b : bag) (n : nat) (fr ba : W) : HProp :=
    match n with
      | O => [| fr = ba /\ b %= empty |]
      | S n' => [| fr <> 0 |] * Ex v1, Ex v2, Ex p, [| (v1, v2) %in b |] * (fr ==*> v1, v2, p) * [| freeable fr 3 |] * lseg (b %- (v1, v2)) n' p ba
    end.

  Definition queue (b : bag) (p : W) : HProp :=
    Ex fr, Ex ba, Ex n, [| freeable p 2 |] * (p ==*> fr, ba) * llist b n fr ba.

  Theorem llist_extensional : forall b n fr ba, HProp_extensional (llist b n fr ba).
    destruct n; reflexivity.
  Qed.

  Theorem lseg_extensional : forall b n fr ba, HProp_extensional (lseg b n fr ba).
    destruct n; reflexivity.
  Qed.

  Theorem queue_extensional : forall b p, HProp_extensional (queue b p).
    reflexivity.
  Qed.

  Theorem lseg_extensional' : forall ba n b b' fr,
    b %= b'
    -> lseg b n fr ba ===> lseg b' n fr ba.
    induction n; sepLemma.
  Qed.

  Theorem llist_extensional' : forall ba n b b' fr,
    b %= b'
    -> llist b n fr ba ===> llist b' n fr ba.
    induction n; sepLemma.
  Qed.

  Theorem queue_fwd : forall b p,
    queue b p
    ===> Ex fr, Ex ba, Ex n, [| freeable p 2 |] * (p ==*> fr, ba) * llist b n fr ba.
    unfold queue; sepLemma.
  Qed.

  Theorem queue_bwd : forall b p,
    (Ex fr, Ex ba, Ex n, [| freeable p 2 |] * (p ==*> fr, ba) * llist b n fr ba)
    ===> queue b p.
    unfold queue; sepLemma.
  Qed.

  Theorem llist_empty_fwd : forall b n (fr : W) ba,
    fr = 0
    -> llist b n fr ba ===> [| b %= empty |] * [| n = O |].
    destruct n; sepLemma.
  Qed.

  Theorem llist_empty_bwd : forall b n (fr : W) ba,
    fr = 0
    -> [| b %= empty |] * [| n = O |] ===> llist b n fr ba.
    destruct n; sepLemma.
  Qed.

  Theorem llist_nonempty_fwd : forall ba n (fr : W) b,
    fr <> 0
    -> focusOnFront
    -> llist b n fr ba ===> Ex n', Ex v1, Ex v2, Ex p, [| n = S n' |] * [| (v1, v2) %in b |] * [| freeable fr 3 |] * (fr ==*> v1, v2, p) * [| ifZero n' fr ba |] * llist (b %- (v1, v2)) n' p ba.
    destruct n; sepLemma.
  Qed.

  Theorem llist_end_fwd : forall ba n (fr : W) b,
    fr <> 0
    -> focusOnBack
    -> llist b n fr ba ===> Ex n', Ex v1, Ex v2, [| n = S n' |] * [| (v1, v2) %in b |] * lseg (b %- (v1, v2)) n' fr ba * [| ba <> 0 |] * [| freeable ba 3 |] * (ba ==*> v1, v2, $0).
    induction n.

    sepLemma.

    sepLemmaLhsOnly.
    destruct n.
    specialize (H4 (refl_equal _)); subst.
    sepLemma.
    sepLemma.
    clear H4.
    transitivity ([| x <> 0 |] * llist (b %- (x1, x0)) (S n) x ba *
      SEP.ST.star (fr =*> x1)
        (SEP.ST.star ((fr ^+ $4) =*> x0) ((fr ^+ $8) =*> x))).
    sepLemma.
    remember (S n).
    sepLemmaLhsOnly.
    etransitivity.
    eapply himp_star_frame; [ auto | reflexivity ].
    sepLemma.
    sepLemma.
    injection H4; clear H4; intros; subst.
    apply lseg_extensional'; bags.
  Qed.

  Theorem llist_nonempty_fwd_b : forall b n (fr : W) ba,
    ~(b %= empty)
    -> focusOnFront
    -> llist b n fr ba ===> [| fr <> 0 |] * Ex n', Ex v1, Ex v2, Ex p, [| n = S n' |] * [| (v1, v2) %in b |]
      * (fr ==*> v1, v2, p) * [| freeable fr 3 |] * [| ifZero n' fr ba |] * llist (b %- (v1, v2)) n' p ba.
    destruct n; sepLemma.
  Qed.

  Theorem llist_nonempty_bwd : forall b n (fr ba : W),
    fr <> 0
    -> focusOnFront
    -> (Ex n', Ex v1, Ex v2, Ex p, [| n = S n' |] * [| (v1, v2) %in b |]
      * (fr ==*> v1, v2, p) * [| freeable fr 3 |] * [| ifZero n' fr ba |] * llist (b %- (v1, v2)) n' p ba) ===> llist b n fr ba.
    destruct n; sepLemma; match goal with
                            | [ H : S _ = S _ |- _ ] => injection H; intros; subst
                          end; auto; sepLemma.
  Qed.

  Lemma llist_end_bwd' : forall (ba : W) n (fr : W) b,
    (Ex v1, Ex v2, Ex v1', Ex v2', Ex n', Ex p,
      [| n = S (S n') |] * [| (v1', v2') %in b |] * [| (v1, v2) %in b %- (v1', v2')|]
      * lseg (b %- (v1, v2) %- (v1', v2')) n' fr p
      * [| p <> 0 |] * [| freeable p 3 |] * (p ==*> v1, v2, ba)
      * [| ba <> 0 |] * [| freeable ba 3 |] * (ba ==*> v1', v2', $0))
    ===> llist b n fr ba.
    induction n.

    sepLemma.

    destruct n.
    sepLemma.

    destruct n.
    sepLemmaLhsOnly.
    injection H; clear H; intros; subst.
    sepLemmaLhsOnly.
    sepLemma.

    remember (S (S n)).
    sepLemmaLhsOnly.
    remember (S (S n)).
    replace x0 with (S n) by omega.
    sepLemmaLhsOnly.
    remember (S (S n)).
    sepLemma.
    etransitivity; try apply IHn.
    sepLemma.
    apply lseg_extensional'; bags.
  Qed.

  Theorem llist_end_bwd : forall (ba : W) n (fr : W) b,
    fr <> 0
    -> focusOnBack
    -> (Ex v1, Ex v2, Ex v1', Ex v2', Ex n', Ex p,
      [| n = S (S n') |] * [| (v1', v2') %in b |] * [| (v1, v2) %in b %- (v1', v2')|]
      * lseg (b %- (v1, v2) %- (v1', v2')) n' fr p
      * [| p <> 0 |] * [| freeable p 3 |] * (p ==*> v1, v2, ba)
      * [| ba <> 0 |] * [| freeable ba 3 |] * (ba ==*> v1', v2', $0))
    ===> llist b n fr ba.
    intros; apply llist_end_bwd'.
  Qed.
End Queue.

Import Queue.
Export Queue.

Hint Immediate llist_extensional lseg_extensional queue_extensional.

Definition hints : TacPackage.
  prepare (queue_fwd, llist_empty_fwd, llist_nonempty_fwd, llist_end_fwd, llist_nonempty_fwd_b)
  (queue_bwd, llist_empty_bwd, llist_nonempty_bwd, llist_end_bwd).
Defined.

(** * The code *)

Definition initS := initS queue 8.
Definition isEmptyS := isEmptyS queue 0.
Definition dequeueS := dequeueS queue 8.
Definition enqueueS := enqueueS queue 10.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "queue" {{
  bfunction "init"("r") [initS]
    "r" <-- Call "malloc"!"malloc"(0, 2)
    [PRE[_, R] R =?> 2 * [| freeable R 2 |]
     POST[R'] [| R' = R |] * queue empty R ];;
    "r" *<- 0;;
    Return "r"
  end with bfunction "isEmpty"("b") [isEmptyS]
    "b" <-* "b";;
    If ("b" = 0) {
      Return 1
    } else {
      Note [focusOnFront];;
      Return 0
    }
  end with bfunction "enqueue"("b", "v1", "v2", "r", "tmp", "tmp2") [enqueueS]
    "r" <-- Call "malloc"!"malloc"(0, 3)
    [Al b,
      PRE[V, R] queue b (V "b") * R =?> 3 * [| R <> 0 |] * [| freeable R 3 |]
      POST[_] queue (b %+ (V "v1", V "v2")) (V "b")];;

    "r" *<- "v1";;
    "tmp" <- "r" + 4;;
    "tmp" *<- "v2";;
    "tmp" <- "r" + 8;;
    "tmp" *<- 0;;

    "tmp" <-* "b";;
    If ("tmp" = 0) {
      (* Empty queue *)
      Note [focusOnFront];;

      "b" *<- "r"
    } else {
      (* Nonempty queue *)
      Note [focusOnBack];;

      "tmp" <- "b" + 4;;
      "tmp" <-* "tmp";;
      "tmp" <- "tmp" + 8;;
      "tmp" *<- "r"
    };;

    "tmp" <- "b" + 4;;
    "tmp" *<- "r";;

    Return 0
  end with bfunction "dequeue"("b", "r", "fr", "tmp") [dequeueS]
    Note [focusOnFront];;

    "fr" <-* "b";;

    "tmp" <-* "fr";;
    "r" *<- "tmp";;
    "tmp" <- "fr" + 4;;
    "tmp" <-* "tmp";;
    "r" <- "r" + 4;;
    "r" *<- "tmp";;

    "tmp" <- "fr" + 8;;
    "tmp" <-* "tmp";;
    "b" *<- "tmp";;

    If ("tmp" = 0) {
      "b" <- "b" + 4;;
      "b" *<- 0
    } else {
      Skip
    };;

    Call "malloc"!"free"(0, "fr", 3)
    [PRE[_] Emp
     POST[_] Emp];;
    Return 0
  end
}}.

Local Hint Extern 5 (@eq W _ _) => words.
Local Hint Extern 1 (himp _ (lseg _ _ _ _) (lseg _ _ _ _)) => apply lseg_extensional'.
Local Hint Extern 1 (himp _ (llist _ _ _ _) (llist _ _ _ _)) => apply llist_extensional'.

Theorem ok : moduleOk m.
  vcgen; abstract (sep hints; auto).
Qed.


From Coq Require Import ssreflect.
Require Import List.

Inductive state_diag :=
| POWERON
| IDLE : nat -> state_diag
| DETECT : nat -> state_diag.

Inductive input_port :=
| INPUT : bool -> bool -> bool -> input_port.

Variables reset_IDLE reset_DETECT : nat.

Definition transition (s : state_diag) (p : input_port) :=
  match s, p with
  | POWERON, INPUT _  _ _ => IDLE reset_IDLE
  | IDLE n, INPUT false true _ => match n with
                              | O => DETECT reset_DETECT
                              | S O => DETECT reset_DETECT
                              | S m => IDLE m
                              end
  | IDLE _, INPUT true _ _ => IDLE reset_IDLE
  | IDLE _, INPUT _ false _ => IDLE reset_IDLE
  | DETECT n, INPUT false _ true => match n with
                                    | O => IDLE reset_IDLE
                                    | S O => IDLE reset_IDLE
                                    | S m => DETECT m
                                    end
  | DETECT _, INPUT true _ _ => DETECT reset_DETECT
  | DETECT _, INPUT _ _ false => DETECT reset_DETECT
end.

Fixpoint block_states (s : state_diag) (ts : list input_port) :=
  match ts with
  | nil => nil
  | x :: xs =>
    let cur_state := transition s x in
    cur_state :: block_states cur_state xs
  end.

Definition block_output (s : state_diag) :=
  match s with
  | DETECT _ => true
  | _ => false
  end.

Definition block_outputs (ts : list input_port) :=
  map block_output (block_states POWERON ts).


From Undecidability.Shared Require Import Dec.
From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ReducibilityFacts.
From Undecidability.Synthetic Require Import ListEnumerabilityFacts MoreEnumerabilityFacts.
From Undecidability Require Import Synthetic.Undecidability.
From Equations Require Import Equations.
Require Import ConstructiveEpsilon.
Require Import List.
Import ListNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* *** Post's theorem: bi-enumerable logically decidable predicates over discrete domain are decidable *)

Definition mu (p : nat -> Prop) :
  (forall x, dec (p x)) -> ex p -> sig p.
Proof.
  apply constructive_indefinite_ground_description_nat_Acc.
Qed.

Definition ldecidable {X} (p : X -> Prop) :=
  forall x, p x \/ ~ p x.

Theorem weakPost X (p : X -> Prop) :
  discrete X -> ldecidable p -> enumerable p -> enumerable (fun x => ~ p x) -> decidable p.
Proof.
  intros [E] % discrete_iff Hl [f Hf] [g Hg].
  eapply decidable_iff. econstructor. intros x.
  assert (exists n, f n = Some x \/ g n = Some x) by (destruct (Hl x); firstorder).
  destruct (@mu (fun n => f n = Some x \/ g n = Some x)) as [n HN]; trivial.
  - intros n. exact _.
  - decide (f n = Some x); decide (g n = Some x); firstorder.
Qed.

Definition MP := forall (f : nat -> bool), ~ ~ (exists n, f n = true) -> exists n, f n = true.

Lemma MP_dec :
  MP -> forall (P : nat -> Prop), (forall n, dec (P n)) -> ~ ~ (exists n, P n) -> exists n, P n.
Proof.
 intros mp P HD HP. destruct (mp (fun n => if HD n then true else false)) as [n Hn].
 - intros H. apply HP. intros [n Hn]. apply H. exists n. destruct (HD n); tauto.
 - exists n. destruct (HD n); trivial. discriminate.
Qed.

Lemma MP_Post X (p : X -> Prop) :
  MP -> discrete X -> enumerable p -> enumerable (fun x => ~ p x) -> decidable p.
Proof.
  intros mp [E] % discrete_iff [f Hf] [g Hg].
  eapply decidable_iff. econstructor. intros x.
  assert (exists n, f n = Some x \/ g n = Some x).
  { apply (MP_dec mp).
    - intros n. exact _.
    - intros H. assert (H' : ~ ~ (p x \/ ~ p x)) by tauto. apply H'. intros [Hp|Hp].
      + apply H. apply Hf in Hp as [n Hn]. exists n. now left.
      + apply H. apply Hg in Hp as [n Hn]. exists n. now right. }
  destruct (@mu (fun n => f n = Some x \/ g n = Some x)) as [n HN]; trivial.
  - intros n. exact _.
  - decide (f n = Some x); decide (g n = Some x); firstorder.
Qed.

Lemma MP_stable_enumerable X :
  MP -> forall (P : X -> Prop), enumerable P -> eq_dec X -> forall x, ~~P x -> P x.
Proof.
  intros mp P [f Hf] Hdec.
  assert (forall x, P x <-> exists n,
       (fun n => if option_eq_dec Hdec (Some x) (f n) then true else false) n = true) as Heq.
  { intros x. split.
    + intros Hx. destruct (Hf x) as [Hl Hr]. destruct (Hl Hx) as [n Hn]. exists n.
      destruct option_eq_dec; try congruence.
    + intros [n Hn]. destruct option_eq_dec; try congruence. apply Hf. now exists n. }
  intros x. rewrite Heq.
  apply mp.
Qed.


Require Import Coqlib.
Require Import List. Import ListNotations.

Definition HMAC_DRBG_update (HMAC: list Z -> list Z -> list Z) (provided_data K V: list Z): (list Z * list Z) :=
  let K := HMAC (V ++ [0] ++ provided_data) K in
  let V := HMAC V K in
  match provided_data with
    | [] => (K, V)
    | _::_ =>
      let K := HMAC (V ++ [1] ++ provided_data) K in
      let V := HMAC V K in
      (K, V)
  end.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Constructive_Dilemma.

Coq < Goal forall p q r s:Prop, (((p -> q) /\ (r ->s)) /\ (p \/ r)) -> (q \/ s).
1 subgoal

  ============================
   forall p q r s : Prop, ((p -> q) /\ (r -> s)) /\ (p \/ r) -> q \/ s

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  ============================
   q \/ s

Unnamed_thm < elim H.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  ============================
   (p -> q) /\ (r -> s) -> p \/ r -> q \/ s

Unnamed_thm < intro.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  ============================
   p \/ r -> q \/ s

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  ============================
   q \/ s

Unnamed_thm < elim H0.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  ============================
   (p -> q) -> (r -> s) -> q \/ s

Unnamed_thm < elim H1.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  ============================
   p -> (p -> q) -> (r -> s) -> q \/ s

subgoal 2 is:
 r -> (p -> q) -> (r -> s) -> q \/ s

Unnamed_thm < intro.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : p
  ============================
   (p -> q) -> (r -> s) -> q \/ s

subgoal 2 is:
 r -> (p -> q) -> (r -> s) -> q \/ s

Unnamed_thm < intro.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  ============================
   (r -> s) -> q \/ s

subgoal 2 is:
 r -> (p -> q) -> (r -> s) -> q \/ s

Unnamed_thm < intro.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   q \/ s

subgoal 2 is:
 r -> (p -> q) -> (r -> s) -> q \/ s

Unnamed_thm < 2:intro.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   q \/ s

subgoal 2 is:
 (p -> q) -> (r -> s) -> q \/ s

Unnamed_thm < 2:intro.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   q \/ s

subgoal 2 is:
 (r -> s) -> q \/ s

Unnamed_thm < 2:intro.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   q \/ s

subgoal 2 is:
 q \/ s

Unnamed_thm < destruct H as [H5 H6].
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H5 : (p -> q) /\ (r -> s)
  H6 : p \/ r
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   q \/ s

subgoal 2 is:
 q \/ s

Unnamed_thm < destruct H0.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H5 : (p -> q) /\ (r -> s)
  H6 : p \/ r
  H : p -> q
  H0 : r -> s
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   q \/ s

subgoal 2 is:
 q \/ s

Unnamed_thm < left.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H5 : (p -> q) /\ (r -> s)
  H6 : p \/ r
  H : p -> q
  H0 : r -> s
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   q

subgoal 2 is:
 q \/ s

Unnamed_thm < apply H.
2 subgoals

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H5 : (p -> q) /\ (r -> s)
  H6 : p \/ r
  H : p -> q
  H0 : r -> s
  H1 : p \/ r
  H2 : p
  H3 : p -> q
  H4 : r -> s
  ============================
   p

subgoal 2 is:
 q \/ s

Unnamed_thm < exact H2.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : r
  H3 : p -> q
  H4 : r -> s
  ============================
   q \/ s

Unnamed_thm < apply or_intror.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : r
  H3 : p -> q
  H4 : r -> s
  ============================
   s

Unnamed_thm < apply H4.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  s : Prop
  H : ((p -> q) /\ (r -> s)) /\ (p \/ r)
  H0 : (p -> q) /\ (r -> s)
  H1 : p \/ r
  H2 : r
  H3 : p -> q
  H4 : r -> s
  ============================
   r

Unnamed_thm < exact H2.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intros.
elim H0.
elim H1.
 intro.
 intro.
 intro.
 2: intro.
 2: intro.
 2: intro.
 destruct H as (H5, H6).
 destruct H0.
 left.
 apply H.
 exact H2.

 apply or_intror.
 apply H4.
 exact H2.

Unnamed_thm is defined

Coq <

*)

Section Constructive_Dilemma.
Goal forall p q r s:Prop, (((p -> q) /\ (r ->s)) /\ (p \/ r)) -> (q \/ s).
intros.
elim H.
intro.
intros.
elim H0.
elim H1.
 intro.
 intro.
 intro.
 2: intro.
 2: intro.
 2: intro.
 destruct H as (H5, H6).
 destruct H0.
 left.
 apply H.
 exact H2.
 apply or_intror.
 apply H4.
 exact H2.
Qed.


(** * Natural transformations involving product categories *)
Require Import Category.Core Functor.Core Category.Prod Functor.Prod.Core NaturalTransformation.Core.
Require Functor.Composition.Core Functor.Identity.
Require Import InitialTerminalCategory.Core.
Require Import Types.Prod.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** ** Product of natural transformations *)
Section prod.
  Context {A : PreCategory}.
  Context {B : PreCategory}.
  Context {C : PreCategory}.
  Variables F F' : Functor A B.
  Variables G G' : Functor A C.
  Variable T : NaturalTransformation F F'.
  Variable U : NaturalTransformation G G'.

  Definition prod
  : NaturalTransformation (F * G) (F' * G')
    := Build_NaturalTransformation
         (F * G) (F' * G')
         (fun x : A => (T x, U x))
         (fun _ _ _ => path_prod' (commutes T _ _ _) (commutes U _ _ _)).
End prod.

Local Infix "*" := prod : natural_transformation_scope.

(** ** Natural transformations between partially applied functors *)
Section induced.
  Variables C D E : PreCategory.

  Variable F : Functor (C * D) E.

  Local Ltac t :=
    simpl; intros;
    rewrite <- !composition_of;
    simpl;
    rewrite ?left_identity, ?right_identity;
    reflexivity.

  Definition induced_fst s d (m : morphism C s d)
  : NaturalTransformation (Functor.Prod.Core.induced_snd F s)
                          (Functor.Prod.Core.induced_snd F d).
  Proof.
    let F0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(F0) end in
    let G0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(G0) end in
    refine (Build_NaturalTransformation
              F0 G0
              (fun d => @morphism_of _ _ F (_, _) (_, _) (m, @identity D d))
              _).
    abstract t.
  Defined.

  Definition induced_snd s d (m : morphism D s d)
  : NaturalTransformation (Functor.Prod.Core.induced_fst F s)
                          (Functor.Prod.Core.induced_fst F d).
  Proof.
    let F0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(F0) end in
    let G0 := match goal with |- NaturalTransformation ?F0 ?G0 => constr:(G0) end in
    refine (Build_NaturalTransformation
              F0 G0
              (fun c => @morphism_of _ _ F (_, _) (_, _) (@identity C c, m))
              _).
    abstract t.
  Defined.
End induced.

Module Export NaturalTransformationProdNotations.
  Infix "*" := prod : natural_transformation_scope.
End NaturalTransformationProdNotations.


Require Import List Omega.

Import ListNotations.

Ltac rewrite_each :=
  match goal with
  | H : _ |- _ => rewrite H || rewrite <- H
  end.

Ltac simpl_hyp :=
  match goal with
  | H : ?a = ?b |- _ => progress (simpl in H)
  | H : _ |- _       => progress (rewrite app_nil_r in H)
  | _ : _ |- _       => progress (rewrite app_nil_r)
  | H : ex _ |- _    => destruct H
  end.

Hint Rewrite app_assoc : standard.

Lemma app_not_empty :
  forall (A : Type) (x : A) (xs ys : list A), xs ++ (x :: ys) <> [].
Proof.
intuition.
induction xs.
simpl in H.
inversion H.
simpl in H.
inversion H.
Qed.

Ltac impossible :=
  match goal with
  | H : _ :: _ = [] |- _ => inversion H
  | H : [] = _ :: _ |- _ => inversion H
  | H : _ ++ (_ :: _) = [] |- _ => apply app_not_empty in H; contradiction
  | H : [] = _ ++ (_ :: _) |- _ => symmetry in H; apply app_not_empty in H; contradiction
  end.

Tactic Notation "prove" int_or_var(n) "with" tactic(tac) :=
  do n (
    intuition;
    try simpl_hyp;
    try impossible;
    try (autorewrite with standard);
    try congruence;
    try rewrite_each;
    try tac).

Tactic Notation "prove" "stop" int_or_var(n) := prove n with idtac.
Tactic Notation "prove" "with" tactic(tac) := prove 5 with tac.

Tactic Notation "quick" tactic(tac) := tac; prove with idtac.

Tactic Notation "autoinduction" ident(x) "with" tactic(tac) :=
    induction x;

    intuition;
    simpl;
    prove with tac;

    intuition;
    simpl;
    prove with tac.

Tactic Notation "auto_rev_ind" ident(x) "with" tactic(tac) :=
    try (generalize x);
    apply rev_ind;

    intuition;
    simpl;
    prove with tac;

    intuition;
    simpl;
    prove with tac.

Tactic Notation "autoinduction" "on" ident(x) := autoinduction x with idtac.
Tactic Notation "auto_rev_ind" "on" ident(x) := auto_rev_ind x with idtac.


Require Export Iron.Language.SystemF2Data.Exp.Base.
Require Export Iron.Language.SystemF2Data.Exp.Alt.

(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx

  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)  (liftTT 1 d t)

  |  XLam t x
  => XLam (liftTT 1 d t)  (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1) (liftTX d x2)

  |  XCon dc ts xs
  => XCon dc (map (liftTT 1 d) ts) (map (liftTX d) xs)

  |  XCase xx alts
  => XCase (liftTX d xx) (map (liftTA d) alts)

  |  XPrim p xs
  => XPrim p (map (liftTX d) xs)

  |  XLit l
  => XLit l
 end

 with liftTA (d: nat) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (liftTX d xx)
  end.

(* Data constructor of alternative is unchanged by lifting. *)
Lemma dcOfAlt_liftTA
 : forall d a
 , dcOfAlt (liftTA d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftTA : global.

(* Data constructor of alternatives are unchaged by lifting. *)
Lemma dcOfAlt_liftTA_map
 :  forall ix aa
 ,  map dcOfAlt (map (liftTA ix) aa)
 =  map dcOfAlt aa.
Proof.
 intros. induction aa; snorm; rewritess; eauto.
Qed.
Hint Rewrite dcOfAlt_liftTA_map : global.


From Undecidability Require StringRewriting.SR.
From Undecidability Require Import TM.SBTM TM.Util.SBTM_facts.

Require Import PeanoNat Lia.

Require Import List ssreflect ssrbool ssrfun.
Import ListNotations SBTMNotations.

Set Default Goal Selector "!".

Section Construction.
  (* input SBTM *)
  Context (M : SBTM).
  #[local] Notation "⦇" := 0.
  #[local] Notation "⦈" := 1.
  Definition encode_symbol (a: bool) := if a then 2 else 3.
  #[local] Notation "# a" := (encode_symbol a) (at level 1).

  Definition encode_state (q: state M) := 4 + proj1_sig (Fin.to_nat q).

  Arguments encode_state : simpl never.

  Definition encode_config (q : state M) (t : tape) : SR.string nat :=
    match t with
    | (ls, a, rs) =>
        ⦇ :: (rev (map encode_symbol ls)) ++ [encode_symbol a] ++ [encode_state q] ++ (map encode_symbol rs) ++ [⦈]
    end.

  Fixpoint all_fins (n : nat) : list (Fin.t n) :=
    match n with
    | 0 => nil
    | S n => Fin.F1 :: map Fin.FS (all_fins n)
    end.

  Lemma all_fins_spec {n} i : In i (all_fins n).
  Proof. by elim: i => >; [left|right; apply: in_map]. Qed.

  Definition encode_rule '(q, a) :=
    match trans' M (q, a) with
    | None => [
      ([⦇; #a; encode_state q; ⦈], [⦈; ⦇]);
      ([#true; #a; encode_state q], [#a; encode_state q]);
      ([#false; #a; encode_state q], [#a; encode_state q]);
      ([#a; encode_state q; #true], [#a; encode_state q]);
      ([#a; encode_state q; #false], [#a; encode_state q])]
    | Some (q', a', go_left) => [
        ([⦇; #a; encode_state q], [⦇; #false; encode_state q'; #a']);
        ([#true; #a; encode_state q], [#true; encode_state q'; #a']);
        ([#false; #a; encode_state q], [#false; encode_state q'; #a'])]
    | Some (q', a', go_right) => [
        ([#a; encode_state q; ⦈], [#a'; #false; encode_state q'; ⦈]);
        ([#a; encode_state q; #true], [#a'; #true; encode_state q']);
        ([#a; encode_state q; #false], [#a'; #false; encode_state q'])]
    end.

  Definition srs : SR.SRS nat :=
    flat_map encode_rule (list_prod (all_fins (num_states M)) ([true; false])).

  Inductive In_srs : SR.string nat -> SR.string nat -> Prop :=
    | In_srs_f {q a} : trans' M (q, a) = None ->
        In_srs [⦇; #a; encode_state q; ⦈] [⦈; ⦇]
    | In_srs_dl {q a} : trans' M (q, a) = None ->
        forall b, In_srs [#b; #a; encode_state q] [#a; encode_state q]
    | In_srs_dr {q a} : trans' M (q, a) = None ->
        forall b, In_srs [#a; encode_state q; #b] [#a; encode_state q]
    | In_srs_l1 {q a q' a'} : trans' M (q, a) = Some (q', a', go_left) ->
        In_srs [⦇; #a; encode_state q] [⦇; #false; encode_state q'; #a']
    | In_srs_l2 {q a q' a'} : trans' M (q, a) = Some (q', a', go_left) ->
        forall b, In_srs [#b; #a; encode_state q] [#b; encode_state q'; #a']
    | In_srs_r1 {q a q' a'} : trans' M (q, a) = Some (q', a', go_right) ->
        In_srs [#a; encode_state q; ⦈] [#a'; #false; encode_state q'; ⦈]
    | In_srs_r2 {q a q' a'} : trans' M (q, a) = Some (q', a', go_right) ->
        forall b, In_srs [#a; encode_state q; #b] [#a'; #b; encode_state q'].

  Lemma In_srsE u v : In_srs u v -> In (u, v) srs.
  Proof.
    case=> q a > E => [|[]|[]||[]||[]].
    all: have ? : In a [true; false] by (case: (a) => /=; tauto).
    all: have ? := all_fins_spec q.
    all: apply /in_flat_map; exists (q, a).
    all: split; first by apply: in_prod.
    all: by rewrite /= E /=; tauto.
  Qed.

  Lemma In_srsI u v : In (u, v) srs -> In_srs u v.
  Proof.
    move=> /in_flat_map [[q a]] [_] /=.
    case E: (trans' M (q, a)) => [[[q' a'] []]|] /=.
    - move=> [|[|[|[]]]] => - [<- <-].
      all: by auto using In_srs_l1, (In_srs_l2 _ true), (In_srs_l2 _ false).
    - move=> [|[|[|[]]]] => - [<- <-].
      all: by auto using In_srs_r1, (In_srs_r2 _ true), (In_srs_r2 _ false).
    - move=> [|[|[|[|[|[]]]]]] => - [<- <-].
      all: by auto using In_srs_f, (In_srs_dl _ true), (In_srs_dl _ false),
        (In_srs_dr _ true), (In_srs_dr _ false).
  Qed.

  (* step simulation *)
  Lemma simulation_step q t q' t' : step M (q, t) = Some (q', t') ->
    SR.rew srs (encode_config q t) (encode_config q' t').
  Proof.
    rewrite /step. move: t => [[ls a] rs].
    move E: (trans' M (q, a)) => [[[q'' a''] d]|]; last done.
    move=> [] <- <- /=.
    move: d ls rs E => [] => [[|l ls] rs|ls [|r rs]].
    - move=> /In_srs_l1 /In_srsE /SR.rewB.
      by move=> /(_ [] (map encode_symbol rs ++ [⦈])).
    - move=> /In_srs_l2 /(_ l) /In_srsE /SR.rewB.
      move=> /(_ (⦇ :: rev (map encode_symbol ls)) (map encode_symbol rs ++ [⦈])).
      by rewrite /= -!app_assoc.
    - move=> /In_srs_r1 /In_srsE /SR.rewB.
      move=> /(_ (⦇ :: rev (map encode_symbol ls)) []).
      by rewrite /= -!app_assoc.
    - move=> /In_srs_r2 /(_ r) /In_srsE /SR.rewB.
      move=> /(_ (⦇ :: rev (map encode_symbol ls)) (map encode_symbol rs ++ [⦈])).
      by rewrite /= -!app_assoc.
  Qed.

  Lemma simulation_halt q t : step M (q, t) = None ->
    SR.rewt srs (encode_config q t) [⦈; ⦇].
  Proof.
    rewrite /step. move: t => [[ls a] rs].
    move E: (trans' M (q, a)) => [[[q'' a''] d]|]; first done.
    move=> _. elim: ls.
    { elim: rs.
      { apply: SR.rewS; [|by apply: SR.rewR].
        by move: E => /In_srs_f /In_srsE /SR.rewB => /(_ [] []). }
      move=> r rs IH. apply: SR.rewS; [|by eassumption].
      move: E => /In_srs_dr /(_ r) /In_srsE /SR.rewB.
      by move=> /(_ [⦇] (map encode_symbol rs ++ [⦈])). }
    move=> l ls IH. apply: SR.rewS; [|by eassumption].
    move: E => /In_srs_dl /(_ l) /In_srsE /SR.rewB.
    move=> /(_ (⦇ :: rev (map encode_symbol ls)) (map encode_symbol rs ++ [⦈])).
    by rewrite /= -!app_assoc.
  Qed.

  Lemma simulation q t k :
    steps M k (q, t) = None ->
    SR.rewt srs (encode_config q t) [⦈; ⦇].
  Proof.
    elim: k q t; first done.
    move=> k IH q t.
    rewrite (steps_plus 1 k). case E: (steps M 1 _) => [[q' t']|].
    - move: E => /simulation_step ?.
      move=> /IH. apply: SR.rewS; by eassumption.
    - by move: E => /simulation_halt.
  Qed.

  Lemma encode_symbol_inj a b : #a = #b -> a = b.
  Proof. by move: a b => [] []. Qed.

  Lemma encode_config_eq_app q ls a rs u v a' q' :
    encode_config q (ls, a, rs) = u ++ [#a'; encode_state q'] ++ v ->
    q = q' /\ a = a' /\
    u = ⦇ :: rev (map encode_symbol ls) /\ v = (map encode_symbol rs) ++ [⦈].
  Proof.
    move: u => [|c u]. { by case: a'. }
    move=> /= [<-]. elim /rev_ind: ls u => /=.
    { move=> [|{}c u].
      { move=> [] /encode_symbol_inj ? /Fin.to_nat_inj ? <-. tauto. }
      move: u => [|c' u]. { by case: (a'). }
      move=> [] _ _ E. exfalso.
      have : In (encode_state q') (u ++ # a' :: encode_state q' :: v).
      { apply /in_app_iff => /=. tauto. }
      rewrite -E. elim: rs {E}. { by case. }
      by move=> [] rs IH /= []. }
    move=> l ls IH u. rewrite map_app rev_unit.
    move: u => [|{}c u].
    - move=> [] _.
      elim /rev_ind: (ls).
      + move=> []. by case: (a).
      + move=> {}c > _. rewrite map_app rev_unit. move=> []. by case: (c).
    - move=> [<-] /IH [<-] [<-] [[-> ->]]. tauto.
  Qed.

  Lemma inverse_simulation_step q t x q' t' :
    SR.rew srs (encode_config q t) x ->
    step M (q, t) = Some (q', t') ->
    x = encode_config q' t'.
  Proof.
    have reassoc (n m : nat) (u v : list nat) : u ++ (n :: m :: v) = (u ++ [n]) ++ m :: v.
    { by rewrite -app_assoc. }
    move Ey: (encode_config q t) => y Hyx.
    move: t Hyx Ey => [[ls a] rs] [] u v > /In_srsI [].
    - move=> > + H. move: H. rewrite (reassoc ⦇).
      move=> /encode_config_eq_app [<-] [<-]. by rewrite /step => _ ->.
    - move=> > + b H. move: H. rewrite (reassoc #b).
      move=> /encode_config_eq_app [<-] [<-]. by rewrite /step => _ ->.
    - move=> > + b H. move: H.
      move=> /encode_config_eq_app [<-] [<-]. by rewrite /step => _ ->.
    - move=> q'' a'' > + H. move: H. rewrite !(reassoc ⦇).
      move=> /encode_config_eq_app [<-] [<-] [].
      case: ls => [|l ?] /=.
      + rewrite /step. by move=> -> -> -> [] <- <-.
      + move=> /(app_inj_tail _ (_ :: _) _ (#l)) []. by case: l.
    - move=> ???? + b H. move: H. rewrite !(reassoc #b).
      move=> /encode_config_eq_app [<-] [<-] [].
      case: ls => [|l ?] /=.
      + move=> /(@app_inj_tail nat _ []) []. by case: b.
      + rewrite /step. move=> -> -> -> [] <- <- /=.
        by rewrite -app_assoc.
    - move=> > + H. move: H.
      move=> /encode_config_eq_app [<-] [<-] [->].
      case: rs => [|r ?]; last by case: r.
      case: v; last done.
      rewrite /step. move=> _ -> [] <- <- /=.
      by rewrite -app_assoc.
    - move=> ???? + b H. move: H.
      move=> /encode_config_eq_app [<-] [<-] [->].
      case: rs => [|r ?]; first by case: b.
      move=> [/encode_symbol_inj ->] ->.
      rewrite /step. move=> -> [] <- <- /=.
      by rewrite -app_assoc.
  Qed.

  Lemma inverse_simulation q t :
    SR.rewt srs (encode_config q t) [⦈; ⦇] ->
    exists k, steps M k (q, t) = None.
  Proof.
    move Eu: (encode_config q t) => u.
    move Ev: [⦈; ⦇] => v Huv.
    elim: Huv q t Eu Ev. { by move=> ?? [[??]?] <-. }
    move=> x y z + _ + q t ??. subst x z.
    case E: (step M (q, t)) => [[q' t']|]; first last.
    { move=> *. by exists 1. }
    move: (E) => /inverse_simulation_step /[apply] ->.
    move=> /(_ _ _ erefl erefl) [k] Hk.
    exists (1+k). by rewrite steps_plus /= E.
  Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

Theorem reduction :
  SBTM_HALT ⪯ SR.SR.
Proof.
  exists ((fun '(existT _ M (q, t)) => (srs M, encode_config M q t, [1; 0]))).
  move=> [M [q t]] /=. split.
  - by move=> [?] /simulation.
  - by apply: inverse_simulation.
Qed.


(*** Coq coding by choukh, Aug 2022 ***)

Require Export Prelim.

(** 序数 **)
Section Ordinal.

(* 全集 *)
Variable U : Type.
(* X的子集 *)
Implicit Types a b c : 𝒫 U.
(* X的子集族, 可能有⊆良序 *)
Implicit Types A B C : 𝒫 𝒫 U.
(* 上者的等价类 *)
Implicit Types α β : 𝒫 𝒫 𝒫 U.

Section WellOrder.
Variable A : 𝒫 𝒫 U.

Definition 良序 := ∀ B ⊆ A, ex B → ∃ m ∈ B, ∀ x ∈ B, m ⊆ x.
Definition 可及 := Acc (λ a b, a ∈ A ∧ b ∈ A ∧ a ⊂ b).
Definition 良基 := ∀ a ∈ A, 可及 a.

Fact 最小元唯一 : (∃ m ∈ A, ∀ x ∈ A, m ⊆ x) → ∃! m ∈ A, ∀ x ∈ A, m ⊆ x.
Proof.
  intros [m Hm]. exists m. split; trivial. intros n Hn.
  apply 外延. now apply Hm. now apply Hn.
Qed.

Fact 良序_良基 `{LEM} : 良序 → 良基.
Proof.
  intros wo a aA. 反证.
  destruct (wo (A ∩ 可及⁻)) as [b Hb]. 1-2:firstorder.
  apply Hb. constructor. fold 可及.
  intros c cA. 反证. apply cA. firstorder.
Qed.

Fact 良序_非严格线序 : 良序 → ∀ a b ∈ A, a ⊆ b ∨ b ⊆ a.
Proof.
  intros wo a aA b bA.
  destruct (wo {a, b}) as (c & [->| ->] & Hc).
  - firstorder congruence.
  - exists a. now left.
  - left. apply Hc. now right.
  - right. apply Hc. now left.
Qed.

Lemma 良序_线序 `{LEM} : 良序 → ∀ a b ∈ A, a ⊆ b ∨ b ⊂ a.
Proof.
  intros wo a aA b bA.
  destruct (wo {a, b}) as (c & [->| ->] & Hc).
  - firstorder congruence.
  - exists a. now left.
  - left. apply Hc. now right.
  - 排中 (a ⊆ b). auto. right. split; trivial. apply Hc. now left.
Qed.

End WellOrder.

Definition 嵌入性 A B (f : Σ A → Σ B) :=
  ∀ aₛ bₛ : Σ A, π₁ aₛ ⊆ π₁ bₛ ↔ π₁ (f aₛ) ⊆ π₁ (f bₛ).

Definition 嵌入 A B := ∃ f : Σ A → Σ B, 嵌入性 f.
Notation "A ≼ B" := (嵌入 A B) (at level 70).
Notation "A ⋠ B" := (¬ 嵌入 A B) (at level 70).

Global Instance 嵌入_预序 : PreOrder 嵌入.
Proof. split.
  - intros A. exists (λ xₛ, xₛ). firstorder.
  - intros A B C [f Hf] [g Hg]. exists (λ xₛ, g (f xₛ)).
    intros p q. rewrite (Hf p q). apply Hg.
Qed.

Fact 嵌入_单射 A B f : @嵌入性 A B f → 单射性 f.
Proof.
  intros Hf aₛ bₛ H. apply π_单射.
  apply 外延; apply Hf; congruence.
Qed.

Lemma 包含_嵌入 A B : A ⊆ B → A ≼ B.
Proof.
  intros H. unshelve eexists.
  - intros [a aA]. exists a. now apply H.
  - intros [a aA] [b bA]. now simpl.
Qed.

Lemma 嵌入_反推良序 A B : A ≼ B → 良序 B → 良序 A.
Proof.
  intros [f Hf] wo C CA [a aC].
  destruct (@wo {b ∊ B | bB in ∃ xₛ, (π₁ xₛ) ∈ C ∧ f xₛ = σ B b bB})
    as [b [[bB [xₛ [xC fxₛ]]] H]].
  - firstorder.
  - set (aₛ := σ A a (CA a aC)).
    exists (π₁ (f aₛ)), (π₂ (f aₛ)), aₛ.
    split; trivial. now rewrite σπ_η.
  - exists (π₁ xₛ). split; trivial. intros c cC.
    set (cₛ := σ A c (CA c cC)).
    apply (Hf xₛ cₛ). rewrite fxₛ. simpl. apply H.
    exists (π₂ (f cₛ)), cₛ. split; trivial. now rewrite σπ_η.
Qed.

Definition 同构 A B := A ≼ B ∧ B ≼ A.
Notation "'ord' A" := (同构 A) (at level 10).
Notation "A ≃ B" := (同构 A B) (at level 70).

Definition 强同构 A B := ∃ f : Σ A → Σ B, 嵌入性 f ∧ ∃ g, 互逆 f g.
Notation "'Ord' A" := (强同构 A) (at level 10).
Notation "A ≅ B" := (强同构 A B) (at level 70).

Lemma 嵌入_逆 A B (f : Σ A → Σ B) g : 嵌入性 f → 互逆 f g → 嵌入性 g.
Proof.
  intros H [fg gf] a b.
  rewrite <- (fg a), <- (fg b), gf, gf. symmetry. apply H.
Qed.

Lemma 强同构_同构 A B : A ≅ B → A ≃ B.
Proof.
  intros (f & emb & g & inv). split.
  - exists f. apply emb.
  - exists g. now apply (嵌入_逆 emb).
Qed.

Lemma 强同构_对称 A B : A ≅ B → B ≅ A.
Proof.
  intros (f & Hf & g & inv). exists g. split.
  - eapply 嵌入_逆; eauto.
  - exists f. split; apply inv.
Qed.

Instance 同构_等价关系 : Equivalence 同构.
Proof. split.
  - intros A. split; reflexivity.
  - intros A B H. split; apply H.
  - intros A B C [AB BA] [BC CB]. split; etransitivity; eauto.
Qed.

Instance 同构改写良序 : Proper (同构 ==> iff) 良序.
Proof. intros A B [AB BA]. split; now apply 嵌入_反推良序. Qed.

Instance 同构改写嵌入 : Proper (同构 ==> 同构 ==> iff) 嵌入.
Proof.
  intros A B [AB BA] C D [CD DC].
  split; etransitivity; etransitivity; eauto; reflexivity.
Qed.

Fact ord_函数 A B : A ≃ B → ord A = ord B.
Proof. intros H. apply 外延; intros C <-; now rewrite H. Qed.

(* 序数 *)
Definition Ω α := ∃ A ∈ α, 良序 A ∧ ∀ B, B ∈ α ↔ A ≃ B.

Fact 序数等于同构类 α A : α ∈ Ω → A ∈ α → α = ord A.
Proof.
  intros [B HB] Aα. apply 外延; intros C HC.
  - apply HB in HC. rewrite <- HC. symmetry. now apply HB.
  - apply HB. rewrite <- HC. now apply HB.
Qed.

Fact 序数_良序集 α A : α ∈ Ω → A ∈ α → 良序 A.
Proof.
  intros (B & Bα & wo & H) Aα.
  enough (A ≃ B) as ->. trivial.
  symmetry. now apply H.
Qed.

Fact 良序集_序数 A : 良序 A → ord A ∈ Ω.
Proof. exists A. firstorder reflexivity. Qed.

Lemma 序数_同构 α A B : α ∈ Ω → A ∈ α → B ∈ α → A ≃ B.
Proof.
  intros (C & _ & _ & HC) Aα Bα. etransitivity.
  - symmetry. apply HC, Aα.
  - apply HC, Bα.
Qed.

Lemma 同构_序数 α A B : α ∈ Ω → A ∈ α → A ≃ B → B ∈ α.
Proof.
  intros (C & _ & _ & HC) Aα AB. apply HC. etransitivity.
  apply HC, Aα. apply AB.
Qed.

Definition 序 α β := ∃ A B, A ∈ α ∧ B ∈ β ∧ A ≼ B.
Notation "α ≤ β" := (序 α β) (at level 70).

Fact 序_嵌入 α β A B : α ∈ Ω → β ∈ Ω → α ≤ β → A ∈ α → B ∈ β → A ≼ B.
Proof.
  intros αΩ βΩ (C & D & Cα & βD & CD) Aα Bβ.
  rewrite (序数_同构 αΩ Aα Cα).
  rewrite (序数_同构 βΩ Bβ βD). apply CD.
Qed.

Lemma 序_自反 α : α ∈ Ω → α ≤ α.
Proof. intros (A & Aα & wo & H). exists A, A. firstorder reflexivity. Qed.

Lemma 序_传递 α β γ : β ∈ Ω → α ≤ β → β ≤ γ → α ≤ γ.
Proof.
  intros βΩ (A & B & Aα & Bβ & AB) (C & D & Cβ & Dγ & CD).
  exists A, D. split; trivial. split; trivial.
  etransitivity. apply AB.
  etransitivity. 2:apply CD.
  apply 序数_同构 with β; trivial.
Qed.

Lemma 序_反自反_引理 α β : α ∈ Ω → β ∈ Ω → α ≤ β → β ≤ α → α ⊆ β.
Proof.
  intros αΩ βΩ (A & B & Aα & Bβ & AB) (C & D & Cβ & Dα & CD) E Eα.
  apply 同构_序数 with B; trivial. split.
  - now rewrite (序数_同构 αΩ Eα Dα), (序数_同构 βΩ Bβ Cβ).
  - now rewrite (序数_同构 αΩ Eα Aα).
Qed.

Lemma 序_反自反 α β : α ∈ Ω → β ∈ Ω → α ≤ β → β ≤ α → α = β.
Proof. intros. apply 外延; now apply 序_反自反_引理. Qed.

(** 用关系定义的序嵌入与序同构 **)

Definition 嵌入性ᵣ A B (R : Σ A → Σ B → Prop) :=
  ∀ aₛ bₛ xₛ yₛ, R aₛ bₛ → R xₛ yₛ → π₁ aₛ ⊆ π₁ xₛ ↔ π₁ bₛ ⊆ π₁ yₛ.

Definition 嵌入ᵣ A B := ∃ R : Σ A → Σ B → Prop, 左完全 R ∧ 嵌入性ᵣ R.
Notation "A ≼ᵣ B" := (嵌入ᵣ A B) (at level 70).

Definition 同构ᵣ A B := ∃ R : Σ A → Σ B → Prop, 左完全 R ∧ 右完全 R ∧ 嵌入性ᵣ R.
Notation "A ≅ᵣ B" := (同构ᵣ A B) (at level 70).

Lemma 嵌入_嵌入ᵣ A B : A ≼ B → A ≼ᵣ B.
Proof.
  intros [f Hf]. exists (λ aₛ bₛ, bₛ = f aₛ). split.
  - intros aₛ. exists (f aₛ). reflexivity.
  - intros aₛ bₛ aₛ' bₛ' -> ->. apply Hf.
Qed.

Lemma 强同构_同构ᵣ A B : A ≅ B → A ≅ᵣ B.
Proof.
  intros (f & Hf & g & gf & _).
  exists (λ aₛ bₛ, bₛ = f aₛ). split3.
  - intros aₛ. exists (f aₛ). reflexivity.
  - intros bₛ. exists (g bₛ). now rewrite gf.
  - intros aₛ bₛ aₛ' bₛ' -> ->. apply Hf.
Qed.

Section Relational.

Variable A B : 𝒫 𝒫 U.
Variable R : Σ A → Σ B → Prop.
Hypothesis R全 : 左完全 R.
Hypothesis R满 : 右完全 R.
Hypothesis R嵌 : 嵌入性ᵣ R.

Lemma 嵌入性ᵣ_函数性 : 函数性 R.
Proof.
  intros aₛ bₛ cₛ Rab Rac. apply π_单射, 外延.
  - apply (R嵌 Rab Rac). firstorder.
  - apply (R嵌 Rac Rab). firstorder.
Qed.

Lemma 嵌入性ᵣ_单射性ᵣ : 单射性ᵣ R.
Proof.
  intros aₛ bₛ cₛ Rab Rac. apply π_单射, 外延.
  - apply (R嵌 Rab Rac). firstorder.
  - apply (R嵌 Rac Rab). firstorder.
Qed.

(** 序嵌入关系的函数化 **)

Let fπ₁ (aₛ : Σ A) := λ x, ∀ b (bB : b ∈ B), R aₛ (σ B b bB) → x ∈ b.

Local Lemma fπ₁_求值 aₛ bₛ : R aₛ bₛ → fπ₁ aₛ = π₁ bₛ.
Proof.
  intros H. apply 外延.
  - intros x Hx. apply (Hx (π₁ bₛ) (π₂ bₛ)). now rewrite σπ_η.
  - intros x Hx c cB Rac. specialize (嵌入性ᵣ_函数性 H Rac). intros ->. apply Hx.
Qed.

Local Lemma fπ₂ aₛ : fπ₁ aₛ ∈ B.
Proof. destruct (R全 aₛ) as [bₛ Rab]. rewrite (fπ₁_求值 Rab). apply π₂. Qed.

Local Definition f (aₛ : Σ A) := σ B (fπ₁ aₛ) (fπ₂ aₛ).

Local Lemma f_求值 aₛ bₛ : R aₛ bₛ → f aₛ = bₛ.
Proof. intros H. now apply π_单射, fπ₁_求值. Qed.

Local Lemma f_关系 aₛ : R aₛ (f aₛ).
Proof. destruct (R全 aₛ) as [bₛ Rab]. now rewrite (f_求值 Rab). Qed.

Local Lemma f_嵌入性 : 嵌入性 f.
Proof. intros a b. apply R嵌; apply f_关系. Qed.

Let gπ₁ (bₛ : Σ B) := λ x, ∀ a (aA : a ∈ A), R (σ A a aA) bₛ → x ∈ a.

Local Lemma gπ₁_求值 aₛ bₛ : R aₛ bₛ → gπ₁ bₛ = π₁ aₛ.
Proof.
  intros H. apply 外延.
  - intros x Hx. apply (Hx (π₁ aₛ) (π₂ aₛ)). now rewrite σπ_η.
  - intros x Hx c cB Rac. specialize (嵌入性ᵣ_单射性ᵣ H Rac). intros ->. apply Hx.
Qed.

Local Lemma gπ₂ bₛ : gπ₁ bₛ ∈ A.
Proof. destruct (R满 bₛ) as [a Rab]. rewrite (gπ₁_求值 Rab). apply π₂. Qed.

Local Definition g (bₛ : Σ B) := σ A (gπ₁ bₛ) (gπ₂ bₛ).

Local Lemma g_求值 aₛ bₛ : R aₛ bₛ → g bₛ = aₛ.
Proof. intros H. now apply π_单射, gπ₁_求值. Qed.

Local Lemma g_关系 bₛ : R (g bₛ) bₛ.
Proof. destruct (R满 bₛ) as [aₛ Rab]. now rewrite (g_求值 Rab). Qed.

Local Lemma fg互逆 : 互逆 f g.
Proof. split.
  - intros bₛ. destruct (R满 bₛ) as [a Rab].
    rewrite (g_求值 Rab). now apply f_求值.
  - intros aₛ. destruct (R全 aₛ) as [b Rab].
    rewrite (f_求值 Rab). now apply g_求值.
Qed.

Local Fact g_嵌入性 : 嵌入性 g.
Proof. apply 嵌入_逆 with f. apply f_嵌入性. apply fg互逆. Qed.

End Relational.

Lemma 嵌入ᵣ_嵌入 A B : A ≼ᵣ B → A ≼ B.
Proof. intros (R & tot & emb). exists (f tot emb). apply f_嵌入性. Qed.

Fact 嵌入_iff_嵌入ᵣ A B : A ≼ B ↔ A ≼ᵣ B.
Proof. split. apply 嵌入_嵌入ᵣ. apply 嵌入ᵣ_嵌入. Qed.

Lemma 同构ᵣ_强同构 A B : A ≅ᵣ B → A ≅ B.
Proof.
  intros (R & tot & sur & emb).
  exists (f tot emb). split. apply f_嵌入性.
  exists (g sur emb). apply fg互逆.
Qed.

Fact 强同构_iff_同构ᵣ A B : A ≅ B ↔ A ≅ᵣ B.
Proof. split. apply 强同构_同构ᵣ. apply 同构ᵣ_强同构. Qed.

Definition 前段 A a := {x ∊ A | x ⊂ a}.
Notation "a ⇠ A" := (前段 A a) (format "a ⇠ A", at level 9, right associativity).

Definition 严格嵌入 A B := ∃ b ∈ B, A ≃ b⇠B.
Notation "A ≺ B" := (严格嵌入 A B) (at level 70).

Definition 强严格嵌入 A B := ∃ b ∈ B, A ≅ b⇠B.
Notation "A ⋨ B" := (强严格嵌入 A B) (at level 70).

Fact 前段是子集 A a : a⇠A ⊆ A.
Proof. firstorder. Qed.

Lemma 前段之前段 A a b : a ⊆ b → a⇠b⇠A = a⇠A.
Proof. intros H. apply 外延; firstorder. Qed.

Lemma 前段良序 A a : 良序 A → 良序 a⇠A.
Proof.
  intros wo B BS [b bB]. destruct (wo B) as [c Hc].
  firstorder. now exists b. now exists c.
Qed.

Lemma 前段嵌入全段 A a : a⇠A ≼ A.
Proof. unshelve eexists.
  - intros [b bS]. exists b. apply bS.
  - intros [b bS] [c cS]. simpl. easy.
Qed.

Lemma 全段不嵌入前段 A a : 良序 A → a ∈ A → A ⋠ a⇠A.
Proof.
  intros wo aA Ea.
  destruct (wo {x ∊ A | A ≼ x⇠A}) as (b & [bA [f Hf]] & min). 1-2:firstorder.
  set (fbₛ := f (σ A b bA)). apply (π₂ fbₛ). apply min.
  split. apply (π₂ fbₛ). unshelve eexists.
  - intros [c cA].
    set (fcₛ := f (σ A c cA)).
    set (ffcₛ := f (σ A (π₁ fcₛ) ltac:(apply (π₂ fcₛ)))).
    exists (π₁ ffcₛ). repeat split.
    + apply (π₂ ffcₛ).
    + apply Hf. simpl. apply (π₂ fcₛ).
    + intros H%Hf. simpl in H. now apply (π₂ fcₛ).
  - intros [c cA] [d dA]; simpl.
    rewrite (Hf (σ A c cA) (σ A d dA)).
    destruct (f (σ A c cA)) as [fc [fcA fcb]].
    destruct (f (σ A d dA)) as [fd [fdA fdb]]. simpl.
    rewrite <- (Hf (σ A fc fcA) (σ A fd fdA)). simpl. easy.
Qed.

Lemma 前段保序_l A a b : a ⊆ b → a ⇠ A ⊆ b⇠A.
Proof. firstorder. Qed.

Lemma 前段保序_r `{LEM} A a b : 良序 A → a ∈ A → b ∈ A → a⇠A ⊆ b⇠A → a ⊆ b.
Proof. intros wo aA bA sub. destruct (良序_线序 wo aA bA); firstorder. Qed.

Lemma 前段保序 `{LEM} A a b : 良序 A → a ∈ A → b ∈ A → a ⊆ b ↔ a⇠A ⊆ b⇠A.
Proof. split. apply 前段保序_l. now apply 前段保序_r. Qed.

Lemma 前段嵌入前段_l A a b : a ⊆ b → a⇠A ≼ b⇠A.
Proof. intros. now apply 包含_嵌入, 前段保序_l. Qed.

Lemma 前段嵌入前段_r `{LEM} A a b : 良序 A → a ∈ A → b ∈ A → a⇠A ≼ b⇠A → a ⊆ b.
Proof.
  intros wo aA bA sub.
  destruct (良序_线序 wo aA bA) as [|[ba ab]]; trivial.
  exfalso. rewrite <- (前段之前段 _ ba) in sub.
  contradict sub. apply 全段不嵌入前段. now apply 前段良序. firstorder.
Qed.

Lemma 前段嵌入前段 `{LEM} A a b : 良序 A → a ∈ A → b ∈ A → a ⊆ b ↔ a⇠A ≼ b⇠A.
Proof. split. apply 前段嵌入前段_l. now apply 前段嵌入前段_r. Qed.

Lemma 前段强同构 A B (f : Σ A → Σ B) g xₛ :
  嵌入性 f → 互逆 f g → (π₁ xₛ)⇠A ≅ (π₁ (f xₛ))⇠B.
Proof.
  intros Hf [fg gf].
  unshelve eexists. 2: split. 3: unshelve eexists. 4: split.
  - intros (a & aA & ax & xa). exists (π₁ (f (σ A a aA))).
    split. apply π₂. split. now apply Hf. intros H. now apply Hf in H.
  - intros (a & aA & ax & xa) (b & bA & bx & xb). simpl.
    apply (Hf (σ A a aA) (σ A b bA)).
  - assert (Hg: 嵌入性 g). eapply 嵌入_逆. apply Hf. split; trivial.
    intros (b & bB & bx & xb). exists (π₁ (g (σ B b bB))).
    split. apply π₂. split; rewrite <- (gf xₛ).
    now apply Hg. intros H. now apply Hg in H.
  - intros (a & aA & ax & xa). simpl. apply σ_函数. now rewrite σπ_η, fg.
  - intros (b & bB & bx & xb). simpl. apply σ_函数. now rewrite σπ_η, gf.
Qed.

(** 考察两个良序集间相同序数位置的元素 **)
Section OrderRelated.

Variable A B : 𝒫 𝒫 U.
Hypothesis HA : 良序 A.
Hypothesis HB : 良序 B.

Definition 序关联 a b := a ∈ A ∧ b ∈ B ∧ a⇠A ≅ b⇠B.
Notation "a ~ b" := (序关联 a b) (at level 70).

Let Dom a := ∃ b, a ~ b.
Let Ran b := ∃ a, a ~ b.

Local Lemma 关联点保序 `{LEM} a b x y : a ~ x → b ~ y → a ⊆ b ↔ x ⊆ y.
Proof.
  intros (aA & xB & ax%强同构_同构) (bA & yB & b_y%强同构_同构). split; intros sub.
  - eapply 前段嵌入前段_r. apply HB. 1-2:trivial.
    rewrite <- ax, <- b_y. now apply 前段嵌入前段_l.
  - eapply 前段嵌入前段_r. apply HA. 1-2:trivial.
    rewrite ax, b_y. now apply 前段嵌入前段_l.
Qed.

Local Lemma 关联域同构 `{LEM} : Dom ≅ Ran.
Proof.
  apply 同构ᵣ_强同构.
  exists (λ aₛ bₛ, π₁ aₛ ~ π₁ bₛ). split3.
  - intros (a & x & ax). unshelve eexists.
    now exists x, a. now simpl.
  - intros (y & b & b_y). unshelve eexists.
    now exists b, y. now simpl.
  - intros a b x y. apply 关联点保序.
Qed.

Local Lemma 定义域充满 `{LEM} : (¬ ∃ a ∈ A, a ∉ Dom) → A = Dom.
Proof.
  intros ne. apply 外延. 2:firstorder.
  intros a aA. 排中 (a ∈ Dom). trivial. exfalso. apply ne. eauto.
Qed.

Local Lemma 值域充满 `{LEM} : (¬ ∃ b ∈ B, b ∉ Ran) → B = Ran.
Proof.
  intros ne. apply 外延. 2:firstorder.
  intros b bB. 排中 (b ∈ Ran). trivial. exfalso. apply ne. eauto.
Qed.

Local Lemma 定义域向下封闭 a a' : a ∈ Dom → a' ∈ a⇠A → a' ∈ Dom.
Proof.
  intros (b & aA & bB & f & Hf & g & inv) Ha'.
  exists (π₁ (f (σ _ a' Ha'))). split3. apply Ha'.
  destruct f as [c Hc]. simpl. apply Hc.
  specialize (@前段强同构 _ _ f g (σ _ a' Ha') Hf inv). simpl.
  rewrite !前段之前段. trivial. 2:apply Ha'.
  destruct f as [c Hc]. simpl. apply Hc.
Qed.

Local Lemma 值域向下封闭 b b' : b ∈ Ran → b' ∈ b⇠B → b' ∈ Ran.
Proof.
  intros (a & bB & aA & f & Hf & g & inv) Hb'.
  exists (π₁ (g (σ _ b' Hb'))). split3. 2:apply Hb'.
  destruct g as [c Hc]. simpl. apply Hc.
  assert (inv': 互逆 g f) by (split; apply inv).
  assert (Hg: 嵌入性 g) by (eapply 嵌入_逆; eauto). apply 强同构_对称.
  specialize (@前段强同构 _ _ g f (σ _ b' Hb') Hg inv'). simpl.
  rewrite !前段之前段. trivial. 2: apply Hb'.
  destruct g as [c Hc]. simpl. apply Hc.
Qed.

Local Lemma 定义域末端 `{LEM} a : a ∈ A → a ∉ Dom → (∀ x, x ∈ A ∧ x ∉ Dom → a ⊆ x) → a⇠A = Dom.
Proof.
  intros aA aD min. apply 外延.
  - intros b [bA ba]. 反证. now apply ba, min.
  - intros b bD. assert (bA: b ∈ A) by firstorder.
    split; trivial. assert (ba : b ⊆ a). {
      destruct (良序_线序 HA bA aA). trivial.
      exfalso. apply aD, 定义域向下封闭 with b; firstorder.
    }
    split; trivial. intros ab.
    enough (a = b) as -> by contradiction. now apply 外延.
Qed.

Local Lemma 值域末端 `{LEM} b : b ∈ B → b ∉ Ran → (∀ x, x ∈ B ∧ x ∉ Ran → b ⊆ x) → b⇠B = Ran.
Proof.
  intros bB bR min. apply 外延.
  - intros a [aB ab]. 反证. now apply ab, min.
  - intros a aR. assert (aB: a ∈ B) by firstorder.
    split; trivial. assert (ab : a ⊆ b). {
      destruct (良序_线序 HB aB bB). trivial.
      exfalso. apply bR, 值域向下封闭 with a; firstorder.
    }
    split; trivial. intros ba.
    enough (a = b) as -> by contradiction. now apply 外延.
Qed.

Theorem 良序集三歧 `{LEM} : A ⋨ B ∨ B ⋨ A ∨ A ≅ B.
Proof.
  排中 (∃ a ∈ A, a ∉ Dom); 排中 (∃ b ∈ B, b ∉ Ran).
  - destruct (@HA {x ∊ A | x ∉ Dom}) as (m&[mA mD]&Hm). 1-2:firstorder.
    destruct (@HB {x ∊ B | x ∉ Ran}) as (n&[nB nR]&Hn). 1-2:firstorder.
    exfalso. apply mD. exists n. split3; trivial.
    rewrite (定义域末端 mA mD Hm), (值域末端 nB nR Hn). apply 关联域同构.
  - right. left. rewrite (值域充满 H1).
    destruct (@HA {x ∊ A | x ∉ Dom}) as (m&[mA mD]&Hm). 1-2:firstorder.
    exists m. split; trivial. rewrite (定义域末端 mA mD Hm). apply 强同构_对称, 关联域同构.
  - left. rewrite (定义域充满 H0).
    destruct (@HB {x ∊ B | x ∉ Ran}) as (n&[nB nR]&Hn). 1-2:firstorder.
    exists n. split; trivial. rewrite (值域末端 nB nR Hn). apply 关联域同构.
  - right. right. rewrite (定义域充满 H0), (值域充满 H1). apply 关联域同构.
Qed.

Corollary 同构_强同构 `{LEM} : A ≃ B → A ≅ B.
Proof.
  intros [AB BA].
  destruct 良序集三歧 as [[b [bB i1]]|[[a [aA i2]]|i3]]. 3:trivial.
  - exfalso. apply (全段不嵌入前段 HB bB). etransitivity. apply BA.
    apply 强同构_同构, 强同构_对称, i1.
  - exfalso. apply (全段不嵌入前段 HA aA). etransitivity. apply AB.
    apply 强同构_同构, 强同构_对称, i2.
Qed.

Lemma 强严格嵌入I `{LEM} : B ⋠ A → A ⋨ B.
Proof.
  intros BA. destruct 良序集三歧 as [|[]]; trivial; exfalso.
  - apply BA. destruct H0 as [a[_ iso%强同构_同构]].
    etransitivity. apply iso. apply 前段嵌入全段.
  - apply 强同构_同构 in H0. apply BA, H0.
Qed.

Lemma 严格嵌入I `{LEM} : B ⋠ A → A ≺ B.
Proof.
  intros BA. destruct (强严格嵌入I BA)
  as [b [bB iso%强同构_同构]]. now exists b.
Qed.

End OrderRelated.

(** 序数的良序 **)

Lemma 良序集族良序 `{LEM} α : α ⊆ 良序 → (∀ A B, A ≃ B → A ∈ α → B ∈ α) →
  ex α → ∃ A ∈ α, ∀ B ∈ α, A ≼ B.
Proof.
  intros WO ISO [A Aα]. 排中 (∃ B ∈ α, A ⋠ B) as [[B [Bα AB]]|].
  - destruct (WO A Aα {x ∊ A | x⇠A ∈ α}) as [a [[aA Sα] min]].
    + firstorder.
    + pose proof (严格嵌入I (WO B Bα) (WO A Aα) AB) as [a [aA iso]].
      exists a. split; trivial. apply ISO with B; trivial.
    + exists (a⇠A). split; trivial. intros C Cα.
      反证. apply 严格嵌入I in H0 as [b [[bA ba] iso]]; trivial.
      * apply ba, min. split; trivial. apply ISO with C; trivial.
        rewrite 前段之前段 in iso; trivial. apply ba.
      * now apply WO.
      * now apply 前段良序, WO.
  - exists A. split; trivial. intros B Bα. 反证. firstorder.
Qed.

Lemma 序数良序 `{LEM} Θ : Θ ⊆ Ω → ex Θ → ∃ α ∈ Θ, ∀ β ∈ Θ, α ≤ β.
Proof.
  intros ΘΩ [α αΘ]. destruct (ΘΩ α αΘ) as (A & αA & woA & isoA).
  destruct (@良序集族良序 H {X ∊ 良序 | ord X ∈ Θ}) as (M & [woM HM] & min).
  - now intros B [HB _].
  - intros B C BC [woB HB]. split.
    now rewrite <- BC. now rewrite <- (ord_函数 BC).
  - exists A. split; trivial. rewrite <- (@序数等于同构类 α); auto.
  - exists (ord M). split; trivial. intros β βΘ.
    destruct (ΘΩ β βΘ) as (B & αB & woB & isoB).
    exists M, B. split3; trivial. reflexivity.
    apply min. split; trivial. rewrite <- (@序数等于同构类 β); auto.
Qed.

(* 哈特格斯数 *)
Definition ℍ := Σ Ω.
Notation "U₊" := ℍ.

Definition ℍ序 (αₛ βₛ : U₊) := (序 (π₁ αₛ) (π₁ βₛ)).
Notation "αₛ ≤ₛ βₛ" := (ℍ序 αₛ βₛ) (at level 70).

Lemma ℍ序_自反 (αₛ : U₊) : αₛ ≤ₛ αₛ.
Proof. apply 序_自反, π₂. Qed.

Lemma ℍ序_传递 (αₛ βₛ γₛ : U₊) : αₛ ≤ₛ βₛ → βₛ ≤ₛ γₛ → αₛ ≤ₛ γₛ.
Proof. apply 序_传递, π₂. Qed.

Global Instance ℍ序_预序 : PreOrder ℍ序.
Proof. split. exact ℍ序_自反. exact ℍ序_传递. Qed.

Lemma ℍ序_反自反 (αₛ βₛ : U₊) : αₛ ≤ₛ βₛ → βₛ ≤ₛ αₛ → αₛ = βₛ.
Proof. intros H1 H2. apply π_单射. apply 序_反自反; trivial; apply π₂. Qed.

Lemma ℍ序_良序 `{LEM} (Aₛ : 𝒫 U₊) : ex Aₛ → ∃ αₛ ∈ Aₛ, ∀ βₛ ∈ Aₛ, αₛ ≤ₛ βₛ.
Proof.
  intros [[α αΩ] αAₛ].
  destruct (@序数良序 H {α ∊ Ω | αΩ in σ _ α αΩ ∈ Aₛ}) as (μ & [μΩ μAₛ] & min).
  - now intros β [βΩ _].
  - now exists α, αΩ.
  - exists (σ _ μ μΩ). split; trivial. intros [βₛ βΩ] βAₛ.
    apply min. now exists βΩ.
Qed.

Fact ℍ_势上界 : |U₊| ≤ |𝒫ₙ 3 U|.
Proof. apply 单射_从子集. Qed.

(* |U₊| ≰ |U| *)
Section Inject.

Local Definition 嵌入性ₛ A (f : ℍ → Σ A) :=
  ∀ αₛ βₛ, αₛ ≤ₛ βₛ ↔ π₁ (f αₛ) ⊆ π₁ (f βₛ).
Local Definition 被嵌 α := ∃ A ∈ α, ∃ f : ℍ → Σ A, 嵌入性ₛ f.

Local Definition 前段之序数 A a : 良序 A → U₊.
Proof. intros wo. exists (ord a⇠A). apply 良序集_序数, 前段良序, wo. Defined.

Local Lemma 序数不被嵌入 `{LEM} α : α ∈ Ω → ¬ 被嵌 α.
Proof.
  intros αΩ (A & Aα & f & Hf).
  assert (woA : 良序 A). apply 序数_良序集 with α; auto.
  set (fαₛ := f (σ _ α αΩ)).
  apply (@全段不嵌入前段 A (π₁ fαₛ)). trivial. apply π₂.
  unshelve eexists.
  - intros [a aA]. exists (π₁ (f (前段之序数 a woA))). split3.
    + apply π₂.
    + apply Hf. exists (a⇠A), A. split3.
      simpl. reflexivity. trivial. apply 前段嵌入全段.
    + intros le%Hf. apply (全段不嵌入前段 woA aA).
      eapply 序_嵌入. 3: apply le. all:simpl; trivial. 2:reflexivity.
      now apply 良序集_序数, 前段良序.
  - intros [a aA] [b bA]; simpl.
    rewrite 前段嵌入前段. 2: apply woA. 2-3:trivial. split.
    + intros emb. apply Hf. exists (a⇠A), (b⇠A).
      split3; simpl; trivial; reflexivity.
    + intros sub. apply Hf in sub as (B & C & HB & HC & emb).
      simpl in HB, HC. now rewrite HB, HC.
Qed.

Variable R : U₊ → U → Prop.
Hypothesis R全 : 左完全 R.
Hypothesis R单 : 单射性ᵣ R.

Local Definition 前 (αₛ : U₊) : 𝒫 U := λ x, ∀ βₛ, R βₛ x → βₛ ≤ₛ αₛ.
Local Definition A := λ a, ∃ αₛ : U₊, a = 前 αₛ.
Local Definition α := ord A.

Local Lemma A良序 `{LEM} : 良序 A.
Proof.
  intros B BA [a aB]. destruct (BA a aB) as [αₛ ->].
  destruct (@ℍ序_良序 H (λ αₛ, 前 αₛ ∈ B)) as (μₛ & μB & min).
  - now exists αₛ.
  - exists (前 μₛ). split; trivial.
    intros b bB. destruct (BA b bB) as [βₛ ->].
    intros x Hx γₛ Rγx%Hx. etransitivity. 2:now apply min. trivial.
Qed.

Local Lemma α是序数 `{LEM} : α ∈ Ω.
Proof. apply 良序集_序数, A良序. Qed.

Local Definition F : ℍ → Σ A.
Proof. intros αₛ. exists (前 αₛ). now exists αₛ. Defined.

Local Lemma F_嵌入性ₛ : 嵌入性ₛ F.
Proof.
  intros αₛ βₛ; simpl. split.
  - intros αβ x Hx γₛ γα%Hx. etransitivity. apply γα. trivial.
  - intros αβ. destruct (R全 αₛ) as [γ Rαγ].
    assert (Hγ : γ ∈ 前 αₛ). intros δₛ Rδγ. rewrite (R单 Rαγ Rδγ). reflexivity.
    apply αβ in Hγ. now apply Hγ.
Qed.

Local Lemma α被嵌 : 被嵌 α.
Proof.
  exists A. split. split; reflexivity.
  exists F. apply F_嵌入性ₛ.
Qed.

Local Lemma 矛盾 `{LEM} : False.
Proof. apply 序数不被嵌入 with α. apply α是序数. apply α被嵌. Qed.

End Inject.

Lemma 后继基数ᵣ `{LEM} : ¬ |U₊| ≤ᵣ |U|.
Proof. intros (R & tot & _ & inj). apply 矛盾 with R; trivial. Qed.

Lemma 后继基数 `{LEM} : ¬ |U₊| ≤ |U|.
Proof. intros le. apply 后继基数ᵣ, 单射_单射ᵣ, le. Qed.

End Ordinal.

Notation "A ≼ B" := (嵌入 A B) (at level 70).
Notation "A ⋠ B" := (¬ 嵌入 A B) (at level 70).

Notation "'ord' A" := (同构 A) (at level 10).
Notation "A ≃ B" := (同构 A B) (at level 70).
Notation "'Ord' A" := (强同构 A) (at level 10).
Notation "A ≅ B" := (强同构 A B) (at level 70).

Notation "a ⇠ A" := (前段 A a) (format "a ⇠ A", at level 9, right associativity).
Notation "A ≺ B" := (严格嵌入 A B) (at level 70).
Notation "A ⋨ B" := (强严格嵌入 A B) (at level 70).

Notation "U ₊" := (ℍ U) (format "U ₊", at level 8).
Notation "α ≤ β" := (ℍ序 α β) (at level 70).


Require Export c_completeness.
Set Implicit Arguments.

Module Type sequent_mod (B: base_mod) (S: sound_mod B) (C: complete_mod B S).
Import B S C.

(** * Gentzen's Sequent Calculus *)

Reserved Notation "Γ ⊃ A" (at level 80).
Inductive G : list PropF->list PropF->Prop :=
| Gax  : forall A Γ Δ      , In A Γ           -> In A Δ          -> Γ ⊃ Δ
| GBot : forall Γ Δ        , In ⊥ Γ                              -> Γ ⊃ Δ
| AndL : forall A B Γ1 Γ2 Δ, Γ1++A::B::Γ2 ⊃ Δ                    -> Γ1++A∧B::Γ2 ⊃ Δ
| AndR : forall A B Γ Δ1 Δ2, Γ ⊃ Δ1++A::Δ2    -> Γ ⊃ Δ1++B::Δ2   -> Γ ⊃ Δ1++A∧B::Δ2
| OrL  : forall A B Γ1 Γ2 Δ, Γ1++A::Γ2 ⊃ Δ    -> Γ1++B::Γ2 ⊃ Δ   -> Γ1++A∨B::Γ2 ⊃ Δ
| OrR  : forall A B Γ Δ1 Δ2, Γ ⊃ Δ1++A::B::Δ2                     -> Γ ⊃ Δ1++A∨B::Δ2
| ImpL : forall A B Γ1 Γ2 Δ, Γ1++B::Γ2 ⊃ Δ    -> Γ1++Γ2 ⊃ A::Δ   -> Γ1++A→B::Γ2 ⊃ Δ
| ImpR : forall A B Γ Δ1 Δ2, A::Γ ⊃ Δ1++B::Δ2                     -> Γ ⊃ Δ1++A→B::Δ2
| Cut  : forall A Γ Δ      , Γ ⊃ A::Δ         -> A::Γ ⊃ Δ        -> Γ ⊃ Δ
where "Γ ⊃ Δ" := (G Γ Δ) : My_scope.

(** The disjunction of a list of formulas*)
Definition BigOr := fold_right Disj ⊥.
Notation "⋁ Δ" := (BigOr Δ) (at level 19).
(** Γ ⊢⊢ Δ means that Γ ⊢ A for all A in Δ*)
Definition Ncl Γ := map_fold_right (Nc Γ) and True.
Notation "Γ ⊢⊢ Δ" := (Ncl Γ Δ) (at level 80).
Notation "¬l Γ" := (map Neg Γ) (at level 40).

(** * Theorems *)

(** Gc to Nc*)

Lemma NegAnd_impl_OrNeg : forall Γ A B, Γ ⊢ ¬(A∧B) -> Γ ⊢ ¬A∨¬B.
do 3 intro;apply prov_impl.
apply ImpI;apply BotC;apply ImpE with (A ∧ B);
 [is_ass|apply AndI;apply BotC;(apply ImpE with (¬A ∨ ¬B);[is_ass|])].
   apply OrI1;is_ass.
   apply OrI2;is_ass.
Qed.

Lemma Nc_list_weakening : forall Γ1 Γ2 Δ, (forall B, In B Γ1 -> In B Γ2) -> Γ1 ⊢⊢ Δ -> Γ2 ⊢⊢ Δ.
intros;induction Δ.
 trivial.
 destruct H0;split.
   eapply weakening2;eassumption.
   apply IHΔ;apply H1.
Qed.

Lemma Nc_list_impl : forall Γ A, Γ ⊢ A ->forall Δ, Δ ⊢⊢ Γ -> Δ ⊢ A.
induction 1;intros;[induction Γ;destruct H;[subst;apply H0|apply IHΓ;[assumption|apply H0]]
|constructor 2|econstructor 3|constructor 4|constructor 5|econstructor 6
|econstructor 7|constructor 8|constructor 9|econstructor 10];try eauto;
[apply IHNc..|apply IHNc2|try apply IHNc3];
(split;[is_ass|eapply Nc_list_weakening;[|eassumption];in_solve]).
Qed.

Lemma Nc_list_contained : forall Γ Δ, (forall B, In B Δ -> In B Γ) -> Γ ⊢⊢ Δ.
intros;induction Δ.
 exact I.
 split.
   constructor;apply H;in_solve.
   apply IHΔ;intros;apply H;in_solve.
Qed.

Lemma Nc_list_app : forall Γ Δ1 Δ2, Γ ⊢⊢ Δ1 -> Γ ⊢⊢ Δ2 -> Γ ⊢⊢ Δ1++Δ2.
intros;induction Δ1.
 assumption.
 destruct H;split.
   assumption.
   apply IHΔ1;apply H1.
Qed.

Ltac Ncl_solve := repeat match goal with
| |- _ ⊢ _     => idtac
| |- _ ⊢⊢ _::_ => split;[eassumption||(try (is_ass;fail))|]
| |- _ ⊢⊢ _++_ => apply Nc_list_app
| |- map_fold_right (Nc ?Γ) and True _ => change (map_fold_right (Nc Γ) and True) with (Ncl Γ)
| _            => eassumption||(apply Nc_list_contained;in_solve)
end.

Lemma G_to_Nc_Neg : forall Γ Δ, Γ ⊃ Δ -> Γ++¬l Δ ⊢ ⊥.
induction 1;try rewrite map_app in *;simpl in *.
 mp;[|is_ass]. constructor. apply in_app_iff;right.
  change (A → ⊥) with (¬A). apply in_map;assumption.
 is_ass.
 eapply Nc_list_impl;[eassumption|]. Ncl_solve.
   eapply AndE1;is_ass.
   eapply AndE2;is_ass.
 eapply OrE;[apply NegAnd_impl_OrNeg;is_ass|eapply Nc_list_impl..];
  [apply IHG1| |apply IHG2|];Ncl_solve.
 eapply OrE;[is_ass|eapply Nc_list_impl..];[apply IHG1| |apply IHG2|];Ncl_solve.
 eapply Nc_list_impl;[eassumption|]. Ncl_solve;(apply ImpI;mp;[is_ass|]).
   eapply OrI1;is_ass.
   eapply OrI2;is_ass.
 eapply OrE;[apply Excluded_Middle|eapply Nc_list_impl..];
  [apply IHG1| |apply IHG2|Ncl_solve];Ncl_solve;mp;is_ass.
 eapply Nc_list_impl;[eassumption|]. Ncl_solve.
   apply BotC;mp;[|apply ImpI;apply BotC;apply ImpE with A];is_ass.
   apply ImpI;mp;[|apply ImpI];is_ass.
 eapply OrE;[apply Excluded_Middle|eapply Nc_list_impl..];
  [apply IHG2| |apply IHG1|];Ncl_solve.
Qed.

Lemma ConjNeg_Disj : forall Δ Γ, Γ ++ ¬l Δ ⊢ ⊥ -> Γ ⊢ ⋁Δ.
induction Δ;simpl;intros.
 rewrite app_nil_r in H;trivial.
 eapply OrE.
   apply Excluded_Middle.
   apply OrI1;is_ass.
   apply OrI2;apply IHΔ;eapply Nc_list_impl;[eassumption|Ncl_solve].
Qed.

Theorem G_to_Nc : forall Γ Δ, Γ ⊃ Δ -> Γ ⊢ ⋁Δ.
intros;apply ConjNeg_Disj;apply G_to_Nc_Neg;assumption.
Qed.

(** Nc to Gc

The hardest part is proving weakening for Gc*)

Local Ltac temp1 := econstructor;split;reflexivity||(rewrite app_comm_cons;reflexivity).

Lemma in_split_app : forall A (a:A) l2 l4 l1 l3, l1++a::l2=l3++l4 -> ((exists l,l3=l1++a::l/\l2=l++l4)\/
                                                                      (exists l,l4=l++a::l2/\l1=l3++l)).
induction l1;intros;
 (destruct l3;[destruct l4|];discriminate||(injection H;intros;subst)).
   right;exists [];split;reflexivity.
   left;temp1.
   right;temp1.
   destruct (IHl1 _ H0) as [(?&?&?)|(?&?&?)];subst.
     left;temp1.
     right;temp1.
Qed.

Lemma in_in_split_app : forall A (a:A) b l2 l4 l1 l3, l1++a::l2=l3++b::l4 -> (exists l,l3=l1++a::l/\l2=l++b::l4)\/
                                                                            (exists l,l4=l++a::l2/\l1=l3++b::l)\/
                                                                            (a=b/\l1=l3/\l2=l4).
intros;apply in_split_app in H as [(?&?&?)|(?&?&?)];subst.
  left;econstructor;split;reflexivity.
  destruct x;injection H;intros;subst.
    repeat (right||split||rewrite app_nil_r||reflexivity).
    right;left;econstructor;split;reflexivity.
Qed.

Ltac rew1 := repeat rewrite <- app_assoc;repeat rewrite <- app_comm_cons.
Ltac rew2 := repeat rewrite app_comm_cons;try rewrite app_assoc.
Ltac constr := constructor 3||constructor 4||constructor 5||constructor 6||constructor 7||constructor 8.
Local Ltac temp2 X Y Z :=
  (rew1;constr;rew2;eapply X;rew1;reflexivity)||
  (rew2;constr;rew1;eapply X;rew2;reflexivity)||
  (rew1;constr;rew2;[eapply Y|eapply Z];rew1;reflexivity)||
  (rew2;constr;rew1;[eapply Y|eapply Z];rew2;reflexivity).
Local Ltac temp3 H IHG IHG1 IHG2 Heql A0 := induction H;intros;subst;
 try apply in_split_app in Heql as [(?&?&?)|(?&?&?)];
  subst;try (temp2 IHG IHG1 IHG2;fail);[is_ass|constructor 2;in_solve|
   apply Cut with A0;[try rewrite app_comm_cons|rew2];auto..].

Lemma WeakL : forall Γ1 Γ2 Δ A, Γ1++Γ2 ⊃ Δ -> Γ1++A::Γ2 ⊃ Δ.
intros;remember (Γ1++Γ2);revert Γ1 Γ2 Heql;temp3 H IHG IHG1 IHG2 Heql A0.
Qed.

Lemma WeakR : forall Γ Δ1 Δ2 A, Γ ⊃ Δ1++Δ2 -> Γ ⊃ Δ1++A::Δ2.
intros;remember (Δ1++Δ2);revert Δ1 Δ2 Heql;temp3 H IHG IHG1 IHG2 Heql A0.
Qed.

Theorem Nc_to_G : forall Γ A, Γ ⊢ A -> Γ ⊃ [A].
induction 1.
 is_ass.
 apply ImpR with (Δ1:=[]);assumption.
 apply Cut with (A→B).
   apply WeakR with (Δ1:=[_]);assumption.
   apply ImpL with (Γ1:=[]).
     is_ass.
     apply WeakR with (Δ1:=[_]);assumption.
 apply Cut with (¬A).
   apply ImpR with (Δ1:=[]);is_ass.
   eapply Cut.
    apply WeakR with (Δ1:=[⊥]);assumption.
    apply GBot;in_solve.
 apply AndR with (Δ1:=[]);assumption.
 apply Cut with (A ∧ B).
   apply WeakR with (Δ1:=[_]);assumption.
   apply AndL with (Γ1:=[]);is_ass.
 apply Cut with (A ∧ B).
   apply WeakR with (Δ1:=[_]);assumption.
   apply AndL with (Γ1:=[]);constructor 1 with B;in_solve.
 apply OrR with (Δ1:=[]);apply WeakR with (Δ1:=[_]);assumption.
 apply OrR with (Δ1:=[]);apply WeakR;assumption.
 apply Cut with (A ∨ B).
   apply WeakR with (Δ1:=[_]);assumption.
   apply OrL with (Γ1:=[]);assumption.
Qed.

End sequent_mod.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This file provides classical logic and functional choice; this
    especially provides both indefinite descriptions and choice functions
    but this is weaker than providing epsilon operator and classical logic
    as the indefinite descriptions provided by the axiom of choice can
    be used only in a propositional context (especially, they cannot
    be used to build choice functions outside the scope of a theorem
    proof) *)

(** This file extends ClassicalUniqueChoice.v with full choice.
    As ClassicalUniqueChoice.v, it implies the double-negation of
    excluded-middle in [Set] and leads to a classical world populated
    with non computable functions. Especially it conflicts with the
    impredicativity of [Set], knowing that [true<>false] in [Set].  *)

Require Export ClassicalUniqueChoice.
Require Export RelationalChoice.
Require Import ChoiceFacts.

Set Implicit Arguments.

Definition subset (U:Type) (P Q:U->Prop) : Prop := forall x, P x -> Q x.

Theorem singleton_choice :
  forall (A : Type) (P : A->Prop),
  (exists x : A, P x) -> exists P' : A->Prop, subset P' P /\ exists! x, P' x.
Proof.
intros A P H.
destruct (relational_choice unit A (fun _ => P) (fun _ => H)) as (R',(Hsub,HR')).
exists (R' tt); firstorder.
Qed.

Theorem choice :
 forall (A B : Type) (R : A->B->Prop),
   (forall x : A, exists y : B, R x y) ->
    exists f : A->B, (forall x : A, R x (f x)).
Proof.
intros A B.
apply description_rel_choice_imp_funct_choice.
exact (unique_choice A B).
exact (relational_choice A B).
Qed.