Set Implicit Arguments.
Unset Strict Implicit.

Require Export lci.

Module Ring.

Section Laws.

Variables (pl ml : E2).

Definition distrib_l g := (forall a, inc a g -> forall b, inc b g -> forall c, inc c g ->
  ml c (pl a b) = pl (ml c a) (ml c b)).

Definition distrib_r g :=(forall a, inc a g -> forall b, inc b g -> forall c, inc c g ->
ml (pl a b) c = pl (ml a c) (ml b c)).

Definition distributes g := A (distrib_l g) (distrib_r g).

Definition is_ring g e u :=
A (is_group pl g e)
(A (commutative pl g)
(A (is_monoid ml g u)
(distributes g))).

Definition is_quasiring a e u :=
A (is_monoid pl a e)
(A (is_monoid ml a u)
(A (distributes a)
(A (forall x, inc x a -> ml e x = e)
(forall x, inc x a -> ml x e = e)))).

Lemma ring_0_multr : forall g e u, is_ring g e u ->
forall x, inc x (g) -> ml x e = e.
Proof.
ir. uh H;ee.
uh H;uh H2;uh H3;ee.
assert (is_regular pl g). apply group_is_regular with e. uhg;ee;am.
uh H10;ee.
apply H10 with (ml x e);au.
ap H2;am.
ap H2;am.
wr H3;au. uh H6;ee. rw H12;au.
rw H12;au.
Qed.

Lemma ring_0_multl : forall g e u, is_ring g e u ->
forall x, inc x (g) -> ml e x = e.
Proof.
ir. uh H;ee.
uh H;uh H2;uh H3;ee.
assert (is_regular pl g). apply group_is_regular with e. uhg;ee;am.
uh H10;ee.
apply H10 with (ml e x);au.
ap H2;am.
ap H2;am.
wr H4;au. uh H6;ee. rw H12;au.
rw H12;au.
Qed.

Lemma ring_is_quasiring : forall g e u, is_ring g e u -> is_quasiring g e u.
Proof.
ir;uhg;ee;try am.
ap group_is_monoid;am.
eapply ring_0_multl. am.
eapply ring_0_multr. am.
Qed.

Definition is_integral g e := forall a, inc a (g) -> forall b, inc b (g) ->
ml a b = e -> (a=e \/ b=e).

Lemma integral_rw : forall g e u, is_ring g e u -> is_integral g e ->
forall a b, inc a (g) -> inc b (g) ->
(ml a b = e) = ((a=e)\/(b=e)).
Proof.
ir. ap iff_eq;ir.
ap H0. am. am. am.

nin H3;subst.
apply ring_0_multl with g u. am. am.
apply ring_0_multr with g u;am.
Qed.

Lemma minus_u_multl : forall g e u, is_ring g e u -> forall x, inc x (g) ->
ml (inverse_of pl g e u) x = inverse_of pl g e x.
Proof.
ir.
assert (are_inverse pl g e x (inverse_of pl g e x)). ap group_inverse_of. am. am.
uh H1;ee. assert (is_regular pl g). apply group_is_regular with e;am.
uh H5;ee.
apply H6 with x. am. uh H;ee. uh H8;ee. ap H8. ap group_inverse_inc. am.
am. am. ap group_inverse_inc. am. am.
rw H4.
replace (pl (ml (inverse_of pl g e u) x) x) with (pl (ml (inverse_of pl g e u) x) (ml u x)).
uh H;ee. uh H9;ee.
wr H10. assert (are_inverse pl g e u (inverse_of pl g e u)). ap group_inverse_of.
am. am. uh H11;ee. rw H14. apply ring_0_multl with g u. uhg;ee. am. am. am. uhg;ee;am.
am. ap group_inverse_inc;am. am. am. uh H;ee. uh H8;ee.
uh H10;ee. rw H13. tv. am.
Qed.

Lemma minus_u_multr : forall g e u, is_ring g e u -> forall x, inc x (g) ->
ml x (inverse_of pl g e u) = inverse_of pl g e x.
Proof.
ir.
assert (are_inverse pl g e x (inverse_of pl g e x)). ap group_inverse_of. am. am.
uh H1;ee. assert (is_regular pl g). apply group_is_regular with e;am.
uh H5;ee.
apply H6 with x. am. uh H;ee. uh H8;ee. ap H8. am. ap group_inverse_inc. am.
am. am.
rw H4.
replace (pl (ml x (inverse_of pl g e u)) x) with (pl (ml x (inverse_of pl g e u)) (ml x u)).
uh H;ee. uh H9;ee.
wr H9. assert (are_inverse pl g e u (inverse_of pl g e u)). ap group_inverse_of.
am. am. uh H11;ee. rw H14. apply ring_0_multr with g u. uhg;ee. am. am. am. uhg;ee;am.
am. ap group_inverse_inc;am. am. am. uh H;ee. uh H8;ee.
uh H10;ee. rw H12. tv. am.
Qed.

Lemma inverse_ml_insert_left : forall g e u, is_ring g e u ->
forall a b, inc a g -> inc b g ->
inverse_of pl g e (ml a b) = ml (inverse_of pl g e a) b.
Proof.
ir. eapply inverse_unicity.
ap group_is_monoid. am.
ap group_inverse_of. am. uh H;ee. uh H3;ee. au.
erewrite <-minus_u_multl.
Focus 2. ap H.
uh H;ee. uh H3;ee.
wr H6;au. rw minus_u_multl;au.
ap group_inverse_of. am. au.
uhg;ee; au. uhg;ee;am.
ap group_inverse_inc;am. am.
Qed.

Lemma inverse_ml_insert_right : forall g e u, is_ring g e u ->
forall a b, inc a g -> inc b g ->
inverse_of pl g e (ml a b) = ml a (inverse_of pl g e b).
Proof.
ir. eapply inverse_unicity.
ap group_is_monoid. am.
ap group_inverse_of. am. uh H;ee. uh H3;ee. au.
erewrite <-minus_u_multr.
Focus 2. ap H.
uh H;ee. uh H3;ee.
rw H6;au. rw minus_u_multr;au.
ap group_inverse_of. am. au.
uhg;ee; au. uhg;ee;am.
ap group_inverse_inc;am. am.
Qed.

Lemma integral_quasiregular_left : forall g e u, is_ring g e u -> is_integral g e ->
forall a b c, inc a g -> inc b g -> inc c g -> a<>e ->
ml a b = ml a c -> b = c.
Proof.
ir.
assert (are_inverse pl g e (ml a b) (inverse_of pl g e (ml a c))).
rw H5. ap group_inverse_of. am. uh H;ee. uh H7;ee;au.
uh H6;ee.
uh H;ee. uh H12;ee.
erewrite inverse_ml_insert_right in H8. Focus 2.
uhg;ee. am. am. ap H11. uhg;ee;am.
wri H12 H8;au.
uh H0;ee. apply H0 in H8. nin H8.
ap False_rect. au.
assert (is_regular pl g). eapply group_is_regular;am.
uh H14;ee. apply H15 with (inverse_of pl g e c).
ap group_inverse_inc;am. am. am.
rw H8. assert (are_inverse pl g e c (inverse_of pl g e c)). ap group_inverse_of;am.
symmetry;am. am.
uh H;ee;ap H. am. ap group_inverse_inc;au. uhg;ee;am.
ap group_inverse_inc;am. am. am.
Qed.

Lemma integral_quasiregular_right : forall g e u, is_ring g e u -> is_integral g e ->
forall a b c, inc a g -> inc b g -> inc c g -> a<>e ->
ml b a = ml c a -> b = c.
Proof.
ir.
assert (are_inverse pl g e (ml b a) (inverse_of pl g e (ml c a))).
rw H5. ap group_inverse_of. am. uh H;ee. uh H7;ee;au.
uh H6;ee.
uh H;ee. uh H12;ee.
erewrite inverse_ml_insert_left in H9. Focus 2.
uhg;ee. am. am. ap H11. uhg;ee;am.
wri H13 H9;au.
uh H0;ee. apply H0 in H9. nin H9.
assert (is_regular pl g). eapply group_is_regular;am.
uh H14;ee. apply H14 with (inverse_of pl g e c).
ap group_inverse_inc;am. am. am.
rw H9. assert (are_inverse pl g e c (inverse_of pl g e c)). ap group_inverse_of;am.
symmetry;am.
ap False_rect;au.
uh H;ee;ap H;au. ap group_inverse_inc;au. uhg;ee;am. am.
ap group_inverse_inc;am. am. am.
Qed.

Lemma integral_injective_l : forall g e u, is_ring g e u -> is_integral g e ->
forall a, inc a g -> a<>e -> Application.injective g g (ml a).
Proof.
ir;uhg;ee;uhg;ir.
ap H. am. am.
eapply integral_quasiregular_left. am. am.
ap H1. am. am. am. am.
Qed.

Lemma integral_injective_r : forall g e u, is_ring g e u -> is_integral g e ->
forall a, inc a g -> a<>e -> Application.injective g g (fun x => ml x a).
Proof.
ir;uhg;ee;uhg;ir.
ap H. am. am.
eapply integral_quasiregular_right. am. am.
ap H1. am. am. am. am.
Qed.

End Laws.

End Ring. Export Ring.

Module Ideal.

Section Law.

Variables (pl ml : E2) (a e u : E).
Hypothesis (rgH : is_ring pl ml a e u).

Definition is_ideal b :=
A (is_subgroup pl a e b)
(A (forall x, inc x (b) -> forall y, inc y (a) -> inc (ml x y) (b))
(forall x, inc x (b) -> forall y, inc y (a) -> inc (ml y x) (b))).

Definition ideal_of x := Im (fun z => ml x z) a.

Definition is_principal_ideal b := is_ideal b & (exists x, inc x (a) & b = ideal_of x).

Definition is_principal_ring := forall b, is_ideal b -> is_principal_ideal b.

Lemma ideal_of_ideal : commutative ml a ->
forall x, inc x (a) ->
is_principal_ideal (ideal_of x).
Proof.
ir. uhg. ee.
uhg;ee.
ap subgroup_show. am.
uf ideal_of. uhg;ir. apply Im_ex in H1;nin H1;ee;subst.
ap rgH;am.
exists e. ap Im_show_inc. exists e. ee. ap rgH.
symmetry;eapply ring_0_multr. ap rgH. am.

ir. ufi ideal_of H1;apply Im_ex in H1;nin H1;ee;subst.
ufi ideal_of H2;apply Im_ex in H2;nin H2;ee;subst.
cp rgH. uh H3;ee. uh H6;ee. wr H6;au.
ap Im_inc. ap H3. am. am.

ir. ufi ideal_of H1;apply Im_ex in H1;nin H1;ee;subst.
erewrite inverse_ml_insert_right. Focus 2. ap rgH.
ap Im_inc. ap group_inverse_inc;am.
am. am.

Focus 3. exists x. ee;au.

ir. ufi ideal_of H1;apply Im_ex in H1;nin H1;ee;subst.
cp rgH. uh H3;ee. uh H5;ee. wr H8;au.
ap Im_inc;au.

ir.
ufi ideal_of H1;apply Im_ex in H1;nin H1;ee;subst.
cp rgH. uh H3;ee. uh H5;ee. rw H8;au.
replace (ml y x) with (ml x y);au.
wr H8;au. ap Im_inc;au.
Qed.

Lemma principal_is_ideal : forall b, is_principal_ideal b -> is_ideal b.
Proof.
ir. uh H. nin H;ee. am.
Qed.

End Law.

Section Division.

Variables (pl ml : E2) (a e u : E).
Hypotheses (rgH : is_ring pl ml a e u)
(comH : commutative ml a).

Definition divides x y := exists z, inc z (a) & y = ml x z.

Lemma divide_ideal_rw : forall x y, inc x (a) -> inc y (a) ->
divides x y = (sub (ideal_of ml a y) (ideal_of ml a x)).
Proof.
ir. ap iff_eq;ir.
nin H1;ee. subst.
uhg;ir. ufi ideal_of H2;apply Im_ex in H2;nin H2;ee;subst.
cp rgH.
uh H3;ee. uh H5;ee. wr H8;au.

ap Im_inc. au.

uhg.
assert (inc y (ideal_of ml a y)).
ap Im_show_inc. exists u. ee. am.
symmetry;ap rgH. am. apply H1 in H2. apply Im_ex in H2. nin H2;ee;subst.
exists x0;ee;au.
Qed.

Lemma divides_refl : forall x, inc x a -> divides x x.
Proof.
ir. uhg.
exists u;ee. am.
symmetry. ap rgH. am.
Qed.

Lemma divides_transitiveT : forall x y z, inc x (a) -> inc y (a) -> inc z (a) ->
divides x y -> divides y z -> divides x z.
Proof.
ir. rw divide_ideal_rw;au. rwi divide_ideal_rw H3;rwi divide_ideal_rw H2;au.
uhg;ir;au.
Qed.

End Division.

End Ideal.

Module SubRing.

Section Law.

Variables (pl ml : E2).

Definition is_subring a e u b :=
A (sub (b) (a))
(is_ring pl ml b e u).

Lemma subring_subgroup : forall a e u b, is_subring a e u b -> is_subgroup pl a e b.
Proof.
ir. uhg. ee. am. am.
Qed.

Lemma show_ring_by_subring : forall b e u, (exists a, is_subring a e u b) -> is_ring pl ml b e u.
Proof.
ir. nin H. am.
Qed.

Lemma show_subring : forall a e u b, is_ring pl ml a e u ->
is_subgroup pl a e b ->
inc u (b) ->
(forall x, inc x b -> forall y, inc y b -> inc (ml x y) b) ->
is_subring a e u b.
Proof.
ir. assert (sub b a). am.
uhg;ee. am.
uhg. ee. am.
uhg;ir. ap H. au. au.
uh H;ee.
uhg;ee. am.
uhg;ee. am.
ir. ap H5. au.
ir. ap H5;au.

uhg;ir. ap H5;au.

uhg; ee;uhg;ir.
ap H;au. ap H;au.
Qed.

End Law.

End SubRing. Export SubRing.

Module Field.

Definition is_field pl ml a e u :=
A (is_ring pl ml a e u)
(forall x, inc x a -> x<>e -> inversible ml a u x).

Lemma field_integral : forall pl ml a e u, is_field pl ml a e u ->
is_integral ml a e. ir.
Proof.
uhg. ir.
apply by_cases with (a0 = e);ir.
left;am.
cp H3. apply H in H3.
nin H3;uh H3;ee.
assert (x<>e). uhg;ir.
rwi H8 H7. uh H;ee. cp H. rwi (ring_0_multl H) H7.
ap H4. uh H10;ee. uh H12;ee. uh H14;ee. symmetry. wr H16.
wr H7. symmetry. eapply ring_0_multr. ap H.
am. am. am.
assert (b = ml x e).
wr H2. uh H;ee. uh H;ee.
uh H11;ee. rw H14;try am. rw H7. symmetry.
ap H13;am.
right. rw H9. eapply ring_0_multr. ap H. am. am.
Qed.

Lemma field_mult_quasireg_l : forall pl ml g e u, is_field pl ml g e u ->
forall a b c, inc a g -> inc b g -> inc c g -> a<>e ->
ml a b = ml a c -> b = c.
Proof.
ir. eapply integral_quasiregular_left. ap H. eapply field_integral.
ap H. ap H0. am. am. am. am.
Qed.

Lemma field_mult_quasireg_r : forall pl ml g e u, is_field pl ml g e u ->
forall a b c, inc a g -> inc b g -> inc c g -> a<>e ->
ml b a = ml c a -> b = c.
Proof.
ir. eapply integral_quasiregular_right. ap H. eapply field_integral.
ap H. ap H0. am. am. am. am.
Qed.

Lemma field_mult_group : forall pl ml a e u, is_field pl ml a e u -> e<>u ->
is_group ml (Z a (fun x => x <> e)) u.
Proof.
ir.
assert (is_lci ml (Z a (fun x : E => x <> e))).
uhg;ir. Ztac;au. Ztac;au.
ap Z_inc. ap H;am.
uhg;ir. apply (field_integral H) in H5;try am.
nin H5;au.
uhg;ee. am.
uhg;ee. ap Z_inc. am. uhg;ir;au.
ir. Ztac;au.
ap H. am.
ir. ap H. Ztac;au.
uhg;ir. Ztac;au;Ztac;au;Ztac;au.
ap H;am.
ir.
Ztac;au. uh H;ee. cp (H4 x H2 H3).
nin H5.
exists x0.
uhg;ee. ap Z_inc;am.
ap Z_inc. am. uhg;ir;subst.
uh H5;ee. rwi (ring_0_multr H) H7. ap H0;am.
am.
am. am.
Qed.

Lemma field_inverse_of : forall pl ml a e u, is_field pl ml a e u ->
forall x, inc x (Z a (fun x => x<>e)) ->
are_inverse ml (Z a (fun x => x<>e)) u x (inverse_of ml a u x).
Proof.
ir. Ztac;au.
uh H;ee. cp (H2 x H0 H1).
apply inversible_inverse_of in H3.
uhg;ee;try am.
ap Z_inc;am. ap Z_inc. am.
uhg;ir;uh H3;ee.
rwi H4 H7. rwi (ring_0_multl H) H7;try am.
ap H1. replace x with (ml u x). wr H7.
ap (ring_0_multl H). am.
ap H. am.
am.
Qed.

End Field. Export Field.

(*
Module Fraction_field.
Export Quotient.

Section Law.

Variables (pl ml : E2) (r e u : E).

Hypotheses (rgH : is_ring pl ml r e u) (iH : is_integral ml r e) (cH : commutative ml r).
Hypothesis (uH : u<>e).

Definition qEquiv x y := ml (P x) (Q y) = ml (P y) (Q x).

Lemma qEquiv_zEquiv : qEquiv = Group_of_Monoid.zEquiv ml.
Proof.
uf Group_of_Monoid.zEquiv. ap arrow_extensionality;ir.
ap arrow_extensionality;ir. uf qEquiv. tv.
Qed.

Definition qBase := product r (Z r (fun x => x <> e)).

Lemma qEquiv_equivalence : is_equivalence qBase qEquiv.
Proof.
uhg;ee.
ir. uf qEquiv. tv.
ir. uhg. uh H1. symmetry. am.
ir. uh H2;uh H3.
uhg.
apply product_pr in H;ee. clear H;Ztac;clear H5.
apply product_pr in H0;ee. clear H0;Ztac;clear H7.
apply product_pr in H1;ee. clear H1;Ztac;clear H9.

cp (integral_quasiregular_right rgH iH).
apply H9 with (Q y).
am. ap rgH;am. ap rgH;am.
am.
assert (is_lci ml r). am.
rw cH;au. cp rgH. uh H12;ee. clear H11;clear H12;clear H13;clear H15.
uh H14. ee. rw H13;try am.
rwi cH H2;try am. rw H2.
symmetry. symmetry in H3.
rw cH;au. rw H13;try am.
rwi cH H3;try am. rw H3.
symmetry. rw cH;au. rw H13;try am.
rw (cH H1 H5). tv.
Qed.

Definition qF := quotient qBase qEquiv.

Definition qMl0 x y := J (ml (P x) (P y)) (ml (Q x) (Q y)).

Lemma qMl0_lci : is_lci qMl0 qBase.
Proof.
uhg;ir.
uf qMl0. apply product_pr in H;apply product_pr in H0.
ap product_pair_inc. ap rgH. am. am.
ee. Ztac;clear H2;Ztac;clear H4.
ap Z_inc. ap rgH;am.
uhg;ir. apply iH in H4. nin H4;au. am. am.
Qed.

Lemma qMl0_compat : forall a b, inc a r -> inc b r -> b<>e ->
forall a' b', inc a' r -> inc b' r -> b'<>e ->
qEquiv (J a b) (J a' b') ->
forall c d, inc c r -> inc d r -> d<>e ->
forall c' d', inc c' r -> inc d' r -> d'<>e ->
qEquiv (J c d) (J c' d') ->
qEquiv (qMl0 (J a b) (J c d)) (qMl0 (J a' b') (J c' d')).
Proof.
uf qEquiv;uf qMl0;ir.
clear_pr. clear_pr_in H12. clear_pr_in H5.

transitivity (ml (ml a b') (ml c d')).
assert (forall f:E1, forall x y, x=y -> f x = f y). ir. rw H13;tv.
assert (is_lci ml r). am. assert (associative ml r). am.
wr H15;au. symmetry. wr H15;au. ap H13.
rw cH;au. wr H15;au.

rw H5. rw H12.
assert (forall f:E1, forall x y, x=y -> f x = f y). ir. rw H13;tv.
assert (is_lci ml r). am. assert (associative ml r). am.
wr H15;au. symmetry. wr H15;au. ap H13.
rw cH;au. wr H15;au.
Qed.

Lemma qMl0_compat0 : forall a, inc a qBase -> forall a', inc a' qBase -> qEquiv a a' ->
forall b, inc b qBase -> forall b', inc b' qBase -> qEquiv b b' ->
qEquiv (qMl0 a b) (qMl0 a' b').
Proof.
ir.
apply product_pr in H;apply product_pr in H0;apply product_pr in H2;apply product_pr in H3;ee.
apply pair_recov in H;apply pair_recov in H0;apply pair_recov in H2;apply pair_recov in H3.
wr H;wr H0;wr H2;wr H3.
ap qMl0_compat;try am.
eapply Z_sub. am. apply Z_pr in H12;am.
eapply Z_sub. am. apply Z_pr in H10;am.
uhg. clear_pr. am.
eapply Z_sub. am. apply Z_pr in H8;am.
eapply Z_sub. am. apply Z_pr in H6;am.
uhg;clear_pr;am.
Qed.

Notation "[ x ]" := (class_of qBase qEquiv x).

Definition qMl x y := [ qMl0 (rep x) (rep y) ].

Lemma qMl_lci : is_lci qMl qF.
Proof.
uhg;ir.
uf qF;uf qMl;uf qMl0.
cp (in_quotient_is_class H). cp (in_quotient_is_class H0).
ap class_of_in_quotient.
ap qMl0_lci. assert (sub x qBase).
uh H1;ee. uh H1;ee. am.
ap H3. eapply class_rep_inc. ap H1.
assert (sub y qBase).
uh H2;ee. uh H2;ee. am.
ap H3. eapply class_rep_inc. ap H2.
Qed.

Lemma qMl_rep_rw0 : forall x y, inc x qBase -> inc y qBase ->
qMl [x] [y] = [ qMl0 x y ].
Proof.
ir. uf qMl.
ap related_classes_eq. ap qMl0_lci.
cp (class_sub (class_of_class qEquiv H)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
cp (class_sub (class_of_class qEquiv H0)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
ap qMl0_lci;am.
ap qMl0_compat0.
cp (class_sub (class_of_class qEquiv H)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am.
eapply equivalent_related.
ap qEquiv_equivalence.
uhg. ee.
cp (class_sub (class_of_class qEquiv H)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am.
ap class_of_rep. ap class_of_in_quotient. am.
cp (class_sub (class_of_class qEquiv H0)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am.
eapply equivalent_related.
ap qEquiv_equivalence.
uhg. ee.
cp (class_sub (class_of_class qEquiv H0)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am. ap class_of_rep.
ap class_of_in_quotient. am.
Qed.

Lemma qMl_rep_rw : forall a b, inc a r -> inc b r -> b<>e ->
forall c d, inc c r -> inc d r -> d<>e ->
qMl [J a b] [J c d] = [J (ml a c) (ml b d)].
Proof.
ir. rw qMl_rep_rw0. uf qMl0. clear_pr.
tv. ap product_pair_inc. am. ap Z_inc;am.
ap product_pair_inc. am. ap Z_inc;am.
Qed.

Definition qU := [ J u u ].

Lemma qU_inc : inc qU qF.
Proof.
ap class_of_in_quotient. ap product_pair_inc.
am. ap Z_inc. am. am.
Qed.

Lemma qMl_comm : commutative qMl qF.
Proof.
uhg;ir.
cp (class_of_rep H). cp (class_of_rep H0).
assert (inc (rep x) qBase).
eapply class_sub. ap in_quotient_is_class. ap H.
eapply class_rep_inc. ap in_quotient_is_class. ap H.
assert (inc (rep y) qBase).
eapply class_sub. ap in_quotient_is_class. ap H0.
eapply class_rep_inc. ap in_quotient_is_class. ap H0.

apply product_pr in H3;apply product_pr in H4;ee.
uf qMl. uf qMl0.
Ztac;clear H6;Ztac;clear H8.
rw (cH H7 H5). rw (cH H6 H9). tv.
Qed.

Lemma qRep_inc : forall x, inc x qF -> inc (rep x) qBase.
Proof.
ir.
eapply class_sub. ap in_quotient_is_class. ap H.
eapply class_rep_inc. ap in_quotient_is_class. ap H.
Qed.

Lemma qF_mult_monoid : is_monoid qMl qF qU.
Proof.
uhg;ee. ap qMl_lci.
uhg. assert (forall x : E, inc x qF -> qMl x qU = x).
ir. uf qU.
assert (inc (rep x) qBase).
eapply class_sub. ap in_quotient_is_class. ap H.
eapply class_rep_inc. ap in_quotient_is_class. ap H.
apply product_pr in H0;ee.
Ztac;clear H2.
assert ([rep x] = x). ap class_of_rep. am.
wr H2. rw qMl_rep_rw0.
uf qMl0. clear_pr.
cp rgH. uh H5;ee. uh H7;ee.
uh H9;ee. rw H11. rw H11. rw pair_recov. tv.
am. am. am. ap product_inc;try am. ap Z_inc;am.
ap product_pair_inc. am. ap Z_inc;am.
ee;try am.
ap qU_inc.
ir. rw qMl_comm. ap H. am.
ap qU_inc. am.

uhg;ir.
cp (class_of_rep H). cp (class_of_rep H0). cp (class_of_rep H1).
cp (qRep_inc H);cp (qRep_inc H0);cp (qRep_inc H1).
replace (qMl y z) with ([ qMl0 (rep y) (rep z)]).
replace (qMl x y) with ([ qMl0 (rep x) (rep y)]).
wr H2. rw qMl_rep_rw0.
rw H2. wr H4. rw qMl_rep_rw0.
rw H4.
uf qMl0. clear_pr.
apply product_pr in H5;ee;apply product_pr in H6;ee;apply product_pr in H7;ee.
Ztac;clear H13;Ztac;clear H11;Ztac;clear H9.
assert (is_lci ml r). am. assert (associative ml r). am.
rw H18;au. rw H18;au.
ap qMl0_lci;am. am. am. ap qMl0_lci;am.
uf qMl. tv. uf qMl. tv.
Qed.

Definition qE := [J e u].

Lemma qE_inc : inc qE qF.
Proof.
ap class_of_in_quotient. ap product_pair_inc.
am. ap Z_inc;am.
Qed.

Lemma qF_mult_inversible0 : forall a b, inc (J a b) qBase -> [J a b] <> qE ->
inversible qMl qF qU [J a b].
Proof.
ir.
exists [J b a].
apply product_pair_pr in H;ee;Ztac. clear H1.
uhg.
assert (aH : a<>e).
uhg;ir;subst. ap H0.
ap related_classes_eq. ap product_pair_inc.
am. ap Z_inc;am.
ap product_pair_inc.
am. ap Z_inc;am.
uhg;clear_pr.
rw (ring_0_multl rgH);try am. rw (ring_0_multl rgH);try am.
tv.

assert (preH : qMl [J a b] [J b a] = qU).
rw qMl_rep_rw.
rw cH;try am.
uf qU. ap related_classes_eq.
ap product_pair_inc. ap rgH;am.
ap Z_inc. ap rgH;am. uhg;ir.
apply iH in H1. nin H1;au.
am. am. ap product_pair_inc. am. ap Z_inc;am.
uhg;clear_pr.
assert (is_neutre ml r u). am.
uh H1;ee. rw H4;au. rw H5;au.
ap rgH;am. ap rgH;am.
am. am. am. am. am. am.

ee. ap class_of_in_quotient. ap product_pair_inc. am.
ap Z_inc;am.
ap class_of_in_quotient;ap product_pair_inc.
am. ap Z_inc;am.
am.
rw qMl_comm. am.
ap class_of_in_quotient;ap product_pair_inc.
am. ap Z_inc;am.
ap class_of_in_quotient;ap product_pair_inc.
am. ap Z_inc;am.
Qed.

Lemma qE_reps : forall x, inc x r -> x<>e ->
[J e x] = qE.
Proof.
ir. uf qE.
ap related_classes_eq.
ap product_pair_inc.
am. ap Z_inc;am.
ap product_pair_inc.
am. ap Z_inc;am.
uhg;clear_pr.
rw (ring_0_multl rgH). rw (ring_0_multl rgH).
tv. am. am.
Qed.

Lemma reps_qE : forall a b, inc a r -> inc b r -> b<>e ->
[J a b] = qE -> a=e.
Proof.
ir.
ufi qE H2.
assert (qEquiv (J a b) (J e u)). eapply equivalent_related.
ap qEquiv_equivalence. uhg;ee.
ap product_pair_inc. am. ap Z_inc;am.
ap product_pair_inc. am. ap Z_inc;am.
am.
uh H3;clear_pr_in H3.
rwi (ring_0_multl rgH) H3. apply iH in H3.
nin H3. am. ap False_rect;au.
am. am. am.
Qed.

Lemma qF_simplify : forall x, inc x r -> x<>e ->
forall a b, inc a r -> inc b r -> b<>e ->
[J (ml x a) (ml x b)] = [J a b].
Proof.
ir.
ap related_classes_eq.
ap product_pair_inc. ap rgH;am.
ap Z_inc. ap rgH;am.
uhg;ir. apply iH in H4. nin H4;au.
am. am.
apply product_pair_inc. am. ap Z_inc;am.
uhg;clear_pr.
assert (associative ml r). am.
wr H4;try am.
symmetry. rw cH;au.
wr H4;try am. rw (cH H1 H2). tv.
ap rgH;am.
Qed.

(* a/b + c/d = (ad + cb)/(bd)*)
Definition qPl0 x y := let a := P x in let b := Q x in let c := P y in let d := Q y in
J (pl (ml a d) (ml c b)) (ml b d).

Lemma qPl0_lci : forall x y, inc x qBase -> inc y qBase -> inc (qPl0 x y) qBase.
Proof.
ir. apply product_pr in H;apply product_pr in H0;ee.
Ztac;clear H2;Ztac;clear H4.
 ap product_pair_inc.
repeat (ap rgH;try am).
ap Z_inc. ap rgH;am.
uhg;ir. apply iH in H4;try am.
nin H4;au.
Qed.

Lemma qPl0_comm : commutative qPl0 qBase.
Proof.
uhg;ir.
uf qPl0. cp rgH. uh H1;ee.
apply product_pr in H;apply product_pr in H0;ee.
Ztac;clear H6;Ztac;clear H8.
rw H2. rw (cH H9 H6). tv.
ap rgH;am. ap rgH;am.
Qed.

Notation "x + y" := (pl x y).
Notation "x * y" := (ml x y).

Lemma qPl0_compat : forall a b, inc a r -> inc b r -> b<>e ->
forall a' b', inc a' r -> inc b' r -> b'<>e ->
qEquiv (J a b) (J a' b') ->
forall c d, inc c r -> inc d r -> d<>e ->
forall c' d', inc c' r -> inc d' r -> d'<>e ->
qEquiv (J c d) (J c' d') ->
qEquiv (qPl0 (J a b) (J c d)) (qPl0 (J a' b') (J c' d')).
Proof.
ir.
uh H5;clear_pr_in H5;uh H12;clear_pr_in H12.
uhg. uf qPl0. clear_pr.
cp rgH.
cp (integral_quasiregular_right rgH iH).
cp (integral_quasiregular_left rgH iH).
uh H13;ee.
uh H13;ee;uh H17;ee.
rw H23;au.
uh H18;ee.
rw H24;au.
replace (a*d*b') with (a*b'*d).
Focus 2. wr H23;au. wr H23;au. rw (cH H3 H7). tv.
rw H5.
symmetry. rw (cH H0 H7).
rw H23;au. rw H24;au.
replace (c'*b'*d) with (c'*d*b').
Focus 2. wr H23;au;wr H23;au. rw (cH H7 H3). tv.
wr H12.
rw H24;au. rw H24;au.
replace (a' * d' * d * b) with (a' * b * d * d').
replace (c * d' * b' * b) with (c * b * b' * d').
tv.
wr H23;au. wr H23;au. wr H23;au.
rw (cH H3 H0).
assert (inc (b*b') r). ap rgH;am.
wr H23;au. rw (cH H10 H25).
wr H23;au.
wr H23;au. wr H23;au. wr H23;au.
rw (cH H7 H0).
assert (inc (b*d) r). ap rgH;am.
wr H23;au. rw (cH H10 H25).
wr H23;au.
Qed.

Lemma qPl0_compat0 : forall a, inc a qBase -> forall a', inc a' qBase -> qEquiv a a' ->
forall b, inc b qBase -> forall b', inc b' qBase -> qEquiv b b' ->
qEquiv (qPl0 a b) (qPl0 a' b').
Proof.
ir.
apply product_pr in H;apply product_pr in H0;apply product_pr in H2;apply product_pr in H3;ee.
apply pair_recov in H;apply pair_recov in H0;apply pair_recov in H2;apply pair_recov in H3.
wr H;wr H0;wr H2;wr H3.
ap qPl0_compat;try am.
eapply Z_sub. am. apply Z_pr in H12;am.
eapply Z_sub. am. apply Z_pr in H10;am.
uhg. clear_pr. am.
eapply Z_sub. am. apply Z_pr in H8;am.
eapply Z_sub. am. apply Z_pr in H6;am.
uhg;clear_pr;am.
Qed.

Definition qPl x y := [qPl0 (rep x) (rep y)].

Lemma qPl_rep_rw0 : forall x y, inc x qBase -> inc y qBase ->
qPl [x] [y] = [ qPl0 x y ].
Proof.
ir. uf qPl.
ap related_classes_eq. ap qPl0_lci.
cp (class_sub (class_of_class qEquiv H)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
cp (class_sub (class_of_class qEquiv H0)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
ap qPl0_lci;am.
ap qPl0_compat0.
cp (class_sub (class_of_class qEquiv H)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am.
eapply equivalent_related.
ap qEquiv_equivalence.
uhg. ee.
cp (class_sub (class_of_class qEquiv H)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am.
ap class_of_rep. ap class_of_in_quotient. am.
cp (class_sub (class_of_class qEquiv H0)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am.
eapply equivalent_related.
ap qEquiv_equivalence.
uhg. ee.
cp (class_sub (class_of_class qEquiv H0)).
ap H1. eapply class_rep_inc. ap class_of_class. am.
am. ap class_of_rep.
ap class_of_in_quotient. am.
Qed.

Lemma qPl_rep_rw : forall a b, inc a r -> inc b r -> b<>e ->
forall c d, inc c r -> inc d r -> d<>e ->
qPl [J a b] [J c d] = [J (pl (ml a d) (ml c b)) (ml b d)].
Proof.
ir. rw qPl_rep_rw0. uf qPl0. clear_pr.
tv. ap product_pair_inc. am. ap Z_inc;am.
ap product_pair_inc. am. ap Z_inc;am.
Qed.

Lemma qPl_lci : is_lci qPl qF.
Proof.
uhg;ir.
uf qPl. ap class_of_in_quotient.
cp (in_quotient_is_class H);cp (in_quotient_is_class H0).
ap qPl0_lci.
assert (sub x qBase).
uh H1;ee. uh H1;ee. am.
ap H3. eapply class_rep_inc. ap H1.
assert (sub y qBase).
uh H2;ee. uh H2;ee. am.
ap H3. eapply class_rep_inc. ap H2.
Qed.

Lemma qPl_comm : commutative qPl qF.
Proof.
uhg;ir.
uf qPl. rw qPl0_comm. tv.
eapply class_sub. ap in_quotient_is_class. ap H.
eapply class_rep_inc. ap in_quotient_is_class. ap H.
eapply class_sub. ap in_quotient_is_class. ap H0.
eapply class_rep_inc. ap in_quotient_is_class. ap H0.
Qed.

Lemma qF_add_group : is_group qPl qF qE.
Proof.
assert (is_neutre qPl qF qE).
uf qE.
uhg. assert (forall x : E, inc x qF -> qPl x [J e u] = x).
ir.
cp (in_quotient_is_class H).
cp (class_of_rep H).
wr H1.
assert (inc (rep x) qBase).
eapply class_sub. ap in_quotient_is_class. ap H.
eapply class_rep_inc. ap in_quotient_is_class. ap H.
apply product_pr in H2;ee. Ztac;clear H4.
rw qPl_rep_rw0. uf qPl0. clear_pr.
rw (ring_0_multl rgH).
cp rgH. uh H4;ee. uh H8;ee.
uh H10;ee. rw H12. rw H12. uh H4;ee.
uh H14;ee. rw H17.
rw (pair_recov H2). tv.
am. am. am. am. ap product_inc. am.
am. ap Z_inc;am. ap product_pair_inc.
ap rgH. ap Z_inc;try ap rgH;am.
ee;au.
ap class_of_in_quotient. ap product_pair_inc.
am. ap Z_inc;am.
ir. rw qPl_comm. ap H;am.
ap class_of_in_quotient. ap product_pair_inc.
am. ap Z_inc;am.
am.

uhg;ee.
ap qPl_lci. am.

uhg;ir.
cp (class_of_rep H0). cp (class_of_rep H1).
cp (class_of_rep H2).
cp (qRep_inc H0). cp (qRep_inc H1). cp (qRep_inc H2).

wr H3. replace (qPl y z) with [qPl0 (rep y) (rep z)].
rw qPl_rep_rw0. rw H3.
replace (qPl x y) with ([qPl0 (rep x) (rep y)]).
wr H5. rw qPl_rep_rw0. rw H5.
uf qPl0. clear_pr.
assert ((P (rep x) * (Q (rep y) * Q (rep z)) +
    (P (rep y) * Q (rep z) + P (rep z) * Q (rep y)) * Q (rep x)) = ((P (rep x) * Q (rep y) + P (rep y) * Q (rep x)) * Q (rep z) +
    P (rep z) * (Q (rep x) * Q (rep y)))).
cp rgH. uh H9;ee.
uh H12;ee. uh H9;ee.
uh H11;ee.
apply product_pr in H6;apply product_pr in H7;apply product_pr in H8;ee.
Ztac;clear H20;Ztac;clear H22;Ztac;clear H24.
rw H13;au. rw H13;au.
rw H15;au.
rw H18;au.
rw (cH H22 H20). rw H18;au.
replace (P (rep y) * Q (rep z) * Q (rep x)) with
(P (rep y) * (Q (rep z) * Q (rep x)));au.
rw (cH H25 H22). rw H18;au.
replace (Q (rep x) * (Q (rep y) * Q (rep z))) with (Q (rep x) * Q (rep y) * Q (rep z)).
rw H9. tv.
assert (associative ml r). am. symmetry;ap H10.
apply product_pr in H6;ee;Ztac. apply product_pr in H7;ee;Ztac.
apply product_pr in H8;ee;Ztac.
ap qPl0_lci;am. am.
uf qPl. tv. am.
ap qPl0_lci;am.
uf qPl. tv.

ir.
cp (qRep_inc H0).
cp (class_of_rep H0).
apply product_pr in H1;ee. Ztac;clear H4.
assert (is_group pl r e). am.
uh H4;ee. cp (H9 (P (rep x)) H3).
nin H10.
exists [J x0 (Q (rep x))].
uhg. assert (qPl x [J x0 (Q (rep x))] = qE).
wr H2. rw qPl_rep_rw0. rw H2.
uf qPl0.
clear_pr.
cp rgH. uh H11;ee. uh H14;ee.
wr H15. uh H10;ee.
rw H17. rw (ring_0_multl rgH).
ap qE_reps. ap rgH;am.
uhg;ir. apply iH in H19;au. nin H19;au.
am. am. am. am. ap product_inc;try am.
ap Z_inc;am.
ap product_pair_inc. am.
rw H2. ap Z_inc;am.
ee. am.
ap class_of_in_quotient. ap product_pair_inc.
am. ap Z_inc;am.
am. rw qPl_comm. am.
ap class_of_in_quotient. ap product_pair_inc.
am. ap Z_inc;am.
am.
Qed.

Lemma qF_distrib_l : forall a b c, inc a qF -> inc b qF -> inc c qF ->
qMl a (qPl b c) = qPl (qMl a b) (qMl a c).
Proof.
ir.
cp (class_of_rep H). cp (class_of_rep H0). cp (class_of_rep H1).
cp (qRep_inc H). cp (qRep_inc H0). cp (qRep_inc H1).
apply product_pr in H5;apply product_pr in H6;apply product_pr in H7;ee.
Ztac;clear H9;Ztac;clear H11;Ztac;clear H13.
uf qMl. rw qPl_rep_rw0.
replace ([qMl0 (rep a) (rep (qPl b c))]) with (qMl a (qPl b c)).
uf qPl. wr H2. rw qMl_rep_rw0. rw H2.
uf qMl0;uf qPl0;clear_pr.
set (a0 := P (rep a)). set (a1 := Q (rep a)).
set (b0 := P (rep b)). set (b1 := Q (rep b)).
set (c0 := P (rep c)). set (c1 := Q (rep c)).
ap related_classes_eq.
ap product_pair_inc. repeat (ap rgH;try am).
ap Z_inc. repeat (ap rgH;try am).
uhg;ir. apply iH in H13. nin H13. au.
apply iH in H13. nin H13;au.
am. am. am. ap rgH;am.
ap product_pair_inc. repeat (ap rgH;try am).
ap Z_inc. repeat (ap rgH;try am).
uhg;ir. assert (is_lci ml r). am.
apply iH in H13;au. nin H13;apply iH in H13;au;nin H13;au.
uhg;clear_pr.
assert (forall f:E1, forall x y, x=y -> f x = f y). ir. rw H13. tv.
assert (is_lci pl r). am. assert (is_lci ml r). am.
assert (associative ml r). am.
assert (associative pl r). am.
assert (distributes pl ml r). am.
symmetry.
uh H22;ee.
rw H22;au. rw H23;au.
rw H23;au.
replace (a0 * (b0 * c1) * (a1 * b1 * (a1 * c1))) with
(a0 * b0 * (a1 * c1) * (a1 * (b1 * c1))).
ap H13. wr H20;au. wr H20;au. symmetry. wr H20;au. ap H13.
wr H20;au. ap H13.
symmetry. wr H20;au. rw cH;au. wr H20;au. ap H13.
wr H20;au. symmetry;wr H20;au. ap H13.
symmetry. wr H20;au.
wr H20;au. wr H20;au. symmetry. wr H20;au.
wr H20;au. ap H13. ap H13.
rw cH;au. wr H20;au. wr H20;au. symmetry.
wr H20;au. ap H13. rw cH;au. wr H20;au.
symmetry. rw cH;au. wr H20;au. wr H20;au. ap H13.
symmetry. wr H20;au. rw cH;au.
symmetry;ap H20;au.

ap product_inc;au. ap Z_inc;am.
ap qPl0_lci;ap product_inc;try am;ap Z_inc;am.
uf qMl. tv.
ap qMl0_lci;ap product_inc;try am;ap Z_inc;am.
ap qMl0_lci;ap product_inc;try am;ap Z_inc;am.
Qed.

Lemma qF_field : is_field qPl qMl qF qE qU.
Proof.
uhg;ee.
uhg;ee.
ap qF_add_group. ap qPl_comm.
ap qF_mult_monoid. uhg;ee.
ir. ap qF_distrib_l;am.
ir. rw qMl_comm;au. rw qF_distrib_l;au.
rw qMl_comm. rw (qMl_comm H1 H0).
tv. am. am. ap qPl_lci;am.

ir. cp (class_of_rep H).
cp (qRep_inc H). apply product_pr in H2;ee.
Ztac;clear H4. apply pair_recov in H2.
wr H1;wr H2.
ap qF_mult_inversible0.
ap product_pair_inc. am. ap Z_inc;am.
uhg;ir.
rwi H2 H4. rwi H1 H4. au.
Qed.

Lemma qPl_same_denom : forall x y q, inc x r -> inc y r -> inc q r -> q<>e ->
qPl [J x q] [J y q] = [J (pl x y) q].
Proof.
ir.
rw qPl_rep_rw;try am.
cp rgH. uh H3;ee. uh H6;ee.
wr H7;try am. rw cH;try am.
rw qF_simplify;try am. tv.
ap rgH;am. ap rgH;am.
Qed.

Lemma qPl_inverse_of_num : forall a b, inc a r -> inc b r -> b<>e ->
inverse_of qPl qF qE [J a b] = [J (inverse_of pl r e a) b].
Proof.
ir.
eapply inverse_unicity.
ap group_is_monoid. ap qF_field.
ap group_inverse_of. ap qF_field.
ap class_of_in_quotient. ap product_pair_inc.
am. ap Z_inc;am.
uhg. assert (qPl [J a b] [J (inverse_of pl r e a) b] = qE).
rw qPl_same_denom. assert (are_inverse pl r e a (inverse_of pl r e a)).
ap group_inverse_of. am. am.
uh H2;ee. rw H4. ap qE_reps. am. am.
am. ap group_inverse_inc. am. am.
am. am.
assert (A (inc [J a b] qF)
  (inc [J (inverse_of pl r e a) b] qF)).
ee. ap class_of_in_quotient. ap product_pair_inc. am.
ap Z_inc;am. ap class_of_in_quotient. ap product_pair_inc.
ap group_inverse_inc. am. am.
ap Z_inc;am.
ee.
am. am.
am. rw qPl_comm. am.
am. am.
Qed.

Lemma qPl_inverse_of_denom : forall a b, inc a r -> inc b r -> b<>e ->
inverse_of qPl qF qE [J a b] = [J a (inverse_of pl r e b)].
Proof.
ir.
assert (A (inc [J a b] qF)
  (inc [J a (inverse_of pl r e b)] qF)).
ee.
ap class_of_in_quotient. ap product_pair_inc. am.
ap Z_inc;am.
ap class_of_in_quotient. ap product_pair_inc. am.
ap Z_inc. ap group_inverse_inc. am. am.
uhg;ir. ap H1. assert (are_inverse pl r e b (inverse_of pl r e b)).
ap group_inverse_of;am.
uh H3;ee.
rwi H2 H5. wr H5.
symmetry. ap rgH. am.

eapply inverse_unicity. ap group_is_monoid;ap qF_field.
ap group_inverse_of. ap qF_field.
am. uhg. assert (qPl [J a b] [J a (inverse_of pl r e b)] = qE).
assert (are_inverse pl r e b (inverse_of pl r e b)).
ap group_inverse_of;am.
assert ((inverse_of pl r e b) <> e).
uhg;ir. ap H1. uh H3;ee.
rwi H4 H7. wr H7.
symmetry. ap rgH. am.

rw qPl_rep_rw;try am.
cp rgH. uh H5;ee. uh H9;ee.
wr H9;try am.
uh H3;ee. rw H13.
rw (ring_0_multr rgH);try am.
ap qE_reps. ap rgH;am.
uhg;ir. apply iH in H14;try am. nin H14;au.

ee. am. am. am.
rw qPl_comm. am.
am. am.
Qed.

Lemma qMl_inverse_of : forall a b, inc a r -> inc b r -> a<>e -> b<>e ->
are_inverse qMl qF qU [J a b] [J b a].
Proof.
ir.
assert (inc [J a b] qF).
ap class_of_in_quotient;ap product_pair_inc;try am;ap Z_inc;am.
assert (inc [J b a] qF).
ap class_of_in_quotient;ap product_pair_inc;try am;ap Z_inc;am.
assert (qMl [J a b] [J b a] = qU).
rw qMl_rep_rw;au. uf qU.
rw (cH H H0).
rw qF_simplify;try am.
assert (a = ml a u). symmetry. ap rgH. am.
rw H5. ap qF_simplify. am. am. am. am.
am.

uhg;ee;try am.
rw qMl_comm;am.
Qed.

End Law.

End Fraction_field.
*)

(*interesting note : distributivity does not carry over through innerLaw
sub (A * (B + C)) ((A * B) (A * C)) but not the other way around*)

Module Ordered_ring.
Export Ordered_lci.

Section Law.

Definition order_preserves (le : E2P) (ml : E2) (g : E) (e : E) :=
forall x, inc x g -> le e x -> forall y, inc y g -> le e y -> le e (ml x y).

Definition is_ordered_quasiring pl ml le a e u :=
A (is_quasiring pl ml a e u)
(A (is_order le a)
(A (is_compatible le pl a)
(A (le e u)
(order_preserves le ml a e)))).

Definition is_ordered_ring pl ml le a e u :=
A (is_ring pl ml a e u)
(A (is_order le a)
(A (is_compatible le pl a)
(A (le e u)
(order_preserves le ml a e)))).

Definition is_ordered_field pl ml le a e u :=
A (is_field pl ml a e u)
(A (is_order le a)
(A (is_compatible le pl a)
(A (le e u)
(order_preserves le ml a e)))).

Lemma oring_ml_lcompat : forall le pl ml a e u, is_ordered_ring pl ml le a e u ->
forall x, inc x a -> le e x -> forall y, inc y a -> forall z, inc z a -> le y z ->
le (ml x y) (ml x z).
Proof.
ir.
uh H;ee.
assert (le e (pl z (inverse_of pl a e y))).
destruct ordered_group_order_regular with le pl a e.
uhg;ee;am.
apply H10 with y.
am. am. ap H. am. ap group_inverse_inc;am.
assert (associative pl a). am.
assert (is_group pl a e). am.
cp (group_inverse_of H12 H2). uh H13;ee.
wr H11;try am.
rw H16. uh H12;ee. uh H17;ee.
rw H20;try am;rw H21;try am.
uh H8.
assert (are_inverse pl a e y (inverse_of pl a e y)).
 ap group_inverse_of;am.
uh H10;ee.
assert (le e (ml x (pl z (inverse_of pl a e y)))).
ap H8;try am. ap H;am.
assert (distrib_l pl ml a). am. rwi H15 H14;try am.
wri (inverse_ml_insert_right H) H14;try am.

destruct ordered_group_order_regular with le pl a e.
uhg;ee;am.
assert (are_inverse pl a e (ml x y) (inverse_of pl a e (ml x y))).
ap group_inverse_of. am.
ap H;am.
eapply H17. ap H18. ap H;am. ap H;am.
uh H18;ee. rw H20. am.
Qed.

(*
Lemma order_group_opp : forall pl le g e, is_group pl g e -> forall Hc : commutative pl g,
is_order le g -> is_order_compat pl le g ->
forall x y, inc x g -> inc y g -> le x y ->
le (inverse_of pl g e y) (inverse_of pl g e x).
Proof.
ir.
cp (group_inverse_of H H2);uh H5;ee. cp (group_inverse_of H H3);uh H9;ee.
uh H;ee.
assert (inverse_of pl g e y = pl x (pl (inverse_of pl g e x) (inverse_of pl g e y))).
rw H14;au. rw H7;au. symmetry;ap H13;au.
assert (inverse_of pl g e x = pl y (pl (inverse_of pl g e y) (inverse_of pl g e x))).
rw H14;au. rw H11;au. symmetry;ap H13;au.

assert (le (pl x (pl (inverse_of pl g e x) (inverse_of pl g e y)))
(pl y (pl (inverse_of pl g e y) (inverse_of pl g e x)))).
rw (Hc (inverse_of pl g e x) (inverse_of pl g e y)).
uh H1;ee.
ap H18. am. am. am. au. au. au.
wri H17 H18;wri H16 H18. am.
Qed.

Lemma order_ring_pos : forall pl ml le a e u, is_ordered_ring pl ml le a e u ->
forall x y, inc x a -> inc y a -> le x y -> forall z, inc z a -> le e z ->
le (ml z x) (ml z y).
Proof.
ir.
uh H;ee.
uh H;ee.
uh H11;ee.

assert (le e (pl y (inverse_of pl a e x))).
cp (group_inverse_of H H0). uh H13;ee.
assert (le (pl x (inverse_of pl a e x)) (pl y (inverse_of pl a e x))).
ap H6;au.
rwi H15 H17. am.
uh H8.
cp (H8 z H3 H4).
assert (inc (pl y (inverse_of pl a e x)) a). ap H. am. ap group_inverse_inc. am. am.
cp (H14 (pl y (inverse_of pl a e x)) H15 H13).
clear H14;clear H13;clear H15.
cp (group_inverse_of H H0).
rwi H11 H16;au. Check inverse_ml_insert_right.
assert (is_ring pl ml a e u).
uhg;ee;try am. uhg;ee;am.
wri (inverse_ml_insert_right H14) H16. clear H14.
assert (le (pl (ml z x) (inverse_of pl a e (ml z x))) (pl (ml z y) (inverse_of pl a e (ml z x)))).
assert (inc (ml z x) a). ap H10;am.
apply (group_inverse_of H) in H14. uh H14;ee.
rw H17. am.
uh H6;ee.
cp (H15 (pl (ml z x) (inverse_of pl a e (ml z x))) (pl (ml z y) (inverse_of pl a e (ml z x)))).
clear H15.
assert (inc (pl (ml z x) (inverse_of pl a e (ml z x))) a).
ap H;au. ap H10;au. ap group_inverse_inc;au.
ap H10;au. cp (H17 H15);clear H17.
assert (inc (pl (ml z y) (inverse_of pl a e (ml z x))) a).
ap H;au. ap H10;au. ap group_inverse_inc;au.
ap H10;au.
cp (H18 H17 H14).
clear H18;clear H17. clear H15.
assert (inc (ml z x) a).
ap H10;am. cp H15.
apply H19 in H15. clear H19.
clear H14.
apply (group_inverse_of H) in H17.
uh H;ee.
uh H17;ee.
cp H14. uh H23;ee.
rwi H21 H15.
rwi H25 H15;au.
wri H18 H15;au.
rwi H22 H15. rwi H24 H15.
am.
ap H10;au. ap H10;au. am. am.
Qed.

*)

End Law.

End Ordered_ring.


Require Import List.
Require Import Program.

Inductive Tree : Set :=
| Br : Tree -> Tree -> Tree
| No : nat -> Tree
.

(* given a tree, we want to know which lists can
   be used to navigate exactly to a node *)
Inductive Exact : Tree -> list bool -> Prop :=
| exDone  n    :              Exact (No n)   nil
| exLeft  l r p: Exact l p -> Exact (Br l r) (true::p)
| exRight l r p: Exact r p -> Exact (Br l r) (false::p)
.

Definition unreachable A : False -> A.
intros.
destruct H.
Defined.

Program Fixpoint fetch t p (x:Exact t p) {struct t} :=
   match t, p with
   | No p' , nil      => p'
   | No p' , _::_     => unreachable nat _
   | Br l r, nil      => unreachable nat _
   | Br l r, true::t  => fetch l t _
   | Br l r, false::t => fetch r t _
   end.

Next Obligation. inversion x. Qed.
Next Obligation. inversion x. Qed.
Next Obligation. inversion x; trivial. Qed.
Next Obligation. inversion x; trivial. Qed.


(**********************************************************************************

 The category of bimodules

 Let `R₁` and `R₂` be rings. A bimodule `B` from `R₁` to `R₂` is an abelian group
 together with a linear biaction of `R₁` and `R₂` on `B`. In this file, we define
 the category of bimodules using two-sided displayed categories.

 Contents
 1. Definition via two-sided displayed categories
 2. Univalence

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.abgrs.
Require Import UniMath.CategoryTheory.categories.commrings.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Constant.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.DispCatOnTwoSidedDispCat.

Local Open Scope cat.

(**
 1. Definition via two-sided displayed categories
 *)
Definition bimodule_abgr
  : twosided_disp_cat commring_category commring_category
  := constant_twosided_disp_cat _ _ abgr_category.

Definition action_on_bimodule_ob_mor
  : disp_cat_ob_mor (total_twosided_disp_category bimodule_abgr).
Proof.
  simple refine (_ ,, _).
  - exact (λ B,
           let R₁ := (pr1 B : commring) in
           let G := (pr22 B : abgr) in
           let R₂ := (pr12 B : commring) in
           R₁ → G → R₂ → G).
  - cbn.
    exact (λ B₁ B₂,
           let R₁ := (pr1 B₁ : commring) in
           let G := (pr22 B₁ : abgr) in
           let R₂ := (pr12 B₁ : commring) in
           let S₁ := (pr1 B₂ : commring) in
           let H := (pr22 B₂ : abgr) in
           let S₂ := (pr12 B₂ : commring) in
           λ (μ₁ : R₁ → G → R₂ → G) (μ₂ : S₁ → H → S₂ → H) f,
           let f₁ := (pr1 f : R₁ → S₁) in
           let f₂ := (pr12 f : R₂ → S₂) in
           let g := (pr22 f : G → H) in
           ∏ (x : R₁) (y : G) (z : R₂),
           g (μ₁ x y z)
           =
           μ₂ (f₁ x) (g y) (f₂ z)).
Defined.

Definition action_on_bimodule_id_comp
  : disp_cat_id_comp
      (total_twosided_disp_category bimodule_abgr)
      action_on_bimodule_ob_mor.
Proof.
  split.
  - intros B μ x y z ; cbn in *.
    apply idpath.
  - intros B₁ B₂ B₃ f g μ₁ μ₂ μ₃ p q x y z ; cbn in *.
    rewrite p.
    rewrite q.
    apply idpath.
Qed.

Definition action_on_bimodule_data
  : disp_cat_data (total_twosided_disp_category bimodule_abgr).
Proof.
  simple refine (_ ,, _).
  - exact action_on_bimodule_ob_mor.
  - exact action_on_bimodule_id_comp.
Defined.

Definition action_on_bimodule_axioms
  : disp_cat_axioms
      (total_twosided_disp_category bimodule_abgr)
      action_on_bimodule_data.
Proof.
  repeat split.
  - intros B₁ B₂ ; intros.
    repeat (use funextsec ; intro).
    apply (pr11 (pr22 B₂)).
  - intros B₁ B₂ ; intros.
    repeat (use funextsec ; intro).
    apply (pr11 (pr22 B₂)).
  - intros B₁ B₂ B₃ B₄ ; intros.
    repeat (use funextsec ; intro).
    apply (pr11 (pr22 B₄)).
  - intros B₁ B₂ ; intros.
    apply isasetaprop.
    repeat (use impred ; intro).
    apply (pr11 (pr22 B₂)).
Qed.

Definition action_on_bimodule
  : disp_cat (total_twosided_disp_category bimodule_abgr).
Proof.
  simple refine (_ ,, _).
  - exact action_on_bimodule_data.
  - exact action_on_bimodule_axioms.
Defined.

Definition bimodule_action
  : twosided_disp_cat commring_category commring_category
  := sigma_twosided_disp_cat _ action_on_bimodule.

Definition bimodule_laws
           {R S : commring}
           {G : abgr}
           (μ : R → G → S → G)
  : UU
  := (∏ (x : G), μ 1 x 1 = x)%ring
     ×
     (∏ (r₁ r₂ : R) (s₁ s₂ : S) (x : G),
      μ (r₁ * r₂)%ring x (s₁ * s₂)%ring
      =
      μ r₁ (μ r₂ x s₁) s₂)
     ×
     (∏ (r₁ r₂ : R) (s : S) (x : G),
      op (μ r₁ x s) (μ r₂ x s)
      =
      μ (r₁ + r₂)%ring x s)
     ×
     (∏ (r : R) (s : S) (x₁ x₂ : G),
      op (μ r x₁ s) (μ r x₂ s)
      =
      μ r (op x₁ x₂) s)
     ×
     (∏ (r : R) (s₁ s₂ : S) (x : G),
      op (μ r x s₁) (μ r x s₂)
      =
      μ r x (s₁ + s₂)%ring).

Definition isaprop_bimodule_laws
           {R S : commring}
           {G : abgr}
           (μ : R → G → S → G)
  : isaprop (bimodule_laws μ).
Proof.
  repeat (apply isapropdirprod) ;
  repeat (apply impred ; intro) ;
  apply (pr11 G).
Qed.

Definition disp_cat_bimodule_laws
  : disp_cat (total_twosided_disp_category bimodule_action).
Proof.
  use disp_full_sub.
  exact (λ X, bimodule_laws (pr222 X)).
Defined.

Definition bimodule_twosided_disp_cat
  : twosided_disp_cat commring_category commring_category
  := sigma_twosided_disp_cat _ disp_cat_bimodule_laws.

(**
 2. Univalence
 *)
Definition is_univalent_action_on_bimodule
  : is_univalent_disp action_on_bimodule.
Proof.
  intros B₁ B₂ p μ₁ μ₂.
  induction p.
  use isweqimplimpl.
  - cbn ; intro f.
    use funextsec ; intro x.
    use funextsec ; intro y.
    use funextsec ; intro z.
    exact (pr1 f x y z).
  - cbn in * ; repeat (use funspace_isaset).
    apply (pr11 (pr22 B₁)).
  - use isaproptotal2.
    + intro.
      apply isaprop_is_z_iso_disp.
    + intros.
      repeat (use funextsec ; intro).
      apply (pr11 (pr22 B₁)).
Qed.

Definition is_univalent_disp_cat_bimodule_laws
  : is_univalent_disp disp_cat_bimodule_laws.
Proof.
  use disp_full_sub_univalent.
  intro.
  apply isaprop_bimodule_laws.
Defined.

Definition is_univalent_bimodule_twosided_disp_cat
  : is_univalent_twosided_disp_cat bimodule_twosided_disp_cat.
Proof.
  use is_univalent_sigma_of_twosided_disp_cat.
  - use is_univalent_sigma_of_twosided_disp_cat.
    + use is_univalent_constant_twosided_disp_cat.
      exact abgr_category_is_univalent.
    + exact is_univalent_action_on_bimodule.
  - exact is_univalent_disp_cat_bimodule_laws.
Qed.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype div.
From mathcomp Require Import tuple finfun path bigop finset binomial.
From mathcomp Require Import fingroup perm automorphism action ssralg.
From mathcomp Require finmodule.

From Combi Require Import symgroup partition Greene tools sorted.

Require Import ssrcomp slicedbij cycles.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import LeqGeqOrder.

Hint Resolve pcycle_id.

Reserved Notation "''1_[' G ]"
         (at level 8, G at level 2, format "''1_[' G ]").

Section CanPCycle.

Variable T : finType.
Variable s : {perm T}.

Definition canpcycle x := odflt x [pick y in pcycle s x].

Lemma canpcycleP x : x \in pcycle s (canpcycle x).
Proof using.
rewrite /canpcycle /= pcycle_sym.
case: pickP => [x0 //|].
by move => /(_ x) /= _.
Qed.

Lemma canpcycleE x y :
  (pcycle s x == pcycle s y) = (canpcycle x == canpcycle y).
Proof using.
apply/eqP/eqP => [| H].
- rewrite /canpcycle => ->; case: pickP => [x0 //|].
  by move => /(_ y) /=; rewrite pcycle_id.
- have:= canpcycleP x; rewrite H.
  rewrite -eq_pcycle_mem => /eqP ->.
  apply esym; apply/eqP; rewrite eq_pcycle_mem.
  exact: canpcycleP.
Qed.

Lemma pcyclePb x y :
  y \in pcycle s x -> exists i, y == (s ^+ i)%g x.
Proof using.
move=> /pcycleP H.
move: H => [i Hi]; exists i; by rewrite Hi.
Qed.

Definition indpcycle (x : T) : nat := ex_minn (pcyclePb (canpcycleP x)).

Lemma indpcycleP x : ((s ^+ (indpcycle x)) (canpcycle x))%g = x.
Proof using. rewrite /indpcycle; by case: ex_minnP => i /eqP. Qed.

End CanPCycle.

Section PCycleBijection.

Variables (U V : finType).
Variables (s : {perm U}) (t : {perm V}).

Record pcycles_map := PCycleMap {
                          fs :> {set U} -> {set V};
                          fs_stab : fs @: pcycles s \subset pcycles t;
                          fs_homog : {in pcycles s, forall C, #|fs C| = #|C| }
                        }.

Variable CM : pcycles_map.

Lemma aux (x : U) : V.
Proof using CM.
have : fs CM (pcycle s x) != set0.
  rewrite -card_gt0 fs_homog ?mem_imset // card_gt0.
  by apply/set0Pn; exists x.
by move/set0Pn/sigW => H; apply H.
Qed.

Definition cymapcan x := odflt (aux x) [pick y in CM (pcycle s x)].
Definition cymap x := ((t ^+ (indpcycle s x)) (cymapcan x))%g.

Lemma fs_pcycleP x : CM (pcycle s x) \in pcycles t.
Proof using.
by apply (subsetP (fs_stab CM)); apply mem_imset; apply mem_imset.
Qed.

Lemma pcycle_cymapcan x : pcycle t (cymapcan x) = CM (pcycle s x).
Proof using.
rewrite /cymapcan /=.
have:= fs_pcycleP x => /imsetP [y0 _ ->].
case: pickP => [/= y|].
- by rewrite -eq_pcycle_mem => /eqP ->.
- by move=> /(_ y0); rewrite pcycle_id.
Qed.

Lemma pcycle_cymap x :  pcycle t (cymap x) = CM (pcycle s x).
Proof using. by rewrite /cymap pcycle_perm pcycle_cymapcan. Qed.

Lemma cymapcan_perm i x : cymapcan ((s ^+ i)%g x) = cymapcan x.
Proof using CM.
rewrite /cymapcan pcycle_perm.
have:= fs_pcycleP x => /imsetP [y0 _ ->].
by case: pickP => // /(_ y0); rewrite pcycle_id.
Qed.

Lemma cymapP x : cymap (s x) = t (cymap x).
Proof using CM.
rewrite /cymap -{3}(expg1 s) cymapcan_perm.
have:= fs_homog CM (mem_imset (x := x) _ isT); rewrite -pcycle_cymapcan.
move: (cymapcan x) => y H.
apply/eqP; rewrite -permM -expgSr eq_in_pcycle {}H.
have:= canpcycleP s x; rewrite -eq_pcycle_mem => /eqP ->.
rewrite -eq_in_pcycle.
rewrite expgSr permM indpcycleP.
have:= mem_pcycle s 1 x; rewrite expg1 -eq_pcycle_mem canpcycleE => /eqP <-.
by rewrite indpcycleP.
Qed.

Lemma canpcycle_cymap x : canpcycle t (cymap x) = cymapcan x.
Proof using CM.
rewrite /cymap /cymapcan /canpcycle pcycle_perm.
have:= erefl (cymapcan x); rewrite {1}/cymapcan.
case: pickP => [im Him /= Hdefim | Habs] /=.
- rewrite /canpcycle (_ : [pick y in  _] = some im) //.
  rewrite [LHS](_ : _ = [pick y in CM (pcycle s x)]); first last.
  apply eq_pick => y /=; congr (y \in _).
  have:= fs_pcycleP x => /imsetP [y0 _ Hy0].
    by move: Him; rewrite Hy0 /= -eq_pcycle_mem => /eqP ->.
  rewrite Hdefim /cymapcan.
  by case: pickP => // /(_ im); rewrite Him.
- exfalso; move: Habs.
  have:= fs_pcycleP x => /imsetP [y _ ->] /(_ y).
  by rewrite pcycle_id.
Qed.

Lemma indpcycle_cymap x : indpcycle t (cymap x) = indpcycle s x.
Proof using CM.
apply eq_ex_minn => i.
rewrite {1}/cymap canpcycle_cymap eq_in_pcycle pcycle_cymapcan.
rewrite (fs_homog CM (mem_imset _ isT)) -{4}(indpcycleP s x) eq_in_pcycle.
suff -> : pcycle s x = pcycle s (canpcycle s x) by [].
by apply/eqP; rewrite eq_pcycle_mem; apply: canpcycleP.
Qed.

End PCycleBijection.

Fact pcycles_stab_id (U : finType) (s : {perm U}) :
  id @: pcycles s \subset pcycles s.
Proof using. by rewrite imset_id. Qed.
Definition CMid (U : finType) (s : {perm U}) :=
  @PCycleMap U U s s id (pcycles_stab_id s) (fun x _ => erefl #|x|).

Lemma cymapE (U V : finType) (s : {perm U}) (t : {perm V})
      (CM1 CM2 : pcycles_map s t) :
   {in pcycles s, CM1 =1 CM2} -> cymap CM1 =1 cymap CM2.
Proof using.
move=> Heq x; rewrite /cymap /cymapcan /=.
rewrite -Heq; last exact: mem_imset.
case: pickP => // Habs.
exfalso; move: Habs.
have:= fs_pcycleP CM1 x => /imsetP [y _ ->] /(_ y).
by rewrite pcycle_id.
Qed.

Lemma cymap_id (U : finType) (s : {perm U}) (CM : pcycles_map s s) :
  {in pcycles s, CM =1 id} -> cymap CM =1 id.
Proof using.
move=> H x; rewrite /cymap /=.
rewrite -[RHS](indpcycleP s).
rewrite /cymapcan /canpcycle H ?mem_imset //.
by case: pickP => // /(_ x); rewrite pcycle_id.
Qed.

Lemma cymap_comp (U V W: finType)
      (u : {perm U}) (v : {perm V}) (w : {perm W})
      (CMuv : pcycles_map u v) (CMvw : pcycles_map v w) (CMuw : pcycles_map u w) :
  {in pcycles u, CMvw \o CMuv =1 CMuw} ->
  (cymap CMvw) \o (cymap CMuv) =1 (cymap CMuw).
Proof using.
move=> Hcomp x; rewrite /cymap /=.
rewrite /cymapcan /= pcycle_perm pcycle_cymapcan indpcycle_cymap; congr (_ _).
have /= -> := (Hcomp (pcycle u x)); last exact: mem_imset.
case: (pickP (mem (CMuw _))) => // Habs; exfalso.
have:= fs_pcycleP CMuw x => /imsetP [z _ Hz].
by have:= Habs z; rewrite Hz /= pcycle_id.
Qed.

Lemma cymapK (U V : finType)
      (u : {perm U}) (v : {perm V})
      (CM : pcycles_map u v) (CMi : pcycles_map v u) :
  {in pcycles u, cancel CM CMi} -> cancel (cymap CM) (cymap CMi).
Proof using.
move=> H x /=.
rewrite [LHS](cymap_comp (CMuw := (CMid u))); first exact: cymap_id.
move=> y Hy /=; exact: H.
Qed.

Section CycleTypeConj.

Variable T : finType.
Implicit Types (s t : {perm T}) (n : nat).

Fact cycle_type_partCT (s : {perm T}) :
  is_part_of_n #|T| (parts_shape (pcycles s)).
Proof using.
rewrite -cardsT; apply parts_shapeP.
exact: partition_pcycles.
Qed.
Definition cycle_type (s : {perm T}) := IntPartN (cycle_type_partCT s).

Lemma conjg_cycle s a : (<[s]> :^ a = <[s ^ a]>)%g.
Proof using.
apply /setP => x.
apply /imsetP/cycleP => [[x0 /cycleP [i] ->] -> | [i] ->].
- by exists i; apply: conjXg.
- by exists (s ^+i)%g; [apply /cycleP; exists i | rewrite conjXg].
Qed.

Lemma pcycle_conjg s a x :
  pcycle ((s ^ a)%g) (a x) = [set a y | y in pcycle s x].
Proof using.
rewrite !pcycleE; apply /setP => y.
apply /idP/imsetP => [|[x0] Hx0 ->].
- rewrite -conjg_cycle => Hy.
  exists ((a ^-1)%g y); last by rewrite permKV.
  move: Hy; rewrite {1}(_: y = a ((a ^-1)%g (y))); last by rewrite permKV.
  by rewrite -{1}apermE orbit_conjsg.
- by rewrite -conjg_cycle -apermE orbit_conjsg.
Qed.

Lemma pcycles_conjg s a :
  pcycles (s ^ a)%g = [set [set a y | y in (X : {set T})] | X in pcycles s].
Proof using.
apply /setP => X0.
apply /imsetP/imsetP => [[x _]|[x /imsetP [x0 _] ->] ->].
- rewrite (_: x = a ((a ^-1)%g (x))); last by rewrite permKV.
  rewrite pcycle_conjg => ->.
  exists (pcycle s ((a^-1)%g x)) => //.
  by apply /imsetP; exists ((a^-1)%g x).
- exists (a x0) => //.
  by rewrite pcycle_conjg.
Qed.

Require Import ordcast. (* for imset_inj TODO : move in tools *)

Lemma cycle_type_conjg s a : cycle_type (s ^ a)%g = cycle_type s.
Proof using.
apply esym; apply val_inj => /=.
rewrite pcycles_conjg; apply/perm_sortP => //.
rewrite (eq_map (f2 := fun X : {set T} => #|a @: X|)); first last.
  by move => x;  apply esym; apply card_imset; exact: perm_inj.
rewrite (map_comp (fun x : {set T} => #|x|)); apply perm_map.
apply uniq_perm_eq.
- rewrite map_inj_uniq; first exact: enum_uniq.
  by apply imset_inj; apply: perm_inj.
- exact: enum_uniq.
- move=> x; rewrite mem_enum.
  apply/mapP/imsetP => [] [x0].
  + by rewrite mem_enum => Hx0 -> {x}; exists x0.
  + by move=> Hx0 -> {x}; exists x0; rewrite ?mem_enum.
Qed.

Lemma card_pred_card_pcycles s (P : pred nat) :
  #|[set x in pcycles s | P #|x| ]| = count P (cycle_type s).
Proof using.
rewrite /cycle_type /= /psupport /parts_shape.
have /perm_eqlP/perm_eqP -> := perm_sort geq [seq #{x} | x <- enum (pcycles s)].
rewrite cardE /enum_mem size_filter /= count_map count_filter.
by apply eq_count => X; rewrite !inE andbC.
Qed.

Lemma cycle_type_cyclic s :
  (cyclic s) = (count (fun x => x != 1) (cycle_type s) == 1).
Proof using. by rewrite -card_pred_card_pcycles /psupport. Qed.

Lemma cyclic_conjg s a : cyclic s -> cyclic (s ^ a)%g.
Proof using. by rewrite !cycle_type_cyclic cycle_type_conjg. Qed.

Lemma support_conjg s a : support (s ^ a) = [set a x | x in support s].
Proof using.
rewrite -!(cover_partition (partition_support _)) /psupport.
rewrite pcycles_conjg /cover (big_morph _ (imsetU _) (imset0 _)).
rewrite -[RHS](big_imset id) /=; first last.
  by move=> X Y _ _; apply: imset_inj; apply perm_inj.
apply/eq_bigl => X; rewrite !inE.
apply/andP/imsetP => [[/imsetP [/= C HC ->{X}]] | [/= C]].
- rewrite card_imset; last exact: perm_inj.
  by move=> cardC; exists C; rewrite // inE HC cardC.
- rewrite inE => /andP [HC cardC] ->{X}; split; first exact: mem_imset.
  by rewrite card_imset; last exact: perm_inj.
Qed.

Lemma card_support_conjg s a : #|support s| = #|support (s ^ a)%g|.
Proof using.
rewrite support_conjg.
apply esym; apply card_imset.
exact: perm_inj.
Qed.

Lemma disjoint_supports_conjg (A : {set {perm T}}) a :
  disjoint_supports A -> disjoint_supports [set (s ^ a)%g | s in A].
Proof using.
move => [/trivIsetP Hdisj Hinj].
split => [|x1 x2 /imsetP [s1 Hs1 ->] /imsetP [s2 Hs2 ->]].
- apply /trivIsetP => B1 B2.
  move => /imsetP [x1 /imsetP [s1 Hs1 ->] -> {x1}].
  move => /imsetP [x2 /imsetP [s2 Hs2 ->] -> {x2}].
  rewrite !support_conjg => Hdiff.
  apply disjoint_imset; first exact: perm_inj.
  apply: Hdisj; try exact: mem_imset.
  by move: Hdiff; apply contra => /eqP ->.
- rewrite !support_conjg => Hsupp.
  rewrite (_ : s1 = s2) //; apply Hinj => //.
  apply /setP => x; apply /idP/idP => Hx.
  + have:= mem_imset a Hx.
    by rewrite Hsupp => /imsetP [y] Hy /perm_inj ->.
  + have:= mem_imset a Hx.
    by rewrite -Hsupp => /imsetP [y] Hy /perm_inj ->.
Qed.

Import finmodule.FiniteModule morphism.

Lemma cycle_dec_conjg s a:
  [set (c ^ a)%g | c in cycle_dec s] = cycle_dec (s ^ a)%g.
Proof using.
have abel : abelian <<[set (c ^ a)%g | c in cycle_dec s]>>.
  apply abelian_disjoint_supports; apply: disjoint_supports_conjg.
  exact: disjoint_cycle_dec.
apply: uniqueness_cycle_dec; constructor => [x /imsetP [x0 Hx0 ->]||].
- by apply: cyclic_conjg; apply: cyclic_dec; apply: Hx0.
- by apply: disjoint_supports_conjg; apply disjoint_cycle_dec.
- rewrite [LHS](_ : _ =
    val (\sum_(i in [set (c ^ a)%g | c in cycle_dec s]) fmod abel i)%R);
      first last.
    rewrite -(morph_prod [morphism of fmod abel]);
      last by move=> i; apply: mem_gen.
    rewrite -[LHS](fmodK abel) //.
    by apply group_prod => i; apply: mem_gen.
  rewrite big_imset /=; last by move=> x y _ _; apply: conjg_inj.
  rewrite -(morph_prod [morphism of fmod abel]); first last.
    by move=> i Hi; apply mem_gen; apply: mem_imset.
  rewrite fmodK; first last.
    by apply group_prod => i Hi; apply mem_gen; apply: mem_imset.
  by rewrite -conjg_prod cycle_decE.
Qed.

End CycleTypeConj.

Definition slice_part (T : finType) (P : {set {set T}}) :=
  SlicedSet set0 P (fun x : {set T} => #|x|).

Definition slpcycles (T : finType) (s : {perm T}) := slice_part (pcycles s).

Lemma slice_slpcycleE (T : finType) (s : {perm T}) i :
  #|slice (slpcycles s) i| = count_mem i (cycle_type s).
Proof using. by rewrite -card_pred_card_pcycles /slice /= imset_id. Qed.

Section DefsSlice.

Variables (U V : finType).
Variables (s : {perm U}) (t : {perm V}).
Hypothesis eqct : cycle_type s = cycle_type t :> seq nat.

Lemma cycle_type_eq :
  forall i, #|slice (slpcycles s) i| = #|slice (slpcycles t) i|.
Proof using eqct. by move=> i; rewrite !slice_slpcycleE eqct. Qed.

Fact conjg_pcycles_stab :
  [set bij (slpcycles t) x | x in (slpcycles s)] \subset slpcycles t.
Proof using eqct. by have := bijP cycle_type_eq => [] [] _ ->. Qed.
Fact conjg_pcycles_homog :
  {in pcycles s, forall C, #|bij (U := slpcycles s) (slpcycles t) C| = #|C| }.
Proof using eqct. by have := bijP cycle_type_eq => [] []. Qed.
Definition CMbij := PCycleMap conjg_pcycles_stab conjg_pcycles_homog.
Definition conjbij := cymap CMbij.

End DefsSlice.

Lemma conjbijK
      (U V : finType) (s : {perm U}) (t : {perm V})
      (eqct : cycle_type s = cycle_type t :> seq nat) :
  cancel (conjbij eqct) (conjbij (esym eqct)).
Proof using.
apply cymapK => C HC; rewrite /= bijK //; exact: cycle_type_eq.
Qed.

Section CycleType.

Variable T : finType.
Implicit Types (s t : {perm T}) (C : {set T}) (P : {set {set T}}).

Theorem conj_permP s t :
  reflect (exists c, t = (s ^ c)%g) (cycle_type s == cycle_type t).
Proof using.
apply (iffP eqP) => [/(congr1 val)/= eqct | [x ->]].
- have conjbij_inj := can_inj (conjbijK eqct).
  exists (perm conjbij_inj); rewrite -permP => x.
  rewrite !permM permE /= /conjbij cymapP.
  by rewrite -/(conjbij eqct) -(permE conjbij_inj) permKV.
- by rewrite cycle_type_conjg.
Qed.

Lemma classes_of_permP s t :
  reflect (t \in (s ^: [set: {perm T}])%g) (cycle_type s == cycle_type t).
Proof using.
apply (iffP (conj_permP s t)) => [[c ->] |].
- by apply: mem_imset; rewrite inE.
- by move=> /imsetP [c Hc ->]; exists c.
Qed.

Section Permofcycletype.

Implicit Types (l : nat) (ct : intpartn #|T|).

Fact perm_of_pcycle_subproof C : injective (next (enum C)).
Proof using. by apply uniq_next; exact: enum_uniq. Qed.
Definition perm_of_pcycle C := perm (@perm_of_pcycle_subproof C).

Lemma support_perm_of_pcycle C :
  #|C| > 1 -> support (perm_of_pcycle C) = C.
Proof using.
move=> Hsize; apply /setP => x.
rewrite in_support permE.
apply/idP/idP => [|Hx]; rewrite next_nth.
- by apply contraR; rewrite -mem_enum => /negbTE ->.
- rewrite mem_enum Hx.
  move: Hsize Hx; rewrite -mem_enum cardE.
  case: (enum C) (enum_uniq (pred_of_set C)) => // a [// | b l] /=.
  move=> /and3P []; rewrite inE => /norP [/negbTE Hab Ha] Hb Huniq _.
  rewrite !inE => /orP [/eqP -> |/orP [/eqP -> |Hx]].
  + by rewrite eq_refl /= eq_sym Hab.
  + rewrite Hab eq_refl /=.
    case: {2 3}l (erefl l) => [|c l0 Hl]; first by rewrite Hab.
    by apply /eqP => Heq; move: Hb; rewrite -Heq Hl mem_head.
  + have /negbTE Hbx: (b != x).
      by apply /eqP => Heq; move: Hb; rewrite Heq Hx.
    have /negbTE Hax: (a != x).
      by apply /eqP => Heq; move: Ha; rewrite Heq Hx.
    have Hxb: x \in (b :: l) by rewrite inE Hx orbT.
    rewrite Hax Hbx.
    case (ltnP (index x l).+2 (size (b :: l))) => Hindex.
    * have:= Hxb; rewrite -index_mem => Hindex1.
      rewrite -{2}(nth_index a Hxb) nth_uniq //=; last by apply /andP.
      by rewrite Hbx gtn_eqF.
    * by rewrite nth_default ?Hax.
Qed.

Lemma perm_of_pcycleE C x :
  x \in C -> C = pcycle (perm_of_pcycle C) (head x (enum C)).
Proof using.
rewrite -mem_enum; have:= erefl (enum C).
case: {2 3 4}(enum C) => [|a l HC _ /=]; first by rewrite in_nil.
apply /setP => y; apply /idP/pcycleP => [| [n ->]].
- rewrite -mem_enum => Hy; exists (index y (enum C)).
  elim: (index y _) {1 2 4}y Hy (erefl (index y (enum C))) =>
                                      [| m IHm] {y} y Hy Hind.
    have:= nth_index y Hy; rewrite Hind HC /= => <-.
    by rewrite expg0 perm1.
  have Hm : m < size (enum C).
    by move: Hy; rewrite -index_mem Hind; apply leq_trans.
  have Hnth : index (nth y (enum C) m) (enum C) = m.
    by rewrite index_uniq // enum_uniq.
  have Hnthin : (nth y (enum C) m) \in enum C.
    by rewrite -index_mem Hnth.
  rewrite expgSr permM -(IHm (nth y (enum C) m)) //.
  rewrite permE next_nth Hnthin {1}HC Hnth.
  have /negbTE Hya : y != a.
    by apply /eqP => Heq; move: Hind; rewrite Heq HC index_head.
  move: Hind; rewrite HC -cat1s index_cat.
  rewrite inE Hya /= add1n => [[]] <-.
  rewrite nth_index //.
  by move: Hy; rewrite HC inE Hya.
- elim: n => [|m IHm].
  + by rewrite expg0 perm1 -mem_enum HC mem_head.
  + by rewrite expgSr permM permE -mem_enum mem_next mem_enum.
Qed.

Lemma pcycles_of_set C : #|C| > 1 -> C \in pcycles (perm_of_pcycle C).
Proof using.
case: (set_0Vmem C) => [->|]; first by rewrite cards0.
move=> [x Hx] Hsize.
apply /imsetP; exists (head x (enum C)) => //.
exact: perm_of_pcycleE.
Qed.

Lemma psupport_of_set C : #|C| > 1 -> psupport (perm_of_pcycle C) = [set C].
Proof using.
move=> Hsize; apply /setP => X.
rewrite !inE.
apply/andP/eqP => [[/imsetP [x _ ->]]|->].
- rewrite support_card_pcycle support_perm_of_pcycle // => Hx.
  rewrite [RHS](perm_of_pcycleE Hx).
  by apply/eqP; rewrite eq_pcycle_mem -perm_of_pcycleE.
- split; first exact: pcycles_of_set.
  by rewrite -(support_perm_of_pcycle Hsize) card_support_noteq1.
Qed.

Lemma isperm_of_pcycle C : #|C| > 1 -> cyclic (perm_of_pcycle C).
Proof using.
move => Hsize.
apply /cards1P; exists C.
exact: psupport_of_set.
Qed.

Definition perm_of_parts P :=
  (\prod_(C in [set perm_of_pcycle s | s in [set X in P |#|X|>1]]) C)%g.

Lemma supports_perm_of_pcycle P :
  [set support (perm_of_pcycle s) | s in [set X in P | 1 < #|X| ]] =
  [set X in P | 1 < #|X|].
Proof using.
rewrite -[RHS]imset_id.
apply eq_in_imset => i; rewrite inE => /andP [_ Hi].
by rewrite support_perm_of_pcycle.
Qed.

Lemma disj_perm_of_parts P :
  partition P [set: T] ->
  disjoint_supports [set perm_of_pcycle s| s in [set X0 in P | 1 < #|X0|]].
Proof using.
move => Hpart; split => [|C D].
- rewrite -imset_comp supports_perm_of_pcycle.
  apply /trivIsetP => A B; rewrite !inE.
  move => /andP [AinP _] /andP [BinP _].
  by move: Hpart => /and3P [_ /trivIsetP /(_ A B AinP BinP) ].
- move => /imsetP [A]; rewrite inE => /andP [_ cardA] ->.
  move => /imsetP [B]; rewrite inE => /andP [_ cardB] ->.
  by rewrite !support_perm_of_pcycle // => ->.
Qed.

Lemma pcycles_perm_of_parts P :
  partition P [set: T] -> pcycles (perm_of_parts P) = P.
Proof using.
move=> Hpart; apply /setP => X.
apply /idP/idP => HX.
- case: (boolP (X \in psupport (perm_of_parts P))).
  + rewrite psupport_of_disjoint; last exact: disj_perm_of_parts.
    move => /bigcupP [C] /imsetP [X0].
    rewrite inE => /andP [H HX0] ->.
    by rewrite psupport_of_set // inE => /eqP ->.
  + rewrite inE => /nandP []; first by rewrite HX.
    move: HX => /imsetP [x _ ->].
    rewrite support_card_pcycle => Hsupp.
    have:= Hsupp; rewrite in_support negbK pcycle_fix => /eqP ->.
    move: Hsupp; rewrite support_of_disjoint; last exact: disj_perm_of_parts.
    rewrite -(big_imset id) /=; first last.
      move=> C D /imsetP [c]; rewrite inE => /andP [_ cardc ->{C}].
      move=>     /imsetP [d]; rewrite inE => /andP [_ cardd ->{D}].
      by rewrite !support_perm_of_pcycle // => ->.
    rewrite -imset_comp supports_perm_of_pcycle => /bigcupP.
    move=> /exists_inP; rewrite -[X in (is_true X) -> _]negbK.
    have xinP : x \in cover P by rewrite (cover_partition Hpart).
    have:= xinP; rewrite -mem_pblock => xPblock.
    rewrite negb_exists_in => /forall_inP/(_ (pblock P x))/contraL/(_ xPblock).
    rewrite inE => /nandP []; first by rewrite pblock_mem.
    rewrite -leqNgt leq_eqVlt => /orP [/cards1P [y Hy]|].
    * move: xPblock; rewrite Hy inE => /eqP ->.
      by rewrite -Hy; apply pblock_mem.
    * rewrite ltnS leqn0 cards_eq0 => /eqP H.
      by move: xPblock; rewrite H inE.
- case: (boolP (#|X| == 1)).
  + move => /cards1P [x Hx]; subst X.
    apply /imsetP; exists x => //.
    apply esym; apply/eqP; rewrite -pcycle_fix.
    rewrite -[_ == x]negbK -in_support support_of_disjoint;
      last exact: disj_perm_of_parts.
    apply /bigcupP => /exists_inP; apply /negP; rewrite negb_exists_in.
    apply /forall_inP => C /imsetP [x0]; rewrite inE => /andP [Hx0 Hcard] ->.
    rewrite support_perm_of_pcycle //.
    move: Hpart => /and3P [_ /trivIsetP /(_ [set x] x0) Hxx0 _].
    move: Hxx0 => /(_ HX Hx0) Htmp.
    have {Htmp} /eqP/Htmp : [set x] <> x0
      by move => Heq; move: Hcard; rewrite -Heq cards1.
    rewrite -setI_eq0 => /eqP Hxx0.
    apply /negP => Hx.
    suff: x \in set0 by rewrite inE.
    by rewrite -Hxx0 inE Hx andbT inE.
  + have:= Hpart => /and3P [_ _ Hset0].
    move=> H; move: H HX Hset0.
    rewrite neq_ltn => /orP [|Hcard HX Hset0].
      by rewrite ltnS leqn0 cards_eq0 => /eqP -> ->.
    suff: X \in psupport (perm_of_parts P) by rewrite inE => /andP [].
    rewrite psupport_of_disjoint; last exact: disj_perm_of_parts.
    apply /bigcupP; exists (perm_of_pcycle X);
      last by rewrite psupport_of_set ?inE.
    apply /imsetP; exists X => //.
    by rewrite inE; apply /andP; split.
Qed.

Lemma perm_of_partsE P :
  partition P [set: T] ->
  cycle_type (perm_of_parts P) = parts_shape P :> seq nat.
Proof using. by move=> /pcycles_perm_of_parts pcy; rewrite /= pcy. Qed.

End Permofcycletype.

Section Classes.

Variable tc : intpartn #|T|.

Lemma perm_of_partCT_exists : exists s, cycle_type s = tc.
Proof using.
have:= ex_set_parts_shape (intpartn_cast (esym (cardsT T)) tc).
move=> [P /perm_of_partsE /= ct shape].
exists (perm_of_parts P); apply val_inj => /=; rewrite ct.
by rewrite shape intpartn_castE.
Qed.

Lemma perm_of_partCT_set : {s | cycle_type s == tc}.
Proof using.
by apply sigW; have:= perm_of_partCT_exists => [[p <-]]; exists p.
Qed.

Definition perm_of_partCT := val perm_of_partCT_set.
Lemma perm_of_partCTP : cycle_type perm_of_partCT = tc.
Proof using.
by rewrite /perm_of_partCT; case: perm_of_partCT_set => s /= /eqP ->.
Qed.

Definition class_of_partCT := class (perm_of_partCT) [set: {perm T}].

Lemma class_of_partCTP s :
  (cycle_type s == tc) = (s \in class_of_partCT).
Proof using.
rewrite /class_of_partCT -perm_of_partCTP /class eq_sym.
by apply/classes_of_permP/idP.
Qed.

Lemma card_class_of_partCT_neq0 : #|class_of_partCT| != 0%N.
Proof using.
rewrite cards_eq0; apply /set0Pn.
by exists perm_of_partCT; exact: class_refl.
Qed.

End Classes.

Lemma class_of_partCT_inj : injective class_of_partCT.
Proof using.
rewrite /class_of_partCT => t1 t2 /class_eqP.
rewrite -class_of_partCTP => /eqP <-.
by rewrite perm_of_partCTP.
Qed.

Lemma imset_class_of_partCT :
  [set class_of_partCT p | p in setT] = classes [set: {perm T}].
Proof using.
rewrite -setP => C.
apply/imsetP/imsetP => [] [s _ Hs].
- by exists (perm_of_partCT s); rewrite // inE.
- exists (cycle_type s) => //.
  by rewrite Hs; apply /class_eqP; rewrite -class_of_partCTP.
Qed.

Lemma card_classes_perm :
  #|classes [set: {perm T}]| = #|{: intpartn #|T| }|.
Proof using.
rewrite -imset_class_of_partCT card_imset; last exact: class_of_partCT_inj.
by apply eq_card => s; rewrite !inE.
Qed.

From mathcomp Require Import matrix vector mxalgebra falgebra ssrnum algC algnum.
From mathcomp Require Import presentation all_character.

Import GroupScope GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Section CFunIndicator.

Variable tc : intpartn #|T|.

Definition cfuni_part :=
  cfun_indicator [set: {perm T}] (class_of_partCT tc).

Local Notation "''1_[' p ]" := (cfuni_part p) : ring_scope.

Lemma cfuni_partE s :
  ('1_[s]) = (cycle_type s == tc)%:R.
Proof using.
rewrite /cfuni_part cfunElock genGid inE /=.
congr ((nat_of_bool _) %:R); apply/idP/idP.
- rewrite class_of_partCTP => /subsetP; apply.
  apply /imsetP; exists 1%g; first by rewrite inE.
  by rewrite conjg1.
- move=> /eqP <-; apply/subsetP => t /imsetP [c] _ -> {t}.
  by rewrite -class_of_partCTP cycle_type_conjg.
Qed.

End CFunIndicator.
End CycleType.

Notation "''1_[' p ]" := (cfuni_part p) : ring_scope.

Coercion partCT_of_partn n := intpartn_cast (esym (card_ord n)).

Import GroupScope GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Section Sn.

Variable n : nat.

Definition partn_of_partCT :=
  intpartn_cast (card_ord n) : intpartn #|'I_n| -> intpartn n .
Definition cycle_typeSN (s : 'S_n) : intpartn n :=
  partn_of_partCT (cycle_type s).

Lemma partCT_of_partnK (p : intpartn n) :
  partn_of_partCT p = p.
Proof using.
rewrite /partn_of_partCT; apply val_inj => /=.
by rewrite !intpartn_castE.
Qed.

Lemma partn_of_partCTE p1 p2 :
  (p1 == p2) = (partn_of_partCT p1 == partn_of_partCT p2).
Proof using.
rewrite /partn_of_partCT.
apply/eqP/eqP => [-> //|].
case: p1 p2 => [p1 Hp1] [p2 Hp2].
move/(congr1 val); rewrite !intpartn_castE /= => Hp.
exact: val_inj.
Qed.

Lemma partn_of_partCTK (p : intpartn #|'I_n|) :
  p = partn_of_partCT p.
Proof using.
rewrite /partCT_of_partn; apply val_inj => /=.
by rewrite !intpartn_castE.
Qed.

Lemma partn_of_partCT_congr p1 (p2 : intpartn n) :
  (partn_of_partCT p1 == p2) = (p1 == p2).
Proof using.
apply/eqP/eqP => [<-|->].
- by rewrite -partn_of_partCTK.
- by rewrite partCT_of_partnK.
Qed.

Lemma cfuni_partnE (tc : intpartn n) (s : 'S_n) :
  '1_[tc] s = (cycle_typeSN s == tc)%:R.
Proof using.
rewrite cfuni_partE /cycle_typeSN /=.
by rewrite partn_of_partCTE partCT_of_partnK.
Qed.

End Sn.


Require Import Axioms.

Require Import Tactics.
Require Import Relation.
Require Import Sigma.
Require Import Syntax.
Require Import Hygiene.
Require Import Equivalence.
Require Import Ofe.

Section object.

Local Arguments operator {object}.
Local Arguments term {object}.
Local Arguments row {object}.

Variable object : Type.

(* 1-indexed *)
Definition uniform (R : nat -> relation (@term object)) : Prop :=
  (forall i m n, R i m n -> hygiene clo m /\ hygiene clo n)
  /\
  (forall i m m' n n',
     hygiene clo m'
     -> hygiene clo n'
     -> equiv m m'
     -> equiv n n'
     -> R i m n
     -> R i m' n')
  /\
  (forall i m n p q,
     R i m n
     -> R i p n
     -> R i p q
     -> R i m q)
  /\
  (forall i m n, R (S i) m n -> R i m n).

Record urel : Type :=
mk_urel
  { rel : nat -> relation term;

    urel_uniform : uniform rel }.

Lemma urel_closed :
  forall R i m n, rel R i m n -> hygiene clo m /\ hygiene clo n.
Proof.
intro R.
exact (urel_uniform R andel).
Qed.

Lemma urel_closed_1 :
  forall R i m n, rel R i m n -> hygiene clo m.
Proof.
intros R i m n H.
exact (urel_closed _#4 H andel).
Qed.

Lemma urel_closed_2 :
  forall R i m n, rel R i m n -> hygiene clo n.
Proof.
intros R i m n H.
exact (urel_closed _#4 H ander).
Qed.

Lemma urel_equiv :
  forall R i m m' n n',
    hygiene clo m'
    -> hygiene clo n'
    -> equiv m m'
    -> equiv n n'
    -> rel R i m n
    -> rel R i m' n'.
Proof.
intro R.
exact (urel_uniform R anderl).
Qed.

Lemma urel_equiv_1 :
   forall R i m m' n,
     hygiene clo m'
     -> equiv m m'
     -> rel R i m n
     -> rel R i m' n.
Proof.
intros R i m m' n Hcl Hequiv Hrel.
eapply urel_equiv; eauto using equiv_refl, urel_closed_2.
Qed.

Lemma urel_equiv_2 :
   forall R i m n n',
     hygiene clo n'
     -> equiv n n'
     -> rel R i m n
     -> rel R i m n'.
Proof.
intros R i m n n' Hcl Hequiv Hrel.
eapply urel_equiv; eauto using equiv_refl, urel_closed_1.
Qed.

Lemma urel_zigzag :
  forall R i m n p q,
    rel R i m n
    -> rel R i p n
    -> rel R i p q
    -> rel R i m q.
Proof.
intro R.
exact (urel_uniform R anderrl).
Qed.

Lemma urel_downward :
  forall R i m n, rel R (S i) m n -> rel R i m n.
Proof.
intro R.
exact (urel_uniform R anderrr).
Qed.

Lemma urel_downward_leq :
  forall (R : urel) i j m n,
    i <= j
    -> rel R j m n
    -> rel R i m n.
Proof.
intros R i j m n Hleq Hmn.
revert Hmn.
induct Hleq.

(* eq *) -
auto.

(* S *) -
intros j Hleq IH Hmn.
apply IH; [].
apply urel_downward; auto.
Qed.

Definition urel_dist (i : nat) (R R' : urel) : Prop :=
  forall j, j < i -> rel R j = rel R' j.

Definition urel_limit (ch : nat -> urel) (Hconv : convergent urel_dist ch) : urel.
Proof.
set (trel := fun i m n => rel (ch (S i)) i m n).
apply (mk_urel trel); unfold trel; clear trel.
do2 3 split.
  {
  intros; eapply urel_closed; eauto.
  }

  {
  intros; eapply urel_equiv; eauto.
  }

  {
  intros; eapply urel_zigzag; eauto.
  }

  {
  intros.
  rewrite -> (Hconv (S i)); [| omega].
  apply urel_downward; auto.
  }
Defined.

Lemma convergent_slice_rel :
  forall (ch : nat -> urel),
    convergent urel_dist ch
    -> forall i j, i < j -> rel (ch (S i)) i = rel (ch j) i.
Proof.
intros ch Hconv i j Hleq.
unfold convergent in Hconv.
induct Hleq.

(* refl *)
{
reflexivity.
}

(* S *)
{
intros j Hleq IH.
rewrite -> IH; [].
apply (Hconv j); [].
omega.
}
Qed.

Lemma urel_complete_dist :
  forall ch i (p : convergent urel_dist ch),
    urel_dist i (urel_limit ch p) (ch i).
Proof.
intros ch i p.
intros j Hlt.
rewrite <- convergent_slice_rel; auto.
Qed.

Lemma empty_uniform : uniform (fun _ _ _ => False).
Proof.
do2 3 split; intros; omega.
Qed.

Definition empty_urel : urel
  :=
  mk_urel _ empty_uniform.

Lemma urel_extensionality :
  forall R R',
    rel R = rel R'
    -> R = R'.
Proof.
intros R R' Heq.
destruct R as [r H].
destruct R' as [r' H'].
simpl in Heq.
subst r'.
f_equal; apply proof_irrelevance.
Qed.

Definition urel_ofe : ofe.
Proof.
apply (mk_ofe urel urel_dist).
  {
  intro i.
  do2 2 split.
    {
    intros R j _; auto.
    }

    {
    intros R1 R2 R3 H12 H23.
    intros j Hlt.
    so (H12 j Hlt).
    so (H23 j Hlt).
    etransitivity; eauto.
    }

    {
    intros R R' H.
    intros j Hlt.
    symmetry; apply H; auto.
    }
  }

  {
  intros R R' Hsim.
  apply urel_extensionality; [].
  apply functional_extensionality; [].
  intro i.
  apply (Hsim (S i)); omega.
  }

  {
  intros i R R' H.
  intros j Hlt.
  apply H; omega.
  }

  {
  intros R R'.
  intros j Hlt.
  omega.
  }
Defined.

Definition urel_complete : complete urel_ofe.
Proof.
apply (mk_complete urel_ofe urel_limit empty_urel).
intros ch n p.
apply urel_complete_dist.
Defined.

Lemma rel_from_dist :
  forall (A B : car urel_ofe) i m n,
    dist (S i) A B
    -> rel A i m n
    -> rel B i m n.
Proof.
intros A B i m n Hdist Hmn.
rewrite <- (Hdist i); auto.
Qed.

End object.

Arguments mk_urel {object}.
Arguments rel {object}.
Arguments urel_dist {object}.
Arguments urel_limit {object}.
Arguments empty_urel {object}.
Arguments urel_complete {object}.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Logic.DisplayMapBicat.

Local Open Scope cat.

Section ArrowSubbicatInitial.
  Context {B : bicat}
          (I : biinitial_obj B)
          (D : arrow_subbicat B)
          (b : B)
          (HD : arrow_subbicat_biinitial I D).

  Definition disp_map_slice_biinitial_obj
    : disp_map_slice_bicat D b.
  Proof.
    simple refine (_ ,, _ ,, _).
    - exact (pr1 I).
    - exact (is_biinitial_1cell_property (pr2 I) b).
    - exact (pr1 HD b).
  Defined.

  Definition disp_map_slice_biinitial_1cell_property
    : biinitial_1cell_property disp_map_slice_biinitial_obj.
  Proof.
    intros h.
    simple refine (_ ,, _ ,, _).
    - exact (is_biinitial_1cell_property (pr2 I) (pr1 h)).
    - exact (pr2 HD _ _ (pr12 h)).
    - use make_invertible_2cell ; cbn.
      + apply (is_biinitial_2cell_property (pr2 I)).
      + use make_is_invertible_2cell.
        * apply (is_biinitial_2cell_property (pr2 I)).
        * apply (is_biinitial_eq_property (pr2 I)).
        * apply (is_biinitial_eq_property (pr2 I)).
  Defined.

  Definition disp_map_slice_biinitial_2cell_property
             (h : disp_map_slice_bicat D b)
    : biinitial_2cell_property disp_map_slice_biinitial_obj h.
  Proof.
    intros α β.
    simple refine (_ ,, _).
    - apply (is_biinitial_2cell_property (pr2 I)).
    - apply (is_biinitial_eq_property (pr2 I)).
  Defined.

  Definition disp_map_slice_biinitial_eq_property
             (h : disp_map_slice_bicat D b)
    : biinitial_eq_property disp_map_slice_biinitial_obj h.
  Proof.
    intros α β p q.
    use eq_2cell_disp_map_slice.
    apply (is_biinitial_eq_property (pr2 I)).
  Defined.

  Definition disp_map_slice_biinitial
    : biinitial_obj (disp_map_slice_bicat D b).
  Proof.
    simple refine (_ ,, _).
    - exact disp_map_slice_biinitial_obj.
    - use make_is_biinitial.
      + exact disp_map_slice_biinitial_1cell_property.
      + exact disp_map_slice_biinitial_2cell_property.
      + exact disp_map_slice_biinitial_eq_property.
  Defined.
End ArrowSubbicatInitial.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo41:
  prime  211948161232579->
  prime  479638690173740827.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      479638690173740827
      2263
      ((211948161232579,1)::nil)
      0
      192
      4
      16)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e338m15_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(* Some exercises about equivalences *)
Require Import UniMath.Foundations.PartA.

(* Prove that the identity function is an equivalence *)
Lemma idisweq (T : UU) : isweq (idfun T).
Admitted.

(* Package this up as an equivalence *)
Definition idweq (X : UU) : X ≃ X.
Admitted.

(* Prove that any map to empty is an equivalence *)
Lemma isweqtoempty {X : UU} (f : X -> ∅) : isweq f.
Admitted.

(* Package this up as an equivalence *)
Definition weqtoempty {X : UU} (f : X -> ∅) : X ≃ ∅.
Admitted.

(* Prove that the composition of equivalences is an equivalence *)
Theorem compisweq {X Y Z : UU} (f : X -> Y) (g : Y -> Z)
        (isf : isweq f) (isg : isweq g) : isweq (g ∘ f).
Admitted.

(* Package this up as an equivalence *)
Definition weqcomp {X Y Z : UU} (w1 : X ≃ Y) (w2 : Y ≃ Z) : X ≃ Z.
Admitted.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e192m2e64m1_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


CoInductive NETree (A : Type) : Type :=
{
  root  : A;
  left  : option (NETree A);
  right : option (NETree A);
}.

Arguments root  {A} _.
Arguments left  {A} _.
Arguments right {A} _.

Inductive WFL {A : Type} : NETree A -> Prop :=
| WFL_None : forall {t : NETree A}, left t = None -> WFL t
| WFL_Some : forall {t t' : NETree A}, left t = Some t' -> WFL t' ->
 WFL t.

Arguments WFL_None {A t} _.

CoInductive WF {A : Type} (t : NETree A) : Prop :=
{
  rootWF : WFL t;
  rightWF : right t = None \/ exists t' : NETree A, right t = Some t' /\ WF t'
}.

(* TODO: fix *)
(*
Fixpoint leftmost {A : Type} {t : NETree A} (wf : WFL t) {struct t} : A :=
match left t with
| None => root t
| Some t' =>
match wf with
| WFL_None _ => root t
| WFL_Some _ wf' => leftmost wf'
end.
*)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25synthconj4_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv1) lv0) (mult lv0 (Succ lv1))) ->  (@eq natural (Succ (plus (mult lv0 lv1) lv2)) (plus (plus lv0 (mult lv1 lv0)) (Succ lv1))).
Admitted.
QuickChick conj25synthconj4_hyp.


Require Import ZArith Lia.

Require Import Statement.

Require Import Wpr CbC.

Open Scope cbc_scope.

Program Definition Swap :=
  ⟨ fun '(x,y) '(x',y')  => x' = y /\ y' = x ⟩
  :{ '(x,y) := (y,x) :{
       '(x,y) ::= (x+y, y);;
       '(x,y) ::= (x, x-y);;
       '(x,y) ::= (x-y, y)
     }
   }.

Next Obligation.
  intros (x,y) _; simpl; f_equal.
  all: lia.
Qed.

Next Obligation.
  intros (x,y) _; simpl.
  auto.
Qed.

Theorem proof : (Πc Swap) ⊑ (Πa Swap).
Proof. apply (CbC.soundness Swap). Qed.

Check proof.
Print Assumptions proof.

Close Scope cbc_scope.


Require Export Category Functor.Core Category.Product NaturalTransformation.Core.
Require Import Common Functor.Equality InitialTerminalCategory Functor.Duals.

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

Section ProductCategoryFunctors.
  Context {C : PreCategory}.
  Context {D : PreCategory}.

  Definition fst_Functor : Functor (C * D) C
    := Build_Functor (C * D) C
                     (@fst _ _)
                     (fun _ _ => @fst _ _)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Definition snd_Functor : Functor (C * D) D
    := Build_Functor (C * D) D
                     (@snd _ _)
                     (fun _ _ => @snd _ _)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End ProductCategoryFunctors.

Section FunctorProduct.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable D' : PreCategory.

  Definition FunctorProduct (F : Functor C D) (F' : Functor C D')
  : Functor C (D * D')
    := Build_Functor
         C (D * D')
         (fun c => (F c, F' c))
         (fun s d m => (MorphismOf F m, MorphismOf F' m))
         (fun _ _ _ _ _ => path_prod' (FCompositionOf F _ _ _ _ _)
                                      (FCompositionOf F' _ _ _ _ _))
         (fun _ => path_prod' (FIdentityOf F _) (FIdentityOf F' _)).

  Local Infix "*" := FunctorProduct : functor_scope.

  Definition FunctorProductFunctorial
             (F G : Functor C D)
             (F' G' : Functor C D')
             (T : NaturalTransformation F G)
             (T' : NaturalTransformation F' G')
  : NaturalTransformation (F * F') (G * G')
    := Build_NaturalTransformation
         (F * F') (G * G')
         (fun x => (T x, T' x))
         (fun _ _ _ => path_prod' (Commutes T _ _ _) (Commutes T' _ _ _)).
End FunctorProduct.

Infix "*" := FunctorProduct : functor_scope.

Section FunctorProduct'.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable C' : PreCategory.
  Variable D' : PreCategory.
  Variable F : Functor C D.
  Variable F' : Functor C' D'.

  Local Open Scope functor_scope.

  Definition FunctorProduct' : Functor (C * C') (D * D')
    := (F ∘ fst_Functor) * (F' ∘ snd_Functor).
End FunctorProduct'.

(*Notation "( x , y , .. , z )" := (FunctorProduct' .. (FunctorProduct' x y) .. z) : functor_scope.*)

Section FunctorProductUniversal.
  Context `{Funext}.

  Variable A : PreCategory.
  Variable B : PreCategory.
  Variable C : PreCategory.

  Local Open Scope functor_scope.

  Section universal.
    Variable a : Functor C A.
    Variable b : Functor C B.

    Local Transparent ComposeFunctors_FCompositionOf ComposeFunctors_FIdentityOf.

    Lemma FunctorProduct_Commutes_fst : fst_Functor ∘ (a * b) = a.
    Proof.
      functor_eq; trivial.
    Defined.

    Lemma FunctorProduct_Commutes_snd : snd_Functor ∘ (a * b) = b.
    Proof.
      functor_eq; trivial.
    Defined.

    Section unique.
      Variable F : Functor C (A * B).
      Hypothesis H1 : fst_Functor ∘ F = a.
      Hypothesis H2 : snd_Functor ∘ F = b.

      Lemma FunctorProduct_unique_helper
            c
      : (a * b) c = F c.
      Proof.
        pose proof (ap (fun F => ObjectOf F c) H1).
        pose proof (ap (fun F => ObjectOf F c) H2).
        simpl in *.
        path_induction.
        apply eta_prod.
      Defined.

      Lemma FunctorProduct_unique_helper2
      :  transport
           (fun GO : C -> A * B =>
              forall s d : C,
                Morphism C s d ->
                Morphism A (fst (GO s)) (fst (GO d)) *
                Morphism B (snd (GO s)) (snd (GO d)))
           (path_forall (a * b) F FunctorProduct_unique_helper)
           (fun (s d : C) (m : Morphism C s d) =>
              ((a ₁ m)%morphism, (b ₁ m)%morphism)) = MorphismOf F.
      Proof.
        repeat (apply path_forall; intro).
        repeat match goal with
                 | _ => reflexivity
                 | _ => progress simpl
                 | _ => rewrite !transport_forall_constant
                 | [ |- appcontext[?f (transport ?P ?p ?z)] ]
                   => rewrite (@ap_transport _ P _ _ _ p (fun _ => f) z)
               end.
        lazymatch goal with
        | [ |- appcontext[transport
                            (fun f => prod
                                        (?P0 (?fst (f ?x0)) (?fst (f ?x1)))
                                        (?P1 (?snd (f ?x0)) (?snd (f ?x1))))
                            (@path_forall ?H ?A ?B ?f ?g ?e)] ]
          => simpl_do_clear do_rewrite (@path_forall_2_beta
                                          H A B x0 x1
                                          (fun fx0 fx1
                                           => prod (P0 (fst fx0) (fst fx1))
                                                   (P1 (snd fx0) (snd fx1)))
                                          f g)
        end.
        rewrite transport_path_prod'.
        unfold FunctorProduct_unique_helper.
        case H1; simpl; clear H1.
        case H2; simpl; clear H2.
        repeat match goal with
                 | [ |- appcontext[@MorphismOf ?C ?D ?F ?s ?d ?m] ]
                   => destruct (@MorphismOf C D F s d m); clear m
                 | [ |- appcontext[@ObjectOf ?C ?D ?F ?x] ]
                   => destruct (@ObjectOf C D F x); clear x
               end.
        reflexivity.
      Qed.

      Lemma FunctorProduct_unique
      : a * b = F.
      Proof.
        functor_eq.
        exists (path_forall _ _ FunctorProduct_unique_helper).
        apply FunctorProduct_unique_helper2.
      Defined.
    End unique.

    Global Instance FunctorProduct_contr
           `{IsHSet (Functor C A), IsHSet (Functor C B)}
    : Contr { F : Functor C (A * B)
            | fst_Functor ∘ F = a
              /\ snd_Functor ∘ F = b }
      := let x := {| center := (a * b;
                                (FunctorProduct_Commutes_fst,
                                 FunctorProduct_Commutes_snd)) |}
         in x.
    Proof.
      intro y.
      apply path_sigma_uncurried.
      simpl.
      exists (FunctorProduct_unique (fst y.2) (snd y.2)).
      exact (center _).
    Qed.
  End universal.

  Definition path_prod_functor (F G : Functor C (A * B))
             (H1 : fst_Functor ∘ F = fst_Functor ∘ G)
             (H2 : snd_Functor ∘ F = snd_Functor ∘ G)
  : F = G.
  Proof.
    etransitivity; [ apply symmetry | ];
    apply FunctorProduct_unique; try eassumption; reflexivity.
  Defined.
End FunctorProductUniversal.

Section ProductInducedFunctors.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable E : PreCategory.

  Variable F : Functor (C * D) E.

  Local Ltac t :=
    simpl; intros;
    repeat (rewrite <- ?FCompositionOf, <- ?FIdentityOf, ?LeftIdentity, ?RightIdentity; simpl);
    trivial.

  (** Note: This is just the currying exponential law *)
  Definition InducedProductFstFunctor (d : D) : Functor C E.
  Proof.
    refine (Build_Functor C E
                          (fun c => F (c, d))
                          (fun _ _ m => MorphismOf F (s := (_, _)) (d := (_, _)) (m, Identity d))
                          _
                          _);
    abstract t.
  Defined.

  Definition InducedProductSndFunctor (c : C) : Functor D E.
  Proof.
    refine (Build_Functor D E
                          (fun d => F (c, d))
                          (fun _ _ m => MorphismOf F (s := (_, _)) (d := (_, _)) (Identity c, m))
                          _
                          _);
    abstract t.
  Defined.
End ProductInducedFunctors.

Section notation.
  Global Class FunctorApplicationInterpretable
         {C D} (F : Functor C D)
         {argsT : Type} (args : argsT)
         {T : Type} (rtn : T)
    := {}.

  Definition FunctorApplicationOf {C D} F {argsT} args {T} {rtn}
             `{@FunctorApplicationInterpretable C D F argsT args T rtn}
    := rtn.

  Global Arguments FunctorApplicationOf / {C} {D} F {argsT} args {T} {rtn} {_}.

  Global Instance FunctorApplicationObject C D (F : Functor C D) (x : C)
  : FunctorApplicationInterpretable F x (F x) | 0.

  Global Instance FunctorApplicationDash C D (F : Functor C D)
  : FunctorApplicationInterpretable F (IdentityFunctor C) F | 0.

  Global Instance FunctorApplicationFunctorTerminal C D (F : Functor C D) (c : C)
  : FunctorApplicationInterpretable F (FunctorFromTerminal _ c) (F c) | 0.

  Global Instance FunctorApplicationFunctor B C D (F : Functor C D) (G : Functor B C)
  : FunctorApplicationInterpretable F G (F ∘ G)%functor | 100.

  Global Instance FunctorApplicationObjObj A B D (F : Functor (A * B) D) (a : A) (b : B)
  : FunctorApplicationInterpretable F (a, b) (F (a, b)) | 100.

  Global Instance FunctorApplicationObjFunctorTerminal A B D (F : Functor (A * B) D) (a : A) (b : B)
  : FunctorApplicationInterpretable F (a, FunctorFromTerminal _ b) (F (a, b)) | 0.

  Global Instance FunctorApplicationFunctorTerminalObj A B D (F : Functor (A * B) D) (a : A) (b : B)
  : FunctorApplicationInterpretable F (FunctorFromTerminal _ a, b) (F (a, b)) | 0.

  Global Instance FunctorApplicationFunctorTerminalFunctorFromTerminal A B D (F : Functor (A * B) D) (a : A) (b : B)
  : FunctorApplicationInterpretable F (FunctorFromTerminal _ a, FunctorFromTerminal _ b) (F (a, b)) | 0.

  Global Instance FunctorApplicationObjFunctor A B C D (F : Functor (A * B) D) (a : A) (F' : Functor C B)
  : FunctorApplicationInterpretable F (a, F') (InducedProductSndFunctor F a ∘ F')%functor | 10.

  Global Instance FunctorApplicationObjIdentity A B D (F : Functor (A * B) D) (a : A)
  : FunctorApplicationInterpretable F (a, IdentityFunctor B) (InducedProductSndFunctor F a)%functor | 5.

  Global Instance FunctorApplicationFunctorObj A B C D (F : Functor (A^op * B) D) (F' : Functor C A) (b : B)
  : FunctorApplicationInterpretable F (F', b) (InducedProductFstFunctor F b ∘ F'^op)%functor | 10.

  Global Instance FunctorApplicationIdentityObj A B D (F : Functor (A * B) D) (b : B)
  : FunctorApplicationInterpretable F (IdentityFunctor A, b) (InducedProductFstFunctor F b)%functor | 5.

  (** Do we want this?  (to special case pairs of functors from the
      same category, so that, e.g., if [F : C * C -> D], then [F ⟨ ─ ,
      ─ ⟩] would be the diagonal functor [C -> D], ather than [F]
      itself.  Freenode says:

   freenode / ##categorytheory / jgross  2013-08-03 18:19  ()
       If F is a functor C * C -> D, and you see F(─, ─), how do you interpret it?
   freenode / ##categorytheory / jgross  2013-08-03 18:21  ()
       In particular, is it the functor C -> D which factors through F and the diagonal functor C -> C * C, or is it F itself?
-> freenode / ##categorytheory / Eduard_Munteanu  2013-08-03 18:21  (Eduard_Munteanu!~Eduard_Mu@188.25.7.132)
       jgross: F itself, I'd say
   freenode / ##categorytheory / jgross  2013-08-03 18:22  ()
       Ok, thanks.
   freenode / ##categorytheory / Eduard_Munteanu  2013-08-03 18:22  (Eduard_Munteanu!~Eduard_Mu@188.25.7.132)
       jgross: https://en.wikipedia.org/wiki/Hom_functor#Internal_Hom_functor seems to use that interpretation too
   freenode / ##categorytheory / Cale  2013-08-03 18:23  (Cale!~Cale@99.247.222.118)
       jgross: By * do you mean × ?
   freenode / ##categorytheory / Cale  2013-08-03 18:23  (Cale!~Cale@99.247.222.118)
       (I suppose you do)
   freenode / ##categorytheory / Eduard_Munteanu  2013-08-03 18:23  (Eduard_Munteanu!~Eduard_Mu@188.25.7.132)
       Actually https://en.wikipedia.org/wiki/Hom_functor#Formal_definition too, near the end
   freenode / ##categorytheory / Cale  2013-08-03 18:23  (Cale!~Cale@99.247.222.118)
       In any case, yeah, I would say it would mean F itself.
   freenode / ##categorytheory / jgross  2013-08-03 18:27  ()
       Yes, by * I mean ×.
 *)
  (**  Global Instance FunctorApplicationFunctorFunctor A B C D (F : Functor (A * B) D) (G : Functor C A) (H : Functor C B)
  : FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct G H))%functor | 10.*)

  Global Instance FunctorApplicationFunctorFunctor' A B C C' D (F : Functor (A^op * B) D) (G : Functor C A) (H : Functor C' B)
  : FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G^op H))%functor | 100.
End notation.

(** First, a bunch of notations for display *)
Notation "F ⟨ a , F' ⟨ 1 ⟩ ⟩" := (InducedProductSndFunctor F a^op ∘ F')%functor : functor_scope.
Notation "F ⟨ F' ⟨ 1 ⟩ , b ⟩" := (InducedProductFstFunctor F b^op ∘ F')%functor : functor_scope.
Notation "F ⟨ a , 1 ⟩" := (InducedProductSndFunctor F a^op)%functor : functor_scope.
Notation "F ⟨ 1 , b ⟩" := (InducedProductFstFunctor F b^op)%functor : functor_scope.
Notation "F ⟨ a , b ⟩" := (F (a, b)) : functor_scope.
Notation "F ⟨ G ⟨ 1 ⟩ , H ⟨ 1 ⟩ ⟩" := (F ∘ (FunctorProduct' G^op H))%functor : functor_scope.
Notation "F ⟨ 1 , H ⟨ 1 ⟩ ⟩" := (F ∘ (FunctorProduct' (IdentityFunctor _) H))%functor : functor_scope.
Notation "F ⟨ G ⟨ 1 ⟩ , 1 ⟩" := (F ∘ (FunctorProduct' G^op (IdentityFunctor _)))%functor : functor_scope.

(** Now, the fully general notation so the defaults can parse *)
Notation "F ⟨ x ⟩" := (FunctorApplicationOf F%functor x%functor) : functor_scope.
Notation "F ⟨ x , y ⟩" := (FunctorApplicationOf F%functor (x%functor , y%functor)) : functor_scope.

(** Now, the default notations, so that anything we don't cover can
    parse, and everything parses in terms of the general notation *)
Notation "F ⟨ 1 ⟩" := (F ⟨ ( 1 ) ⟩)%functor : functor_scope.
Notation "F ⟨ x , 1 ⟩" := (F ⟨ x , ( 1 ) ⟩)%functor : functor_scope.
Notation "F ⟨ 1 , y ⟩" := (F ⟨ ( 1 ) , y ⟩)%functor : functor_scope.
Notation "F ⟨ 1 , 1 ⟩" := (F ⟨ ( 1 ) , ( 1 ) ⟩)%functor : functor_scope.
Notation "F ⟨ x ⟨ 1 ⟩ ⟩" := (F ⟨ ( x ⟨ 1 ⟩ ) ⟩)%functor : functor_scope.
Notation "F ⟨ x ⟨ 1 ⟩ , y ⟨ 1 ⟩ ⟩" := (F ⟨ ( x ⟨ 1 ⟩ ) , ( y ⟨ 1 ⟩ ) ⟩)%functor : functor_scope.
Notation "F ⟨ x , y ⟨ 1 ⟩ ⟩" := (F ⟨ x , ( y ⟨ 1 ⟩ ) ⟩)%functor : functor_scope.
Notation "F ⟨ 1 , y ⟨ 1 ⟩ ⟩" := (F ⟨ ( 1 ) , ( y ⟨ 1 ⟩ ) ⟩)%functor : functor_scope.
Notation "F ⟨ x ⟨ 1 ⟩ , y ⟩" := (F ⟨ ( x ⟨ 1 ⟩ ) , y ⟩)%functor : functor_scope.
Notation "F ⟨ x ⟨ 1 ⟩ , 1 ⟩" := (F ⟨ ( x ⟨ 1 ⟩ ) , ( 1 ) ⟩)%functor : functor_scope.

(** Redefine the general notation, so it takes precedence when it can *)
Notation "F ⟨ x ⟩" := (FunctorApplicationOf F%functor x%functor) : functor_scope.
Notation "F ⟨ x , y ⟩" := (FunctorApplicationOf F%functor (x%functor , y%functor)) : functor_scope.
(*Notation "F ⟨ c , - ⟩" := (InducedProductSndFunctor F c) : functor_scope.
Notation "F ⟨ - , d ⟩" := (InducedProductFstFunctor F d) : functor_scope.*)