Set Implicit Arguments.
Unset Strict Implicit.

Require Export cardinal.
Require Export lci.
Require Export ring.

Module Cardinal_arith.
Export Cardinal.

Lemma singleton_product_l : forall x y, product (singleton x) y = Im (J x) y.
Proof.
ir;ap extensionality;uhg;ir.
apply product_pr in H;ee;nin H.
clpri H0;clpri H1;apply singleton_eq in H0;subst.
ap Im_inc. am.
Im_nin H;subst;ap product_pair_inc;au.
ap singleton_inc.
Qed.

Lemma singleton_product_r : forall x y, product x (singleton y) = Im (fun a => J a y) x.
Proof.
ir;ap extensionality;uhg;ir.
apply product_pr in H;ee;nin H.
clpri H0;clpri H1;apply singleton_eq in H1;subst.
ap Im_show_inc. exists a;ee;au.
Im_nin H;subst;ap product_pair_inc;au.
ap singleton_inc.
Qed.

Definition caPlus c d := card (union2 (product (singleton emptyset) c)
(product (singleton (singleton emptyset)) d)).

Definition caMult c d := card (product c d).

Section NotaSection.

Infix "+" := caPlus.
Infix "*" := caMult.

Lemma caPlus_0eq : forall a b, caPlus a b = emptyset -> (a=emptyset & b=emptyset).
Proof.
ir.
ufi caPlus H.
cp (card_equipotent ((union2 (product (singleton ∅) a) (product (singleton (singleton ∅)) b)))).
rwi H H0. clear H.
nin H0. ee;
ap excluded_middle;uhg;ir;
apply not_empty_nonempty in H0;
nin H0.
apply emptyset_empty with (ev x (J emptyset x0)).
eapply trans_of_map;try am.
ap union2_l;ap product_pair_inc;au.
ap singleton_inc.
apply emptyset_empty with (ev x (J (singleton emptyset) x0)).
eapply trans_of_map;try am.
ap union2_r;ap product_pair_inc;au.
ap singleton_inc.
Qed.

Lemma caPlus_card_proper : forall a a', are_equipotent a a' ->
forall b b', are_equipotent b b' ->
caPlus a b = caPlus a' b'.
Proof.
ir.
ap card_invariant.
ap Equipotent.union2_equipotent;try ap Equipotent.product_equipotent;
try ap are_equipotent_refl;au.
ap empty_emptyset;ir.
apply inter2_and in H1;ee. apply product_pr in H1;apply product_pr in H2;ee.
apply singleton_eq in H5;apply singleton_eq in H3.
apply emptyset_empty with emptyset. eapply eq_ind.
ap singleton_inc.
wr H3;au.
ap empty_emptyset;ir.
apply inter2_and in H1;ee. apply product_pr in H1;apply product_pr in H2;ee.
apply singleton_eq in H5;apply singleton_eq in H3.
apply emptyset_empty with emptyset. eapply eq_ind.
ap singleton_inc.
wr H3;au.
Qed.

Lemma caPlus_strict_union : forall x y, inter2 x y = emptyset ->
caPlus x y = card (union2 x y).
Proof.
ir. ap card_invariant.
ap Equipotent.union2_equipotent.
ap empty_emptyset;ir.
apply inter2_and in H0;ee.
apply product_pr in H0;ee;nin H0.
clpri H2;clpri H3.
apply singleton_eq in H2;subst.
apply product_pair_pr in H1;ee.
apply singleton_eq in H0.
apply emptyset_empty with emptyset. eapply eq_ind.
ap singleton_inc. au.
am.
ap are_equipotent_sym. ap trans_equipotent.
exists (J emptyset). uhg;ee;uhg;ir.
ap product_pair_inc;au. ap singleton_inc.
apply pair_eq in H2;au.
apply product_pr in H0;ee;nin H0.
clpri H1;clpri H2;apply singleton_eq in H1;subst.
exists b;ee;au.

ap are_equipotent_sym. ap trans_equipotent.
exists (J (singleton emptyset)). uhg;ee;uhg;ir.
ap product_pair_inc;au. ap singleton_inc.
apply pair_eq in H2;au.
apply product_pr in H0;ee;nin H0.
clpri H1;clpri H2;apply singleton_eq in H1;subst.
exists b;ee;au.
Qed.

Lemma caMult_card_proper : forall a a', are_equipotent a a' ->
forall b b', are_equipotent b b' ->
caMult a b = caMult a' b'.
Proof.
ir. ap card_invariant. ap Equipotent.product_equipotent;am.
Qed.

Lemma caMult_singleton_l : forall x y, caMult (singleton x) y = card y.
Proof.
ir;ap card_invariant.
ap are_equipotent_sym. ap trans_equipotent.
exists (J x). uhg;ee;uhg;ir.
ap product_pair_inc;au. ap singleton_inc.
apply pair_eq in H1;am.
apply product_pr in H;ee;nin H;clpri H0;clpri H1.
apply singleton_eq in H0;subst.
exists b;ee;au.
Qed.

Lemma caPlus_comm : forall c d, c + d = d + c.
Proof.
ir;uf caPlus.
ap card_invariant.
rw are_equipotent_transformation.
exists (fun x => let a := P x in let b := Q x in if eq_dec a (emptyset) then
J ((singleton emptyset)) b else
J (emptyset) b).

assert (Hs : singleton emptyset <> emptyset).
uhg;ir. apply emptyset_empty with emptyset. eapply eq_ind.
ap singleton_inc. am.

uhg;ee;uhg;ir.
apply union2_or in H. nin H; apply product_pr in H;ee;nin H;
clpri H0;clpri H1;clpr.
apply singleton_eq in H0;subst.
rw eq_dec_if. ap union2_r. ap product_pair_inc. ap singleton_inc.
am.

apply singleton_eq in H0;subst.
rw eq_dec_if_not.
ap union2_l. ap product_pair_inc. ap singleton_inc. am.
am.

apply union2_or in H;apply union2_or in H0.
nin H;nin H0;apply product_pr in H;apply product_pr in H0;ee;nin H;nin H0;
clpri H1;clpri H2;clpri H3;clpri H4;clpri H5;clpr;
apply singleton_eq in H4;apply singleton_eq in H2;
subst;repeat rwi eq_dec_if H1.
apply pair_eq in H1. ap uneq. am.
rwi eq_dec_if_not H1. cp Hs;nin H.
apply pair_eq in H1. au.
cp Hs;nin H. rwi eq_dec_if_not H1. apply pair_eq in H1. am.
am.
rwi eq_dec_if_not H1;au. apply pair_eq in H1.
nin Hs;ee;au.

rwi eq_dec_if_not H1;au;rwi eq_dec_if_not H1;au.
apply pair_eq in H1. ee;subst. tv.

apply union2_or in H. nin H;apply product_pr in H;ee;nin H;clpri H0;clpri H1;clpr;
apply singleton_eq in H0;subst.
econstructor. ee. ap union2_r. ap product_pair_inc. ap singleton_inc.
am.
clpr. rw eq_dec_if_not;au.
econstructor. ee. ap union2_l. ap product_pair_inc. ap singleton_inc. am.
clpr. rw eq_dec_if. tv.
Qed.

Lemma caMult_comm : forall c d, c*d=d*c.
Proof.
ir;uf caMult;ap card_invariant.
rw are_equipotent_transformation.
exists (fun x => J (Q x) (P x)).
uhg;ee;uhg;ir.
apply product_pr in H;ee;nin H. clpri H0;clpri H1;clpr.
ap product_pair_inc;au.
apply product_pr in H;ee;nin H. clpri H1;clpri H2;clpri H3.
apply product_pr in H0;ee; nin H. clpri H1.
apply pair_eq in H1. ee;subst;tv.

apply product_pr in H;ee;nin H. clpri H0;clpri H1;clpr.
econstructor;ee. ap product_pair_inc. am. am.
clpr. tv.
Qed.

Lemma caPlus_assoc : forall x y z, caPlus x (caPlus y z) = caPlus (caPlus x y) z.
Proof.
ir. uf caPlus.

assert (Hs : singleton emptyset <> emptyset).
uhg;ir. apply emptyset_empty with emptyset. eapply eq_ind.
ap singleton_inc. am.

ap card_invariant.
rw are_equipotent_transformation.
set (t1:= singleton emptyset). set (t2 := singleton t1).

cp (card_equipotent (union2 (product t1 y) (product t2 z))).
cp (card_equipotent (union2 (product t1 x) (product t2 y))).
apply are_equipotent_sym in H. rwi are_equipotent_transformation H.
rwi are_equipotent_transformation H0.
destruct H as [f H]. destruct H0 as [g H0].

exists (fun p => let a := P p in let b := Q p in
if eq_dec a emptyset then (*b in x -> g (emptyset, b) in card ...*)
J emptyset (g p )
else let c := f b in
if eq_dec (P c) emptyset then J emptyset (g (J (t1) (Q c)))
else c).
uhg;ee;uhg;ir.
apply union2_or in H1;nin H1;apply product_pr in H1;ee;
nin H1;clpri H2;clpri H3;clpr;apply singleton_eq in H2;subst.
rw eq_dec_if.
ap union2_l. ap product_pair_inc. ap singleton_inc.
ap H0. ap union2_l. ap product_pair_inc. ap singleton_inc. am.
rw eq_dec_if_not;au.
apply H in H3. apply union2_or in H3;nin H3;apply product_pr in H1;ee;
nin H1;clpri H2;clpri H3;clpr;apply singleton_eq in H2;subst.
rw eq_dec_if. ap union2_l. ap product_pair_inc. ap singleton_inc. ap H0.
ap union2_r. ap product_pair_inc. ap singleton_inc. am.
rw eq_dec_if_not;au. ap union2_r. ap product_pair_inc. ap singleton_inc.
am.

apply union2_or in H1;nin H1;apply product_pr in H1;ee;
nin H1;clpri H4;clpri H5;apply singleton_eq in H4;subst;
apply union2_or in H2;nin H2;apply product_pr in H1;ee;nin H1;
clpri H4;clpri H2;apply singleton_eq in H2;subst;clpri H3;repeat rwi eq_dec_if H3.
apply pair_eq in H3;ee.
ap H0. ap union2_l. ap product_pair_inc. ap singleton_inc.
am. ap union2_l. ap product_pair_inc. ap singleton_inc.
am.
am.

apply H in H4. apply union2_or in H4;nin H4; apply product_pr in H1;ee;
nin H1;clpri H2;clpri H4.
rwi eq_dec_if_not H3;au.
clpri H3.
apply singleton_eq in H2;subst. rwi eq_dec_if H3.
apply pair_eq in H3;ee.
apply H0 in H2. apply pair_eq in H2;ee. nin Hs;au.
ap union2_l. ap product_pair_inc. ap singleton_inc.
am.
 ap union2_r. ap product_pair_inc. ap singleton_inc.
am.
rwi eq_dec_if_not H3;au.
clpri H3. apply singleton_eq in H2;subst.
rwi eq_dec_if_not H3;au. apply pair_eq in H3;ee;nin Hs;au.
rwi eq_dec_if_not H3;au.
apply H in H5.
apply union2_or in H5;nin H5;apply product_pr in H1;ee;nin H1;
clpri H2;clpri H5;apply singleton_eq in H2;subst;clpri H3.
rwi eq_dec_if H3.
apply pair_eq in H3;ee.
apply H0 in H2. apply pair_eq in H2;ee;nin Hs;au.
 ap union2_r. ap product_pair_inc. ap singleton_inc.
am.  ap union2_l. ap product_pair_inc. ap singleton_inc.
am.
rwi eq_dec_if_not H3;au. apply pair_eq in H3;ee;nin Hs;au.

ap uneq. ap H. am. am.
apply H in H5;apply H in H4.
apply union2_or in H5;nin H5;apply product_pr in H1;ee;nin H1;
clpri H2;clpri H5;apply singleton_eq in H2;subst;
apply union2_or in H4;nin H4;apply product_pr in H1;ee;nin H1;
clpri H2;clpri H4;apply singleton_eq in H2;subst;clpri H3;
repeat rwi eq_dec_if H3.
rwi eq_dec_if_not H3;au. rwi eq_dec_if_not H3;au.
apply pair_eq in H3. ee.
apply H0 in H2;try (ap union2_r;ap product_pair_inc;try (ap singleton_inc);am).
apply pair_eq in H2;ee.
subst.  tv.
rwi eq_dec_if_not H3;au. rwi eq_dec_if_not H3;au.
rwi eq_dec_if_not H3;au. apply pair_eq in H3;ee;nin Hs;au.
rwi eq_dec_if_not H3;au. rwi eq_dec_if_not H3;au. rwi eq_dec_if_not H3;au.
apply pair_eq in H3;ee;nin Hs;au.
rwi eq_dec_if_not H3;au. rwi eq_dec_if_not H3;au. rwi eq_dec_if_not H3;au.
rwi eq_dec_if_not H3;au.

apply union2_or in H1;nin H1;apply product_pr in H1;ee;nin H1;
clpri H2;clpri H3;clpr;apply singleton_eq in H2;subst.
apply H0 in H3. nin H3;ee.
subst. apply union2_or in H1;nin H1;apply product_pr in H1;ee;
nin H1;clpri H2;clpri H3;apply singleton_eq in H2;subst;clpr.
exists (J emptyset b). ee.
ap union2_l. ap product_pair_inc. ap singleton_inc.
am.
clpr. rw eq_dec_if. tv.
assert (inc (J emptyset b) (union2 (product t1 y) (product t2 z))).
ap union2_l. ap product_pair_inc. ap singleton_inc.
am.
apply H in H1. nin H1;ee;subst.
exists (J t1 x0);ee.
ap union2_r. ap product_pair_inc. ap singleton_inc.
am.
clpr.  rw eq_dec_if_not;au. rw H2;clpr. rw eq_dec_if. tv.
assert (inc (J t1 b) (union2 (product t1 y) (product t2 z))).
ap union2_r. ap product_pair_inc. ap singleton_inc.
am.
apply H in H1;nin H1;ee;subst.
econstructor. ee. ap union2_r. ap product_pair_inc.
ap singleton_inc. am. clpr. rw eq_dec_if_not;au.
rw H2;clpr. rw eq_dec_if_not;au.
Qed.

Lemma caMult_assoc : forall x y z, caMult x (caMult y z) = caMult (caMult x y) z.
Proof.
ir. transitivity (card (product x (product y z))).
ap card_invariant.
ap Equipotent.product_equipotent.
ap are_equipotent_refl.
ap are_equipotent_sym. ap card_equipotent.
etransitivity. ap card_invariant. ap Equipotent.product_equipotent_assoc.
ap card_invariant.
ap Equipotent.product_equipotent.
ap card_equipotent.
ap are_equipotent_refl.
Qed.

Lemma caPlus_cardinal_0_r : forall x, is_cardinal x -> caPlus x emptyset = x.
Proof.
ir. transitivity (card x).
ap card_invariant. rw product_emptyset_r.
ap trans_equipotent.
exists Q. uhg;ee;uhg;ir.
apply union2_or in H0;nin H0. apply product_pr in H0;ee. am.
edestruct emptyset_empty;am.
apply union2_or in H0;apply union2_or in H1.
nin H0;nin H1;try (edestruct emptyset_empty;am).
apply product_pr in H0;apply product_pr in H1. ee.
nin H0;nin H1. clpri H3;clpri H4;clpri H5;clpri H6.
clpri H2. apply singleton_eq in H5;apply singleton_eq in H3;subst;tv.
exists (J emptyset y). ee.
ap union2_l. ap product_pair_inc. ap singleton_inc. am.
clpr;tv.
symmetry;ap cardinal_eq_card. am.
ap are_equipotent_refl.
Qed.

Lemma caPlus_N_0_r : forall x, inc x nNum -> caPlus x emptyset = x.
Proof.
ir. ap caPlus_cardinal_0_r. wr nNum_card. ap card_is_cardinal. am.
Qed.

Lemma caPlus_N_S : forall x, inc x nNum -> forall y, inc y nNum ->
caPlus x (oS y) = oS (caPlus x y).

Proof.
pose (p := fun x y => inc (caPlus x y) nNum -> caPlus x (oS y) = oS (caPlus x y)).
assert (forall x n, inc x nNum -> inc n nNum -> p x n).
uf p;ir.
symmetry. ap cardinal_eq_card. eapply eq_ind. ap card_is_cardinal.
ap nNum_card. ap oS_nNum;am.

ap are_equipotent_sym. ap trans_equipotent.
cp (card_equipotent (union2 (product (singleton ∅) x)
          (product (singleton (singleton ∅)) n))).
apply are_equipotent_sym in H2.
rwi are_equipotent_transformation H2.
destruct H2 as [f H2].
cp product_pair_inc;cp singleton_inc.
assert (singleton emptyset <> emptyset).
uhg;ir;apply emptyset_empty with emptyset.
eapply eq_ind. ap singleton_inc. am.

assert (forall a, inc a (x+n) -> a<>x+n).
ir. ap ordinal_inc_neq. ap card_ordinal. am.
assert (forall a, a=x+n -> ~ inc a (x+n)).
uhg;ir;subst. eapply H6. am. tv.

exists (fun a => if eq_dec a (x+n) then J (singleton emptyset) n
else f a).
uhg;ee;uhg;ir.
rwi oS_inc H8;nin H8.
rw eq_dec_if_not. apply H2 in H8.
apply union2_or in H8. nin H8.
ap union2_l;am. ap union2_r. apply product_pr in H8.
ee. ap product_inc. am. am. rw oS_inc;au.
ap ordinal_inc_neq. ap card_ordinal. am.
subst. rw eq_dec_if. ap union2_r.
ap product_pair_inc;au. rw oS_inc;au.

rwi oS_inc H8;rwi oS_inc H9.
nin H8;nin H9;subst;repeat rwi eq_dec_if H10.
rwi eq_dec_if_not H10;au. rwi eq_dec_if_not H10;au.
ap H2;au.
subst. rwi eq_dec_if_not H10;au.
apply H2 in H8.
apply union2_or in H8. rwi H10 H8.
nin H8;apply product_pair_pr in H8;ee.
apply singleton_eq in H8. nin H5;am.
edestruct ordinal_inc_neq. ap nNum_ordinal.
ap H0. am. tv.
rwi eq_dec_if_not H10;au.
apply H2 in H9. apply union2_or in H9.
wri H10 H9. nin H9;apply product_pair_pr in H8;ee.
nin H5;ap singleton_eq;am.
edestruct ordinal_inc_neq. ap nNum_ordinal.
ap H0. am. tv.
tv.

apply union2_or in H8. nin H8;apply product_pr in H8;ee;
nin H8;clpri H9;clpri H10;apply singleton_eq in H9;subst.
assert (inc (J emptyset b)  (union2 (product (singleton ∅) x)
          (product (singleton (singleton ∅)) n))).
ap union2_l;au.
apply H2 in H8.
nin H8. ee.
exists x0;ee.
rw oS_inc. left;am.
rw eq_dec_if_not;au.
rwi oS_inc H10. nin H10.
assert (inc (J (singleton emptyset) b)  (union2 (product (singleton ∅) x)
          (product (singleton (singleton ∅)) n))).
ap union2_r;au.
apply H2 in H9.
nin H9. ee.
exists x0;ee.
rw oS_inc. left;am.
rw eq_dec_if_not;au.
subst.
exists (x+n). ee. rw oS_inc;au.
rw eq_dec_if;au.

pose (p' x n := inc (x+n) nNum).
assert (forall x, inc x nNum -> forall n, inc n nNum -> p' x n).
intros x Hx. ap nNum_rect;uf p';ir.
rw caPlus_N_0_r;am.
ufi p H. rw H. ap oS_nNum. am.
am. am. am.

ir;ap H;try am.
ap H0;am.
Qed.

Lemma caPlus_N_lci : is_lci caPlus nNum.
Proof.
uhg. intros x Hx.
ap nNum_rect.
rw caPlus_N_0_r;am.
ir. rw caPlus_N_S;au. ap oS_nNum;am.
Qed.

Lemma caPlus_N_comm : commutative caPlus nNum.
Proof.
uhg;ir;ap caPlus_comm.
Qed.

Lemma caPlus_N_assoc : associative caPlus nNum.
Proof.
uhg;ir;ap caPlus_assoc.
Qed.

Lemma caPlus_N_0_l : forall x, inc x nNum -> caPlus emptyset x = x.
Proof.
ir;etransitivity. ap caPlus_comm.
ap caPlus_N_0_r;am.
Qed.

Lemma caPlus_0_N_neutre : is_neutre caPlus nNum emptyset.
Proof.
uhg;ee. ap emptyset_N. ap caPlus_N_0_r. ap caPlus_N_0_l.
Qed.

Lemma caPlus_N_monoid : is_monoid caPlus nNum emptyset.
Proof.
uhg;ee. ap caPlus_N_lci. ap caPlus_0_N_neutre.
ap caPlus_N_assoc.
Qed.

Lemma caMult_0_r : forall x, caMult x emptyset = emptyset.
Proof.
ir. ap empty_emptyset;ir.
cp (card_equipotent (product x emptyset)).
nin H0. apply H0 in H. nin H;ee.
apply product_pr in H;ee;eapply emptyset_empty;am.
Qed.

Lemma caMult_0_l : forall x, caMult emptyset x = emptyset.
Proof.
ir. rw caMult_comm. ap caMult_0_r.
Qed.

Lemma caMult_singleton_r : forall a x, caMult a (singleton x) = card a.
Proof.
ir. ap card_invariant. ap are_equipotent_sym. ap trans_equipotent.
exists (fun y => J y x).
uhg;ee;uhg;ir. ap product_pair_inc. am. ap singleton_inc.
apply pair_eq in H1;ee;au.
apply product_pr in H;ee;nin H;clpri H0;clpri H1.
apply singleton_eq in H1;subst.
exists a0;ee. am. tv.
Qed.

Lemma caMult_N_o1_r : forall n, inc n nNum -> caMult n o1 = n.
Proof.
ir. rw o1_rw. rw caMult_singleton_r. ap nNum_card. am.
Qed.

Lemma caMult_N_S : forall a, inc a nNum -> forall b, inc b nNum ->
caMult a (oS b) = caPlus (caMult a b) a.
Proof.
pose (p := fun x y => inc (caMult x y) nNum -> caMult x (oS y) = caPlus (caMult x y) x).
assert (forall a, inc a nNum -> forall b, inc b nNum -> p a b).
uf p;ir.
ap card_invariant.
ap trans_equipotent.
cp (card_equipotent (product a b)).
rwi are_equipotent_transformation H2.
destruct H2 as [f H2].

assert (singleton emptyset <> emptyset).
uhg;ir;apply emptyset_empty with emptyset.
eapply eq_ind. ap singleton_inc. am.

exists (fun p => let pb := Q p in
if eq_dec pb b then J (singleton emptyset) (P p)
else J emptyset (f p)).
uhg;ee;uhg;ir.
apply product_pr in H4;ee;nin H4.
clpri H5;clpri H6. rwi oS_inc H6.
clpr. nin H6.
rw eq_dec_if_not. ap union2_l. ap product_pair_inc.
ap singleton_inc. ap H2. ap product_pair_inc;am.
ap ordinal_inc_neq;try am. ap nNum_ordinal;am.
subst. rw eq_dec_if. ap union2_r.
ap product_pair_inc. ap singleton_inc. am.

apply product_pr in H4;apply product_pr in H5;ee;nin H4;nin H5.
clpri H9;clpri H10;clpri H7;clpri H8.
clpri H6.
rwi oS_inc H10;rwi oS_inc H8;nin H10;nin H8;subst;repeat rwi eq_dec_if H6.
rwi eq_dec_if_not H6. rwi eq_dec_if_not H6. apply pair_eq in H6;ee.
apply H2;au. ap product_pair_inc;am. ap product_pair_inc;am.
ap ordinal_inc_neq;au. ap nNum_ordinal;am.
ap ordinal_inc_neq;au. ap nNum_ordinal;am.
rwi eq_dec_if_not H6. apply pair_eq in H6;ee.
nin H3;au.
ap ordinal_inc_neq;au. ap nNum_ordinal;am.
rwi eq_dec_if_not H6. apply pair_eq in H6;ee. nin H3;au.
ap ordinal_inc_neq;au. ap nNum_ordinal;am.
apply pair_eq in H6;ee.
subst. tv.

apply union2_or in H4;nin H4;
apply product_pr in H4;ee;nin H4;
clpri H5;clpri H6;apply singleton_eq in H5;subst.
cp H6. apply H2 in H4. nin H4;ee.
subst. apply product_pr in H4;ee;nin H4.
clpri H5;clpri H7.
exists (J a0 b0);ee. ap product_pair_inc. am. rw oS_inc;au.
clpr. rw eq_dec_if_not. tv.
ap ordinal_inc_neq;au. ap nNum_ordinal;am.
exists (J b0 b);ee. ap product_pair_inc;au.
rw oS_inc;au. clpr. rw eq_dec_if;au.

assert (forall a, inc a nNum -> forall b, inc b nNum -> inc (caMult a b) nNum).
intros a Ha. ap nNum_rect;ir.
rw caMult_0_r. ap emptyset_N.
rw H. ap caPlus_N_lci. am. am. am. am. am.

ir;ap H;au.
Qed.

Lemma caMult_N_lci : is_lci caMult nNum.
Proof.
uhg;intros a Ha;ap nNum_rect;ir.
rw caMult_0_r. ap emptyset_N.
rw caMult_N_S. ap caPlus_N_lci. am. am. am. am.
Qed.

Lemma caMult_N_comm : commutative caMult nNum.
Proof.
uhg;ir;ap caMult_comm.
Qed.

Lemma caMult_N_assoc : associative caMult nNum.
Proof.
uhg;ir;ap caMult_assoc.
Qed.

Lemma caMult_1_neutre : is_neutre caMult nNum o1.
Proof.
uhg;ee. ap o1_N. ap caMult_N_o1_r.
ir. rw caMult_comm. ap caMult_N_o1_r;am.
Qed.

Lemma caMult_N_monoid : is_monoid caMult nNum o1.
Proof.
uhg;ee. ap caMult_N_lci.
ap caMult_1_neutre. ap caMult_N_assoc.
Qed.

Lemma caMult_distrib_l : forall a b c, caMult a (caPlus b c) = caPlus
(caMult a b) (caMult a c).
Proof.
ir. transitivity (caPlus (product a b) (product a c)). ap card_invariant.
ap trans_equipotent.
assert (singleton emptyset <> emptyset).
uhg;ir;apply emptyset_empty with emptyset.
eapply eq_ind. ap singleton_inc. am.

cp (card_equipotent (union2 (product (singleton emptyset) b)
(product (singleton (singleton emptyset)) c))).
replace ((card
          (union2 (product (singleton ∅) b)
             (product (singleton (singleton ∅)) c)))) with (b+c) in H0.
Focus 2. tv.
apply are_equipotent_sym in H0.
rwi are_equipotent_transformation H0.
destruct H0 as [f H0].
pose (g := fun p => let pfp := P (f (Q p)) in let qfp := Q (f (Q p)) in
if eq_dec pfp emptyset then J emptyset (J (P p) (qfp))
else J (singleton emptyset) (J (P p) (qfp))).
assert (forall p, inc p (product a (b+c)) -> (Q (g p) = J (P p) (Q (f (Q p))) &
inc (g p) (union2 (product (singleton ∅) (product a b))
        (product (singleton (singleton ∅)) (product a c))))).
ir.
 ap PropGuard_use. uf g;ee. apply product_pr in H1;ee;nin H1. clpri H2;clpri H3.
clpr. apply H0 in H3. apply union2_or in H3;nin H3;
apply product_pr in H1;ee;nin H1;clpri H3;clpri H4;apply singleton_eq in H3;
ap Pguard;ee;subst;clpr.
rw eq_dec_if. clpr. tv.
rw eq_dec_if. ap union2_l. ap product_pair_inc.
ap singleton_inc. ap product_pair_inc;am.

rw eq_dec_if_not. clpr. tv.
am.
rw eq_dec_if_not;au. ap union2_r.
repeat ap product_pair_inc;au. ap singleton_inc.

exists g.
uhg;ee;uhg;ir.
ap H1. am.

cp (uneq Q H4). rwi (and_P (H1 x H2)) H5.
rwi (and_P (H1 y H3)) H5.
apply pair_eq in H5. ee.
apply product_pr in H2;ee;apply product_pr in H3;ee;nin H2;nin H3;
clpri H7;clpri H8;clpri H9;clpri H10;clpri H4;clpri H5;clpri H6.
cp H8;cp H10;apply H0 in H8. apply H0 in H10.
subst.
ap uneq. apply union2_or in H8;apply union2_or in H10.
clear H1. ufi g H4;clpri H4.
ap H0. am. am.
nin H8;nin H10;apply product_pr in H1;apply product_pr in H5;ee;
nin H1;nin H5;clpri H11;clpri H12;clpri H6;clpri H10;clpri H8;
apply singleton_eq in H11;apply singleton_eq in H8;subst;clpri H4
;repeat rwi eq_dec_if H4;au.
rwi eq_dec_if_not H4;au. apply pair_eq in H4;ee;nin H;au.
rwi eq_dec_if_not H4;au. apply pair_eq in H4;ee;nin H;au.

clear H1.
apply union2_or in H2;nin H2;apply product_pr in H1;ee;nin H1;
clpri H2;clpri H3;apply singleton_eq in H2;subst;clpr.
assert (inc (J emptyset (Q b0))  (union2 (product (singleton ∅) b)
          (product (singleton (singleton ∅)) c))).
ap union2_l;ap product_pair_inc. ap singleton_inc. eapply product_pr. am.
apply H0 in H1. nin H1;ee;subst.
uf g. apply product_pr in H3;ee;nin H3.
clpri H4;clpri H5;clpri H2. exists (J a0 x).
ee. ap product_pair_inc;am.
clpr. rw H2;clpr. rw eq_dec_if. tv.

assert (inc (J (singleton emptyset) (Q b0))  (union2 (product (singleton ∅) b)
          (product (singleton (singleton ∅)) c))).
ap union2_r;ap product_pair_inc. ap singleton_inc. eapply product_pr. am.
apply H0 in H1. nin H1;ee;subst.
uf g. apply product_pr in H3;ee;nin H3.
clpri H4;clpri H5;clpri H2. exists (J a0 x).
ee. ap product_pair_inc;am.
clpr. rw H2;clpr. rw eq_dec_if_not;au.

(*other part of transitivity from very beginning*)
ap caPlus_card_proper; ap card_equipotent.
Qed.

Lemma caMult_distrib_r : forall a b c, caMult (caPlus b c) a = caPlus
(caMult b a) (caMult c a).
Proof.
ir. rw caMult_comm. rw caMult_distrib_l. rw caMult_comm. ap uneq.
ap caMult_comm.
Qed.

Lemma caMult_N_distrib : distributes caPlus caMult nNum.
Proof.
uhg. ee. uhg. ir.
ap caMult_distrib_l.
uhg;ir;ap caMult_distrib_r.
Qed.

Lemma ca_N_quasiring : is_quasiring caPlus caMult nNum emptyset o1.
Proof.
uhg;ee.
ap caPlus_N_monoid.
ap caMult_N_monoid.
ap caMult_N_distrib.
ir;ap caMult_0_l.
ir;ap caMult_0_r.
Qed.

Lemma caMult_integral : forall a b, caMult a b = emptyset -> (a=emptyset \/ b=emptyset).
Proof.
ir;apply by_cases with (a=emptyset);ir;au.
right. ap empty_emptyset;ir.
cp (card_equipotent (product a b)).
ufi caMult H. rwi H H2.
nin H2. assert (nonempty a).
ap not_empty_nonempty.
am.
nin H3.
cp (product_pair_inc H3 H1).
apply (bijective_of_map H2) in H4.
eapply emptyset_empty;am.
Qed.

End NotaSection.

End Cardinal_arith.

Module Ordinal_arith.
Export Ordinal. Export Function.
Export Map.
Import Cardinal_arith.

Definition oPlus b := ordinal_rec_cases b (fun o fo => oS fo)
(fun h => union (range h)).

Lemma oPlus_0_r : forall b, oPlus b emptyset = b.
Proof.
ir. uf oPlus.
rw ordinal_rec_case_0. tv.
Qed.

Lemma oPlus_S : forall b, forall a, is_ordinal a ->
oPlus b (oS a) = oS (oPlus b a).
Proof.
ir. uf oPlus.
rw ordinal_rec_case_S. tv. am.
Qed.

Lemma oPlus_limit : forall a, limit_ordinal a -> forall b,
oPlus b a = union (Im (oPlus b) a).
Proof.
ir.
uf oPlus. rw ordinal_rec_case_limit.
rw range_Im_rw. rw create_domain.
ap uneq. fold (oPlus b).
ap Im_ev_create. ap create_axioms.
am.
Qed.

Lemma oPlus_1_r : forall a, oPlus a (oS emptyset) = oS a.
Proof.
ir.  rw oPlus_S. rw oPlus_0_r. tv. ap emptyset_ordinal.
Qed.

Lemma oPlus_inc_compat_r : forall a, forall b c, is_ordinal c -> inc b c ->
inc (oPlus a b) (oPlus a c).
Proof.
intros a b. pose (H := emptyset). (*dummy value*)
 pose (p := fun c => inc b c -> inc (oPlus a b) (oPlus a c)).
assert (forall c, is_ordinal c -> p c).
ap ordinal_ind_cases;uf p;ir.
apply emptyset_empty in H0;nin H0.

ufi oS H2. rwi tack_on_inc H2. nin H2.
rw oPlus_S. uf oS;rw tack_on_inc;au. am.
subst. rw oPlus_S;au.
uf oS;rw tack_on_inc;au.

rw (oPlus_limit H0).
cp H2. wri (ordinal_limit_union_self H0) H3. apply union_ex in H3;nin H3;ee.
cp (H1 x H3 H4).
ap union_inc. exists (oPlus a x). ee.
ap Im_inc. am. am.

ap H0.
Qed.

Lemma oPlus_ordinal : forall b, is_ordinal b -> forall a, is_ordinal a ->
is_ordinal (oPlus b a).
Proof.
intros b H. ap ordinal_ind_cases.
rw oPlus_0_r;am.
ir. rw oPlus_S;au. ap ordinal_S;am.
ir. rw oPlus_limit;au.
ap ordinal_union.
ir. apply Im_ex in H2;nin H2;ee;subst;au.
Qed.

Lemma oPlus_sub_compat_l : forall b c, is_ordinal c -> inc b c -> forall a, is_ordinal a ->
sub (oPlus b a) (oPlus c a).
Proof.
intros b c H H0. assert (is_ordinal b).
apply ordinal_in_ordinal with c;am.
ap ordinal_ind_cases.
rw oPlus_0_r. rw oPlus_0_r.
rw ordinal_sub_leq_of;au;uhg;au.

ir.
repeat rw oPlus_S;au.
cp oPlus_ordinal.
uf oS;uhg;intro;repeat rw tack_on_inc;ir.
nin H5. left. au.
subst.
rwi ordinal_sub_leq_of H3;au.

ir. rw oPlus_limit;au.
rw oPlus_limit;au.
uhg;ir.
apply union_ex in H4;nin H4;ee.
apply Im_ex in H4;nin H4;ee;subst.
ap union_inc. exists (oPlus c x0). ee.
ap Im_inc;am.
ap H3. am. am.
Qed.

Lemma oPlus_sub_compat_r : forall a, is_ordinal a -> forall b, is_ordinal b ->
forall c, is_ordinal c -> sub b c ->
sub (oPlus a b) (oPlus a c).
Proof.
ir. rwi ordinal_sub_leq_of H2;au.
rw ordinal_sub_leq_of.
nin H2. left.
ap oPlus_inc_compat_r. am. am.
subst. right;tv.
ap oPlus_ordinal;am. ap oPlus_ordinal;am.
Qed.

Lemma oPlus_reg_r : forall a, is_ordinal a -> forall b c, is_ordinal b -> is_ordinal c ->
oPlus a b = oPlus a c -> b=c.
Proof.
ir.
cp (oPlus_ordinal).
destruct ordinal_inc_eq_inc with b c;au.
destruct ordinal_not_inc_self with (oPlus a b).
au. assert (inc (oPlus a b) (oPlus a c)).
ap oPlus_inc_compat_r;au. wri H2 H5;am.
nin H4. am.
destruct ordinal_not_inc_self with (oPlus a c).
au. assert (inc (oPlus a c) (oPlus a b)).
ap oPlus_inc_compat_r;au. rwi H2 H5;am.
Qed.

Lemma oPlus_assoc : forall a, is_ordinal a -> forall b, is_ordinal b -> forall c, is_ordinal c -> oPlus (oPlus a b) c = oPlus a (oPlus b c).
Proof.
intros a Ha b H. ap ordinal_ind_cases.
rw oPlus_0_r. rw oPlus_0_r. tv.
ir. rw oPlus_S. rw oPlus_S. rw oPlus_S.
rw H1. tv. ap oPlus_ordinal;am. am. am.

ir.  rw (oPlus_limit H0).
rw (oPlus_limit H0).
assert (limit_ordinal (⋃ (Im (oPlus b) o))).
uhg;ee. ap ordinal_union.
ir. apply Im_ex in H2;nin H2;ee;subst. ap oPlus_ordinal.
am. apply ordinal_in_ordinal with o;am.
assert (sub (oS emptyset) o).
uhg;ir. ufi oS H2;rwi tack_on_inc H2. nin H2.
apply emptyset_empty in H2;nin H2. subst.
destruct (ordinal_inc_eq_inc) with emptyset o;try am.
ap emptyset_ordinal. nin H2. subst. ap False_rect.
uh H0;ee. nin H2. apply emptyset_empty with x;am.
apply emptyset_empty in H2;nin H2.

exists (oPlus b emptyset).
assert (union o = o). ap ordinal_limit_union_self;am.
assert (inc emptyset o). ap H2;uf oS;rw tack_on_inc;au.
wri H3 H4. apply union_ex in H4;nin H4.
ee.
ap union_inc. econstructor.
ee. ap Im_inc. am. ap oPlus_inc_compat_r. apply ordinal_in_ordinal with o;am.
am.

uhg;ir. nin H2.
ee. assert (inc x (oS x)). uf oS;rw tack_on_inc;au.
wri H3 H4.
apply union_ex in H4. nin H4;ee.
apply Im_ex in H4. nin H4;ee.
subst.
eapply H0. exists x1. assert (is_ordinal x1). apply ordinal_in_ordinal with o;am.
ee. am.
destruct (ordinal_inc_eq_inc) with o (oS x1).
am. ap ordinal_S;am.
ufi oS H7;rwi tack_on_inc H7;nin H7. destruct ordinal_inc_inc_not with o x1;au.
subst. destruct ordinal_not_inc_self with x1;au.
nin H7. am.
assert (inc (oS x) (union (Im (oPlus b) o))).
ap union_inc. econstructor. ee.
ap Im_inc. am. rw oPlus_S;au.
ap ordinal_S_inc_inc. am. ap oPlus_ordinal;au.
am.
rwi H3 H8. destruct ordinal_not_inc_self with (oS x);au.
ap ordinal_S;am.

assert (oPlus b o = union (Im (oPlus b) o)).
ap oPlus_limit. am.

wr oPlus_limit;au. wr oPlus_limit;au.
assert (oPlus (oPlus a b) o = union (Im (oPlus (oPlus a b)) o)).
ap oPlus_limit;au. rw H4.
assert (⋃ (Im (oPlus (oPlus a b)) o) = (union (Im (fun d => oPlus a (oPlus b d)) o))).
ap uneq. ap Im_uneq. ir. au. rw H5.
transitivity (union (Im (oPlus a) (oPlus b o))).
Focus 2. symmetry. ap oPlus_limit. rw H3;am.

assert (forall y, inc y ((Im (fun d : E => oPlus a (oPlus b d)) o)) -> is_ordinal y).
ir. apply Im_ex in H6. nin H6. ee. subst. ap oPlus_ordinal;try am.
ap oPlus_ordinal;try am. apply ordinal_in_ordinal with o;am.
assert (forall y, inc y ( (Im (oPlus a) (oPlus b o))) -> is_ordinal y).
ir. apply Im_ex in H7;nin H7;ee;subst. ap oPlus_ordinal. am.
eapply ordinal_in_ordinal. Focus 2. am. ap oPlus_ordinal;try am. ap H0.
ap extensionality;[idtac | ap ordinal_union_sub;try am;ir].

uhg;ir. apply union_ex in H8;ee;nin H8;ee.
ap union_inc;exists x;ee;try am.
apply Im_ex in H8. nin H8;ee;subst.
ap Im_inc.
rw H3. assert (inc (oS x0) o). ap ordinal_limit_gt. am. am.
ap union_inc;econstructor;ee. ap Im_inc. am. rw oPlus_S. uf oS;rw tack_on_inc;au.
apply ordinal_in_ordinal with o;try am. ap H0.

apply Im_ex in H8. nin H8;ee;subst.
rwi H3 H8. apply union_ex in H8;nin H8;ee.
apply Im_ex in H8;nin H8;ee;subst.
assert (inc (oPlus a x) (oPlus a (oPlus b x1))).
ap oPlus_inc_compat_r. ap oPlus_ordinal. am. apply ordinal_in_ordinal with o.
ap H0. am.
am.
exists (oPlus a (oPlus b x1)). ee.
ap Im_show_inc. exists x1;ee. am. tv.
assert (is_ordinal a). am. assert (is_ordinal b). am.
assert (is_ordinal o). ap H0. assert (is_ordinal x1).
apply ordinal_in_ordinal with o;am.
assert (is_ordinal (oPlus b x1)). ap oPlus_ordinal. am. am.
assert (is_ordinal x). apply ordinal_in_ordinal with (oPlus b x1);am.
cp (oPlus_ordinal). rw ordinal_sub_leq_of;au.
uhg. au.
Qed.

Lemma oPlus_sub_l : forall a, is_ordinal a -> forall b, is_ordinal b ->
sub a (oPlus a b).
Proof.
intros a H. ap ordinal_ind_cases.
rw oPlus_0_r. ap sub_refl.
ir. uhg;ir. rw oPlus_S;au. uf oS;rw tack_on_inc;au.

ir.
rw (oPlus_limit H0).
uhg;ir. ap union_inc.
uh H0;ee. nin H3.
cp (H1 x H3).
cp ( H5  a0 H2).
econstructor. ee. ap Im_inc. am. am.
Qed.

Lemma oPlus_sub_r : forall a, is_ordinal a -> forall b, is_ordinal b ->
sub b (oPlus a b).
Proof.
intros a H. ap ordinal_ind_cases.
ap emptyset_sub_all.
ir.
rw oPlus_S;au. uf oS;uhg;ir. rwi tack_on_inc H2. nin H2.
rw tack_on_inc. left. au.
rw tack_on_inc;subst. rwi ordinal_sub_leq_of H1;au.
ap oPlus_ordinal;au.

ir.
uhg;ir.
assert (inc (oS a0) o). ap ordinal_limit_gt;am.
apply H1 in H3.
rw oPlus_limit;try am. ap union_inc.
econstructor. ee. ap Im_inc. ap ordinal_limit_gt. am. am.
ap H3. uf oS;rw tack_on_inc;au.
Qed.

Lemma oPlus_0_l : forall a, is_ordinal a -> oPlus emptyset a = a.
Proof.
ap ordinal_ind_cases.
ap oPlus_0_r.
ir. rw oPlus_S. ap uneq. am. am.
ir. rw oPlus_limit;au.
ap extensionality;uhg;ir.
apply union_ex in H1;nin H1;ee. apply Im_ex in H1;nin H1;ee;subst.
rwi H0 H2. uh H;ee;uh H;ee;eapply H;am.
am.
ap union_inc.
econstructor. ee. ap Im_inc. ap ordinal_limit_gt;am.
rw H0. uf oS;rw tack_on_inc;au. ap ordinal_limit_gt;au.
Qed.

Lemma oPlus_caPlus_N_eq : forall x, inc x nNum -> forall y, inc y nNum ->
oPlus x y = caPlus x y.
Proof.
intros x Hx;ap nNum_rect.
rw oPlus_0_r. rw caPlus_N_0_r. tv. am.
ir. rw oPlus_S. rw caPlus_N_S. ap uneq. am.
am. am. ap nNum_ordinal;am.
Qed.

Lemma ordinal_sub_ex : forall a, is_ordinal a -> forall b, is_ordinal b ->
sub a b -> exists c, is_ordinal c & b = oPlus a c.
Proof.
intros a H.
pose (p := fun a b => exists c, is_ordinal c & b = oPlus a c).
assert (forall b, is_ordinal b -> sub a b -> p a b);try am.
ap ordinal_sub_ind;uf p;ir. am.

exists emptyset;ee. ap emptyset_ordinal. rw oPlus_0_r;au.

destruct H2 as [c H2].
ee.
exists (oS c);ee. ap ordinal_S. am. subst.
symmetry. ap oPlus_S. am.

(*limit ordinal case*)
pose (n := union (Z b (fun x => inc (oPlus a x) b))).
assert (forall x, is_ordinal x -> inc (oPlus a x) b -> inc x b).
ir.
assert (sub x (oPlus a x)). ap oPlus_sub_r. am. am.
eapply ordinal_sub_inc_trans. am. am.
am. am.

assert (forall x, is_ordinal x -> inc (oPlus a x) b -> inc x (Z b (fun y => inc (oPlus a x) b))).
ir;ap Z_inc;au.

assert (b = union (Z b (sub a))).
ap extensionality. uhg;ir.
assert (is_ordinal a0). apply ordinal_in_ordinal with b;am.
ap union_inc.
destruct ordinal_inc_eq_inc with a a0;try am.
exists (oS a0). ee. ap Z_inc. ap ordinal_limit_gt. am. am.
cp (ordinal_S H6). uh H8;ee.
ap H8. clear H8;clear H9;clear H10.
apply ordinal_inc_trans with a0;try am.
rw oS_inc;au.
ap ordinal_S;am.
rw oS_inc;au.
nin H7;subst.
exists (oS a0). ee.
ap Z_inc. ap ordinal_limit_gt. am. am.
uhg;ir;rw oS_inc;au.
rw oS_inc;au.

exists a;ee. ap Z_inc. am. ap sub_refl.
am.

uhg;ir. union_nin H5. apply Z_all in H5;ee.
assert (is_transitive_set b). am. eapply H8.
am. am.

exists n;ee. uf n. ap ordinal_union. ir.
apply Z_sub in H6. apply ordinal_in_ordinal with b;am.
etransitivity. am.
transitivity (union (Im (oPlus a) n)).
ap uneq. ap extensionality;uhg;ir.
apply Z_all in H6;ee.
ap Im_show_inc. destruct H2 with a0.
am. am. ee.
exists x. ee;au. ap union_inc. exists (oS x).
ee. ap Z_inc. ap ordinal_limit_gt;try am. ap H3.
am. wr H9. am.
rw oPlus_S;au. ap ordinal_limit_gt;try am. wr H9. am.
rw oS_inc;au.
Im_nin H6.
rw H7.
union_nin H6. apply Z_all in H6. ee.
ap Z_inc. apply ordinal_inc_trans with (oPlus a x0).
ap oPlus_inc_compat_r. apply ordinal_in_ordinal with b;am.
am. am. am.
ap oPlus_sub_l. am.
apply ordinal_in_ordinal with x0;try am. apply ordinal_in_ordinal with b;try am.

assert (limit_ordinal n).
uhg;ee. ap ordinal_union. ir.
apply Z_sub in H6. apply ordinal_in_ordinal with b;am.
uf n. econstructor. ap union_inc. econstructor;ee.
ap Z_inc. Focus 2. rw oPlus_S. rw oPlus_0_r. ap ordinal_limit_gt. am. am.
ap emptyset_ordinal. ap ordinal_limit_gt. am.
ap ordinal_nonempty_emptyset_inc. am. am.
rw oS_inc;right;tv.
uhg;ir. nin H6. ee.
assert (inc (oS x) n).
uf n. assert (inc x n). rw H7. rw oS_inc;au.
union_nin H8.
apply Z_all in H8. ee.
ap union_inc. exists (oS x0). ee.
ap Z_inc. ap ordinal_limit_gt;am.
rw oPlus_S;au. ap ordinal_limit_gt;am.
apply ordinal_in_ordinal with b;am.
ap ordinal_S_inc_inc. am.
apply ordinal_in_ordinal with b;am.
am.
rwi H7 H8. apply ordinal_not_inc_self with (oS x).
ap ordinal_S;am. am.
rw (oPlus_limit H6).
tv.
Qed.

Lemma ordinal_sub_ex_rw : forall a, is_ordinal a -> forall b, is_ordinal b ->
sub a b = (exists c, is_ordinal c & b = oPlus a c).
Proof.
ir;ap iff_eq.
ap ordinal_sub_ex. am. am.
ir;nin H1;ee;subst.
ap oPlus_sub_l. am. am.
Qed.

Definition oMult a := ordinal_rec_cases emptyset (fun b fb => oPlus (fb) a)
(fun h => union ( range h)).

Lemma oMult_0_r : forall a, oMult a emptyset = emptyset.
Proof.
ir. ap ordinal_rec_case_0.
Qed.

Lemma oMult_S : forall a b, is_ordinal b -> oMult a (oS b) = oPlus (oMult a b) a.
Proof.
ir.
ap ordinal_rec_case_S. am.
Qed.

Lemma oMult_limit : forall a b, limit_ordinal b -> oMult a b = union (Im (oMult a) b).
Proof.
ir. etransitivity. ap ordinal_rec_case_limit. am.
rw create_range. reflexivity.
Qed.

Lemma oMult_1_r : forall a, is_ordinal a -> oMult a o1 = a.
Proof.
uf o1. ir.
rw oMult_S. rw oMult_0_r. rw oPlus_0_l. tv. am.
ap emptyset_ordinal.
Qed.

Lemma oMult_nNum_repeat : forall a, is_ordinal a ->
forall n, inc n nNum -> oMult a n = nNum_repeat (fun x => oPlus x a) n emptyset.
Proof.
intros a H. ap nNum_rect.
rw oMult_0_r. rw nNum_repeat_0. tv.
ir.
rw oMult_S.
rw nNum_repeat_S. wr H1.
tv. am. ap nNum_ordinal;am.
Qed.

Definition oExp a := ordinal_rec_cases o1 (fun b fb => oMult fb a)
(fun h => union (range h)).
(*oExp a b = a^b*)

Lemma oExp_0_r : forall a, oExp a emptyset = o1.
Proof.
ir. ap ordinal_rec_case_0.
Qed.

Lemma oExp_S : forall a b, is_ordinal b -> oExp a (oS b) = oMult (oExp a b) a.
Proof.
ir. ap ordinal_rec_case_S. am.
Qed.

Lemma oExp_limit : forall a b, limit_ordinal b -> oExp a b = union (Im (oExp a) b).
Proof.
ir. etransitivity. ap ordinal_rec_case_limit. am.
rw create_range. tv.
Qed.

Section Order_types.

Definition union_order (ra : E2P) (a : E) (rb : E2P) (b : E) (x y : E) :=
(inc x a & inc y a & ra x y)\/(inc x a & inc y b)\/(inc x b & inc y b & rb x y).

Lemma union_order_wo : forall ra a, is_well_order ra a ->
forall rb b, is_well_order rb b ->
inter2 a b = emptyset ->
is_well_order (union_order ra a rb b) (union2 a b).
Proof.
ir. uhg;dj.
uhg;ee;uhg;ir;try uhg.

apply union2_or in H2;nin H2.
left. ee;au. ap H. am.
right;right. ee;au. ap H0;am.

uh H4;uh H5;repeat nin H4;repeat nin H5;ee.
ap H;au.
destruct emptyset_empty with x. wr H1.
ap inter2_inc;am.
edestruct emptyset_empty. wr H1.
ap inter2_inc;am.
destruct emptyset_empty with y. wr H1.
ap inter2_inc;am.
edestruct emptyset_empty. wr H1.
ap inter2_inc;am.
edestruct emptyset_empty. wr H1.
ap inter2_inc;am.
edestruct emptyset_empty. wr H1.
ap inter2_inc;am.
destruct emptyset_empty with y. wr H1.
ap inter2_inc;am.
ap H0;am.

repeat nin H4;repeat nin H6;ee.
left. ee;au. apply H with y;am.
right;left;ee;au.
right;left;ee;au.
destruct emptyset_empty with y. wr H1.
ap inter2_inc;am.
right;left;au.
right;left;au.
destruct emptyset_empty with y. wr H1.
ap inter2_inc;am.
destruct emptyset_empty with y. wr H1.
ap inter2_inc;am.
right;right;ee;au;apply H0 with y;am.

apply by_cases with (exists x, inc x b0 & inc x a);ir.
nin H5;ee.
assert (ex (is_min a ra (inter2 a b0))).
ap H. ap inter2_l. exists x;ap inter2_inc;am.
nin H7. exists x0.
uhg;ee. uhg;ee.
ap union2_l;am.
ir. cp (H3 x1 H8).
apply union2_or in H9. nin H9.
uhg. left. ee;au.
ap H7. ap inter2_inc;am.
right. left. ee;am.
eapply inter2_r. am.

assert (sub b0 b).
uhg;ir. cp (H3 a0 H6).
apply union2_or in H7;nin H7.
nin H5;exists a0;ee;am. am.
assert (ex (is_min b rb b0)).
ap H0.
am. am.
nin H7. exists x;uhg;ee;try uhg;ee.
ap union2_r;am.
ir.
right;right. ee;au.
ap H7;au.
am.
Qed.

Lemma union_order_l : forall ra a rb b, inter2 a b = emptyset ->
forall x,  forall y, inc y a ->
union_order ra a rb b x y -> (A (ra x y) (inc x a)).
Proof.
ir. nin H1. ee;am.
nin H1. edestruct emptyset_empty;ee;wr H. ap inter2_inc.
ap H0. am.
edestruct emptyset_empty;wr H. ap inter2_inc.
ap H0. am.
Qed.

Lemma union_order_r : forall ra a rb b, inter2 a b = emptyset -> forall x y, inc x b ->
union_order ra a rb b x y -> (A (rb x y) (inc y b)).
Proof.
ir.
nin H1. destruct emptyset_empty with x;wr H;ap inter2_inc;am.
nin H1. destruct emptyset_empty with x;wr H;ap inter2_inc;am.
ee;am.
Qed.

Lemma union_order_m : forall ra a rb b x, inc x a -> forall y, inc y b -> union_order ra a rb b x y.
Proof.
ir;uhg;au.
Qed.

(*
Lemma oPlus_union_order_isomorphic : forall ra a, is_well_order ra a ->
forall rb b, is_well_order rb b ->
inter2 a b = emptyset ->
are_rel_isomorphic (union_order ra a rb b) (union2 a b) sub (oPlus (oType ra a) (oType rb b)).
Proof.
pose (prop := fun ra a o => forall rb b, is_well_order rb b -> o = oType rb b -> inter2 a b = emptyset ->
are_rel_isomorphic (union_order ra a rb b) (union2 a b) sub (oPlus (oType ra a) (oType rb b))).
assert (forall ra a, is_well_order ra a -> forall o, is_ordinal o ->
prop ra a o).
Focus 2.
ir.
ufi prop H. apply H with (oType rb b). am. ap oType_ordinal.
am. tv. am.
intros ra a Ha.
cp (oType_wo_pr Ha).
destruct H as [fa Hfa].
assert (Hfa' : is_isomorphism ra a sub (oType ra a) (inverse fa)).
ap isomorphism_inverse. uhg;ee. ap sub_is_order. ap well_order_total.
ap ordinal_sub_wo.
ap oType_ordinal.
am. am.

ap ordinal_ind_cases;uf prop;clear prop;ir.

(*case 0*)
wr H0. rw oPlus_0_r.
assert (b = emptyset). ap empty_emptyset;ir.
cp (oType_wo_pr H). nin H3. apply H3 in H2. nin H2;ee.
wri H0 H2. eapply emptyset_empty;am.
subst. rw union2_emptyset_r.
exists (inverse fa). uhg;ee;try am.
uhg;ee;try am. ir.
nin H4. ee. ap Hfa'. am. am. am.
nin H4;ee;edestruct emptyset_empty;am.

(*case S*)
assert (exists bm, exists b', b = tack_on b' bm & is_well_order rb b' & ~inc bm b' &
(forall x, inc x b' -> rb x bm) & o = oType rb b').
cp (oType_wo_pr H1). wri H2 H4.
nin H4. exists (ev x o). exists (Im (ev x) o).
dj. ap extensionality;uhg;ir.
apply H4 in H5.
nin H5;ee;rwi oS_inc H5. subst.
rw tack_on_inc.
nin H5. left. ap Im_inc;am.
right. ap uneq;am.
rwi tack_on_inc H5;nin H5. Im_nin H5;subst.
eapply trans_of_map;try am. rw oS_inc;au.
subst. eapply trans_of_map;try am. rw oS_inc;au.
eapply sub_wellorder. am. rw H5. uhg;ir;rw tack_on_inc;au.
uhg;ir. Im_nin H7.
assert (x0<>o). ap ordinal_inc_neq. am. am.
ap H9. ap H4. rw oS_inc;au. rw oS_inc;au. au.
Im_nin H8;subst.
ap H4;try (rw oS_inc;au).
ap H. am.
ap oType_eq. am. am.
ap are_rel_iso_sym. ap well_order_total_order. ap ordinal_sub_wo. am.
am. exists (L o (ev x)).
uhg;ee. uhg;ee. ap map_of_trans.
uhg;ir. ap Im_inc;am.
ir. rw create_ev;au. rw create_ev;au. assert (sub o (oS o)).
uhg;ir;rw oS_inc;au. ap H4;au.
ap map_of_bijective.
assert (sub o (oS o)). uhg;ir;rw oS_inc;au.
uhg;ee. uhg;ir;ap Im_inc;am.
uhg;ir. ap H4;au.
uhg;ir. Im_nin H10;subst. exists x0;ee;au.

destruct H4 as [bm H4]. destruct H4 as [b' H4]. ee.
subst.
destruct H0 with rb b' as [f H'].
am. tv. ap empty_emptyset. ir.
apply inter2_and in H4;ee.
apply emptyset_empty with y. wr H3.
ap inter2_inc. am. rw tack_on_inc;au.
clear H0.
wr H2. rw oPlus_S. Focus 2. ap oType_ordinal.
exists (tack_on f (J bm (oPlus (oType ra a) (oType rb b')))).
uf oS. rw union2_tack_on_r.

assert (forall x, inc x a -> x<>bm).
uhg;ir;subst. apply emptyset_empty with bm. wr H3.
ap inter2_inc. am. rw tack_on_inc;au.
assert (forall x, inc x b' -> x<>bm).
uhg;ir;subst;au.
assert (Hubm : ~ inc bm (union2 a b')).
uhg;ir. apply union2_or in H8;nin H8.
eapply H0;au. eapply H4;au.

uhg;ee. uhg;ee. ap tack_on_map. am.
uhg;ir. apply union2_or in H8;nin H8.
destruct H0 with bm. am. tv.
destruct H4 with bm;au.

ir.
nin H10. ee.
clear H8;clear H9.
rw (map_tack_on_ev (and_P (and_P H'))).
rw (map_tack_on_ev (and_P (and_P H'))).
ap H';au. ap union2_l. am. ap union2_l. am.
left. ee;am.
uhg;ir. apply union2_or in H8;nin H8.
eapply H0;au. eapply H4;au.
ap union2_l. am. am.
ap union2_l. am.
clear H8;clear H9.
repeat rwi tack_on_inc H10.
nin H10;ee.
rw (map_tack_on_ev (and_P (and_P H'))).
nin H9. rw (map_tack_on_ev (and_P (and_P H'))).
ap H';au. ap union2_l;am. ap union2_r;am.
right;left;ee;am.
am. ap union2_r;am.
subst. rw (map_tack_on_ev_eq (and_P (and_P H'))).
ap oPlus_ordinal. ap oType_ordinal. ap oType_ordinal.
eapply trans_of_map. am. ap union2_l;am.
am. am. ap union2_l;am.
nin H8;nin H9;subst.
rw (map_tack_on_ev (and_P (and_P H'))).  rw (map_tack_on_ev (and_P (and_P H'))).
ap H'. ap union2_r;am. ap union2_r;am.
right;right;ee;am.
am. ap union2_r;am. am.
ap union2_r;am.
rw (map_tack_on_ev (and_P (and_P H'))).
rw (map_tack_on_ev_eq (and_P (and_P H'))).
ap oPlus_ordinal. ap oType_ordinal. ap oType_ordinal.
eapply trans_of_map. am. ap union2_r;am.
am. am. ap union2_r;am.
destruct H4 with y. am.
ap H1. rw tack_on_inc;au. rw tack_on_inc;au.
ap H7. am. am.
ap sub_refl.

ap tack_on_bijective.
am. am.
ap ordinal_not_inc_self. ap oPlus_ordinal;ap oType_ordinal.

(*limit case*)
subst.
assert (forall b', sub b' b -> inc (oType rb b') (oType rb b) ->
are_rel_isomorphic (union_order ra a rb b') (union2 a b') sub
       (oPlus (oType ra a) (oType rb b'))).
ir. eapply H0. am. eapply sub_wellorder.
am. am. tv. ap empty_emptyset;ir.
apply inter2_and in H5;ee;apply emptyset_empty with y.
wr H3. ap inter2_inc;au.
clear H0.
assert ( Hie : forall b', sub b' b -> inter2 a b'  = emptyset).
ir. ap empty_emptyset;ir.
apply inter2_and in H4;ee;apply emptyset_empty with y.
wr H3. ap inter2_inc;au.

assert (forall b', sub b' b -> inc (oType rb b') (oType rb b) ->
oPlus (oType ra a) (oType rb b') = oType (union_order ra a rb b') (union2 a b')).
ir.
ap oType_eq.
ap union_order_wo. am. apply sub_wellorder with b.
am. am. au. ap oPlus_ordinal;ap oType_ordinal.
au.
rw (oPlus_limit H).
replace (oPlus (oType ra a)) with (fun o => oPlus (oType ra a) o).
Focus 2. ap arrow_extensionality. ir;tv.
(*
need something to say that forall x, inc x b ->
inc (oType rb (Z b (fun y => lt_of rb y x))) (oType rb b)
*)

Qed.
*)

End Order_types.

End Ordinal_arith.


From VST Require Import floyd.proofauto floyd.sublist.
From VSTArrayProgs Require Import binary_search_theory binary_search_shift.

Ltac do_compute_expr_warning::=idtac.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition binary_search_spec :=
 DECLARE _binary_search
  WITH a: val, sh : share, contents : list Z, len : Z, key : Z
  PRE [ tptr tint, tint, tint ]
    PROP (readable_share sh;
          Zlength contents <= Int.max_signed;
          len = Zlength contents;
          Int.min_signed <= key <= Int.max_signed;
          Forall (fun x => Int.min_signed <= x <= Int.max_signed) contents;
          sorted contents)
    PARAMS (a; Vint (Int.repr len); Vint (Int.repr key))
    SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a)
  POST [ tint ]
    EX i:Z,
     PROP (if in_dec Z.eq_dec key contents then Znth i contents = key
           else insertion_point (-i - 1) contents key 0 (Zlength contents))
     RETURN (Vint (Int.repr i))
     SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

Definition binary_search_while_spec a sh contents len key :=
EX low : Z, EX high : Z,
 PROP (0 <= low <= len;
  Int.min_signed <= high < len;
  In key contents -> In key (sublist low (high + 1) contents);
  ~ In key contents ->
   Forall (fun x => x < key) (sublist 0 low contents) /\
   Forall (fun x => key < x) (sublist (high + 1) len contents))
 LOCAL (temp _a a; temp _key (Vint (Int.repr key));
        temp _low (Vint (Int.repr low)); temp _high (Vint (Int.repr high)))
 SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs := ltac:(with_library prog [binary_search_spec; main_spec]).

Lemma mean_le_plus : forall i j : Z,
 i <= j ->
 i <= (i + j)/2 <= j.
Proof.
intros.
split.
- apply Zdiv_le_lower_bound; lia.
- apply Zdiv_le_upper_bound; lia.
Qed.

Lemma body_binary_search: semax_body Vprog Gprog f_binary_search binary_search_spec.
Proof.
start_function.
forward.
forward.
forward_while (binary_search_while_spec a sh contents len key).
- entailer!.
  Exists 0; Exists (Zlength contents - 1).
  entailer!.
  split; intros; [|split]; autorewrite with sublist in *.
  * assumption.
  * apply Forall_nil.
  * apply Forall_nil.
- entailer!.
- assert (Hle: low <= high) by lia.
  pose proof (mean_le_plus _ _  Hle) as Hdle.
  assert (Heq: Int.unsigned (Int.shru (Int.repr (low + high)) (Int.repr 1)) =
    (low + high) / 2).
    rewrite Int.shru_div_two_p.
    change (two_p (Int.unsigned (Int.repr 1))) with 2.
    rewrite !Int.unsigned_repr; try rep_lia.
    rewrite !Int.unsigned_repr; rep_lia.
  assert (Heq': Int.signed (Int.shru (Int.repr (low + high)) (Int.repr 1)) =
   (low + high) / 2).
    rewrite Int.shru_div_two_p.
    change (two_p (Int.unsigned (Int.repr 1))) with 2.
    rewrite !Int.signed_repr; try rep_lia; [rewrite !Int.unsigned_repr; rep_lia|].
    rewrite !Int.unsigned_repr; rep_lia.
  forward.
  forward.
  forward_if.
  * forward.
    entailer!.
    Exists ((low + high)/2 + 1,high).
    entailer!.
    rewrite Heq in H8.
    split; [lia|]; rewrite !Int.signed_repr in H8; [split;[|split]|].
    + intro H0; specialize (H6 H0).
      eapply In_sorted_gt; eauto; lia.
    + intro H0; specialize (H7 H0).
      destruct H7 as [Hlow Hhigh].
      split; [|assumption].
      apply Forall_forall; intros.
      eapply Znth_lt_sublist_lt; eauto; lia.
    + f_equal.
      unfold Int.add at 1.
      f_equal.
      rewrite <- Heq.
      rewrite !Int.unsigned_repr; rep_lia.
    + assert (Hin: In (Znth ((low + high) / 2) contents) contents)
       by (eapply Znth_In; eauto; lia).
      pose proof (Forall_forall (fun x : Z => Int.min_signed <= x <= Int.max_signed) contents) as HFA.
      simpl in HFA.
      destruct HFA as [HFA1 HFA2].
      apply (HFA1 H2 _ Hin).
  * forward_if.
    + forward.
      entailer!.
      Exists (low,(low + high)/2 - 1).
      entailer!.
      autorewrite with sublist in *.
      rewrite Heq in H9.
      split; [rep_lia|]; rewrite !Int.signed_repr in H9; [split;[|split]|].
      -- intro H0.
         specialize (H6 H0).
         eapply (In_sorted_lt _ _ _ _ _ (high + 1)); eauto; lia.
      -- intro H0.
         specialize (H7 H0).
         destruct H7 as [Hl Hh].
         split; [assumption|].
         apply Forall_forall; intros.
         revert H7.
         apply Znth_gt_sublist_gt; auto; lia.
      -- f_equal.
         unfold Int.sub.
         f_equal.
         rewrite !Int.unsigned_repr; [|rep_lia].
         rewrite Heq; reflexivity.
      -- assert (Hin: In (Znth ((low + high) / 2) contents) contents)
          by (eapply Znth_In; eauto; lia).
         pose proof (Forall_forall (fun x : Z => Int.min_signed <= x <= Int.max_signed) contents) as HFA.
         simpl in HFA.
         destruct HFA as [HFA1 HFA2].
         apply (HFA1 H2 _ Hin).
    + forward.
      Exists ((low + high) / 2).
      entailer!.
      revert H8 H9.
      rewrite Heq.
      rewrite !Int.signed_repr.
      -- intros H8 H9.
         assert (Hkey: Znth ((low + high) / 2) contents = key) by lia.
         case (in_dec _ _); intro; [split|]; auto.
         ** f_equal.
            rewrite Int.shru_div_two_p.
            change (two_p (Int.unsigned (Int.repr 1))) with 2.
            f_equal.
            rewrite !Int.unsigned_repr; [|rep_lia].
            reflexivity.
         ** contradict n.
            assert (Hin: In (Znth ((low + high) / 2) contents) contents)
              by (eapply Znth_In; eauto; lia).
            rewrite Hkey in Hin; assumption.
      -- assert (Hin: In (Znth ((low + high) / 2) contents) contents)
          by (eapply Znth_In; eauto; lia).
         pose proof (Forall_forall (fun x : Z => Int.min_signed <= x <= Int.max_signed) contents) as HFA.
         simpl in HFA.
         destruct HFA as [HFA1 HFA2].
         apply (HFA1 H2 _ Hin).
- forward.
  + entailer!.
    set (j := Int.signed Int.zero) in *; compute in j; subst j.
    rep_lia.
  + Exists (-low - 1).
    entailer!.
    case (in_dec _ _); intro.
    * specialize (H6 i).
      contradict H6.
      assert (Hlow: high + 1 <= low) by lia.
      rewrite sublist_nil1; auto.
    * unfold insertion_point.
      assert (Hl: - (- low - 1) - 1 = low) by lia.
      rewrite Hl.
      specialize (H7 n).
      destruct H7.
      split; [lia|].
      split; auto.
      assert (Hle: high + 1 <= low) by lia.
      eapply Forall_sublist_overlap; eauto.
Qed.

Definition four_contents := [1; 2; 3; 4].

Lemma body_main : semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  forward_call (gv _four,Ews,four_contents,4,3).
  { split. auto.
    change (Zlength four_contents) with 4.
    repeat constructor; computable.
  }
  Intro r; forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_binary_search.
semax_func_cons body_main.
Qed.


(*===========================================================================
    Model for the EVM memory, the memory is little endian.

    Note that operations are partial, as not all memory is mapped.
    Each memory cell is a BYTE.
  ===========================================================================*)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype finfun tuple zmodp.

Require Import bitsrep bitsops cursor pmap reader writer.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* 256-bit addressable memory of bytes *)
(*=Mem *)
Definition Mem := PMAP BYTE 256.
(*=End*)

Definition PTR := EVMWORD.
Identity Coercion PTRtoEVMWORD : PTR >-> EVMWORD.

(* Initialize the memory, no memory is mapped *)
Definition initialMemory : Mem := @EmptyPMap BYTE 256.

(* Check the memory region from pointer [p] to just below pointer [p'] in [m]
   consists exactly the bytes in [xs] *)
Fixpoint memIs (m : Mem) (p p' : PTR) xs :=
  if xs is x::xs then m p = Some x /\ memIs m (incB p) p' xs
  else p = p'.

(* Map a byte at [p] with 1-bits *)
Definition reserveMemoryBYTE (m : Mem) (p : PTR) : Mem :=
  m !p := ones 8.

(* Map memory region of [c] bytes at [p] with 1-bits *)
Definition reserveMemory (m : Mem) (p : PTR) (c : EVMWORD) : Mem :=
  bIterFrom p c (fun p m => m !p := ones 8) m.

(* Return bytes with most-significant first *)
Definition EVMWORDtoBytes (d : EVMWORD) : BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*
                                          BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*
                                          BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*
                                          BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE*BYTE :=
  split32 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 d.

Definition isMapped (p : PTR) (ms : Mem) : bool := ms p.

(* Update EVMWORD at [p] on [m] *)
Instance MemUpdateOpsEVMWORD : UpdateOps Mem PTR EVMWORD :=
  fun m p v =>
    let '(b31,b30,b29,b28,b27,b26,b25,b24,b23,b22,b21,b20,b19,b18,b17,b16,
          b15,b14,b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,b2,b1,b0) := EVMWORDtoBytes v in
    m !p := b0 !incB p := b1 !incB(incB p) := b2 !incB(incB(incB p)) := b3 !incB(incB(incB(incB p))) := b4 !incB(incB(incB(incB(incB p)))) := b5 !incB(incB(incB(incB(incB(incB p))))) := b6 !incB(incB(incB(incB(incB(incB(incB p)))))) := b7 !incB(incB(incB(incB(incB(incB(incB(incB p))))))) := b8 !incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))) := b9 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))) := b10 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))) := b11 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))) := b12 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))) := b13 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))) := b14 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))) := b15 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))) := b16 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))) := b17 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))))) := b18 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))))) := b19 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))))))) := b20 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))))))) := b21 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))))))))) := b22 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))))))))) := b23 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))))))))))) := b24 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))))))))))) := b25 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))))))))))))) := b26 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))))))))))))) := b27 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))))))))))))))) := b28 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))))))))))))))) := b29 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p))))))))))))))))))))))))))))) := b30 !incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB(incB p)))))))))))))))))))))))))))))) := b31.

(* Update BYTE at [p] on [m] *)
Definition updateBYTE (m : Mem) (p : PTR) (b : BYTE) : option Mem :=
  if isMapped p m then Some (m !p := b)
  else None.

(*--------------------------------------------------------------------------------------------
 "readers of T" type:

   read m p = readerFail if memory at p in m is inaccessible for reading T
   read m p = readerWrap if we tried to read beyond the end of memory
   read m p = readerOk x q if memory between p inclusive and q exclusive represents x : T
 --------------------------------------------------------------------------------------------*)
Inductive readerResult T :=
  readerOk (x : T) (q : EVMWORDCursor)
| readerWrap
| readerFail.

Implicit Arguments readerOk [T].
Implicit Arguments readerWrap [T].
Implicit Arguments readerFail [T].

(* Read BYTE at [pos] on [m].
   It is equivalent to using the [readMem] with [readBYTE].
 *)
Definition readMemBYTE (m : Mem) (pos : EVMWORDCursor) : readerResult BYTE :=
  if pos is mkCursor p then
    if m p is Some x then
      readerOk x (next p)
    else readerFail
  else readerWrap.

(*------------------------------------------------------------------------------------------
 read on sequences
 ------------------------------------------------------------------------------------------*)
Fixpoint readMem T (r : Reader T) (m : Mem) (pos : EVMWORDCursor) : readerResult T :=
  match r with
    | readerRetn x => readerOk x pos
    | readerNext rd =>
      if pos is mkCursor p then
        if m p is Some x then readMem (rd x) m (next p)
        else readerFail
      else readerWrap
    | readerSkip rd =>
      if pos is mkCursor p then
        if m p is Some x then readMem rd m (next p)
        else readerFail
      else readerWrap
    | readerCursor rd =>
      readMem (rd pos) m pos
  end.

(*--------------------------------------------------------------------------------------------
   writer on sequences
 --------------------------------------------------------------------------------------------*)
Fixpoint writeMemTm (w : WriterTm unit) (m : Mem) (pos : EVMWORDCursor) : option (EVMWORDCursor * Mem) :=
  match w with
    | writerRetn _ => Some (pos, m)
    | writerNext byte w =>
      if pos is mkCursor p then
        if isMapped p m then
          writeMemTm w (m!p := byte) (next p)
        else None
      else None
    | writerSkip w =>
      if pos is mkCursor p then
        if isMapped p m then
          writeMemTm w (m!p := #0) (next p)
        else None
      else None
    | writerCursor w =>
        writeMemTm (w pos) m pos
    | writerFail =>
        None
  end.

Definition writeMem {T} (w : Writer T) (m : Mem) (pos : EVMWORDCursor) (t : T) : option (EVMWORDCursor * Mem) :=
  writeMemTm (w t) m pos.

(* Write BYTE at [pos] on [m].
   If m p is mapped, update it.
   Otherwise, reserve a byte at p and write
 *)
Definition writeMemBYTE (m : Mem) (pos : EVMWORDCursor) (b : BYTE) : option (EVMWORDCursor * Mem) :=
  if pos is mkCursor p then
    if m p is Some x then
      Some ((next p), (m !p := b))
    else Some ((next p), ((reserveMemoryBYTE m p) !p := b))
  else None.

(*-------------------------------------------------------------------------------------------
   Memory layout to string
 -------------------------------------------------------------------------------------------*)
Require Import Coq.Strings.String.
Import Ascii.

(* Memory to string *)
Fixpoint enumMemToString (xs : seq (EVMWORD * BYTE)) :=
  (if xs is (p, b)::xs then
     toHex p ++ ":=" ++ toHex b ++ ", " ++ enumMemToString xs
   else "")%string.

Definition memtoString (m : Mem) := enumMemToString (enumPMap m).

(* readerResult to string *)
Fixpoint readerResultToString (n : nat) (rs : readerResult (BITS n)) :=
  match rs with
     | readerFail => ("Inaccessible memory!")%string
     | readerWrap => ("Out of memory!")%string
     | readerOk x q =>
       if q is mkCursor p then
         ("Next cursor:=" ++ toHex p ++ ", " ++ "Content:=" ++ toHex x)%string
       else ("Next curspr:= Top" ++ ", " ++ "Content:=" ++ toHex x)%string
  end.

(*----------------------------------------------------------------------------------------------
 A simple unit test
 ----------------------------------------------------------------------------------------------*)
Example m: Mem := (@EmptyPMap _ _) ! #5 := (#12 : BYTE) ! #6 := (#10 : BYTE) ! #8 := (#15 : BYTE).
Compute (memtoString m).

(* Read a byte at pos 5 *)
Compute (
    let rb := readMemBYTE m (#5) in
    readerResultToString rb
  ).

(* Read a byte at pos 5 with [readMem] *)
Compute (
    let rb := readMem readBYTE m (#5) in
    readerResultToString rb
  ).

(* Read a word at pos 5 *)
Example rw: readerResult WORD := readMem readWORD m (#5).
Compute (
    let rw := readMem readWORD m (#5) in
    readerResultToString rw
  ).

(* Write a byte at pos 6 *)
Compute (
    let omem := writeMem writeBYTE m (#6) (#9 : BYTE) in
    match omem with
      | Some (c, m) => memtoString m
      | None => ("Write error!")%string
    end
  ).

(* Write a byte at pos 9 - errir since this cell is not mapped yet *)
Compute (
    let omem := writeMem writeBYTE m (#9) (#12 : BYTE) in
    match omem with
      | Some (c, m) => memtoString m
      | None => ("Write error!")%string
    end
  ).

(* Write a byte at pos 9 - succes with [writeMemBYTE] *)
Compute (
    let omem := writeMemBYTE m (#9) (#12 : BYTE) in
    match omem with
      | Some (c, m) => memtoString m
      | None => ("Write error!")%string
    end
  ).

(* Write 32 bytes *)
Compute (
    let m := reserveMemory m (#255) (#32 : EVMWORD) in
    let omem := writeMem writeEVMWORD m (#255) (#255 : EVMWORD) in
    match omem with
      | Some (c, m) => memtoString m
      | None => ("Write error!")%string
    end
  ).

(* Write 5 bytes from the pos 0
   Then read the written bytes *)
Example bytes : 5.-tuple BYTE := (cons_tuple (#5:BYTE) (cons_tuple (#4:BYTE) (cons_tuple (#3:BYTE) (cons_tuple (#2:BYTE) (cons_tuple (#1:BYTE) (nil_tuple _)))))).
Compute (toHex (thead bytes)).
Example m1 := reserveMemory m (#0) (#5 : EVMWORD).
Example omem := writeMem (@writeTupleBYTE 5) m1 (#0) (bytes : 5.-tuple BYTE).

Compute (
    match omem with
      | Some (c, m) => memtoString m
      | None => ("Write error!")%string
    end
  ).

(* Read 5 bytes from the pos 0 *)
Example  rbytes :=
  if omem is Some (c, m) then
    readMem (@readTupleBYTE 5) m (#0)
  else readerFail.

Compute (
    match rbytes with
      | readerFail => ("Inaccessible memory!")%string
      | readerWrap => ("Out of memory!")%string
      | readerOk x q =>
        if q is mkCursor p then
          ("Next cursor:=" ++ toHex p ++ ", " ++ "Content:=" ++ bytesToHex x)%string
        else ("Next curspr:= Top" ++ ", " ++ "Content:=" ++ bytesToHex x)%string
    end
  ).


Require Import Pointed HSpace.Core HSpace.Coherent.

Local Open Scope pointed_scope.
Local Open Scope mc_mult_scope.

(** * Pointwise H-space structures *)

(** Whenever [X] is an H-space, so is any type of maps or pointed maps into [X]. *)

Global Instance ishspace_map `{Funext} (X : pType) (Y : Type)
  `{IsHSpace X} : IsHSpace [Y -> X, const pt].
(* Note: When writing [f * g], Coq only finds this instance if [f] is explicitly in the pointed type [[Y -> X, const pt]]. *)
Proof.
  snrapply Build_IsHSpace.
  - exact (fun f g y => (f y) * (g y)).
  - intro g; funext y.
    apply hspace_left_identity.
  - intro f; funext y.
    apply hspace_right_identity.
Defined.

(** If [X] is coherent, so is [[Y -> X, const pt]]. *)
Global Instance iscoherent_ishspace_map `{Funext} (X : pType) (Y : Type)
  `{IsCoherent X} : IsCoherent [Y -> X, const pt].
Proof.
  hnf; cbn.
  refine (ap _ _).
  funext y; apply iscoherent.
Defined.

(** If [X] is left-invertible, so is [[Y -> X, const pt]]. *)
Global Instance isleftinvertible_hspace_map `{Funext} (X : pType) (Y : Type)
  `{IsHSpace X} `{forall x, IsEquiv (x *.)}
  : forall f : [Y -> X, const pt], IsEquiv (f *.).
Proof.
  intro f; cbn.
  (** Left multiplication by [f] unifies with [functor_forall]. *)
  exact (isequiv_functor_forall (P:=const X) (f:=idmap)
           (g:=fun y gy => (f y) * gy)).
Defined.

(** For the type of pointed maps [Y ->** X], coherence of [X] is needed even to get a noncoherent H-space structure on [Y ->** X]. *)

Global Instance ishspace_pmap `{Funext} (X Y : pType) `{IsCoherent X}
  : IsHSpace (Y ->** X).
Proof.
  snrapply Build_IsHSpace.
  - intros f g.
    snrapply Build_pMap.
    + exact (fun y => hspace_op (f y) (g y)).
    + cbn.
      refine (ap _ (point_eq g) @ _); cbn.
      refine (ap (.* pt) (point_eq f) @ _).
      apply hspace_left_identity.
  - intro g.
    apply path_pforall.
    snrapply Build_pHomotopy.
    + intro y; cbn.
      apply hspace_left_identity.
    + cbn.
      apply moveL_pV.
      exact (1 @@ concat_1p _ @ concat_A1p _ _)^.
  - intro f.
    apply path_pforall.
    snrapply Build_pHomotopy.
    + intro y; cbn.
      apply hspace_right_identity.
    + cbn.
      apply moveL_pV.
      refine (concat_1p _ @ _ @ concat_A1p _ (dpoint_eq f))^; cbn.
      apply whiskerL.
      apply iscoherent.
Defined.

Global Instance iscoherent_hspace_pmap `{Funext} (X Y : pType) `{IsCoherent X}
  : IsCoherent (Y ->** X).
Proof.
  (* Note that [pt] sometimes means the constant map [Y ->* X]. *)
  unfold IsCoherent.
  (* Both identities are created using [path_pforall]. *)
  refine (ap path_pforall _).
  apply path_pforall.
  snrapply Build_pHomotopy.
  - intro y; cbn.
    apply iscoherent.
  - cbn.
    generalize iscoherent as isc.
    unfold left_identity, right_identity.
    (* The next line is essentially the same as [generalize], but for some reason that tactic doesn't work here. *)
    set (p := hspace_left_identity pt); clearbody p.
    intros [].
    induction p.
    reflexivity.
Defined.

(** If the H-space structure on [X] is left-invertible, so is that one induced on [Y ->** X]. *)
Global Instance isleftinvertible_hspace_pmap `{Funext} (X Y : pType)
  `{IsCoherent X} `{forall x, IsEquiv (x *.)}
  : forall f : Y ->** X, IsEquiv (f *.).
Proof.
  intro f.
  srefine (isequiv_homotopic (equiv_functor_pforall_id _ _) _).
  - exact (fun a => equiv_hspace_left_op (f a)).
  - cbn. exact (right_identity _ @ point_eq f).
  - intro g.
    apply path_pforall; snrapply Build_pHomotopy.
    + intro y; cbn.
      reflexivity.
    + cbn. apply (moveR_1M _ _)^-1.
      apply whiskerL.
      refine (whiskerL _ iscoherent @ _).
      exact (concat_A1p right_identity (point_eq f)).
Defined.


(** * 6.512 Formal Reasoning About Programs, Spring 2023 - Pset 6 *)
Require Import Frap.Frap Pset6.Pset6Sig.
Import Swap.
(*|
Modern compilers achieve excellent performance by leveraging a wide variety of
program transformations.  For example, GCC (the GNU C compiler) version 10.2
produces the *exact same* assembly code for the following two programs (if you
want to see for yourself, try it on https://godbolt.org!):

1. Recursive version with accumulator, naive division and modulo, no function
   inlining, multiple returns, redundant ``+ 1``, not tail-recursive::

      static unsigned int affine(unsigned int n,
                                 unsigned int slope,
                                 unsigned int offset) {
          return n * slope + offset;
      }

      unsigned int collatz1(unsigned int start) {
          if (start == 1)
            return 0;
          else if (start % 2 == 0)
            return collatz1(start / 2) + 1;
          else
            return collatz1(affine(start, 3, 1)) + 1;
      }

2. Single loop, inlined function, bitwise arithmetic::

      unsigned int collatz2(unsigned int start) {
          unsigned int flight = 0;
          while (start != 1) {
              flight++;
              if ((start & 1) == 0) {
                  start = start >> 1;
              } else {
                  start = start * 2 + start + 1;
              }
          }
          return flight;
      }

The way GCC achieves this is by applying a sequence of transformation passes on
the code: you can see the output of each intermediate pass (all ~320 of them)
using ``gcc -O3 -fdump-tree-all -fdump-rtl-all -c collatz1.c``.  For instance,
the ``ssa`` pass puts the code into a form similar to the three-address code
that we saw in class, the ``tailr1`` passes convert the recursive function to a
loop, etc.

Students interested in an introduction to the magic of modern compiler
optimizations might enjoy Matt Godbolt's 2017 talk at CPPCon, *What Has My
Compiler Done for Me Lately? Unbolting the Compiler's Lid*
(https://www.youtube.com/watch?v=bSkpMdDe4g4).

In this lab, we'll see how formal methods can help us reason about the
correctness of these optimization passes, focusing on a couple of particular
optimizations.

Pset6Sig.v contains the number of points you get for each definition and
proof. Note that since we ask you to come up with some definitions
yourself, all proofs being accepted by Coq does not necessarily guarantee a
full score: you also need to make sure that your definitions correspond to
what we ask for in the instructions. That said, if the required tests pass
and your definitions do not intentionally special-case them, you should be
fine.

*A few notes of caution*:

- Some of the proofs in this lab can be a bit long to complete fully manually:
  we encourage you to try your hand at simple automation.  However, make sure
  that your whole file compiles in a reasonable amount of time (at most a minute
  or two).

- When decomposed into the right sequence of lemmas, most of the theorems in
  this pset have relatively short proofs.  The best way to find these lemmas is
  to approach each problem cautiously, trying to work an understanding of the
  proof before diving into long series of `invert`, `econstructor`, etc.  In
  general, it's also a good idea to admit lemmas until you are sure that they
  allow you to prove the complete theorem, then go back and prove the lemmas —
  but do take the time to convince yourself that your lemmas make sense, so that
  you don't waste time using incorrect lemmas.

- We have included plenty of hints below in the HINTS section of the
  signature file.
|*)

Module Impl.

(*
  We'll be working with a small stack-based language in this lab, where we
  interpret a program as a transformation from an input stack to an output stack,
  primarily done by pushing and popping values on and off the stack.
 *)

(*
  Our values consist of natural numbers and lists of values.
  So that we can have a single value type, we use the following datatype:
 *)
Inductive stack_val :=
| val_lit (n : nat)
| val_nil
| val_cons (v1 v2 : stack_val).

(*
  However, this inductive definition admits expressions that do not conform
  to our English definition of our set of values. For example, the following
  term has the Coq type `stack_val`: `val_cons (val_lit 0) (val_lit 1)`, even
  though we see it as ill-formed since the tail of a cons should be a list.
  In order to describe the set of well-formed values, we define the following
  datatype of stack-language type signatures and an associated typing judgment
  for stack values.

  The typing judgments in this lab are fairly straightforward since they only
  have to be concerned with natural numbers and lists, but you can think of them
  as a preview of the sort of problems that will be in next week's assignment.
 *)
Inductive ty : Set :=
| ty_nat
| ty_list (t : ty).

Inductive val_well_typed : stack_val -> ty -> Prop :=
| val_lit_wt n : val_well_typed (val_lit n) ty_nat
| val_nil_wt t : val_well_typed val_nil (ty_list t)
| val_cons_wt t v1 v2
  : val_well_typed v1 t ->
      val_well_typed v2 (ty_list t) ->
      val_well_typed (val_cons v1 v2) (ty_list t).
Local Hint Constructors val_well_typed : core.

(*
  Since a stack is a list of values, we can use this judgment to define
  a typing judgments for stacks as well. The type of a stack is just a list
  of the types of its values. Since `val_well_typed` is a binary relation,
  we can use `Forall2` from the standard library to lift it to operate on stacks.
  You can see the definition of `Forall2` by printing it:
 *)
Print Forall2.

(*
  We define `stack_well_typed` as a notation instead of a definition for some
  convenience in tactics. You don't need to pay attention to the difference
  except to know that you can't unfold `stack_well_typed`, but Coq automatically
  will see it as a use of `Forall2`.
 *)
Notation stack_well_typed := (Forall2 val_well_typed).
Local Hint Constructors Forall2 : core.

(* Here are some definitions that we will use in the interpreter.
   Many of them have dummy cases that we do not expect to hit.
   Specifically, the benefit of all of the typing judgments is that
   they guarantee these cases will never happen.
 *)

Definition stack_unop f (s : list stack_val) :=
  match s with
  | a::s' => (f a)::s'
  | _ => (*this case never happens on well-typed programs*) s
  end.

Definition stack_binop f (s : list stack_val) :=
  match s with
  | a::b::s' => (f a b)::s'
  | _ => (*this case never happens on well-typed programs*) s
  end.

Definition stack_pop (s : list stack_val) :=
  match s with
  | a::s => (a,s)
  | _ => (*this case never happens on well-typed programs*) (val_lit 0, [])
  end.

Definition stack_peek (s : list stack_val) :=
  match s with
  | a::_ => a
  | _ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Fixpoint val_app v1 v2 :=
  match v1 with
  | val_nil => v2
  | val_cons v11 v12 => val_cons v11 (val_app v12 v2)
  | val_lit _ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Fixpoint val_flatmap (f : stack_val -> stack_val) v :=
  match v with
  | val_nil => val_nil
  | val_cons v1 v2 =>
      val_app (f v1) (val_flatmap f v2)
  | val_lit _ => val_lit 0
  end.

Fixpoint val_reduce (f : stack_val -> stack_val -> stack_val) vl vacc :=
  match vl with
  | val_nil => vacc
  | val_cons v1 v2 =>
      val_reduce f v2 (f vacc v1)
  | val_lit _ => val_lit 0
  end.

(*
  You will have to prove some lemmas about most of these functions to finish
  the later exercises. We've given you one of the more complicated ones here
  to prove, but you should come up with your own for the other functions as
  needed.
 *)
Lemma val_flatmap_sound t1 t2 f l
  : (forall x, val_well_typed x t1 -> val_well_typed (f x) (ty_list t2)) ->
    val_well_typed l (ty_list t1) ->
    val_well_typed (val_flatmap f l) (ty_list t2).
Proof.
Admitted.

(*
  Now that we have values, we can define our syntax of commands.
  Their purposes are as follows:
  - cmd_atom: push a value onto the stack
  - cmd_unop: pop a value from the stack, perform an unary operation on it,
              and push the result back
  - cmd_binop: pop two values from the stack, perform a binary operation on them,
              and push the result back
  - cmd_swap: switch 2 values in the stack, determined by their positions.
              `n1` must always be the earlier (smaller) position.
  - cmd_flatmap: the most interesting operation in this assignment. It pops a
                 list value from the stack, runs a command `cf` on each element of
                 the list, and appends the outputs of that command in order.
  - cmd_reduce: pops a list value and another value from the stack and accumulates
                an output value by starting with the second value and running
                a command `cf` on the current accumulator and each item in the list
                in turn.
  - cmd_skip: All other commands take the rest of the program as their final arguments.
              We use `cmd_skip` when we want to end the current command.

  You may notice that we're playing a little trick here with cmd_unop and cmd_binop.
  These cases of our stack language actually take in Coq functions directly.
  This has some drawbacks, but it allows us to use these two constructors to add
  all sorts of operations to our language, from arithmetic to cons and ranges.
 *)
Inductive stack_cmd :=
| cmd_atom (v : stack_val) (c : stack_cmd)
| cmd_unop (f : stack_val -> stack_val) (c : stack_cmd)
| cmd_binop (f : stack_val -> stack_val -> stack_val) (c : stack_cmd)
| cmd_swap (n1 n2 : nat) (c : stack_cmd)
| cmd_flatmap (cf : stack_cmd) (c : stack_cmd)
| cmd_reduce (cf : stack_cmd) (c : stack_cmd)
| cmd_skip.

(*
  This is the typing judgment for commands. You should read `cmd_well_typed S c S'`
  as "On an input stack of type S, running c must produce an output stack of type S'".

  Notice that in the flatmap and reduce cases, `cf` only works with fixed input and
  output stacks. This means that it's not allowed to affect the rest of the stack,
  for example by swapping with some earlier value.
 *)
Inductive cmd_well_typed : list ty -> stack_cmd -> list ty -> Prop :=
| cmd_atom_wt v t S c S'
  : val_well_typed v t ->
    cmd_well_typed (t::S) c S' ->
    cmd_well_typed S (cmd_atom v c) S'
| cmd_unop_wt f t1 t2 S c S'
  : (forall v, val_well_typed v t1 -> val_well_typed (f v) t2) ->
    cmd_well_typed (t2::S) c S' ->
    cmd_well_typed (t1::S) (cmd_unop f c) S'
| cmd_binop_wt f t1 t2 t3 S c S'
  : (forall v1 v2, val_well_typed v1 t1 ->
                   val_well_typed v2 t2 ->
                   val_well_typed (f v1 v2) t3) ->
    cmd_well_typed (t3::S) c S' ->
    cmd_well_typed (t1::t2::S) (cmd_binop f c) S'
| cmd_swap_wt S n1 n2 c S'
  : n1 < n2 ->
    n2 < length S ->
    cmd_well_typed (swap n1 n2 S) c S' ->
    cmd_well_typed S (cmd_swap n1 n2 c) S'
| cmd_flatmap_wt S (cf : stack_cmd) t1 t2 c S'
  : cmd_well_typed ((ty_list t2)::S) c S' ->
    cmd_well_typed [t1] cf [ty_list t2] ->
    cmd_well_typed ((ty_list t1)::S) (cmd_flatmap cf c) S'
| cmd_reduce_wt S (cf : stack_cmd) t t_acc c S'
  : cmd_well_typed (t_acc::S) c S' ->
    cmd_well_typed [t; t_acc] cf [t_acc] ->
    cmd_well_typed ((ty_list t)::t_acc::S) (cmd_reduce cf c) S'
| cmd_skip_wt S
  : cmd_well_typed S (cmd_skip) S.
Local Hint Constructors cmd_well_typed : core.

(*
  This is our interpreter, which defines the behavior of our programs.
  Since all programs in this language terminate, we can define it as a
  regular Coq function that takes a command and a stack and runs the
  command against the stack.
 *)
Fixpoint interp_cmd (c : stack_cmd) (s : list stack_val) : list stack_val :=
  match c with
  | cmd_atom v c' => interp_cmd c' (v::s)
  | cmd_unop f c' => interp_cmd c' (stack_unop f s)
  | cmd_binop f c' => interp_cmd c' (stack_binop f s)
  | cmd_swap n1 n2 c' => interp_cmd c' (swap n1 n2 s)
  | cmd_flatmap cf c' =>
      let (l,s1) := stack_pop s in
      let out := val_flatmap (fun x => stack_peek (interp_cmd cf [x])) l in
      interp_cmd c' (out::s1)
  | cmd_reduce cf c' =>
      let (l,s) := stack_pop s in
      let (acc,s) := stack_pop s in
      let out := val_reduce (fun acc x => stack_peek (interp_cmd cf [x;acc])) l acc in
      interp_cmd c' (out::s)
  | cmd_skip => s
  end.

(*
  Now let's prove that our interpreter satisfies our typing judgment.
  In other words, that running a well-typed command on a well-typed
  input stack produces a well-typed output stack.

  HINT: If you aren't sure what to do in the `cmd_reduce` case,
  look at `val_flatmap_sound` for inspiration.
  If you're really stuck, read HINT 1 in Pset6Sig.v.
 *)
Lemma interp_sound S c S'
  : cmd_well_typed S c S' ->
    forall s, stack_well_typed s S ->
              stack_well_typed (interp_cmd c s) S'.
Proof.
Admitted.

(*
  Sometimes it's useful to combine two sequences of commands.
  Define a function `cmd_seq` so that the output is the
  concatenation of its inputs and you can prove the two following
  lemmas.
 *)
Fixpoint cmd_seq (c1 c2 : stack_cmd) : stack_cmd.
Admitted.

Lemma cmd_seq_wt S1 S2 S3 c1 c2
  : cmd_well_typed S1 c1 S2 ->
    cmd_well_typed S2 c2 S3 ->
    cmd_well_typed S1 (cmd_seq c1 c2) S3.
Proof.
Admitted.

Lemma interp_seq c1 c2 s
  : interp_cmd (cmd_seq c1 c2) s
    = interp_cmd c2 (interp_cmd c1 s).
Proof.
Admitted.

(*
  Let's take a look at ways to optimize programs in our language.
  You may have noticed in our earlier tests that it's often convenient
  to write `stack_cmd` programs that push constants and immediately
  operate on them, or that perform a couple unops and/or binops in sequence.
  Let's take advantage of the way we defined `stack_cmd` to collapse
  those operations where possible. We'll call this "partial evaluation"
  since we're effectively interpreting portions of our command sequence
  to compute parts of the result ahead of time.

  For example, if we have a `cmd_atom` immediately followed by a
  `cmd_binop`, we want to combine the two into a `cmd_unop` by filling in
  one argument of the `cmd_binop`'s function. Take a look at the tests
  to get a better idea of this function's expected behavior.
 *)
Fixpoint partial_eval c :=
  match c with
  | cmd_atom v c' =>
      match partial_eval c' with
      | cmd_unop f c'' => cmd_atom (f v) c''
      | cmd_binop f c'' => cmd_unop (f v) c''
      | c'_fused => cmd_atom v c'_fused
      end
  | cmd_unop f c' =>
      match partial_eval c' with
      | cmd_unop g c'' => cmd_unop (fun v => g (f v)) c''
      | cmd_binop g c'' => cmd_binop (fun v1 v2 => g (f v1) v2) c''
      | c'_fused => cmd_unop f c'_fused
      end
  | cmd_binop f c' =>
      match partial_eval c' with
      | cmd_unop g c'' => cmd_binop (fun v1 v2 => g (f v1 v2)) c''
      | c'_fused => cmd_binop f c'_fused
      end
  | cmd_swap n1 n2 c' => cmd_swap n1 n2 (partial_eval c')
  | cmd_flatmap cf1 c' => cmd_flatmap (partial_eval cf1) (partial_eval c')
  | cmd_reduce cf c' => cmd_reduce (partial_eval cf) (partial_eval c')
  | cmd_skip => cmd_skip
  end.

(* Some common commands for use in our test cases *)
Definition val_add x y :=
  match x,y with
  | val_lit xl, val_lit yl => val_lit (xl + yl)
  | _,_ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Definition val_square x :=
  match x with
  | val_lit xl => val_lit (Nat.square xl)
  | _ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Definition cmd_singleton := cmd_unop (fun x => val_cons x val_nil).
Definition cmd_lit n := cmd_atom (val_lit n).
Definition cmd_cons := cmd_binop val_cons.
Definition cmd_add := cmd_binop val_add.

Lemma partial_eval_test1
  : partial_eval (cmd_atom (val_lit 2) (cmd_unop val_square cmd_skip))
    = (cmd_atom (val_lit 4) cmd_skip).
Proof. equality. Qed.

Lemma partial_eval_test2
  : partial_eval (cmd_atom (val_lit 5) (cmd_binop val_add cmd_skip))
    = (cmd_unop (val_add (val_lit 5)) cmd_skip).
Proof. equality. Qed.

Lemma partial_eval_test3
  : partial_eval (cmd_unop val_square (cmd_unop val_square cmd_skip))
    = (cmd_unop (fun v => val_square (val_square v)) cmd_skip).
Proof. equality. Qed.

Lemma partial_eval_test4
  : partial_eval (cmd_binop val_add (cmd_unop val_square cmd_skip))
    = (cmd_binop (fun v1 v2 => val_square (val_add v1 v2)) cmd_skip).
Proof. equality. Qed.

Lemma partial_eval_test5
  : partial_eval (cmd_swap 0 2 (cmd_atom (val_lit 2) (cmd_atom (val_lit 3) (cmd_binop val_add cmd_skip))))
    = cmd_swap 0 2 (cmd_atom (val_lit 5) cmd_skip).
Proof. equality. Qed.

Lemma partial_eval_test6
  : partial_eval (cmd_unop val_square (cmd_atom (val_lit 1) (cmd_binop val_add (cmd_unop val_square cmd_skip))))
    = cmd_unop (fun x => val_square (val_add (val_lit 1) (val_square x))) cmd_skip.
Proof. equality. Qed.

Lemma partial_eval_test7
  : partial_eval (cmd_flatmap (cmd_atom (val_lit 2) (cmd_binop val_add (cmd_singleton cmd_skip)))
               (cmd_atom (val_lit 2) (cmd_unop val_square cmd_skip)))
    = cmd_flatmap (cmd_unop (fun v2 => val_cons (val_add (val_lit 2) v2) val_nil) cmd_skip)
        (cmd_atom (val_lit 4) cmd_skip).
Proof. equality. Qed.

(* With any program transformation, we want to make sure
   that it preserves all the right invariants, the most
   basic of which is type soundness, the idea that,
   given well-formed input, our optimization produces
   well-formed output.

   Since types are the focus of the next assignment,
   we've proven this for you.
 *)
Lemma partial_eval_sound S c S'
  : cmd_well_typed S c S' ->
    cmd_well_typed S (partial_eval c) S'.
Proof.
  induct 1;
    simplify;
    eauto.
  all:cases (partial_eval c);
    simplify;
    eauto.
  all: invert IHcmd_well_typed; eauto.
Qed.

(*
  Now that we've warmed up, let's get to the meat of this assigment,
  proving compiler correctness. Since we've defined the semantics of
  our language with an interpreter, we want to show that, given an
  arbitrary (well-typed) stack, interpreting the output of our compiler
  will give us the same result as interpreting the input. If you're having
  trouble, make sure to check the hints, as this proof is tricky.

  WARNING: For this assignment in particular, be careful of simplifying
           too early. `simplify` is helpful, but doesn't always do what
           you want when dealing with the cases here. Our solution does
           use `simplify`, but you should specifically be cautious of
           using it after using `cases (partial_eval c)` (which will likely
           appear in your proof).

  If you're having trouble with the function argument to val_flatmap,
  read HINT 4 in Pset6Sig.v.

 *)
Lemma partial_eval_correct S c S'
  : cmd_well_typed S c S' ->
    forall s, stack_well_typed s S -> interp_cmd (partial_eval c) s = interp_cmd c s.
Proof.
Admitted.

(*
  Let's try another compiler optimization. It turns out that when we have
  two flatmap commands in a row, we can reorder them so that the second
  one operates on each output of the first as it's produced. In other
  words, instead of generating a whole intermediate list, we can compute
  the final output as we calculate each intermediate element. This idea
  is from a family of optimizations called list fusion.

  The following lemma formalizes this idea.

  If you're having trouble with the function argument to val_flatmap,
  read HINT 2 in Pset6Sig.v.
 *)
Lemma flatmap_fuse : forall cf1 cf2 c s,
    interp_cmd (cmd_flatmap cf1 (cmd_flatmap cf2 c)) s
    = interp_cmd (cmd_flatmap (cmd_seq cf1 (cmd_flatmap cf2 cmd_skip)) c) s.
Proof.
Admitted.

(*
  Now, define an optimization pass that does this transformation on an
  arbitrary input command. Try to fuse as many instances of consecutive
  flatmaps as you can. You don't have to catch everything (there is one
  specific corner case that is difficult). For full credit, you should
  pass all of the test cases below without hardcoding them. If your
  definition isn't passing all of the test cases, try to compare it to
  our `partial_eval` compiler earlier and see if you're missing out on any
  chances to optimize.

  If you're having trouble with the tests, read HINT 3 in Pset6Sig.v.
 *)
Fixpoint loop_fuse (c : stack_cmd) : stack_cmd.
Admitted.

(*
  Your loop_fuse optimizer should pass all of the following tests.
  In the event that your optimizer fuses more `cmd_flatmap`s than ours
  and this causes one or more of these tests to fail, admit the failing test,
  add a corresponding passing test, and explain why the second output is superior.
 *)

Lemma loop_fuse_test1
  : loop_fuse (cmd_flatmap (cmd_singleton (cmd_lit 0 (cmd_cons cmd_skip)))
                 (cmd_flatmap (cmd_lit 1 (cmd_add (cmd_singleton cmd_skip))) cmd_skip))
    = (cmd_flatmap (cmd_singleton
                      (cmd_lit 0
                         (cmd_cons
                            (cmd_flatmap (cmd_lit 1 (cmd_add (cmd_singleton cmd_skip)))
                               cmd_skip))))
         cmd_skip).
Proof. (* equality. *) Admitted.

Lemma loop_fuse_test2
  : loop_fuse (cmd_flatmap (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                              (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                                 (cmd_singleton cmd_skip)))
                 cmd_skip)
    = cmd_flatmap
         (cmd_flatmap
            (cmd_unop val_square
               (cmd_singleton
                  (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                     cmd_skip)))
            (cmd_singleton cmd_skip))
         cmd_skip.
Proof. (* equality. *) Admitted.

Lemma loop_fuse_test3
  : loop_fuse (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                 (cmd_flatmap (cmd_singleton (cmd_lit 0 (cmd_cons cmd_skip)))
                 (cmd_flatmap (cmd_lit 1 (cmd_add (cmd_singleton cmd_skip))) cmd_skip)))
    = cmd_flatmap
        (cmd_unop val_square
           (cmd_singleton
              (cmd_flatmap
                 (cmd_singleton
                    (cmd_atom (val_lit 0)
                       (cmd_binop val_cons
                          (cmd_flatmap
                             (cmd_atom (val_lit 1)
                                (cmd_binop val_add (cmd_singleton cmd_skip)))
                             cmd_skip))))
                 cmd_skip)))
        cmd_skip.
Proof. (* equality. *) Admitted.

(* As a first step, let's prove that this optimization preserves
   our typing judgment like before. The proof will be very similar
   to the one for `op_fuse`.
 *)
Lemma loop_fuse_sound S c S'
  : cmd_well_typed S c S' ->
    cmd_well_typed S (loop_fuse c) S'.
Proof.
Admitted.

(*
  Now for the largest proof of the pset, let's prove that `loop_fuse` is correct.
  Make sure you've attempted `op_fuse_correct` first since the proof is similar
  and relies on some of the same lemmas.
 *)
Lemma loop_fuse_correct S c S'
  : cmd_well_typed S c S' ->
    forall s, stack_well_typed s S -> interp_cmd (loop_fuse c) s = interp_cmd c s.
Proof.
Admitted.

End Impl.

Module ImplCorrect : Pset6Sig.S := Impl.

(* Authors: Dustin Jamner *)


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Add LoadPath "..".
Require Import CpdtTactics.
Require Import wyv_common.
Require Import rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_low_reduce :
  forall T1 x1 L1 T1',
    T1 = (t_sel_low x1 L1 T1') ->
    forall T2, subtype T1 T2 = match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                          | t_sel_upp x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                          | t_sel_nom x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                          | _ => false
                          end.
Proof.
  intros.

  destruct T2.

  apply subtype_top;
    subst;
    intros;
    intro Hcontra;
    inversion Hcontra.

  subst;
    apply subtype_sel_low_bot_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_upp_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_low_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_equ_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_nom_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_rfn_top_reduce
      with (x1:=x1)(L1:=L1)(Ts:=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_rfn_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(Ts:=T2_1)(T':=T2_2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sha_top_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(T1':=T1')(ss2:=d);
    auto.

  subst;
    apply subtype_sel_low_sha_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(T':=T2)(T1':=T1')(ss2:=d);
    auto.

  subst;
    apply subtype_sel_low_all_reduce
      with (x1:=x1)(L1:=L1)(T:=T2_1)(T':=T2_2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_upp_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_low_low_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_low_equ_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_low_nom_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst; eapply subtype_sel_low_nil_reduce; eauto.

  subst; eapply subtype_sel_low_con_reduce; eauto.
Qed.