(** * Algebra I. Part C. Groups, abelian groups. Vladimir Voevodsky. Aug. 2011 - . *)

(** ** Contents

 - Groups
  - Basic definitions
  - Univalence for groups
  - Computation lemmas for groups
  - Relations on groups
  - Subobjects
  - Quotient objects
  - Cosets
  - Normal Subgroups
  - Direct products
  - Group of invertible elements in a monoid
 - Abelian groups
  - Basic definitions
  - Univalence for abelian groups
  - Subobjects
  - Kernels
  - Quotient objects
  - Direct products
  - Abelian group of fractions of an abelian unitary monoid
  - Abelian group of fractions and abelian monoid of fractions
  - Canonical homomorphism to the abelian group of fractions
  - Abelian group of fractions in the case when all elements are
    cancelable
  - Relations on the abelian group of fractions
  - Relations and the canonical homomorphism to [abgrdiff]
*)

Require Import UniMath.MoreFoundations.Orders.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.MoreFoundations.Subtypes.
Require Export UniMath.Algebra.BinaryOperations.
Require Export UniMath.Algebra.Monoids.

Local Open Scope logic.

(** ** Groups *)

(** *** Basic definitions *)

Definition gr : UU := total2 (λ X : setwithbinop, isgrop (@op X)).

Definition make_gr :
  ∏ (t : setwithbinop), (λ X : setwithbinop, isgrop op) t → ∑ X : setwithbinop, isgrop op :=
  tpair (λ X : setwithbinop, isgrop (@op X)).

Definition grtomonoid : gr -> monoid := λ X : _, make_monoid (pr1 X) (pr1 (pr2 X)).
Coercion grtomonoid : gr >-> monoid.

Definition grinv (X : gr) : X -> X := pr1 (pr2 (pr2 X)).

Definition grlinvax (X : gr) : islinv (@op X) (unel X) (grinv X) := pr1 (pr2 (pr2 (pr2 X))).

Definition grrinvax (X : gr) : isrinv (@op X) (unel X) (grinv X) := pr2 (pr2 (pr2 (pr2 X))).

Definition gr_of_monoid (X : monoid) (H : invstruct (@op X) (pr2 X)) : gr :=
  make_gr X (make_isgrop (pr2 X) H).

Lemma monoidfuninvtoinv {X Y : gr} (f : monoidfun X Y) (x : X) :
  f (grinv X x) = grinv Y (f x).
Proof.
  intros.
  apply (invmaponpathsweq (make_weq _ (isweqrmultingr_is (pr2 Y) (f x)))).
  simpl.
  change (paths (op (pr1 f (grinv X x)) (pr1 f x)) (op (grinv Y (pr1 f x)) (pr1 f x))).
  rewrite (grlinvax Y (pr1 f x)).
  destruct (pr1 (pr2 f) (grinv X x) x).
  rewrite (grlinvax X x).
  apply (pr2 (pr2 f)).
Defined.

Lemma grinv_path_from_op_path {X : gr} {x y : X} (p : (x * y)%multmonoid = unel X) :
  grinv X x = y.
Proof.
  now rewrite <- (lunax X y), <- (grlinvax X x), assocax, p, runax.
Defined.

(** *** Construction of the trivial abmonoid consisting of one element given by unit. *)

Definition unitgr_isgrop : isgrop (@op unitmonoid).
Proof.
  use make_isgrop.
  - exact unitmonoid_ismonoid.
  - use make_invstruct.
    + intros i. exact i.
    + use make_isinv.
      * intros x. use isProofIrrelevantUnit.
      * intros x. use isProofIrrelevantUnit.
Qed.

Definition unitgr : gr := make_gr unitmonoid unitgr_isgrop.

Lemma grfuntounit_ismonoidfun (X : gr) : ismonoidfun (λ x : X, (unel unitgr)).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use isProofIrrelevantUnit.
  - use isProofIrrelevantUnit.
Qed.

Definition grfuntounit (X : gr) : monoidfun X unitgr := monoidfunconstr (grfuntounit_ismonoidfun X).

Lemma grfunfromunit_ismonoidfun (X : gr) : ismonoidfun (λ x : unitgr, (unel X)).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use pathsinv0. use (runax X).
  - use idpath.
Qed.

Definition grfunfromunit (X : gr) : monoidfun unitmonoid X :=
  monoidfunconstr (monoidfunfromunit_ismonoidfun X).

Lemma unelgrfun_ismonoidfun (X Y : gr) : ismonoidfun (λ x : X, (unel Y)).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use pathsinv0. use lunax.
  - use idpath.
Qed.

Definition unelgrfun (X Y : gr) : monoidfun X Y :=
  monoidfunconstr (unelgrfun_ismonoidfun X Y).

(** *** (X = Y) ≃ (monoidiso X Y)
   The idea is to use the composition

            (X = Y) ≃ (make_gr' X = make_gr' Y)
                    ≃ ((gr'_to_monoid (make_gr' X)) = (gr'_to_monoid (make_gr' Y)))
                    ≃ (monoidiso X Y).

   The reason why we use gr' is that then we can use univalence for monoids. See
   [gr_univalence_weq3].
*)

Local Definition gr' : UU :=
  ∑ g : (∑ X : setwithbinop, ismonoidop (@op X)), invstruct (@op (pr1 g)) (pr2 g).

Local Definition make_gr' (X : gr) : gr' := tpair _ (tpair _ (pr1 X) (pr1 (pr2 X))) (pr2 (pr2 X)).

Local Definition gr'_to_monoid (X : gr') : monoid := pr1 X.

Definition gr_univalence_weq1 : gr ≃ gr' :=
  weqtotal2asstol
    (λ Z : setwithbinop, ismonoidop (@op Z))
    (fun y : (∑ (x : setwithbinop), ismonoidop (@op x)) => invstruct (@op (pr1 y)) (pr2 y)).

Definition gr_univalence_weq1' (X Y : gr) : (X = Y) ≃ (make_gr' X = make_gr' Y) :=
  make_weq _ (@isweqmaponpaths gr gr' gr_univalence_weq1 X Y).

Definition gr_univalence_weq2 (X Y : gr) :
  ((make_gr' X) = (make_gr' Y)) ≃ ((gr'_to_monoid (make_gr' X)) = (gr'_to_monoid (make_gr' Y))).
Proof.
  use subtypeInjectivity.
  intros w. use isapropinvstruct.
Defined.
Opaque gr_univalence_weq2.

Definition gr_univalence_weq3 (X Y : gr) :
  ((gr'_to_monoid (make_gr' X)) = (gr'_to_monoid (make_gr' Y))) ≃ (monoidiso X Y) :=
  monoid_univalence (gr'_to_monoid (make_gr' X)) (gr'_to_monoid (make_gr' Y)).

Definition gr_univalence_map (X Y : gr) : (X = Y) -> (monoidiso X Y).
Proof.
  intro e. induction e. exact (idmonoidiso X).
Defined.

Lemma gr_univalence_isweq (X Y : gr) : isweq (gr_univalence_map X Y).
Proof.
  use isweqhomot.
  - exact (weqcomp (gr_univalence_weq1' X Y)
                   (weqcomp (gr_univalence_weq2 X Y) (gr_univalence_weq3 X Y))).
  - intros e. induction e.
    use (pathscomp0 weqcomp_to_funcomp_app).
    use weqcomp_to_funcomp_app.
  - use weqproperty.
Defined.
Opaque gr_univalence_isweq.

Definition gr_univalence (X Y : gr) : (X = Y) ≃ (monoidiso X Y).
Proof.
  use make_weq.
  - exact (gr_univalence_map X Y).
  - exact (gr_univalence_isweq X Y).
Defined.
Opaque gr_univalence.

(** *** Computation lemmas for groups *)

Definition weqlmultingr (X : gr) (x0 : X) : pr1 X ≃ pr1 X :=
  make_weq _ (isweqlmultingr_is (pr2 X) x0).

Definition weqrmultingr (X : gr) (x0 : X) : pr1 X ≃ pr1 X :=
  make_weq _ (isweqrmultingr_is (pr2 X) x0).

Lemma grlcan (X : gr) {a b : X} (c : X) (e : paths (op c a) (op c b)) : a = b.
Proof. apply (invmaponpathsweq (weqlmultingr X c) _ _ e). Defined.

Lemma grrcan (X : gr) {a b : X} (c : X) (e : paths (op a c) (op b c)) : a = b.
Proof. apply (invmaponpathsweq (weqrmultingr X c) _ _ e). Defined.

Lemma grinvunel (X : gr) : paths (grinv X (unel X)) (unel X).
Proof.
  apply (grrcan X (unel X)).
  rewrite (grlinvax X). rewrite (runax X).
  apply idpath.
Defined.

Lemma grinvinv (X : gr) (a : X) : paths (grinv X (grinv X a)) a.
Proof.
  apply (grlcan X (grinv X a)).
  rewrite (grlinvax X a). rewrite (grrinvax X _).
  apply idpath.
Defined.

Lemma grinvmaponpathsinv (X : gr) {a b : X} (e : paths (grinv X a) (grinv X b)) : a = b.
Proof.
  assert (e' := maponpaths (λ x, grinv X x) e).
  simpl in e'. rewrite (grinvinv X _) in e'.
  rewrite (grinvinv X _) in e'. apply e'.
Defined.

Lemma grinvandmonoidfun (X Y : gr) {f : X -> Y} (is : ismonoidfun f) (x : X) :
  paths (f (grinv X x)) (grinv Y (f x)).
Proof.
  apply (grrcan Y (f x)).
  rewrite (pathsinv0 (pr1 is _ _)). rewrite (grlinvax X).
  rewrite (grlinvax Y).
  apply (pr2 is).
Defined.

Lemma grinvop (Y : gr) :
  ∏ y1 y2 : Y, grinv Y (@op Y y1 y2) = @op Y (grinv Y y2) (grinv Y y1).
Proof.
  intros y1 y2.
  apply (grrcan Y y1).
  rewrite (assocax Y). rewrite (grlinvax Y). rewrite (runax Y).
  apply (grrcan Y y2).
  rewrite (grlinvax Y). rewrite (assocax Y). rewrite (grlinvax Y).
  apply idpath.
Qed.

(** *** Relations on groups *)

Lemma isinvbinophrelgr (X : gr) {R : hrel X} (is : isbinophrel R) : isinvbinophrel R.
Proof.
  set (is1 := pr1 is). set (is2 := pr2 is). split.
  - intros a b c r. set (r' := is1 _ _ (grinv X c) r).
    clearbody r'. rewrite (pathsinv0 (assocax X _ _ a)) in r'.
    rewrite (pathsinv0 (assocax X _ _ b)) in r'.
    rewrite (grlinvax X c) in r'.
    rewrite (lunax X a) in r'.
    rewrite (lunax X b) in r'.
    apply r'.
  - intros a b c r. set (r' := is2 _ _ (grinv X c) r).
    clearbody r'. rewrite ((assocax X a _ _)) in r'.
    rewrite ((assocax X b _ _)) in r'.
    rewrite (grrinvax X c) in r'.
    rewrite (runax X a) in r'.
    rewrite (runax X b) in r'.
    apply r'.
Defined.
Opaque isinvbinophrelgr.

Lemma isbinophrelgr (X : gr) {R : hrel X} (is : isinvbinophrel R) : isbinophrel R.
Proof.
  set (is1 := pr1 is). set (is2 := pr2 is). split.
  - intros a b c r. rewrite (pathsinv0 (lunax X a)) in r.
    rewrite (pathsinv0 (lunax X b)) in r.
    rewrite (pathsinv0 (grlinvax X c)) in r.
    rewrite (assocax X _ _ a) in r.
    rewrite (assocax X _ _ b) in r.
    apply (is1 _ _ (grinv X c) r).
  - intros a b c r. rewrite (pathsinv0 (runax X a)) in r.
    rewrite (pathsinv0 (runax X b)) in r.
    rewrite (pathsinv0 (grrinvax X c)) in r.
    rewrite (pathsinv0 (assocax X a _ _)) in r.
    rewrite (pathsinv0 (assocax X b _ _)) in r.
    apply (is2 _ _ (grinv X c) r).
Defined.
Opaque isbinophrelgr.

Lemma grfromgtunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R x (unel X)) :
  R (unel X) (grinv X x).
Proof.
  intros.
  set (r := (pr2 is) _ _ (grinv X x) isg).
  rewrite (grrinvax X x) in r.
  rewrite (lunax X _) in r.
  apply r.
Defined.

Lemma grtogtunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R (unel X) (grinv X x)) :
  R x (unel X).
Proof.
  assert (r := (pr2 is) _ _ x isg).
  rewrite (grlinvax X x) in r.
  rewrite (lunax X _) in r.
  apply r.
Defined.

Lemma grfromltunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R (unel X) x) :
  R (grinv X x) (unel X).
Proof.
  assert (r := (pr1 is) _ _ (grinv X x) isg).
  rewrite (grlinvax X x) in r.
  rewrite (runax X _) in r.
  apply r.
Defined.

Lemma grtoltunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R (grinv X x) (unel X)) :
  R (unel X) x.
Proof.
  assert (r := (pr1 is) _ _ x isg).
  rewrite (grrinvax X x) in r. rewrite (runax X _) in r.
  apply r.
Defined.

(** *** Subobjects *)

Definition issubgr {X : gr} (A : hsubtype X) : UU :=
  dirprod (issubmonoid A) (∏ x : X, A x -> A (grinv X x)).

Definition make_issubgr {X : gr} {A : hsubtype X} (H1 : issubmonoid A)
           (H2 : ∏ x : X, A x -> A (grinv X x)) : issubgr A := make_dirprod H1 H2.

Lemma isapropissubgr {X : gr} (A : hsubtype X) : isaprop (issubgr A).
Proof.
  apply (isofhleveldirprod 1).
  - apply isapropissubmonoid.
  - apply impred. intro x.
    apply impred. intro a.
    apply (pr2 (A (grinv X x))).
Defined.

Definition subgr (X : gr) : UU := total2 (λ A : hsubtype X, issubgr A).

Definition make_subgr {X : gr} :
  ∏ (t : hsubtype X), (λ A : hsubtype X, issubgr A) t → ∑ A : hsubtype X, issubgr A :=
  tpair (λ A : hsubtype X, issubgr A).

Definition subgrconstr {X : gr} :
  ∏ (t : hsubtype X), (λ A : hsubtype X, issubgr A) t → ∑ A : hsubtype X, issubgr A :=
  @make_subgr X.

Definition subgrtosubmonoid (X : gr) : subgr X -> submonoid X :=
  λ A : _, make_submonoid (pr1 A) (pr1 (pr2 A)).
Coercion subgrtosubmonoid : subgr >-> submonoid.

Definition totalsubgr (X : gr) : subgr X.
Proof.
  split with (@totalsubtype X).
  split.
  - exact (pr2 (totalsubmonoid X)).
  - exact (fun _ _ => tt).
Defined.

Definition trivialsubgr (X : gr) : subgr X.
Proof.
  exists (λ x, x = @unel X)%logic.
  split.
  - exact (pr2 (@trivialsubmonoid X)).
  - intro.
    intro eq_1.
    induction (!eq_1).
    apply grinvunel.
Defined.

Lemma isinvoncarrier {X : gr} (A : subgr X) :
  isinv (@op A) (unel A) (λ a : A, make_carrier _ (grinv X (pr1 a)) (pr2 (pr2 A) (pr1 a) (pr2 a))).
Proof.
  split.
  - intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)).
    simpl. apply (grlinvax X (pr1 a)).
  - intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)).
    simpl. apply (grrinvax X (pr1 a)).
Defined.

Definition isgrcarrier {X : gr} (A : subgr X) : isgrop (@op A) :=
  tpair _ (ismonoidcarrier A)
        (tpair _ (λ a : A, make_carrier _ (grinv X (pr1 a)) (pr2 (pr2 A) (pr1 a) (pr2 a)))
               (isinvoncarrier A)).

Definition carrierofasubgr {X : gr} (A : subgr X) : gr.
Proof. split with A. apply (isgrcarrier A). Defined.
Coercion carrierofasubgr : subgr >-> gr.

Lemma intersection_subgr : forall {X : gr} {I : UU} (S : I -> hsubtype X)
                                  (each_is_subgr : ∏ i : I, issubgr (S i)),
    issubgr (subtype_intersection S).
Proof.
  intros.
  use make_issubgr.
  - exact (intersection_submonoid S (λ i, (pr1 (each_is_subgr i)))).
  - exact (λ x x_in_S i, pr2 (each_is_subgr i) x (x_in_S i)).
Qed.

Definition subgr_incl {X : gr} (A : subgr X) : monoidfun A X :=
submonoid_incl A.

(** *** Quotient objects *)

Lemma grquotinvcomp {X : gr} (R : binopeqrel X) : iscomprelrelfun R R (grinv X).
Proof.
  destruct R as [ R isb ].
  set (isc := iscompbinoptransrel _ (eqreltrans _) isb).
  unfold iscomprelrelfun. intros x x' r.
  destruct R as [ R iseq ]. destruct iseq as [ ispo0 symm0 ].
  destruct ispo0 as [ trans0 refl0 ]. unfold isbinophrel in isb.
  set (r0 := isc _ _ _ _ (isc _ _ _ _ (refl0 (grinv X x')) r) (refl0 (grinv X x))).
  rewrite (grlinvax X x') in r0.
  rewrite (assocax X (grinv X x') x (grinv X x)) in r0.
  rewrite (grrinvax X x) in r0. rewrite (lunax X _) in r0.
  rewrite (runax X _) in r0.
  apply (symm0 _ _ r0).
Defined.
Opaque grquotinvcomp.

Definition invongrquot {X : gr} (R : binopeqrel X) : setquot R -> setquot R :=
  setquotfun R R (grinv X) (grquotinvcomp R).

Lemma isinvongrquot {X : gr} (R : binopeqrel X) :
  isinv (@op (setwithbinopquot R)) (setquotpr R (unel X)) (invongrquot R).
Proof.
  split.
  - unfold islinv.
    apply (setquotunivprop R (λ x, _ = _)).
    intro x.
    apply (@maponpaths _ _ (setquotpr R) (@op X (grinv X x) x) (unel X)).
    apply (grlinvax X).
  - unfold isrinv.
    apply (setquotunivprop R (λ x, _ = _)).
    intro x.
    apply (@maponpaths _ _ (setquotpr R) (@op X x (grinv X x)) (unel X)).
    apply (grrinvax X).
Defined.
Opaque isinvongrquot.

Definition isgrquot {X : gr} (R : binopeqrel X) : isgrop (@op (setwithbinopquot R)) :=
  tpair _ (ismonoidquot R) (tpair _ (invongrquot R) (isinvongrquot R)).

Definition grquot {X : gr} (R : binopeqrel X) : gr.
Proof. split with (setwithbinopquot R). apply isgrquot. Defined.

(** *** Cosets *)

Section GrCosets.
  Context {X : gr}.

  Local Open Scope multmonoid.

  Local Lemma isaprop_mult_eq_r (x y : X) : isaprop (∑ z : X, x * z = y).
  Proof.
    apply invproofirrelevance; intros z1 z2.
    apply subtypePath.
    { intros x'. apply setproperty. }
    refine (!lunax _ _ @ _ @ lunax _ _).
    refine (maponpaths (λ z, z * _) (!grlinvax X x) @ _ @
            maponpaths (λ z, z * _) (grlinvax X x)).
    refine (assocax _ _ _ _ @ _ @ !assocax _ _ _ _).
    refine (maponpaths _ (pr2 z1) @ _ @ !maponpaths _ (pr2 z2)).
    reflexivity.
  Defined.

  Local Lemma isaprop_mult_eq_l (x y : X) : isaprop (∑ z : X, z * x = y).
  Proof.
    apply invproofirrelevance; intros z1 z2.
    apply subtypePath.
    { intros x'. apply setproperty. }
    refine (!runax _ _ @ _ @ runax _ _).
    refine (maponpaths (λ z, _ * z) (!grrinvax X x) @ _ @
            maponpaths (λ z, _ * z) (grrinvax X x)).
    refine (!assocax _ _ _ _ @ _ @ assocax _ _ _ _).
    refine (maponpaths (λ z, z * _) (pr2 z1) @ _ @ !maponpaths (λ z, z * _) (pr2 z2)).
    reflexivity.
  Defined.

  Context (Y : subgr X).

  Lemma isaprop_in_same_left_coset (x1 x2 : X) :
    isaprop (in_same_left_coset Y x1 x2).
  Proof.
    unfold in_same_left_coset.
    apply invproofirrelevance; intros p q.
    apply subtypePath.
    { intros x'. apply setproperty. }
    apply subtypePath.
    { intros x'. apply propproperty. }
    pose (p' := (pr11 p,, pr2 p) : ∑ y : X, x1 * y = x2).
    pose (q' := (pr11 q,, pr2 q) : ∑ y : X, x1 * y = x2).
    apply (maponpaths pr1 (iscontrpr1 (isaprop_mult_eq_r _ _ p' q'))).
  Defined.

  Lemma isaprop_in_same_right_coset (x1 x2 : X) :
    isaprop (in_same_right_coset Y x1 x2).
  Proof.
    apply invproofirrelevance.
    intros p q.
    apply subtypePath; [intros x; apply setproperty|].
    apply subtypePath; [intros x; apply propproperty|].
    pose (p' := (pr11 p,, pr2 p) : ∑ y : X, y * x1 = x2).
    pose (q' := (pr11 q,, pr2 q) : ∑ y : X, y * x1 = x2).
    apply (maponpaths pr1 (iscontrpr1 (isaprop_mult_eq_l _ _ p' q'))).
  Defined.

  (** The property of being in the same coset defines an equivalence relation. *)

  Definition in_same_left_coset_prop : X -> X -> hProp.
  Proof.
    intros x1 x2.
    use make_hProp.
    + exact (in_same_left_coset Y x1 x2).
    + apply isaprop_in_same_left_coset.
  Defined.

  Definition in_same_right_coset_prop : X -> X -> hProp.
  Proof.
    intros x1 x2.
    use make_hProp.
    + exact (in_same_right_coset Y x1 x2).
    + apply isaprop_in_same_right_coset.
  Defined.

  Definition in_same_left_coset_eqrel : eqrel X.
    use make_eqrel.
    - exact in_same_left_coset_prop.
    - use iseqrelconstr.
      + (** Transitivity *)
        intros ? ? ?; cbn; intros inxy inyz.
        unfold in_same_left_coset in *.
        use tpair.
        * exists (pr11 inxy * pr11 inyz).
          apply (pr2 Y).
        * cbn.
          refine (_ @ pr2 inyz).
          refine (_ @ maponpaths (λ z, z * _) (pr2 inxy)).
          apply pathsinv0, assocax.
      + (** Reflexivity *)
        intro; cbn.
        use tpair.
        * exists 1; apply (pr2 Y).
        * apply runax.
      + (** Symmetry *)
        intros x y inxy.
        use tpair.
        * exists (grinv X (pr1 (pr1 inxy))).
          apply (pr2 Y).
          exact (pr2 (pr1 inxy)).
        * cbn in *.
          refine (!maponpaths (λ z, z * _) (pr2 inxy) @ _).
          refine (assocax _ _ _ _ @ _).
          refine (maponpaths _ (grrinvax _ _) @ _).
          apply runax.
  Defined.

  (** x₁ and x₂ are in the same Y-coset if and only if x₁⁻¹ * x₂ is in Y.
      (Proposition 4 in Dummit and Foote) *)

  Definition in_same_coset_test (x1 x2 : X) :
             (Y ((grinv _ x1) * x2)) ≃ in_same_left_coset Y x1 x2.
  Proof.
    apply weqimplimpl; unfold in_same_left_coset in *.
    - intros yx1x2.
      exists ((grinv _ x1) * x2,, yx1x2); cbn.
      refine (!assocax X _ _ _ @ _).
      refine (maponpaths (λ z, z * _) (grrinvax X _) @ _).
      apply lunax.
    - intros y.
      use (transportf (pr1 Y)).
      + exact (pr11 y).
      + refine (_ @ maponpaths _ (pr2 y)).
        refine (_ @ assocax _ _ _ _).
        refine (_ @ !maponpaths (λ z, z * _) (grlinvax X _)).
        apply pathsinv0, lunax.
      + exact (pr2 (pr1 y)).
    - apply propproperty.
    - apply isaprop_in_same_left_coset.
  Defined.
End GrCosets.

(** *** Normal Subgroups *)

Section NormalSubGroups.
  Local Open Scope multmonoid.

  Definition isnormalsubgr {X : gr} (N : subgr X) : hProp :=
    ∀ g : X, ∀ n1 : N, N ((g * (pr1 n1)) * (grinv X g)).

  Definition normalsubgr (X : gr) : UU := ∑ N : subgr X, isnormalsubgr N.

  Definition normalsubgrtosubgr (X : gr) : normalsubgr X -> subgr X := pr1.
  Coercion normalsubgrtosubgr : normalsubgr >-> subgr.

  Definition normalsubgrprop {X : gr} (N : normalsubgr X) : isnormalsubgr N := pr2 N.

  Definition lcoset_in_rcoset {X : gr} (N : subgr X) : UU :=
    ∏ g : X, ∏ n1 : N, ∑ n2 : N, g * (pr1 n1) = (pr1 n2) * g.
  Definition lcoset_in_rcoset_witness {X : gr} {N : subgr X} :
    lcoset_in_rcoset N -> (X -> N -> N) := fun H g n1 => pr1 (H g n1).
  Definition lcoset_in_rcoset_property {X : gr} {N : subgr X}
      (H : lcoset_in_rcoset N) (g : X) (n1 : N) :
    N (pr1 (lcoset_in_rcoset_witness H g n1)) := pr2 (lcoset_in_rcoset_witness H g n1).
  Definition lcoset_in_rcoset_equation {X : gr} {N : subgr X}
      (H : lcoset_in_rcoset N) (g : X) (n1 : N) :
    g * (pr1 n1) = (pr1 (lcoset_in_rcoset_witness H g n1)) * g := pr2 (H g n1).

  Definition rcoset_in_lcoset {X : gr} (N : subgr X) : UU :=
    ∏ g : X, ∏ n1 : N, ∑ n2 : N, (pr1 n1) * g = g * (pr1 n2).
  Definition rcoset_in_lcoset_witness {X : gr} {N : subgr X} :
    rcoset_in_lcoset N -> (X -> N -> N) := fun H g n1 => pr1 (H g n1).
  Definition rcoset_in_lcoset_property {X : gr} {N : subgr X}
      (H : rcoset_in_lcoset N) (g : X) (n1 : N) :
    N (pr1 (rcoset_in_lcoset_witness H g n1)) := pr2 (rcoset_in_lcoset_witness H g n1).
  Definition rcoset_in_lcoset_equation {X : gr} {N : subgr X}
      (H : rcoset_in_lcoset N) (g : X) (n1 : N) :
    (pr1 n1) * g = g * (pr1 (rcoset_in_lcoset_witness H g n1)) := pr2 (H g n1).

  Definition lcoset_equal_rcoset {X : gr} (N : subgr X) : UU :=
    lcoset_in_rcoset N × rcoset_in_lcoset N.

  Lemma lcoset_in_rcoset_impl_normal {X : gr} (N : subgr X) :
    lcoset_in_rcoset N -> isnormalsubgr N.
  Proof.
    intros lcinrc.
    unfold isnormalsubgr.
    intros g n1.
    refine (@transportb _ (fun x => N x) _ _ _ _).
    { etrans. { apply maponpaths_2, (lcoset_in_rcoset_equation lcinrc). }
      etrans. { apply assocax. }
      etrans. { apply maponpaths, grrinvax. }
      apply runax.
    }
    apply lcoset_in_rcoset_property.
  Defined.

  Lemma lcoset_equal_rcoset_impl_normal {X : gr} (N : subgr X) :
    lcoset_equal_rcoset N -> isnormalsubgr N.
  Proof.
    intros H. apply lcoset_in_rcoset_impl_normal. exact (pr1 H).
  Defined.

  Lemma normal_lcoset_in_rcoset {X : gr} (N : normalsubgr X) : lcoset_in_rcoset N.
  Proof.
    unfold normalsubgr in N.
    induction N as [N normalprop].
    simpl.
    unfold lcoset_in_rcoset.
    intros g n1.
    use tpair.
    - exact (tpair _ (g * (pr1 n1) * (grinv X g)) (normalprop g n1)).
    - simpl.
      rewrite (assocax _ _ _ g).
      rewrite (grlinvax X _).
      rewrite (runax X).
      reflexivity.
  Defined.

  Definition normal_rcoset_in_lcoset {X : gr} (N : normalsubgr X) : rcoset_in_lcoset N.
  Proof.
    induction N as [N normalprop].
    simpl.
    unfold rcoset_in_lcoset.
    intros g n1.
    use tpair.
    - exists ((grinv X g) * (pr1 n1) * (grinv X (grinv X g))). use normalprop.
    - simpl.
      rewrite (assocax _ (grinv X g) _ _).
      rewrite (!assocax _ g _ _).
      rewrite (grrinvax X).
      rewrite (lunax X).
      rewrite (grinvinv X).
      reflexivity.
  Defined.

  Definition normal_lcoset_equal_rcoset {X : gr} (N : normalsubgr X) : lcoset_equal_rcoset N :=
    (normal_lcoset_in_rcoset N,,normal_rcoset_in_lcoset N).

  Lemma in_same_coset_isbinophrel {X : gr} (N : normalsubgr X) :
    isbinophrel (in_same_left_coset_eqrel N).
  Proof.
    unfold isbinophrel.
    split.
    - intros a b c.
      unfold in_same_left_coset_eqrel.
      simpl.
      unfold in_same_left_coset.
      intros ab_same_lcoset.
      use tpair.
      + exact (pr1 ab_same_lcoset).
      + simpl.
        rewrite (assocax _ c _ _).
        apply maponpaths.
        exact (pr2 ab_same_lcoset).
    - intros a b c.
      unfold in_same_left_coset_eqrel.
      simpl.
      unfold in_same_left_coset.
      intros ab_same_lcoset.
      use tpair.
      + refine (rcoset_in_lcoset_witness _ c (pr1 ab_same_lcoset));
          apply normal_rcoset_in_lcoset.
      + simpl.
        rewrite (grinvinv _).
        rewrite (assocax _ a _ _).
        rewrite (assocax _ (grinv X c) _ _).
        rewrite (!assocax _ c _ _).
        rewrite (grrinvax _).
        rewrite (lunax _).
        rewrite (!assocax _ a _ _).
        apply maponpaths_2.
        exact (pr2 ab_same_lcoset).
  Defined.

  Definition in_same_coset_binopeqrel {X : gr} (N : normalsubgr X) : binopeqrel X :=
    tpair _ (in_same_left_coset_eqrel N) (in_same_coset_isbinophrel N).

  Definition grquot_by_normal_subgr (X : gr) (N : normalsubgr X) : gr :=
    grquot (in_same_coset_binopeqrel N).

End NormalSubGroups.

(** *** Direct products *)

Lemma isgrdirprod (X Y : gr) : isgrop (@op (setwithbinopdirprod X Y)).
Proof.
  split with (ismonoiddirprod X Y).
  split with (λ xy : _, make_dirprod (grinv X (pr1 xy)) (grinv Y (pr2 xy))).
  split.
  - intro xy. destruct xy as [ x y ].
    unfold unel_is. simpl. apply pathsdirprod.
    apply (grlinvax X x). apply (grlinvax Y y).
  - intro xy. destruct xy as [ x y ].
    unfold unel_is. simpl. apply pathsdirprod.
    apply (grrinvax X x). apply (grrinvax Y y).
Defined.

Definition grdirprod (X Y : gr) : gr.
Proof. split with (setwithbinopdirprod X Y). apply isgrdirprod. Defined.

(** *** Group of invertible elements in a monoid *)

Local Open Scope multmonoid.

Definition invertible_submonoid_grop X : isgrop (@op (invertible_submonoid X)).
Proof.
  pose (submon := invertible_submonoid X).
  pose (submon_carrier := ismonoidcarrier submon).

  (** We know that if each element has an inverse, it's a grop *)
  apply (isgropif submon_carrier).

  intros xpair.
  pose (x := pr1 xpair).
  pose (unel := (unel_is submon_carrier)).

  (** We can use other hProps when proving an hProp (assume it has an inverse) *)
  apply (squash_to_prop (pr2 xpair) (propproperty _)).

  intros xinv.
  unfold haslinv.
  apply hinhpr.
  refine ((pr1 xinv,, inverse_in_submonoid _ x (pr1 xinv) (pr2 xpair) (pr2 xinv)),, _).
  apply subtypePath_prop.
  exact (pr2 (pr2 xinv)).
Defined.

Local Close Scope multmonoid.

Definition gr_merely_invertible_elements : monoid -> gr :=
  fun X => (carrierofasubsetwithbinop
             (submonoidtosubsetswithbinop
                _ (invertible_submonoid X)),, invertible_submonoid_grop X).

(** ** Abelian groups *)

(** *** Basic definitions *)

Definition abgr : UU := total2 (λ X : setwithbinop, isabgrop (@op X)).

Definition make_abgr (X : setwithbinop) (is : isabgrop (@op X)) : abgr :=
  tpair (λ X : setwithbinop,  isabgrop (@op X)) X is.

Definition abgrconstr (X : abmonoid) (inv0 : X -> X) (is : isinv (@op X) (unel X) inv0) : abgr :=
  make_abgr X (make_dirprod (make_isgrop (pr2 X) (tpair _ inv0 is)) (commax X)).

Definition abgrtogr : abgr -> gr := λ X : _, make_gr (pr1 X) (pr1 (pr2 X)).
Coercion abgrtogr : abgr >-> gr.

Definition abgrtoabmonoid : abgr -> abmonoid :=
  λ X : _, make_abmonoid (pr1 X) (make_dirprod (pr1 (pr1 (pr2 X))) (pr2 (pr2 X))).
Coercion abgrtoabmonoid : abgr >-> abmonoid.

Definition abgr_of_gr (X : gr) (H : iscomm (@op X)) : abgr :=
  make_abgr X (make_isabgrop (pr2 X) H).

Declare Scope abgr.
Delimit Scope abgr with abgr.
Notation "x - y" := (op x (grinv _ y)) : abgr.
Notation   "- y" := (grinv _ y) : abgr.

(** *** Construction of the trivial abgr consisting of one element given by unit. *)

Definition unitabgr_isabgrop : isabgrop (@op unitabmonoid).
Proof.
  use make_isabgrop.
  - exact unitgr_isgrop.
  - exact (commax unitabmonoid).
Qed.

Definition unitabgr : abgr := make_abgr unitabmonoid unitabgr_isabgrop.

Lemma abgrfuntounit_ismonoidfun (X : abgr) : ismonoidfun (λ x : X, (unel unitabgr)).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use isProofIrrelevantUnit.
  - use isProofIrrelevantUnit.
Qed.

Definition abgrfuntounit (X : abgr) : monoidfun X unitabgr :=
  monoidfunconstr (abgrfuntounit_ismonoidfun X).

Lemma abgrfunfromunit_ismonoidfun (X : abgr) : ismonoidfun (λ x : unitabgr, (unel X)).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use pathsinv0. use (runax X).
  - use idpath.
Qed.

Definition abgrfunfromunit (X : abgr) : monoidfun unitabgr X :=
  monoidfunconstr (abgrfunfromunit_ismonoidfun X).

Lemma unelabgrfun_ismonoidfun (X Y : abgr) : ismonoidfun (λ x : X, (unel Y)).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use pathsinv0. use lunax.
  - use idpath.
Qed.

Definition unelabgrfun (X Y : abgr) : monoidfun X Y :=
  monoidfunconstr (unelgrfun_ismonoidfun X Y).

(** *** Abelian group structure on morphism between abelian groups *)

Definition abgrshombinop_inv_ismonoidfun {X Y : abgr} (f : monoidfun X Y) :
  ismonoidfun (λ x : X, grinv Y (pr1 f x)).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. cbn.
    rewrite (pr1 (pr2 f)). rewrite (pr2 (pr2 Y)). use (grinvop Y).
  - use (pathscomp0 (maponpaths (λ y : Y, grinv Y y) (monoidfununel f))).
    use grinvunel.
Qed.

Definition abgrshombinop_inv {X Y : abgr} (f : monoidfun X Y) : monoidfun X Y :=
  monoidfunconstr (abgrshombinop_inv_ismonoidfun f).

Definition abgrshombinop_linvax {X Y : abgr} (f : monoidfun X Y) :
  @abmonoidshombinop X Y (abgrshombinop_inv f) f = unelmonoidfun X Y.
Proof.
  use monoidfun_paths. use funextfun. intros x. use (@grlinvax Y).
Qed.

Definition abgrshombinop_rinvax {X Y : abgr} (f : monoidfun X Y) :
  @abmonoidshombinop X Y f (abgrshombinop_inv f) = unelmonoidfun X Y.
Proof.
  use monoidfun_paths. use funextfun. intros x. use (grrinvax Y).
Qed.

Lemma abgrshomabgr_isabgrop (X Y : abgr) :
  @isabgrop (abmonoidshomabmonoid X Y) (λ f g : monoidfun X Y, @abmonoidshombinop X Y f g).
Proof.
  use make_isabgrop.
  - use make_isgrop.
    + exact (abmonoidshomabmonoid_ismonoidop X Y).
    + use make_invstruct.
      * intros f. exact (abgrshombinop_inv f).
      * use make_isinv.
          intros f. exact (abgrshombinop_linvax f).
          intros f. exact (abgrshombinop_rinvax f).
  - intros f g. exact (abmonoidshombinop_comm f g).
Defined.

Definition abgrshomabgr (X Y : abgr) : abgr.
Proof.
  use make_abgr.
  - exact (abmonoidshomabmonoid X Y).
  - exact (abgrshomabgr_isabgrop X Y).
Defined.

(** *** (X = Y) ≃ (monoidiso X Y)
   The idea is to use the following composition

        (X = Y) ≃ (make_abgr' X = make_abgr' Y)
                ≃ (pr1 (make_abgr' X) = pr1 (make_abgr' Y))
                ≃ (monoidiso X Y)

    We use abgr' so that we can use univalence for groups, [gr_univalence]. See
    [abgr_univalence_weq3].
 *)

Local Definition abgr' : UU :=
  ∑ g : (∑ X : setwithbinop, isgrop (@op X)), iscomm (pr2 (pr1 g)).

Local Definition make_abgr' (X : abgr) : abgr' :=
  tpair _ (tpair _ (pr1 X) (dirprod_pr1 (pr2 X))) (dirprod_pr2 (pr2 X)).

Local Definition abgr_univalence_weq1 : abgr ≃ abgr' :=
  weqtotal2asstol (λ Z : setwithbinop, isgrop (@op Z))
                  (fun y : (∑ x : setwithbinop, isgrop (@op x)) => iscomm (@op (pr1 y))).

Definition abgr_univalence_weq1' (X Y : abgr) : (X = Y) ≃ (make_abgr' X = make_abgr' Y) :=
  make_weq _ (@isweqmaponpaths abgr abgr' abgr_univalence_weq1 X Y).

Definition abgr_univalence_weq2 (X Y : abgr) :
  (make_abgr' X = make_abgr' Y) ≃ (pr1 (make_abgr' X) = pr1 (make_abgr' Y)).
Proof.
  use subtypeInjectivity.
  intros w. use isapropiscomm.
Defined.
Opaque abgr_univalence_weq2.

Definition abgr_univalence_weq3 (X Y : abgr) :
  (pr1 (make_abgr' X) = pr1 (make_abgr' Y)) ≃ (monoidiso X Y) :=
  gr_univalence (pr1 (make_abgr' X)) (pr1 (make_abgr' Y)).

Definition abgr_univalence_map (X Y : abgr) : (X = Y) -> (monoidiso X Y).
Proof.
  intro e. induction e. exact (idmonoidiso X).
Defined.

Lemma abgr_univalence_isweq (X Y : abgr) : isweq (abgr_univalence_map X Y).
Proof.
  use isweqhomot.
  - exact (weqcomp (abgr_univalence_weq1' X Y)
                   (weqcomp (abgr_univalence_weq2 X Y) (abgr_univalence_weq3 X Y))).
  - intros e. induction e.
    use (pathscomp0 weqcomp_to_funcomp_app).
    use weqcomp_to_funcomp_app.
  - use weqproperty.
Defined.
Opaque abgr_univalence_isweq.

Definition abgr_univalence (X Y : abgr) : (X = Y) ≃ (monoidiso X Y).
Proof.
  use make_weq.
  - exact (abgr_univalence_map X Y).
  - exact (abgr_univalence_isweq X Y).
Defined.
Opaque abgr_univalence.

(** *** Subobjects *)

Definition subabgr (X : abgr) := subgr X.
Identity Coercion id_subabgr : subabgr >-> subgr.

Lemma isabgrcarrier {X : abgr} (A : subgr X) : isabgrop (@op A).
Proof.
  split with (isgrcarrier A).
  apply (pr2 (@isabmonoidcarrier X A)).
Defined.

Definition carrierofasubabgr {X : abgr} (A : subabgr X) : abgr.
Proof. split with A. apply isabgrcarrier. Defined.
Coercion carrierofasubabgr : subabgr >-> abgr.

Definition subabgr_incl {X : abgr} (A : subabgr X) : monoidfun A X :=
  submonoid_incl A.

Definition abgr_kernel_hsubtype {A B : abgr} (f : monoidfun A B) : hsubtype A :=
  monoid_kernel_hsubtype f.

Definition abgr_image_hsubtype {A B : abgr} (f : monoidfun A B) : hsubtype B :=
  (λ y : B, ∃ x : A, (f x) = y).

(** * Kernels
    Let f : X -> Y be a morphism of abelian groups. A kernel of f is given by the subgroup of X
    consisting of elements x such that [f x = unel Y].
 *)

(** ** Kernel as abelian group *)

Definition abgr_Kernel_subabgr_issubgr {A B : abgr} (f : monoidfun A B) :
  issubgr (abgr_kernel_hsubtype f).
Proof.
  use make_issubgr.
  - apply kernel_issubmonoid.
  - intros x a.
    apply (grrcan B (f x)).
    apply (pathscomp0 (! (binopfunisbinopfun f (grinv A x) x))).
    apply (pathscomp0 (maponpaths (λ a : A, f a) (grlinvax A x))).
    apply (pathscomp0 (monoidfununel f)).
    apply pathsinv0.
    apply (pathscomp0 (lunax B (f x))).
    exact a.
Defined.

Definition abgr_Kernel_subabgr {A B : abgr} (f : monoidfun A B) : @subabgr A :=
  subgrconstr (@abgr_kernel_hsubtype A B f) (abgr_Kernel_subabgr_issubgr f).

(** ** The inclusion Kernel f --> X is a morphism of abelian groups *)

Definition abgr_Kernel_monoidfun_ismonoidfun {A B : abgr} (f : monoidfun A B) :
  @ismonoidfun (abgr_Kernel_subabgr f) A
               (make_incl (pr1carrier (abgr_kernel_hsubtype f))
                         (isinclpr1carrier (abgr_kernel_hsubtype f))).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use idpath.
  - use idpath.
Qed.

  (** ** Image of f is a subgroup *)

Definition abgr_image_issubgr {A B : abgr} (f : monoidfun A B) : issubgr (abgr_image_hsubtype f).
Proof.
  use make_issubgr.
  - use make_issubmonoid.
    + intros a a'.
      use (hinhuniv _ (pr2 a)). intros ae.
      use (hinhuniv _ (pr2 a')). intros a'e.
      use hinhpr.
      use tpair.
      * exact (@op A (pr1 ae) (pr1 a'e)).
      * use (pathscomp0 (binopfunisbinopfun f (pr1 ae) (pr1 a'e))).
        use two_arg_paths.
          exact (pr2 ae).
          exact (pr2 a'e).
    + use hinhpr. use tpair.
      * exact (unel A).
      * exact (monoidfununel f).
  - intros b b'.
    use (hinhuniv _ b'). intros eb.
    use hinhpr.
    use tpair.
    + exact (grinv A (pr1 eb)).
    + use (pathscomp0 _ (maponpaths (λ bb : B, (grinv B bb)) (pr2 eb))).
      use monoidfuninvtoinv.
Qed.

Definition abgr_image {A B : abgr} (f : monoidfun A B) : @subabgr B :=
  @subgrconstr B (@abgr_image_hsubtype A B f) (abgr_image_issubgr f).

(** *** Quotient objects *)

Lemma isabgrquot {X : abgr} (R : binopeqrel X) : isabgrop (@op (setwithbinopquot R)).
Proof.
  split with (isgrquot R).
  apply (pr2 (@isabmonoidquot X R)).
Defined.

Definition abgrquot {X : abgr} (R : binopeqrel X) : abgr.
Proof. split with (setwithbinopquot R). apply isabgrquot. Defined.

(** *** Direct products *)

Lemma isabgrdirprod (X Y : abgr) : isabgrop (@op (setwithbinopdirprod X Y)).
Proof.
  split with (isgrdirprod X Y).
  apply (pr2 (isabmonoiddirprod X Y)).
Defined.

Definition abgrdirprod (X Y : abgr) : abgr.
Proof.
  split with (setwithbinopdirprod X Y).
  apply isabgrdirprod.
Defined.

(** *** Abelian group of fractions of an abelian unitary monoid *)

Section Fractions.
Import UniMath.Algebra.Monoids.AddNotation.
Local Open Scope addmonoid.

Definition hrelabgrdiff (X : abmonoid) : hrel (X × X) :=
  λ xa1 xa2,
    hexists (λ x0 : X, paths (((pr1 xa1) + (pr2 xa2)) + x0) (((pr1 xa2) + (pr2 xa1)) + x0)).

Definition abgrdiffphi (X : abmonoid) (xa : dirprod X X) :
  dirprod X (totalsubtype X) := make_dirprod (pr1 xa) (make_carrier (λ x : X, htrue) (pr2 xa) tt).

Definition hrelabgrdiff' (X : abmonoid) : hrel (X × X) :=
  λ xa1 xa2, eqrelabmonoidfrac X (totalsubmonoid X) (abgrdiffphi X xa1) (abgrdiffphi X xa2).

Lemma logeqhrelsabgrdiff (X : abmonoid) : hrellogeq (hrelabgrdiff' X) (hrelabgrdiff X).
Proof.
  split. simpl. apply hinhfun. intro t2.
  set (a0 := pr1 (pr1 t2)). split with a0. apply (pr2 t2). simpl.
  apply hinhfun. intro t2. set (x0 := pr1 t2). split with (tpair _ x0 tt).
  apply (pr2 t2).
Defined.

Lemma iseqrelabgrdiff (X : abmonoid) : iseqrel (hrelabgrdiff X).
Proof.
  apply (iseqrellogeqf (logeqhrelsabgrdiff X)).
  apply (iseqrelconstr).
  intros xx' xx'' xx'''.
  intros r1 r2.
  apply (eqreltrans (eqrelabmonoidfrac X (totalsubmonoid X)) _ _ _ r1 r2).
  intro xx. apply (eqrelrefl (eqrelabmonoidfrac X (totalsubmonoid X)) _).
  intros xx xx'. intro r.
  apply (eqrelsymm (eqrelabmonoidfrac X (totalsubmonoid X)) _ _ r).
Defined.
Opaque iseqrelabgrdiff.

Definition eqrelabgrdiff (X : abmonoid) : @eqrel (abmonoiddirprod X X) :=
  make_eqrel _ (iseqrelabgrdiff X).

Lemma isbinophrelabgrdiff (X : abmonoid) : @isbinophrel (abmonoiddirprod X X) (hrelabgrdiff X).
Proof.
  apply (@isbinophrellogeqf (abmonoiddirprod X X) _ _ (logeqhrelsabgrdiff X)).
  split. intros a b c r.
  apply (pr1 (isbinophrelabmonoidfrac X (totalsubmonoid X)) _ _
             (make_dirprod (pr1 c) (make_carrier (λ x : X, htrue) (pr2 c) tt))
             r).
  intros a b c r.
  apply (pr2 (isbinophrelabmonoidfrac X (totalsubmonoid X)) _ _
             (make_dirprod (pr1 c) (make_carrier (λ x : X, htrue) (pr2 c) tt))
             r).
Defined.
Opaque isbinophrelabgrdiff.

Definition binopeqrelabgrdiff (X : abmonoid) : binopeqrel (abmonoiddirprod X X) :=
  make_binopeqrel (eqrelabgrdiff X) (isbinophrelabgrdiff X).

Definition abgrdiffcarrier (X : abmonoid) : abmonoid := @abmonoidquot (abmonoiddirprod X X)
                                                                      (binopeqrelabgrdiff X).

Definition abgrdiffinvint (X : abmonoid) :  dirprod X X -> dirprod X X :=
  λ xs : _, make_dirprod (pr2 xs) (pr1 xs).

Lemma abgrdiffinvcomp (X : abmonoid) :
  iscomprelrelfun (hrelabgrdiff X) (eqrelabgrdiff X) (abgrdiffinvint X).
Proof.
  unfold iscomprelrelfun. unfold eqrelabgrdiff. unfold hrelabgrdiff.
  unfold eqrelabmonoidfrac. unfold hrelabmonoidfrac. simpl. intros xs xs'.
  apply (hinhfun). intro tt0.
  set (x := pr1 xs). set (s := pr2 xs).
  set (x' := pr1 xs'). set (s' := pr2 xs').
  split with (pr1 tt0).
  destruct tt0 as [ a eq ]. change (paths (s + x' + a) (s' + x + a)).
  apply pathsinv0. simpl.
  set(e := commax X s' x). simpl in e. rewrite e. clear e.
  set (e := commax X s x'). simpl in e. rewrite e. clear e.
  apply eq.
Defined.
Opaque abgrdiffinvcomp.

Definition abgrdiffinv (X : abmonoid) : abgrdiffcarrier X -> abgrdiffcarrier X :=
  setquotfun (hrelabgrdiff X) (eqrelabgrdiff X) (abgrdiffinvint X) (abgrdiffinvcomp X).

Lemma abgrdiffisinv (X : abmonoid) :
  isinv (@op (abgrdiffcarrier X)) (unel (abgrdiffcarrier X)) (abgrdiffinv X).
Proof.
  set (R := eqrelabgrdiff X).
  assert (isl : islinv (@op (abgrdiffcarrier X)) (unel (abgrdiffcarrier X)) (abgrdiffinv X)).
  {
    unfold islinv.
    apply (setquotunivprop R (λ x, _ = _)).
    intro xs.
    set (x := pr1 xs). set (s := pr2 xs).
    apply (iscompsetquotpr R (@op (abmonoiddirprod X X) (abgrdiffinvint X xs) xs) (unel _)).
    simpl. apply hinhpr. split with (unel X).
    change (paths (s + x + (unel X) + (unel X)) ((unel X) + (x + s) + (unel X))).
    destruct (commax X x s). destruct (commax X (unel X) (x + s)).
    apply idpath.
  }
  apply (make_dirprod isl (weqlinvrinv (@op (abgrdiffcarrier X)) (commax (abgrdiffcarrier X))
                                      (unel (abgrdiffcarrier X)) (abgrdiffinv X) isl)).
Defined.
Opaque abgrdiffisinv.

Definition abgrdiff (X : abmonoid) : abgr := abgrconstr (abgrdiffcarrier X) (abgrdiffinv X)
                                                        (abgrdiffisinv X).

Definition prabgrdiff (X : abmonoid) : X -> X -> abgrdiff X :=
  λ x x' : X, setquotpr (eqrelabgrdiff X) (make_dirprod x x').

(** *** Abelian group of fractions and abelian monoid of fractions *)

Definition weqabgrdiffint (X : abmonoid) : weq (X × X) (dirprod X (totalsubtype X)) :=
  weqdirprodf (idweq X) (invweq (weqtotalsubtype X)).

Definition weqabgrdiff (X : abmonoid) : weq (abgrdiff X) (abmonoidfrac X (totalsubmonoid X)).
Proof.
  intros.
  apply (weqsetquotweq (eqrelabgrdiff X)
                       (eqrelabmonoidfrac X (totalsubmonoid X)) (weqabgrdiffint X)).
  - simpl. intros x x'. destruct x as [ x1 x2 ]. destruct x' as [ x1' x2' ].
    simpl in *. apply hinhfun. intro tt0. destruct tt0 as [ xx0 is0 ].
    split with (make_carrier (λ x : X, htrue) xx0 tt). apply is0.
  - simpl. intros x x'. destruct x as [ x1 x2 ]. destruct x' as [ x1' x2' ].
    simpl in *. apply hinhfun. intro tt0. destruct tt0 as [ xx0 is0 ].
    split with (pr1 xx0). apply is0.
Defined.

(** *** Canonical homomorphism to the abelian group of fractions *)

Definition toabgrdiff (X : abmonoid) (x : X) : abgrdiff X := setquotpr _ (make_dirprod x (unel X)).

Lemma isbinopfuntoabgrdiff (X : abmonoid) : isbinopfun (toabgrdiff X).
Proof.
  unfold isbinopfun. intros x1 x2.
  change (paths (setquotpr _ (make_dirprod (x1 + x2) (unel X)))
                (setquotpr (eqrelabgrdiff X) (make_dirprod (x1 + x2) ((unel X) + (unel X))))).
  apply (maponpaths (setquotpr _)).
  apply (@pathsdirprod X X).
  apply idpath.
  apply (pathsinv0 (lunax X 0)).
Defined.

Lemma isunitalfuntoabgrdiff (X : abmonoid) : paths (toabgrdiff X (unel X)) (unel (abgrdiff X)).
Proof. apply idpath. Defined.

Definition ismonoidfuntoabgrdiff (X : abmonoid) : ismonoidfun (toabgrdiff X) :=
  make_dirprod (isbinopfuntoabgrdiff X) (isunitalfuntoabgrdiff X).

(** *** Abelian group of fractions in the case when all elements are cancelable *)

Lemma isinclprabgrdiff (X : abmonoid) (iscanc : ∏ x : X, isrcancelable (@op X) x) :
  ∏ x' : X, isincl (λ x, prabgrdiff X x x').
Proof.
  intros.
  set (int := isinclprabmonoidfrac X (totalsubmonoid X) (λ a : totalsubmonoid X, iscanc (pr1 a))
                                   (make_carrier (λ x : X, htrue) x' tt)).
  set (int1 := isinclcomp (make_incl _ int) (weqtoincl (invweq (weqabgrdiff X)))).
  apply int1.
Defined.

Definition isincltoabgrdiff (X : abmonoid) (iscanc : ∏ x : X, isrcancelable (@op X) x) :
  isincl (toabgrdiff X) := isinclprabgrdiff X iscanc (unel X).

Lemma isdeceqabgrdiff (X : abmonoid) (iscanc : ∏ x : X, isrcancelable (@op X) x) (is : isdeceq X) :
  isdeceq (abgrdiff X).
Proof.
  intros.
  apply (isdeceqweqf (invweq (weqabgrdiff X))).
  apply (isdeceqabmonoidfrac X (totalsubmonoid X) (λ a : totalsubmonoid X, iscanc (pr1 a)) is).
Defined.

(** *** Relations on the abelian group of fractions *)

Definition abgrdiffrelint (X : abmonoid) (L : hrel X) : hrel (setwithbinopdirprod X X) :=
  λ xa yb, hexists (λ c0 : X, L (((pr1 xa) + (pr2 yb)) + c0) (((pr1 yb) + (pr2 xa)) + c0)).

Definition abgrdiffrelint' (X : abmonoid) (L : hrel X) : hrel (setwithbinopdirprod X X) :=
  λ xa1 xa2, abmonoidfracrelint _ (totalsubmonoid X) L (abgrdiffphi X xa1) (abgrdiffphi X xa2).

Lemma logeqabgrdiffrelints (X : abmonoid) (L : hrel X) :
  hrellogeq (abgrdiffrelint' X L) (abgrdiffrelint X L).
Proof.
  split. unfold abgrdiffrelint. unfold abgrdiffrelint'.
  simpl. apply hinhfun. intro t2. set (a0 := pr1 (pr1 t2)).
  split with a0. apply (pr2 t2). simpl. apply hinhfun.
  intro t2. set (x0 := pr1 t2). split with (tpair _ x0 tt). apply (pr2 t2).
Defined.

Lemma iscomprelabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) :
  iscomprelrel (eqrelabgrdiff X) (abgrdiffrelint X L).
Proof.
  apply (iscomprelrellogeqf1 _ (logeqhrelsabgrdiff X)).
  apply (iscomprelrellogeqf2 _ (logeqabgrdiffrelints X L)).
  intros x x' x0 x0' r r0.
  apply (iscomprelabmonoidfracrelint
           _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)  _ _ _ _ r r0).
Defined.
Opaque iscomprelabgrdiffrelint.

Definition abgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) :=
  quotrel (iscomprelabgrdiffrelint X is).

Definition abgrdiffrel' (X : abmonoid) {L : hrel X} (is : isbinophrel L) : hrel (abgrdiff X) :=
  λ x x', abmonoidfracrel X (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                           (weqabgrdiff X x) (weqabgrdiff X x').

Definition logeqabgrdiffrels (X : abmonoid) {L : hrel X} (is : isbinophrel L) :
  hrellogeq (abgrdiffrel' X is) (abgrdiffrel X is).
Proof.
  intros x1 x2. split.
  - assert (int : ∏ x x', isaprop (abgrdiffrel' X is x x' -> abgrdiffrel X is x x')).
    {
      intros x x'.
      apply impred. intro.
      apply (pr2 _).
    }
    generalize x1 x2. clear x1 x2.
    apply (setquotuniv2prop _ (λ x x', make_hProp _ (int x x'))).
    intros x x'.
    change ((abgrdiffrelint' X L x x')  -> (abgrdiffrelint _ L x x')).
    apply (pr1 (logeqabgrdiffrelints X L x x')).
  - assert (int : ∏ x x', isaprop (abgrdiffrel X is x x' -> abgrdiffrel' X is x x')).
    intros x x'.
    apply impred. intro.
    apply (pr2 _).
    generalize x1 x2. clear x1 x2.
    apply (setquotuniv2prop _ (λ x x', make_hProp _ (int x x'))).
    intros x x'.
    change ((abgrdiffrelint X L x x') -> (abgrdiffrelint' _ L x x')).
    apply (pr2 (logeqabgrdiffrelints X L x x')).
Defined.

Lemma istransabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : istrans L) :
  istrans (abgrdiffrelint X L).
Proof.
  apply (istranslogeqf (logeqabgrdiffrelints X L)).
  intros a b c rab rbc.
  apply (istransabmonoidfracrelint
           _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)  isl _ _ _ rab rbc).
Defined.
Opaque istransabgrdiffrelint.

Lemma istransabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : istrans L) :
  istrans (abgrdiffrel X is).
Proof.
  refine (istransquotrel _ _). apply istransabgrdiffrelint.
  - apply is.
  - apply isl.
Defined.

Lemma issymmabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : issymm L) :
  issymm (abgrdiffrelint X L).
Proof.
  apply (issymmlogeqf (logeqabgrdiffrelints X L)).
  intros a b rab.
  apply (issymmabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl _ _ rab).
Defined.
Opaque issymmabgrdiffrelint.

Lemma issymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : issymm L) :
  issymm (abgrdiffrel X is).
Proof.
  refine (issymmquotrel _ _). apply issymmabgrdiffrelint.
  - apply is.
  - apply isl.
Defined.

Lemma isreflabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isrefl L) :
  isrefl (abgrdiffrelint X L).
Proof.
  intro xa. unfold abgrdiffrelint. simpl.
  apply hinhpr. split with (unel X). apply (isl _).
Defined.

Lemma isreflabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isrefl L) :
  isrefl (abgrdiffrel X is).
Proof.
  refine (isreflquotrel _ _). apply isreflabgrdiffrelint.
  - apply is.
  - apply isl.
Defined.

Lemma ispoabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : ispreorder L) :
  ispreorder (abgrdiffrelint X L).
Proof.
  split with (istransabgrdiffrelint X is (pr1 isl)).
  apply (isreflabgrdiffrelint X is (pr2 isl)).
Defined.

Lemma ispoabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : ispreorder L) :
  ispreorder (abgrdiffrel X is).
Proof.
  refine (ispoquotrel _ _). apply ispoabgrdiffrelint.
  - apply is.
  - apply isl.
Defined.

Lemma iseqrelabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iseqrel L) :
  iseqrel (abgrdiffrelint X L).
Proof.
  split with (ispoabgrdiffrelint X is (pr1 isl)).
  apply (issymmabgrdiffrelint X is (pr2 isl)).
Defined.

Lemma iseqrelabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iseqrel L) :
  iseqrel (abgrdiffrel X is).
Proof.
  refine (iseqrelquotrel _ _). apply iseqrelabgrdiffrelint.
  - apply is.
  - apply isl.
Defined.

Lemma isantisymmnegabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L)
      (isl : isantisymmneg L) : isantisymmneg (abgrdiffrel X is).
Proof.
  apply (isantisymmneglogeqf (logeqabgrdiffrels X is)).
  intros a b rab rba.
  set (int := isantisymmnegabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                                           isl (weqabgrdiff X a) (weqabgrdiff X b) rab rba).
  apply (invmaponpathsweq _ _ _ int).
Defined.

Lemma isantisymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isantisymm L) :
  isantisymm (abgrdiffrel X is).
Proof.
  apply (isantisymmlogeqf (logeqabgrdiffrels X is)).
  intros a b rab rba.
  set (int := isantisymmabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                                        isl (weqabgrdiff X a) (weqabgrdiff X b) rab rba).
  apply (invmaponpathsweq _ _ _ int).
Defined.
Opaque  isantisymmabgrdiffrel.

Lemma isirreflabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isirrefl L) :
  isirrefl (abgrdiffrel X is).
Proof.
  apply (isirrefllogeqf (logeqabgrdiffrels X is)).
  intros a raa.
  apply (isirreflabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                                 isl (weqabgrdiff X a) raa).
Defined.
Opaque isirreflabgrdiffrel.

Lemma isasymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isasymm L) :
  isasymm (abgrdiffrel X is).
Proof.
  apply (isasymmlogeqf (logeqabgrdiffrels X is)).
  intros a b rab rba.
  apply (isasymmabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                                isl (weqabgrdiff X a) (weqabgrdiff X b) rab rba).
Defined.
Opaque isasymmabgrdiffrel.

Lemma iscoasymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iscoasymm L) :
  iscoasymm (abgrdiffrel X is).
Proof.
  apply (iscoasymmlogeqf (logeqabgrdiffrels X is)).
  intros a b rab.
  apply (iscoasymmabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                                  isl (weqabgrdiff X a) (weqabgrdiff X b) rab).
Defined.
Opaque iscoasymmabgrdiffrel.

Lemma istotalabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : istotal L) :
  istotal (abgrdiffrel X is).
Proof.
  apply (istotallogeqf (logeqabgrdiffrels X is)).
  intros a b.
  apply (istotalabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                                isl (weqabgrdiff X a) (weqabgrdiff X b)).
Defined.
Opaque istotalabgrdiffrel.

Lemma iscotransabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iscotrans L) :
  iscotrans (abgrdiffrel X is).
Proof.
  apply (iscotranslogeqf (logeqabgrdiffrels X is)).
  intros a b c.
  apply (iscotransabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)
                                  isl (weqabgrdiff X a) (weqabgrdiff X b) (weqabgrdiff X c)).
Defined.
Opaque iscotransabgrdiffrel.

Lemma isStrongOrder_abgrdiff {X : abmonoid} (gt : hrel X)
      (Hgt : isbinophrel gt) :
  isStrongOrder gt → isStrongOrder (abgrdiffrel X Hgt).
Proof.
  intros H.
  repeat split.
  - apply istransabgrdiffrel, (istrans_isStrongOrder H).
  - apply iscotransabgrdiffrel, (iscotrans_isStrongOrder H).
  - apply isirreflabgrdiffrel, (isirrefl_isStrongOrder H).
Defined.
Opaque isStrongOrder_abgrdiff.

Definition StrongOrder_abgrdiff {X : abmonoid} (gt : StrongOrder X)
           (Hgt : isbinophrel gt) : StrongOrder (abgrdiff X) :=
  abgrdiffrel X Hgt,, isStrongOrder_abgrdiff gt Hgt (pr2 gt).

Lemma abgrdiffrelimpl (X : abmonoid) {L L' : hrel X} (is : isbinophrel L) (is' : isbinophrel L')
      (impl : ∏ x x', L x x' -> L' x x') (x x' : abgrdiff X) (ql : abgrdiffrel X is x x') :
  abgrdiffrel X is' x x'.
Proof.
  generalize ql. refine (quotrelimpl _ _ _ _ _).
  intros x0 x0'. simpl. apply hinhfun. intro t2. split with (pr1 t2).
  apply (impl _ _ (pr2 t2)).
Defined.
Opaque abgrdiffrelimpl.

Lemma abgrdiffrellogeq (X : abmonoid) {L L' : hrel X} (is : isbinophrel L) (is' : isbinophrel L')
      (lg : ∏ x x', L x x' <-> L' x x') (x x' : abgrdiff X) :
  (abgrdiffrel X is x x') <-> (abgrdiffrel X is' x x').
Proof.
  refine (quotrellogeq _ _ _ _ _). intros x0 x0'. split.
  - simpl. apply hinhfun. intro t2. split with (pr1 t2).
    apply (pr1 (lg _ _) (pr2 t2)).
  - simpl. apply hinhfun. intro t2. split with (pr1 t2).
    apply (pr2 (lg _ _) (pr2 t2)).
Defined.
Opaque abgrdiffrellogeq.

Lemma isbinopabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) :
  @isbinophrel (setwithbinopdirprod X X) (abgrdiffrelint X L).
Proof.
  apply (isbinophrellogeqf (logeqabgrdiffrelints X L)). split.
  - intros a b c lab.
    apply (pr1 (ispartbinopabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is))
               (abgrdiffphi X a) (abgrdiffphi X b) (abgrdiffphi X c) tt lab).
  - intros a b c lab.
    apply (pr2 (ispartbinopabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is))
               (abgrdiffphi X a) (abgrdiffphi X b) (abgrdiffphi X c) tt lab).
Defined.
Opaque isbinopabgrdiffrelint.

Lemma isbinopabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) :
  @isbinophrel (abgrdiff X) (abgrdiffrel X is).
Proof.
  intros.
  apply (isbinopquotrel (binopeqrelabgrdiff X) (iscomprelabgrdiffrelint X is)).
  apply (isbinopabgrdiffrelint X is).
Defined.

Definition isdecabgrdiffrelint (X : abmonoid) {L : hrel X}
           (is : isinvbinophrel L) (isl : isdecrel L) : isdecrel (abgrdiffrelint X L).
Proof.
  intros xa1 xa2.
  set (x1 := pr1 xa1). set (a1 := pr2 xa1).
  set (x2 := pr1 xa2). set (a2 := pr2 xa2).
  assert (int : coprod (L (x1 + a2) (x2 + a1)) (neg (L (x1 + a2) (x2 + a1)))) by apply (isl _ _).
  destruct int as [ l | nl ].
  - apply ii1. unfold abgrdiffrelint. apply hinhpr. split with (unel X).
    rewrite (runax X _). rewrite (runax X _). apply l.
  - apply ii2. generalize nl. clear nl. apply negf. unfold abgrdiffrelint.
    simpl. apply (@hinhuniv _ (make_hProp _ (pr2 (L _ _)))).
    intro t2l. destruct t2l as [ c0a l ]. simpl. apply ((pr2 is) _ _ c0a l).
Defined.

Definition isdecabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L)
           (isi : isinvbinophrel L) (isl : isdecrel L) : isdecrel (abgrdiffrel X is).
Proof.
  refine (isdecquotrel _ _). apply isdecabgrdiffrelint.
  - apply isi.
  - apply isl.
Defined.

(** *** Relations and the canonical homomorphism to [ abgrdiff ] *)

Lemma iscomptoabgrdiff (X : abmonoid) {L : hrel X} (is : isbinophrel L) :
  iscomprelrelfun L (abgrdiffrel X is) (toabgrdiff X).
Proof.
  unfold iscomprelrelfun.
  intros x x' l.
  change (abgrdiffrelint X L (make_dirprod x (unel X)) (make_dirprod x' (unel X))).
  simpl. apply (hinhpr). split with (unel X).
  apply ((pr2 is) _ _ 0). apply ((pr2 is) _ _ 0).
  apply l.
Defined.
Opaque iscomptoabgrdiff.

Close Scope addmonoid_scope.
End Fractions.


(** * Combi.MPoly.MurnaghanNakayama : Murnaghan-Nakayama rule *)
(******************************************************************************)
(*      Copyright (C) 2021-2021 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * The Murnaghan-Nakayama rule

See the page
#Murnaghan-Nakayama# on Wikipedia for a statement. The fixpoint [MN_coeff la mu]
implement the recursive version, as stated in
[[
Theorem MN_coeff_consE la m0 mu :
  MN_coeff la (m0 :: mu) =
  \sum_(sh : 'P_(sumn mu) | ribbon sh la)
   MN_coeff sh mu * (-1) ^+ (ribbon_height sh la).-1.
]]
and the base case
[[
Lemma MN_coeff0 : MN_coeff [::] [::] = 1.
]]
The Murnaghan-Nakayama rule stated in terms of symmetric polynomials is then
[[
Theorem MN_coeffP d (la : 'P_d) :
  'p[la] = \sum_(sh : 'P_d) (MN_coeff sh la)%:~R *: 's[sh] :> {sympoly R[n]}.
]]
There is a second implementation which goes bottom up, adding ribbons instead
of removing them. It allows to compute skew Murnaghan-Nakayama coefficients.

We provide the following definitions:

- [MN_coeff la mu] == then Murnaghan-Nakayama coefficients. That is the
               alternating number of ribbon filling of the shape [la]
               with content [mu], defined recursively.
- [MN_coeff_fast la mu] == fast version of [MN_coeff la mu]
- [MN_coeff_rec la nu mu] == The alternating number of ribbon filling of
               the skew shape [la / nu] with content [mu], defined recursively.
 ******)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp Require Import bigop ssralg ssrint perm fingroup tuple vector rat.
From SsrMultinomials Require Import ssrcomplements freeg mpoly monalg.

Require Import sorted tools ordtype permuted partition skewpart.
Require Import antisym Schur_mpoly Schur_altdef sympoly homogsym.

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

Local Open Scope ring_scope.
Import GRing.Theory.

Local Reserved Notation "''a_' k"
      (at level 8, k at level 2, format "''a_' k").
Local Reserved Notation "m # s"
      (at level 40, left associativity, format "m # s").

(** ** Product of an alternating polynomial and a power sum *)
Section MultAlternSymp.

Variable n0 : nat.
Variable R : comRingType.

Local Notation n := n0.+1.
Local Notation rho := (rho n).
Local Notation "''a_' k" := (@alternpol n R 'X_[k]).

Lemma mult_altern_symp_pol p d :
  'a_(mpart p + rho) * (symp_pol n R d.+1) =
   \sum_(i < n) 'a_(mpart p + rho + U_(i) *+ d.+1).
Proof.
rewrite /alternpol mulr_suml [RHS]exchange_big /=; apply eq_bigr => s _.
rewrite -scaler_sumr -scalerAl; congr (_ *: _).
rewrite -(issymP _ (symp_sym n R d.+1) s) -msymM -linear_sum /=; congr msym.
rewrite /symp_pol mulr_sumr; apply eq_bigr => i _.
by rewrite !mpolyXD mpolyXn.
Qed.

Lemma mult_altern_oapp p d :
  is_part p -> size p <= n ->
  'a_(mpart p + rho) * (symp_pol n R d.+1) =
  \sum_(i < n) oapp (fun ph => (-1) ^+ ph.2.-1 *: 'a_(mpart ph.1 + rho)) 0
   (add_ribbon p d i).
Proof.
move=> partp szp; rewrite mult_altern_symp_pol.
apply eq_bigr => i _ /=.
case Hrib : add_ribbon => [[sh h]|] /=.
  by rewrite (alt_straight_add_ribbon _ partp szp Hrib).
by rewrite (alt_straight_add_ribbon0 _ partp szp) // Hrib.
Qed.

Lemma mult_altern_pmap p d :
  is_part p -> size p <= n ->
  'a_(mpart p + rho) * (symp_pol n R d.+1) =
  \sum_(psh <- pmap (add_ribbon p d) (iota 0 n))
   (-1) ^+ (psh.2).-1 *: 'a_(mpart psh.1 + rho).
Proof.
move=> partp szp; rewrite mult_altern_oapp //.
rewrite -(big_mkord xpredT (fun i => oapp _ 0 (add_ribbon p d i))).
by rewrite big_pmap /index_iota subn0.
Qed.

End MultAlternSymp.

(** ** Product of a Schur polynomial and a power sum *)
(* We first state the theorem on ints and then transfer to any ring *)
Section MultSymsSympIDomain.

Variable n0 : nat.
Local Notation n := n0.+1.
Local Notation SF := {sympoly int[n]}.

Lemma syms_sympM_oapp_int d (la : 'P_d) m :
  m != 0%N -> size la <= n ->
  's[la] * 'p_m =
  \sum_(i < n) oapp (fun ph => (-1) ^+ ph.2.-1 *: 's[ph.1]) 0
   (add_ribbon_intpartn la m.-1 i) :> SF.
Proof.
case: m => // m _ szla; apply val_inj.
rewrite /= !raddf_sum /=.
apply: (mulfI (alt_rho_non0 n _)).
rewrite mulrA alt_SchurE //= mult_altern_oapp //.
rewrite mulr_sumr; apply eq_bigr => mu _.
rewrite add_ribbon_intpartnE.
case Haddrib: add_ribbon_intpartn => [[sh h]|]/=; last by rewrite mulr0.
move/add_ribbon_intpartnP in Haddrib.
rewrite -scalerAr alt_SchurE //.
by rewrite (size_add_ribbon Haddrib) geq_max szla ltn_ord.
Qed.

End MultSymsSympIDomain.

Section MultSymsSymp.

Variable n0 : nat.
Variable R : comRingType.
Local Notation n := n0.+1.
Local Notation SF := {sympoly R[n]}.

Lemma syms_sympM_oapp d (la : 'P_d) m :
  m != 0%N ->
  's[la] * 'p_m =
  \sum_(i < n) oapp (fun ph => (-1) ^+ ph.2.-1 *: 's[ph.1]) 0
   (add_ribbon_intpartn la m.-1 i) :> SF.
Proof.
move=> Hm.
case: (leqP (size la) n) => szla; first last.
  rewrite syms_oversize // mul0r; apply/esym/big1 => /= i _.
  case Haddrib: add_ribbon_intpartn => [[sh h]|]//=.
  move/add_ribbon_intpartnP in Haddrib.
  rewrite syms_oversize ?scaler0 //.
  by rewrite (size_add_ribbon Haddrib) leq_max szla.
rewrite -(map_syms [rmorphism of intr]) -(map_symp [rmorphism of intr]).
rewrite -rmorphM syms_sympM_oapp_int // rmorph_sum /=.
apply eq_bigr => i _.
case: add_ribbon_intpartn => [p|]/=; last by rewrite rmorph0.
by rewrite scale_map_sympoly rmorphX rmorphN1 map_syms.
Qed.

Lemma syms_sympM_pmap d (la : 'P_d) m :
  m != 0%N ->
  's[la] * 'p_m =
  \sum_(ph <- pmap (add_ribbon_intpartn la m.-1) (iota 0 n))
   (-1) ^+ ph.2.-1 *: 's[ph.1] :> SF.
Proof.
move=> Hm; rewrite syms_sympM_oapp //.
by rewrite big_pmap -[n in iota 0 n](subn0 n) -/(index_iota 0 n) big_mkord.
Qed.

(** The following theorem is a step of the Murnaghan-Nakayama rule *)
Theorem syms_sympM d (la : 'P_d) m :
  m != 0%N ->
  's[la] * 'p_m =
  \sum_(sh : 'P_(m + d) | ribbon la sh)
   (-1) ^+ (ribbon_height la sh).-1 *: 's[sh] :> SF.
Proof.
move=> Hm.
case: (ltnP n (size la)) => szla.
  rewrite syms_oversize // mul0r; apply/esym/big1 => /= i.
  move=> /ribbon_included/includedP [/(leq_trans szla)/syms_oversize -> _].
    by rewrite scaler0.
rewrite (syms_sympM_oapp _ Hm).
case: m Hm => // m _.
rewrite (bigID (fun i : 'I_n => add_ribbon_intpartn la m i)) /=.
rewrite [X in _ + X = _]big1 ?addr0;
  last by move=> i; case: add_ribbon_intpartn.
rewrite [RHS](bigID (fun sh => size (val sh) <= n)) /=.
rewrite [X in _ = _ + X]big1 ?addr0; first last => [mu /andP[_]|].
  by rewrite -ltnNge => /syms_oversize ->; rewrite scaler0.
have ribbon_stop_subproof (mu : 'P_(m.+1 + d)) :
  (if size mu <= n then (mindropeq la mu).-1 else 0%N) < n.
  case: (leqP (size mu) n) => // szmu.
  case: mindropeq (mindropeq_leq la mu) => // md /= /leq_trans; apply.
  by rewrite geq_max szla szmu.
pose ribbon_stop mu := Ordinal (ribbon_stop_subproof mu).
rewrite (reindex_omap ribbon_stop
          (omap fst \o (add_ribbon_intpartn la m))) /=; first last => [i|].
  case Haddrib: add_ribbon_intpartn => [[res h]|]//= _.
  move/add_ribbon_intpartnP in Haddrib.
  congr Some; apply val_inj => /=.
  rewrite (size_add_ribbon Haddrib) geq_max szla ltn_ord /=.
  rewrite (ribbon_on_mindropeq (intpartnP la) _ (add_ribbon_onP Haddrib)) //.
  exact: (is_part_add_ribbon _ Haddrib).
apply esym; apply: eq_big => mu.
  rewrite andbC; case leqP => Hszmu /=; first last.
  + case Haddrib: add_ribbon_intpartn => [[res h]|] //=; first last.
    move/add_ribbon_intpartnP in Haddrib.
    case (altP (_ =P Some mu)) => // [[Heq]].
    have := size_add_ribbon Haddrib; rewrite {res Haddrib}Heq /= => Heq.
    by move: Hszmu; rewrite Heq leq_max 2!ltnNge szla.
  + apply esym; case: (boolP (ribbon la mu)) => [Hrib | Hnrib].
    * have := ribbon_addE (intpartnP la) (intpartnP mu) Hrib.
      rewrite sumn_diff_shape ?ribbon_included // !sumn_intpartn addnK.
      rewrite add_ribbon_intpartnE.
      case Haddrib: add_ribbon_intpartn => [[res h]|]//=.
      by move=> [/val_inj ->]; rewrite eqxx.
    * case Haddrib: add_ribbon_intpartn => [[res h]|]//=.
      move/add_ribbon_intpartnP in Haddrib.
      apply/negP => /eqP [] Heq.
      by move: Hnrib; rewrite -{}Heq (add_ribbonP _ Haddrib).
move=> /andP[Hrib ->].
have:= ribbon_addE (intpartnP la) (intpartnP mu) Hrib.
rewrite sumn_diff_shape ?ribbon_included // !sumn_intpartn addnK.
rewrite add_ribbon_intpartnE.
by case Haddrib: add_ribbon_intpartn => [[res h]|]//= [/val_inj -> <-].
Qed.

End MultSymsSymp.

(** * Murnaghan-Nakayama coefficients *)

(** We define those for any sequence of nat, but              *)
(** [MN_coeff] should only be used when [sumn la == sumn mu]. *)
Fixpoint MN_coeff (la mu : seq nat) : int :=
  if mu is m0 :: m then
    foldr (fun sh acc =>
             if ribbon sh la then
               MN_coeff sh m * (-1) ^+ (ribbon_height sh la).-1 + acc
             else acc)
          0 (enum_partn (sumn m))
  else 1.

(** Base case *)
Lemma MN_coeff0 : MN_coeff [::] [::] = 1.
Proof. by []. Qed.

(** Recursive step *)
Theorem MN_coeff_consE la m0 mu :
  MN_coeff la (m0 :: mu) =
  \sum_(sh : 'P_(sumn mu) | ribbon sh la)
   MN_coeff sh mu * (-1) ^+ (ribbon_height sh la).-1.
Proof.
apply esym; transitivity (
                \sum_(sh <- enum_partn (sumn mu) | ribbon sh la)
                 MN_coeff sh mu * (-1) ^+ (ribbon_height sh la).-1).
  by rewrite -enum_intpartnE [LHS]big_mkcond [RHS]big_mkcond big_map big_enum.
rewrite big_mkcond /=; elim: enum_partn => [| p0 p] /=; first by rewrite big_nil.
by rewrite big_cons => ->; case: (ribbon p0 la); rewrite //= add0r.
Qed.

Section Tests.
(** Tests :
<<
sage: s(p[2,1,1])
-s[1, 1, 1, 1] - s[2, 1, 1] + s[3, 1] + s[4]
>>
*****)
Goal ([seq x | x <- [seq (p, MN_coeff p [:: 2; 1; 1]) | p <- enum_partn 4]
               & x.2 != 0%R] =
      [:: ([:: 4], Posz 1);
      ([:: 3; 1], Posz 1);
      ([:: 2; 1; 1], Negz 0);
      ([:: 1; 1; 1; 1], Negz 0)])%N.
Proof. by []. Abort.

(** Tests :
<<
sage: s(p[4,2,1,1])
s[1, 1, 1, 1, 1, 1, 1, 1] + s[2, 1, 1, 1, 1, 1, 1] - s[3, 1, 1, 1, 1, 1]
 - 2*s[3, 3, 2] - s[4, 1, 1, 1, 1] + 2*s[4, 2, 1, 1] - s[5, 1, 1, 1]
 - s[6, 1, 1] + s[7, 1] + s[8]
>>
*****)
Goal ([seq x | x <- [seq (p, MN_coeff p [:: 4; 2; 1; 1]) | p <- enum_partn 8]
               & x.2 != 0%R] =
      [:: ([:: 8], Posz 1);
      ([:: 7; 1], Posz 1);
      ([:: 3; 3; 2], Negz 1);
      ([:: 6; 1; 1], Negz 0);
      ([:: 4; 2; 1; 1], Posz 2);
      ([:: 5; 1; 1; 1], Negz 0);
      ([:: 4; 1; 1; 1; 1], Negz 0);
      ([:: 3; 1; 1; 1; 1; 1], Negz 0);
      ([:: 2; 1; 1; 1; 1; 1; 1], Posz 1);
      ([:: 1; 1; 1; 1; 1; 1; 1; 1], Posz 1)])%N.
Proof. by []. Abort.

End Tests.

(** * Murnaghan-Nakayama rule *)
Section MNRule.

Variable n0 : nat.
Local Notation n := n0.+1.

Theorem MN_coeffP_int d (la : 'P_d) :
  'p[la] = \sum_(sh : 'P_d) MN_coeff sh la *: 's[sh] :> {sympoly int[n]}.
Proof.
rewrite /prod_symp /prod_gen.
case: la => la /= /andP [/eqP <-{d} /in_part_non0].
elim: la => [/=|l0 la IHla] Hall.
  rewrite big_nil (big_pred1 (rowpartn 0)) ?scale1r ?syms0 //.
  by move=> i /=; rewrite intpartn0 eqxx.
rewrite big_cons {}IHla; first last.
  by move=> i iinla; apply: Hall; rewrite inE {}iinla orbT.
under [RHS]eq_bigr do rewrite MN_coeff_consE.
rewrite mulr_sumr.
have {Hall} l0n0 : l0 != 0%N by apply: Hall; rewrite inE eqxx.
under eq_bigr do rewrite mulrC -scalerAl syms_sympM // scaler_sumr.
rewrite (exchange_big_dep xpredT) //=; apply: eq_bigr => mu _.
rewrite scaler_suml; apply eq_bigr => nu _.
by rewrite scalerA.
Qed.

Variable R : comRingType.
Local Notation SF := {sympoly R[n]}.
Local Notation HSF := {homsym R[n, _]}.

Theorem MN_coeffP d (la : 'P_d) :
  'p[la] = \sum_(sh : 'P_d) (MN_coeff sh la)%:~R *: 's[sh] :> SF.
Proof.
rewrite -(map_symp_prod [rmorphism of intr]) MN_coeffP_int rmorph_sum /=.
by under [LHS]eq_bigr do rewrite scale_map_sympoly map_syms.
Qed.

Corollary MN_coeff_homogP d (la : 'P_d) :
  'hp[la] = \sum_(sh : 'P_d) (MN_coeff sh la)%:~R *: 'hs[sh] :> HSF.
Proof.
apply val_inj => /=; apply val_inj => /=.
have /= := congr1 val (MN_coeffP la); rewrite /prod_symp => ->.
by rewrite !raddf_sum.
Qed.

End MNRule.

(** [MN_coeff_rec] should only be used when [sumn la == sum nu + sumn mu]. *)
Fixpoint MN_coeff_rec (la nu mu : seq nat) : int :=
  if mu is m0 :: m then
    foldr (fun psh acc =>
             MN_coeff_rec la psh.1 m * (-1) ^+ psh.2.-1 + acc)
          0
          [seq psh | psh <- pmap (add_ribbon nu m0.-1) (iota 0 (size la))
                   & included psh.1 la]
  else (la == nu).
Definition MN_coeff_fast la mu := MN_coeff_rec la [::] mu.

Lemma MN_coeff_rec_szE la nu m0 mu :
  MN_coeff_rec la nu (m0 :: mu) =
  \sum_(psh <- pmap (add_ribbon nu m0.-1) (iota 0 (size la))
       | included psh.1 la)
   MN_coeff_rec la psh.1 mu * (-1) ^+ psh.2.-1.
Proof.
rewrite /=; elim: pmap => [|[sh0 h0] s IHs]/=; first by rewrite big_nil.
by rewrite big_cons /= -{}IHs; case: included.
Qed.

Lemma MN_coeff_rec_notincl la nu mu :
  0%N \notin mu -> is_part nu ->  ~~ included nu la ->
  MN_coeff_rec la nu mu = 0.
Proof.
elim: mu nu => [/= |[|m0] mu IHmu] nu //.
  by case: eqP => // ->; rewrite included_refl.
rewrite inE negb_or eq_sym => /andP[_ {}/IHmu Hrec] partnu nincl.
rewrite MN_coeff_rec_szE big_mkcond big_pmap /=; apply big1 => i _.
case Haddrib : add_ribbon => [[sh h]|]//=.
suff /negbTE -> : ~~ included sh la by [].
by apply/contra : nincl =>
  /(included_trans (included_add_ribbon partnu Haddrib)).
Qed.

Lemma MN_coeff_rec_consE n la nu m0 mu :
  m0 != 0%N -> size la <= n ->
  MN_coeff_rec la nu (m0 :: mu) =
  \sum_(psh <- pmap (add_ribbon nu m0.-1) (iota 0 n) | included psh.1 la)
   MN_coeff_rec la psh.1 mu * (-1) ^+ psh.2.-1.
Proof.
case: m0 => // m0 _ Hsz; rewrite MN_coeff_rec_szE.
rewrite big_mkcond big_pmap -(subn0 (size la)) -/(index_iota 0 _) /=.
rewrite [RHS]big_mkcond big_pmap -(subn0 n) -/(index_iota 0 _) /=.
rewrite (big_cat_nat _ _ _ _ Hsz) //=.
rewrite [X in _ + X]big_nat [X in _ + X]big1 ?addr0 // => i /andP[leszi _].
case Haddrib : add_ribbon => [[sh h]|]//=.
suff /negbTE -> : ~~ included sh la by [].
apply/negP => /includedP [] + _.
by rewrite (size_add_ribbon Haddrib) geq_max ltnNge leszi andbF.
Qed.

Section Tests.

(** Tests :
<<
sage: s(p[3, 3, 1, 1]).coefficient([5, 2, 1])
-2
>>
*****)
Goal MN_coeff_fast [:: 5; 2; 1]%N [:: 3; 3; 1; 1]%N = - 2%:R.
Proof. by []. Abort.
(** Tests :
<<
sage: s(p[5, 2, 1]).coefficient([3, 3, 1, 1])
1
>>
*****)
Goal MN_coeff_fast [:: 3; 3; 1; 1]%N [:: 5; 2; 1]%N = 1%:R.
Proof. by []. Abort.

(** Tests :
<<
sage: s(p[6, 5, 5, 4, 2, 1]).coefficient([12, 5, 2, 2, 1, 1])
4
>>
*****)
Goal MN_coeff_fast [:: 12; 5; 2; 2; 1; 1]%N [:: 6; 5; 5; 4; 2; 1]%N = 4%:R.
Proof. by []. Abort.
(** Tests :
<<
sage: s(p[6, 5, 5, 4, 2, 1]).coefficient([12, 5, 3, 1, 1, 1])
-2
>>
*****)
Goal MN_coeff_fast [:: 12; 5; 3; 1; 1; 1]%N [:: 6; 5; 5; 4; 2; 1]%N = - 2%:R.
Proof. by []. Abort.
Goal MN_coeff_fast [:: 12; 5; 3; 2; 1]%N [:: 6; 5; 5; 4; 2; 1]%N = - 3%:R.
Proof. by []. Abort.
Goal MN_coeff_fast [:: 12; 5; 4; 1; 1]%N [:: 6; 5; 5; 4; 2; 1]%N = 2%:R.
Proof. by []. Abort.
Goal MN_coeff_fast [:: 12; 5; 4; 2]%N [:: 6; 5; 5; 4; 2; 1]%N = 4%:R.
Proof. by []. Abort.

End Tests.

Section FastImplem.

Variable n0 : nat.
Local Notation n := n0.+1.

Lemma syms_prod_sympM_int dn (nu : 'P_dn) dm (mu : 'P_dm) :
  's[nu] * 'p[mu] =
  \sum_(la : 'P_(dn + dm)) MN_coeff_rec la nu mu *: 's[la] :> {sympoly int[n]}.
Proof.
case: mu => [mu /= Hnu]; rewrite /prod_symp /prod_gen /=.
move: Hnu => /andP[/eqP <-{dm} /notin0_part].
elim: mu dn nu => [|m0 mu IHmu] d nu.
  rewrite big_nil mulr1 (bigD1 (cast_intpartn (esym (addn0 d)) nu)) //=.
  rewrite syms_cast cast_intpartnE // eqxx scale1r.
  rewrite big1 ?addr0 // => la.
  rewrite -val_eqE /= cast_intpartnE => /negbTE ->.
  by rewrite scale0r.
rewrite inE negb_or eq_sym => /andP [Hm0 Hmu].
rewrite big_cons mulrA syms_sympM_oapp //.
move Hmmu : (m0 :: mu) => mmu.  (* to prevent the expansion of MN_coeff_rec *)
rewrite [RHS](bigID (fun sh => size (val sh) <= n)) /=.
rewrite [X in _ + X]big1 ?addr0; first last => [la|].
  by rewrite -ltnNge => /syms_oversize ->; rewrite scaler0.
under [RHS]eq_bigr => la Hla.
  rewrite -{2}Hmmu (MN_coeff_rec_consE _ _ Hm0 Hla).
  rewrite big_mkcond big_pmap.
  rewrite -[n in iota 0 n](subn0 n) -/(index_iota 0 n) big_mkord /=.
  by rewrite scaler_suml over.
rewrite [RHS]exchange_big /= mulr_suml; apply: eq_bigr => i _.
rewrite -{mmu}Hmmu; case: m0 Hm0 => // m0 _ /=.
rewrite add_ribbon_intpartnE.
case Haddrib: add_ribbon_intpartn => [[res h]|]/=; first last.
  by rewrite mul0r; apply/esym/big1 => t; rewrite scale0r.
rewrite -scalerAl {}IHmu // scaler_sumr.
have cast_eq : (d + (m0.+1 + sumn mu) = m0.+1 + d + sumn mu)%N.
  by rewrite [(m0.+1 + d)%N]addnC addnA.
rewrite (reindex _ (onW_bij _ (cast_intpartn_bij cast_eq))) /=.
under [LHS]eq_bigr do rewrite cast_intpartnE syms_cast /=.
rewrite [LHS](bigID (fun sh => size (val sh) <= n)) /=.
rewrite [X in _ + X]big1 ?addr0; first last => [la|].
  by rewrite -ltnNge => /syms_oversize ->; rewrite !scaler0.
apply eq_bigr => la szla.
case: (boolP (included res la)) => incl; first by rewrite scalerA mulrC.
by rewrite MN_coeff_rec_notincl // !scale0r scaler0.
Qed.

Section ComRing.

Variable R : comRingType.
Local Notation SF := {sympoly R[n]}.
Local Notation HSF := {homsym R[n, _]}.

Theorem syms_prod_sympM dn (nu : 'P_dn) dm (mu : 'P_dm) :
  's[nu] * 'p[mu] =
  \sum_(la : 'P_(dn + dm)) (MN_coeff_rec la nu mu)%:~R *: 's[la] :> SF.
Proof.
rewrite -(map_syms [rmorphism of intr]) -(map_symp_prod [rmorphism of intr]).
rewrite -rmorphM syms_prod_sympM_int rmorph_sum /=.
by under [LHS]eq_bigr do rewrite scale_map_sympoly map_syms.
Qed.

Corollary homsyms_homsympM dn (nu : 'P_dn) dm (mu : 'P_dm) :
  'hs[nu] *h 'hp[mu] =
  \sum_(la : 'P_(dn + dm)) (MN_coeff_rec la nu mu)%:~R *: 'hs[la] :> HSF.
Proof.
apply val_inj => /=; apply val_inj => /=.
have /= := congr1 val (syms_prod_sympM nu mu); rewrite /prod_symp => ->.
by rewrite !raddf_sum.
Qed.

Corollary MN_coeff_recP d (la : 'P_d) :
  'p[la] = \sum_(sh : 'P_d) (MN_coeff_fast sh la)%:~R *: 's[sh] :> SF.
Proof.
rewrite -[LHS]mul1r -(syms0 _ _ (colpartn 0)).
by rewrite syms_prod_sympM; apply eq_bigr => sh _; rewrite colpartnE.
Qed.

Corollary MN_coeff_rec_homogP d (la : 'P_d) :
  'hp[la] = \sum_(sh : 'P_d) (MN_coeff_fast sh la)%:~R *: 'hs[sh] :> HSF.
Proof.
apply val_inj => /=; apply val_inj => /=.
have /= := congr1 val (MN_coeff_recP la); rewrite /prod_symp => ->.
by rewrite !raddf_sum.
Qed.

End ComRing.

End FastImplem.

(** The two implementations coincide *)
Corollary MN_coeffE d (la mu : 'P_d) : MN_coeff_fast la mu = MN_coeff la mu.
Proof.
pose HSF := {homsym rat[(sumn mu).+1 , d]}.
pose Pval i := (@enum_val _ xpredT i : 'P_d).
have : \sum_i (MN_coeff_rec (Pval i) [::] mu)%:~R *: 'hs`_i =
       \sum_i (MN_coeff     (Pval i) mu     )%:~R *: 'hs`_i :> HSF.
  rewrite !(reindex _ (onW_bij _ (@enum_rank_bij [finType of 'P_d]))) /=.
  under [LHS]eq_bigr do rewrite /Pval symbsE enum_rankK.
  under [RHS]eq_bigr do rewrite /Pval symbsE enum_rankK.
  by rewrite -[LHS]MN_coeff_rec_homogP -[RHS]MN_coeff_homogP.
move/(congr1 (coord 'hs (enum_rank la))) => /eqP.
have free_hs : free ('hs : seq HSF) by apply: symbs_free; rewrite sumn_intpartn.
by rewrite !coord_sum_free // {}/Pval enum_rankK => /eqP/intr_inj.
Qed.


Require Import simple.

Require Import List.
Require Import ZArith.

Definition average_fun :=
  FunDef "average" ["x";"y";"z"]
  (Seq (Decl "sum")
  (Seq (SAssign "sum" (EPlus (EPlus (EVar "x") (EVar "y")) (EVar "z")))
       (SReturn (EDiv (EVar "sum") (ECon 3))))).

Inductive average_spec : Spec kcfg :=
  | average_claim : forall xv yv zv,
      simple_fun average_spec average_fun [Int xv; Int yv; Int zv]
         (Int ((xv + yv + zv)  / 3)%Z).
Lemma average_proof : sound kstep average_spec.
Proof. simple_solver. Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import Arith.

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_nat utils_decidable pos vec.

From Undecidability.MuRec
  Require Import recalg ra_utils.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

Section ra_min_extra.

  Variable (n : nat) (f : recalg (S n)) (v : vec nat n).

  Hypothesis Hf : forall x, ex (⟦f⟧ (x##v)).

  Theorem ra_min_extra : ex (⟦ra_min f⟧ v) <-> exists x, ⟦f⟧ (x##v) 0.
  Proof using Hf.
    split.
    + intros (x & H1 & H2); exists x; auto.
    + intros (x & Hx).
      destruct bounded_min_d with (P := fun x => ⟦f⟧ (x##v) 0)
                                  (Q := fun x => exists k, ⟦f⟧ (x##v) (S k))
                                  (n := S x)
        as [ (m & H1 & H2 & H3) | H1 ]; auto.
      * intros y _; destruct (Hf y) as ([ | k ] & Hk); auto.
        right; exists k; auto.
      * exists m; split; auto.
      * destruct (H1 _ (le_refl _)) as (k & Hk).
        generalize (ra_rel_fun _ _ _ _ Hx Hk); discriminate.
  Qed.

End ra_min_extra.

Section ra_min_extra'.

  Variable (n : nat) (f : recalg (S n)) (v : vec nat n).

  Hypothesis Hf : forall x, ⟦f⟧ (x##v) 0 \/ ⟦f⟧ (x##v) 1.

  Theorem ra_min_ex : ex (⟦ra_min f⟧ v) <-> exists x, ⟦f⟧ (x##v) 0.
  Proof using Hf.
    apply ra_min_extra.
    intros x; destruct (Hf x); firstorder.
  Qed.

End ra_min_extra'.

Section ra_enum.

  Variables (k : nat) (f : recalg (S k)).

  Let a : recalg (S (S k)).
  Proof.
    ra root f.
    + ra arg pos0.
    + apply vec_set_pos; intros p.
      ra arg (pos_nxt (pos_nxt p)).
  Defined.

  Let Ha v x : ⟦a⟧ v x <-> ⟦f⟧ (vec_pos v pos0##vec_tail (vec_tail v)) x.
  Proof.
    unfold a.
    rewrite ra_rel_fix_comp; simpl.
    split.
    + intros (w & H1 & H2); revert H1 H2.
      vec split w with y; intros H1 H2.
      generalize (H2 pos0); simpl; intros H3; subst.
      eq goal H1; do 2 f_equal.
      apply vec_pos_ext; intros p.
      specialize (H2 (pos_nxt p)); simpl in H2.
      rewrite vec_pos_map, vec_pos_set in H2; simpl in H2.
      rewrite <- H2; repeat rewrite vec_pos_tail; auto.
    + vec split v with p; vec split v with q; simpl; intros H.
      exists (p##v); split; auto.
      intros y; analyse pos y; simpl; auto.
      rewrite vec_pos_map, vec_pos_set; simpl; auto.
  Qed.

  Let b : recalg (S (S k)).
  Proof.
    ra root ra_succ.
    ra arg pos1.
  Defined.

  Let Hb v x : ⟦b⟧ v x <-> x = S (vec_pos v pos1).
  Proof.
    unfold b; simpl; split.
    + intros (w & H1 & H2); revert H1 H2.
      vec split w with y; vec nil w; intros H1 H2.
      specialize (H2 pos0); simpl in H2; subst; auto.
    + intros H; exists (vec_pos v pos1##vec_nil); subst; split; simpl; auto.
      pos split; simpl; auto.
  Qed.

  Opaque a b.

  Let g : recalg (S (S k)).
  Proof.
    ra root ra_eq.
    + exact a.
    + exact b.
  Defined.

  Hypothesis Hf : forall v, exists x, ⟦f⟧ v x.

  Let Hg v : exists e, ⟦g⟧ v e /\ (e = 0 <-> ⟦f⟧ (vec_pos v pos0##vec_tail (vec_tail v)) (S (vec_pos v pos1))).
  Proof.
    unfold g.
    destruct (Hf (vec_pos v pos0##vec_tail (vec_tail v))) as (x & Hx).
    destruct (ra_eq_rel (x##S (vec_pos v pos1)##vec_nil)) as (e & H1 & H2).
    exists e; split.
    + exists (x##S (vec_pos v pos1)##vec_nil); split; auto.
      intros p; analyse pos p; simpl.
      * apply Ha; auto.
      * apply Hb; auto.
    + simpl in H2; rewrite H2; split.
      * intros; subst; auto.
      * revert Hx; apply ra_rel_fun.
  Qed.

  Opaque g.

  Definition ra_enum : recalg (S k).
  Proof using a. apply ra_min, g. Defined.

  (* A reduction of listability into recursive computability *)

  Fact ra_enum_spec x v : ex (⟦ra_enum⟧ (x##v)) <-> exists n, ⟦f⟧ (n##v) (S x).
  Proof using Hf.
    unfold ra_enum; simpl; unfold s_min.
    rewrite μ_min_of_total.
    + split.
      * intros (r & Hr).
        destruct (Hg (r##x##v)) as (e & H1 & H2).
        simpl in H2.
        exists r; apply H2.
        revert H1 Hr; apply ra_rel_fun.
      * intros (n & Hn); exists n.
        destruct (Hg (n##x##v)) as (e & H1 & H2).
        apply H2 in Hn; subst; auto.
    + intros ? ? ?; apply ra_rel_fun.
    + intros y; destruct (Hg (y##x##v)) as (e & ? & _).
      exists e; auto.
  Qed.

End ra_enum.


Require Import RelationClasses.

From Paco Require Import paco.
From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Time.

Fixpoint incr_time_seq (n: nat): Time.t :=
  match n with
  | O => BinNums.xI (BinNums.xH)
  | S n' => BinNums.xI (incr_time_seq n')
  end.

Lemma incr_time_seq_succesor' n
  :
    DenseOrder.DOAux.lt (incr_time_seq n) (incr_time_seq (S n)).
Proof.
  ginduction n; ss; i.
  { econs. econs. }
  { econs. eauto. }
Qed.

Lemma incr_time_seq_lt' n0 n1
      (LT: n0 < n1)
  :
    DenseOrder.DOAux.lt (incr_time_seq n0) (incr_time_seq n1).
Proof.
  ginduction LT.
  { eapply incr_time_seq_succesor'. }
  { etrans.
    { eapply IHLT. }
    { eapply incr_time_seq_succesor'. }
  }
Qed.

Lemma incr_time_seq_diverge' ts
  :
    exists n, <<LT: DenseOrder.DOAux.lt ts (incr_time_seq n)>>.
Proof.
  ginduction ts.
  { des. exists (S n). ss. econs. eauto. }
  { exists 0. ss. econs. }
  { exists 0. ss. econs. }
Qed.

Lemma incr_time_seq_lt n0 n1
      (LT: n0 < n1)
  :
    Time.lt (incr_time_seq n0) (incr_time_seq n1).
Proof.
  set (incr_time_seq_lt' n0 n1 LT). inv l; try by econs.
  destruct n0; ss.
Qed.

Lemma incr_time_seq_diverge ts
  :
    exists n, <<LT: Time.lt ts (incr_time_seq n)>>.
Proof.
  set (incr_time_seq_diverge' ts). des.
  exists n. inv LT; try by econs.
  destruct n; ss.
Qed.

Definition lb_time (times: Time.t -> Prop) (ts ts': Time.t) :=
  forall t (IN: times t) (LT: Time.lt ts t),
    Time.lt ts' t.

Lemma eq_lb_time times ts
  :
    lb_time times ts ts.
Proof.
  ii. auto.
Qed.

Lemma lb_time_lower times ts ts'0 ts'1
      (LB: lb_time times ts ts'0)
      (TS: Time.le ts'1 ts'0)
  :
    lb_time times ts ts'1.
Proof.
  ii. exploit LB; eauto.
  i. eapply TimeFacts.le_lt_lt; eauto.
Qed.

Definition well_ordered (times: Time.t -> Prop): Prop :=
  forall (sub: Time.t -> Prop)
         (SUB: sub <1= times)
         x
         (INHABITED: sub x),
  exists ts,
    (<<SAT: sub ts>>) /\
    (<<LEAST: forall ts' (IN: sub ts'), Time.le ts ts'>>).

Lemma lb_time_exists times
      (WO: well_ordered times)
      ts
  :
    exists ts', <<TS: Time.lt ts ts'>> /\ <<LB: lb_time times ts ts'>>.
Proof.
  destruct (classic (exists x, __guard__(fun x => <<IN: times x>> /\ <<LT: Time.lt ts x>>) x)).
  { des. eapply WO in H.
    { des. exists (Time.middle ts ts0). unguard. des. splits; auto.
      { eapply Time.middle_spec; auto. }
      { ii. hexploit (LEAST t).
        { splits; eauto. }
        i. eapply TimeFacts.lt_le_lt; eauto.
        eapply Time.middle_spec; auto. }
    }
    { i. unguard. ss. des. auto. }
  }
  { exists (Time.incr ts). splits; auto.
    { eapply Time.incr_spec. }
    { ii. exfalso. eapply H. unguard. esplits; eauto. }
  }
Qed.

Lemma sub_well_ordered times0 times1
      (WO: well_ordered times0)
      (SUB: times1 <1= times0)
  :
    well_ordered times1.
Proof.
  ii. exploit WO.
  { i. eapply SUB. eapply SUB0. eapply PR. }
  { eauto. }
  { i. des. exists ts. splits; eauto. }
Qed.

Lemma join_well_ordered times0 times1
      (WO0: well_ordered times0)
      (WO1: well_ordered times1)
  :
    well_ordered (times0 \1/ times1).
Proof.
  ii. exploit SUB; eauto. i. des.
  { destruct (classic (exists ts1, <<IN1: (sub /1\ times1) ts1>>)) as [?|NIN].
    { des. exploit (WO0 (sub /1\ times0)).
      { i. des; auto. }
      { instantiate (1:=x). splits; auto. } i. des.
      exploit (WO1 (sub /1\ times1)).
      { i. des; auto. }
      { instantiate (1:=ts1). splits; auto. } i. des.
      exists (Time.meet ts ts0). splits; auto.
      { unfold Time.meet. des_ifs. }
      { i. unfold Time.meet. des_ifs.
        { exploit SUB; eauto. i. des; eauto. }
        { exploit SUB; eauto. i. des; eauto.
          exploit LEAST; eauto. i.
          transitivity ts; eauto. left. auto. }
      }
    }
    { exploit (WO0 sub); eauto.
      i. exploit SUB; eauto. i. des; auto. exfalso. eauto. }
  }
  { destruct (classic (exists ts0, <<IN0: (sub /1\ times0) ts0>>)) as [?|NIN].
    { des. exploit (WO1 (sub /1\ times1)).
      { i. des; auto. }
      { instantiate (1:=x). splits; auto. } i. des.
      exploit (WO0 (sub /1\ times0)).
      { i. des; auto. }
      { instantiate (1:=ts0). splits; auto. } i. des.
      exists (Time.meet ts ts1). splits; auto.
      { unfold Time.meet. des_ifs. }
      { i. unfold Time.meet. des_ifs.
        { exploit SUB; eauto. i. des; eauto. }
        { exploit SUB; eauto. i. des; eauto.
          exploit LEAST; eauto. i.
          transitivity ts; eauto. left. auto. }
      }
    }
    { exploit (WO1 sub); eauto.
      i. exploit SUB; eauto. i. des; auto. exfalso. eauto. }
  }
Qed.

Lemma empty_well_ordered
  :
    well_ordered bot1.
Proof.
  ii. eapply SUB in INHABITED. ss.
Qed.

Lemma singleton_well_ordered ts
  :
    well_ordered (eq ts).
Proof.
  ii. exploit SUB; eauto. i. subst.
  esplits; eauto. i. eapply SUB in IN. subst. refl.
Qed.

Lemma finite_well_ordered (l: list Time.t)
  :
    well_ordered (fun ts => List.In ts l).
Proof.
  induction l.
  { ss. eapply empty_well_ordered. }
  { ss. eapply join_well_ordered; eauto.
    eapply singleton_well_ordered. }
Qed.

Lemma finite_join_well_ordered
      (sets: nat -> (Time.t -> Prop))
      (WO: forall n, well_ordered (sets n))
      n
  :
    well_ordered (fun ts => exists n', (<<LT: n' < n>>) /\ (<<SAT: sets n' ts>>)).
Proof.
  induction n.
  { eapply sub_well_ordered with (times0 := bot1).
    { eapply empty_well_ordered. }
    { i. ss. des. inv LT. }
  }
  { eapply sub_well_ordered.
    { eapply join_well_ordered.
      { eapply IHn. }
      { eapply (WO n). }
    }
    { i. des. inv LT; auto. left. exists n'; eauto. }
  }
Qed.

Lemma increasing_join_well_ordered
      (f: nat -> Time.t)
      (sets: nat -> (Time.t -> Prop))
      (MON: forall n0 n1 (LT: n0 < n1), Time.lt (f n0) (f n1))
      (DIV: forall ts, exists n, <<LT: Time.lt ts (f n)>>)
      (LB: forall n ts (SAT: sets n ts), Time.le (f n) ts)
      (WO: forall n, well_ordered (sets n))
  :
    well_ordered (fun ts => exists n, <<SAT: sets n ts>>).
Proof.
  ii. hexploit (DIV x); eauto. i. des.
  exploit SUB; eauto. i. des.
  assert (LT0: n0 < n).
  { destruct (Compare_dec.le_lt_dec n n0); auto.
    exfalso. eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
    { eapply LB. eapply SAT. } eapply TimeFacts.lt_le_lt.
    { eapply LT. }
    { eapply Lt.le_lt_or_eq in l. des.
      { left. eapply MON; eauto. }
      { subst. refl. }
    }
  }
  exploit finite_join_well_ordered.
  { eapply WO. }
  { instantiate (1:=n).
    instantiate (1:=fun ts =>
                      exists n', (<<LT: n' < n>>) /\ (<<SAT: sets n' ts>>) /\ (<<SUB: sub ts>>)).
    i. ss. des. eauto. }
  { instantiate (1:=x). ss. esplits; eauto. }
  i. des. exists ts. splits; auto.
  i. destruct (Time.le_lt_dec x ts').
  { transitivity x; auto. eapply LEAST. exists n0. splits; auto. }
  { exploit (SUB ts'); eauto. i. des. eapply LEAST; eauto.
    exists n1. splits; eauto.
    destruct (Compare_dec.le_lt_dec n n1); auto.
    exfalso. eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
    { eapply LB. eapply SAT1. } eapply TimeFacts.lt_le_lt.
    { eapply l. } etrans.
    { left. eapply LT. }
    { eapply Lt.le_lt_or_eq in l0. des.
      { left. eapply MON; eauto. }
      { subst. refl. }
    }
  }
Qed.

Definition incr_times (ts: Time.t):=
  exists n, incr_time_seq n = ts.

Lemma incr_times_well_ordered
  :
    well_ordered incr_times.
Proof.
  hexploit (increasing_join_well_ordered
              incr_time_seq
              (fun n => eq (incr_time_seq n))).
  { eapply incr_time_seq_lt. }
  { eapply incr_time_seq_diverge. }
  { i. subst. refl. }
  { i. apply singleton_well_ordered. }
  i. eapply sub_well_ordered; eauto.
Qed.

Lemma mapped_well_ordered
      (f: Time.t -> Time.t -> Prop)
      (times ftimes: Time.t -> Prop)
      (MAPLT: forall t0 t1 ft0 ft1
                     (MAP0: f t0 ft0)
                     (MAP1: f t1 ft1),
          Time.lt t0 t1 <-> Time.lt ft0 ft1)
      (WO: well_ordered times)
      (FTIMES: forall fts (IN: ftimes fts),
          exists ts,
            (<<MAP: f ts fts>>) /\
            (<<TIMES: times ts>>))
  :
    well_ordered ftimes.
Proof.
  ii.
  dup INHABITED. eapply SUB in INHABITED. dup INHABITED. eapply FTIMES in INHABITED. des.
  exploit (WO (fun ts => exists fts, (<<MAP: f ts fts>>) /\ (<<TIMES: sub fts>>))).
  { i. des. eapply SUB in TIMES0. eapply FTIMES in TIMES0. des.
    destruct (Time.le_lt_dec x0 ts0).
    { destruct l.
      { exploit MAPLT.
        { eapply MAP0. }
        { eapply MAP1. } intros x1. des.
        exfalso. eapply Time.lt_strorder. eapply x1; eauto.
      }
      { inv H. auto. }
    }
    { exploit MAPLT.
      { eapply MAP1. }
      { eapply MAP0. } intros x1. des.
      exfalso. eapply Time.lt_strorder. eapply x1; eauto.
    }
  }
  { eauto. }
  { i. des. exists fts. splits; auto. i.
    dup IN. eapply SUB in IN. dup IN. eapply FTIMES in IN. des.
    exploit LEAST; eauto. i.
    destruct (Time.le_lt_dec fts ts'); auto.
    erewrite <- MAPLT in l; eauto. timetac.
  }
Qed.