(* Snake lemma *)

Require Import Utf8.
Require Import Classes.RelationClasses.
Require Import Setoid.
Require ClassicalChoice.

Reserved Notation "x '∈' S" (at level 60).
Reserved Notation "x '≡' y" (at level 70).

(* Abelian Groups.

   Note: group sets are setoids, i.e. there is a specific equality (gr_eq)
   which must be compatible with membership (gr_mem_compat), with addition
   (gr_add_compat), and with inverse (gr_inv_compat). This allows to define
   groups quotients by changing this equality, e.g. in cokernels *)

Record AbGroup :=
  { (* data *)
    gr_set : Type;
    gr_mem : gr_set → Prop where "x ∈ G" := (gr_mem x);
    gr_eq : gr_set → gr_set → Prop where "x ≡ y" := (gr_eq x y);
    gr_zero : gr_set where "0" := (gr_zero);
    gr_add : gr_set → gr_set → gr_set where "x + y" := (gr_add x y);
    gr_inv : gr_set → gr_set where "- x" := (gr_inv x);
    (* properties *)
    gr_zero_mem : 0 ∈ G;
    gr_add_mem : ∀ x y, x ∈ G → y ∈ G → x + y ∈ G;
    gr_add_0_l : ∀ x, 0 + x ≡ x;
    gr_add_assoc : ∀ x y z, (x + y) + z ≡ x + (y + z);
    gr_inv_mem : ∀ x, x ∈ G → - x ∈ G;
    gr_add_inv_r : ∀ x, x + (- x) ≡ 0;
    gr_add_comm : ∀ x y, x + y ≡ y + x;
    gr_equiv : Equivalence gr_eq;
    gr_mem_compat : ∀ x y, x ≡ y → x ∈ G → y ∈ G;
    gr_add_compat : ∀ x y x' y', x ≡ y → x' ≡ y' → x + x' ≡ y + y';
    gr_inv_compat : ∀ x y, x ≡ y → - x ≡ - y }.

Arguments gr_eq [_].
Arguments gr_zero [_].
Arguments gr_add [_].
Arguments gr_inv [_].
Arguments gr_zero_mem G : rename.
Arguments gr_add_mem G : rename.
Arguments gr_add_0_l G : rename.
Arguments gr_add_assoc G : rename.
Arguments gr_inv_mem G : rename.
Arguments gr_add_inv_r G : rename.
Arguments gr_add_comm G : rename.
Arguments gr_equiv G : rename.
Arguments gr_mem_compat G : rename.
Arguments gr_add_compat G : rename.
Arguments gr_inv_compat G : rename.

Notation "x '∈' S" := (gr_mem S x) (at level 60).
Notation "x '∉' S" := (¬ gr_mem S x) (at level 60).
Notation "x '≡' y" := (gr_eq x y) (at level 70).

Delimit Scope group_scope with G.

Notation "0" := (gr_zero) : group_scope.
Notation "a = b" := (gr_eq a b) : group_scope.
Notation "a ≠ b" := (¬ gr_eq a b) : group_scope.
Notation "a + b" := (gr_add a b) : group_scope.
Notation "a - b" := (gr_add a (gr_inv b)) : group_scope.
Notation "- a" := (gr_inv a) : group_scope.

Axiom MemDec : ∀ G x, {x ∈ G} + {x ∉ G}.

Open Scope group_scope.

Record HomGr (A B : AbGroup) :=
  { H_app : gr_set A → gr_set B;
    H_mem_compat : ∀ x, x ∈ A → H_app x ∈ B;
    H_linear : ∀ x y, x ∈ A → y ∈ A → (H_app (x + y) = H_app x + H_app y)%G;
    H_compat : ∀ x y, x ∈ A → y ∈ A → (x = y)%G → (H_app x = H_app y)%G }.

Arguments H_app [A] [B].
Arguments H_mem_compat _ _ f : rename.
Arguments H_linear _ _ f : rename.
Arguments H_compat _ _ f : rename.

Theorem gr_eq_refl : ∀ G (x : gr_set G), x ≡ x.
Proof.
apply gr_equiv.
Qed.

Theorem gr_eq_symm : ∀ G (x y : gr_set G), x ≡ y → y ≡ x.
Proof.
apply gr_equiv.
Qed.

Theorem gr_eq_trans : ∀ G (x y z : gr_set G), x ≡ y → y ≡ z → x ≡ z.
Proof.
apply gr_equiv.
Qed.

Theorem gr_add_0_r : ∀ G (x : gr_set G), (x + 0 = x)%G.
Proof.
intros.
eapply gr_eq_trans; [ apply gr_add_comm | ].
Check gr_add_0_l.
apply gr_add_0_l.
Qed.

Theorem gr_add_inv_l : ∀ G (x : gr_set G), (- x + x = 0)%G.
Proof.
intros.
eapply gr_eq_trans; [ apply gr_add_comm | ].
apply gr_add_inv_r.
Qed.

Theorem gr_inv_zero : ∀ G, (- 0 = @gr_zero G)%G.
Proof.
intros.
specialize (@gr_add_inv_r G gr_zero) as H1.
specialize (@gr_add_0_l G (gr_inv gr_zero)) as H3.
eapply gr_eq_trans; [ | apply H1 ].
now apply gr_eq_symm.
Qed.

Theorem gr_sub_move_r : ∀ G (x y z : gr_set G),
  (x - y = z)%G ↔ (x = z + y)%G.
Proof.
intros.
split; intros Hxyz.
-apply gr_eq_trans with (y := ((x - y) + y)%G).
 +apply gr_eq_symm.
  eapply gr_eq_trans; [ apply gr_add_assoc | ].
  apply gr_eq_trans with (y := (x + 0)%G).
  *apply gr_add_compat; [ apply gr_eq_refl | apply gr_add_inv_l ].
  *apply gr_add_0_r.
 +apply gr_add_compat; [ easy | apply gr_eq_refl ].
-apply gr_eq_trans with (y := (z + y - y)%G).
 +apply gr_add_compat; [ easy | apply gr_eq_refl ].
 +eapply gr_eq_trans; [ apply gr_add_assoc | ].
  apply gr_eq_trans with (y := (z + 0)%G).
  *apply gr_add_compat; [ apply gr_eq_refl | apply gr_add_inv_r ].
  *apply gr_add_0_r.
Qed.

Theorem gr_sub_move_l : ∀ G (x y z : gr_set G),
  (x - y = z)%G ↔ (x = y + z)%G.
Proof.
intros.
split; intros Hxyz.
-apply gr_eq_symm.
 eapply gr_eq_trans; [ apply gr_add_comm | ].
 now apply gr_eq_symm, gr_sub_move_r.
-apply gr_sub_move_r.
 eapply gr_eq_trans; [ apply Hxyz | ].
 apply gr_add_comm.
Qed.

Theorem gr_inv_add_distr : ∀ G (x y : gr_set G), (- (x + y) = - x - y)%G.
Proof.
intros *.
apply gr_eq_symm.
apply gr_sub_move_r.
eapply gr_eq_trans.
-apply gr_eq_symm, gr_add_0_l.
-apply gr_sub_move_r.
 apply gr_eq_symm.
 eapply gr_eq_trans; [ apply gr_add_assoc | ].
 apply gr_eq_trans with (y := (- (x + y) + (x + y))%G).
 +apply gr_add_compat; [ apply gr_eq_refl | apply gr_add_comm ].
 +apply gr_add_inv_l.
Qed.

Theorem gr_inv_inv : ∀ G (x : gr_set G), (- - x = x)%G.
Proof.
intros.
apply gr_eq_trans with (y := (- - x + (- x + x))%G).
-apply gr_eq_symm.
 apply gr_eq_trans with (y := (- - x + 0)%G).
 +apply gr_add_compat; [ apply gr_eq_refl | apply gr_add_inv_l ].
 +apply gr_add_0_r.
-eapply gr_eq_trans; [ apply gr_eq_symm, gr_add_assoc | ].
 eapply gr_eq_trans; [ | apply gr_add_0_l ].
 apply gr_add_compat; [ apply gr_add_inv_l | apply gr_eq_refl ].
Qed.

Theorem H_zero : ∀ A B (f : HomGr A B), (H_app f 0 = 0)%G.
Proof.
intros.
assert (H1 : (@gr_zero A + 0 = 0)%G) by apply A.
assert (H2 : (H_app f 0 + H_app f 0 = H_app f 0)%G). {
  eapply gr_eq_trans; [ apply gr_eq_symm, f; apply A | ].
  apply f; [ apply A; apply A | apply A | apply A ].
}
assert (H3 : (H_app f 0 + H_app f 0 - H_app f 0 = H_app f 0 - H_app f 0)%G). {
  apply gr_add_compat; [ apply H2 | apply gr_eq_refl ].
}
assert (H4 : (H_app f 0 + H_app f 0 - H_app f 0 = 0)%G). {
  eapply gr_eq_trans; [ apply H3 | apply B ].
}
eapply gr_eq_trans; [ | apply H4 ].
apply gr_eq_symm.
eapply gr_eq_trans; [ apply gr_add_assoc | ].
eapply gr_eq_trans; [ | apply gr_add_0_r ].
apply gr_add_compat; [ apply gr_eq_refl | apply B ].
Qed.

Theorem H_inv : ∀ A B (f : HomGr A B) x,
  x ∈ A → (H_app f (- x) = - H_app f x)%G.
Proof.
intros * Hx.
assert (H1 : (x - x = 0)%G) by apply A.
assert (H2 : (H_app f (x - x) = H_app f 0)%G). {
  apply H_compat; [ now apply A, A | apply A | apply H1 ].
}
assert (H3 : (H_app f x + H_app f (- x) = H_app f 0)%G). {
  eapply gr_eq_trans; [ | apply H2 ].
  apply gr_eq_symm, H_linear; [ easy | now apply A ].
}
assert (H4 : (H_app f x + H_app f (- x) = 0)%G). {
  eapply gr_eq_trans; [ apply H3 | apply H_zero ].
}
apply gr_eq_trans with (y := (0 - H_app f x)%G).
-now apply gr_eq_symm, gr_sub_move_l, gr_eq_symm.
-apply gr_add_0_l.
Qed.

Inductive Gr0_set := G0 : Gr0_set.

Theorem Gr0_add_0_l : ∀ x, (λ _ _ : Gr0_set, G0) G0 x = x.
Proof.
now intros x; destruct x.
Qed.

Definition Gr0 :=
   {| gr_set := Gr0_set;
      gr_mem _ := True;
      gr_eq := eq;
      gr_zero := G0;
      gr_add _ _ := G0;
      gr_inv x := x;
      gr_zero_mem := I;
      gr_add_mem _ _ _ _ := I;
      gr_add_0_l := Gr0_add_0_l;
      gr_add_assoc _ _ _ := eq_refl G0;
      gr_inv_mem _ H := H;
      gr_add_inv_r _ := eq_refl;
      gr_add_comm _ _ := eq_refl G0;
      gr_equiv := eq_equivalence;
      gr_mem_compat _ _ _ _ := I;
      gr_add_compat _ _ _ _ _ _ := eq_refl;
      gr_inv_compat _ _ H := H |}.

Definition is_initial (G : AbGroup) :=
  ∀ H (f g : HomGr G H) (x : gr_set G), H_app f x ≡ H_app g x.
Definition is_final (G : AbGroup) :=
  ∀ H (f g : HomGr H G) (x : gr_set H), H_app f x ≡ H_app g x.
Definition is_null (G : AbGroup) := is_initial G ∧ is_final G.

Theorem is_null_Gr0 : is_null Gr0.
Proof.
split; intros H f g x.
-destruct x.
 apply gr_eq_trans with (y := gr_zero); [ apply H_zero | ].
 apply gr_eq_symm, H_zero.
-now destruct (H_app f x), (H_app g x).
Qed.

Theorem Im_zero_mem {G H} : ∀ (f : HomGr G H),
  ∃ a : gr_set G, a ∈ G ∧ (H_app f a = 0)%G.
Proof.
intros.
exists 0%G.
split; [ apply gr_zero_mem | apply H_zero ].
Qed.

Theorem Im_add_mem {G H} : ∀ f (x y : gr_set H),
  (∃ a : gr_set G, a ∈ G ∧ (H_app f a = x)%G)
  → (∃ a : gr_set G, a ∈ G ∧ (H_app f a = y)%G)
  → ∃ a : gr_set G, a ∈ G ∧ (H_app f a = x + y)%G.
Proof.
intros f y y' (x & Hxg & Hx) (x' & Hx'g & Hx').
exists (gr_add x x').
split; [ now apply G | ].
eapply gr_eq_trans; [ now apply H_linear | ].
apply gr_eq_trans with (y := gr_add y y').
+now apply gr_add_compat.
+apply gr_eq_refl.
Qed.

Theorem Im_inv_mem {G H} : ∀ (f : HomGr G H) (x : gr_set H),
  (∃ a : gr_set G, a ∈ G ∧ (H_app f a = x)%G)
  → ∃ a : gr_set G, a ∈ G ∧ (H_app f a = - x)%G.
Proof.
intros f x (y & Hy & Hyx).
exists (gr_inv y).
split; [ now apply gr_inv_mem | ].
apply gr_eq_trans with (y := gr_inv (H_app f y)).
+now apply H_inv.
+now apply gr_inv_compat.
Qed.

Theorem Im_equiv {G} : Equivalence (@gr_eq G).
Proof.
apply gr_equiv.
Show Proof.
Qed.

Theorem Im_mem_compat {G H} : ∀ f (x y : gr_set H),
  (x = y)%G
  → (∃ a, a ∈ G ∧ (H_app f a = x)%G)
  → ∃ a, a ∈ G ∧ (H_app f a = y)%G.
intros * Hxy (z, Hz).
exists z.
split; [ easy | ].
eapply gr_eq_trans; [ apply Hz | easy ].
Qed.

Definition Im {G H : AbGroup} (f : HomGr G H) :=
  {| gr_set := gr_set H;
     gr_zero := gr_zero;
     gr_eq := @gr_eq H;
     gr_mem := λ b, ∃ a, a ∈ G ∧ H_app f a ≡ b;
     gr_add := @gr_add H;
     gr_inv := @gr_inv H;
     gr_zero_mem := Im_zero_mem f;
     gr_add_mem := Im_add_mem f;
     gr_add_0_l := gr_add_0_l H;
     gr_add_assoc := gr_add_assoc H;
     gr_inv_mem := Im_inv_mem f;
     gr_add_inv_r := gr_add_inv_r H;
     gr_add_comm := gr_add_comm H;
     gr_equiv := gr_equiv H;
     gr_mem_compat := Im_mem_compat f;
     gr_add_compat := gr_add_compat H;
     gr_inv_compat := gr_inv_compat H |}.

Theorem Ker_zero_mem {G H} : ∀ (f : HomGr G H), 0%G ∈ G ∧ (H_app f 0 = 0)%G.
Proof.
intros f.
split; [ apply gr_zero_mem | apply H_zero ].
Qed.

Theorem Ker_add_mem {G H} : ∀ (f : HomGr G H) (x y : gr_set G),
  x ∈ G ∧ (H_app f x = 0)%G
  → y ∈ G ∧ (H_app f y = 0)%G → (x + y)%G ∈ G ∧ (H_app f (x + y) = 0)%G.
Proof.
intros f x x' (Hx, Hfx) (Hx', Hfx').
split; [ now apply gr_add_mem | ].
eapply gr_eq_trans; [ now apply H_linear | ].
eapply gr_eq_trans; [ | apply gr_add_0_l ].
now apply gr_add_compat.
Qed.

Theorem Ker_inv_mem {G H} : ∀ (f : HomGr G H) (x : gr_set G),
  x ∈ G ∧ (H_app f x = 0)%G → (- x)%G ∈ G ∧ (H_app f (- x) = 0)%G.
Proof.
intros f x (Hx & Hfx).
split.
+now apply gr_inv_mem.
+eapply gr_eq_trans; [ now apply H_inv | ].
 eapply gr_eq_trans; [ apply gr_inv_compat, Hfx | ].
 apply gr_inv_zero.
Qed.

Theorem Ker_mem_compat {G H} : ∀ (f : HomGr G H) x y,
  (x = y)%G → x ∈ G ∧ (H_app f x = 0)%G → y ∈ G ∧ (H_app f y = 0)%G.
Proof.
intros * Hxy (ax, Hx).
split.
-eapply gr_mem_compat; [ apply Hxy | easy ].
-eapply gr_eq_trans; [ | apply Hx ].
 apply gr_eq_symm.
 apply H_compat; [ easy | | easy ].
 eapply gr_mem_compat; [ apply Hxy | easy ].
Qed.

Definition Ker {G H : AbGroup} (f : HomGr G H) :=
  {| gr_set := gr_set G;
     gr_zero := gr_zero;
     gr_eq := @gr_eq G;
     gr_mem := λ a, a ∈ G ∧ H_app f a ≡ gr_zero;
     gr_add := @gr_add G;
     gr_inv := @gr_inv G;
     gr_zero_mem := Ker_zero_mem f;
     gr_add_mem := Ker_add_mem f;
     gr_add_0_l := gr_add_0_l G;
     gr_add_assoc := gr_add_assoc G;
     gr_inv_mem := Ker_inv_mem f;
     gr_add_inv_r := gr_add_inv_r G;
     gr_add_comm := gr_add_comm G;
     gr_equiv := gr_equiv G;
     gr_mem_compat := Ker_mem_compat f;
     gr_add_compat := gr_add_compat G;
     gr_inv_compat := gr_inv_compat G |}.

Definition gr_sub {G} (x y : gr_set G) := gr_add x (gr_inv y).

(* x ∈ Coker f ↔ x ∈ H/Im f
   quotient group is H with setoid, i.e. set with its own equality *)

Definition Coker_eq {G H} (f : HomGr G H) x y := (x - y)%G ∈ Im f.

Theorem Coker_add_0_l {G H} : ∀ (f : HomGr G H) x, Coker_eq f (0 + x)%G x.
Proof.
intros.
unfold Coker_eq.
exists 0%G.
split; [ apply gr_zero_mem | ].
eapply gr_eq_trans; [ apply H_zero | ].
apply gr_eq_symm.
simpl in x; simpl.
eapply gr_eq_trans; [ apply gr_add_assoc | ].
eapply gr_eq_trans; [ apply gr_add_0_l | ].
apply gr_add_inv_r.
Qed.

Theorem Coker_add_assoc {G H} : ∀ (f : HomGr G H) x y z,
  Coker_eq f (x + y + z)%G (x + (y + z))%G.
Proof.
intros.
unfold Coker_eq.
exists 0%G.
split; [ apply gr_zero_mem | ].
eapply gr_eq_trans; [ apply H_zero | ].
apply gr_eq_symm.
simpl in x, y, z; simpl.
apply gr_sub_move_r, gr_eq_symm.
eapply gr_eq_trans; [ apply gr_add_0_l | ].
apply gr_eq_symm, gr_add_assoc.
Qed.

Theorem Coker_add_inv_r {G H} : ∀ (f : HomGr G H) x, Coker_eq f (x - x)%G 0%G.
Proof.
intros.
exists 0%G.
split; [ apply gr_zero_mem | ].
eapply gr_eq_trans; [ apply H_zero | ].
apply gr_eq_symm.
simpl.
apply gr_eq_trans with (y := (0 - 0)%G).
-apply gr_add_compat; [ apply gr_add_inv_r | apply gr_eq_refl ].
-apply gr_add_inv_r.
Qed.

Theorem Coker_add_comm {G H} : ∀ (f : HomGr G H) x y,
  Coker_eq f (x + y)%G (y + x)%G.
Proof.
intros.
exists 0%G.
split; [ apply gr_zero_mem | ].
eapply gr_eq_trans; [ apply H_zero | ].
apply gr_eq_symm.
simpl.
apply gr_sub_move_r.
eapply gr_eq_trans; [ apply gr_add_comm | ].
apply gr_eq_symm.
eapply gr_eq_trans; [ apply gr_add_0_l | apply gr_eq_refl ].
Qed.

Theorem Coker_equiv {G H} : ∀ (f : HomGr G H), Equivalence (Coker_eq f).
Proof.
intros.
unfold Coker_eq; split.
-intros x.
 exists 0%G.
 split; [ apply gr_zero_mem | ].
 eapply gr_eq_trans; [ apply H_zero | ].
 simpl.
 apply gr_eq_symm, gr_add_inv_r.
-intros x y Hxy.
 destruct Hxy as (z & Hz).
 exists (- z)%G.
 split; [ now apply gr_inv_mem | ].
 eapply gr_eq_trans; [ now apply H_inv | ].
 apply gr_eq_trans with (y := (- (x - y))%G).
 +now simpl; apply gr_inv_compat.
 +simpl; eapply gr_eq_trans; [ apply gr_inv_add_distr | ].
  eapply gr_eq_trans; [ apply gr_add_comm | ].
  apply gr_add_compat; [ | apply gr_eq_refl ].
  apply gr_inv_inv.
-intros x y z Hxy Hyz.
 simpl in Hxy, Hyz.
 destruct Hxy as (t, Ht).
 destruct Hyz as (u, Hu).
 exists (t + u)%G.
 split; [ now apply gr_add_mem | ].
 eapply gr_eq_trans; [ now apply H_linear | ].
 apply gr_eq_trans with (y := (x - y + (y - z))%G).
 +now simpl; apply gr_add_compat.
 +simpl; eapply gr_eq_trans; [ apply gr_add_assoc | ].
  apply gr_add_compat; [ apply gr_eq_refl | ].
  eapply gr_eq_trans; [ apply gr_eq_symm, gr_add_assoc | ].
  apply gr_eq_trans with (y := (0 - z)%G).
  *simpl; apply gr_add_compat; [ apply gr_add_inv_l | apply gr_eq_refl ].
  *simpl; apply gr_add_0_l.
Qed.

Theorem Coker_mem_compat {G H} : ∀ (f : HomGr G H) x y,
  Coker_eq f x y → x ∈ H → y ∈ H.
Proof.
intros * Heq Hx.
destruct Heq as (z, Hz).
apply gr_mem_compat with (x := (x - H_app f z)%G).
-apply gr_eq_trans with (y := (x - (x - y))%G); simpl.
 +apply gr_add_compat; [ apply gr_eq_refl | ].
  now apply gr_inv_compat.
 +apply gr_sub_move_r, gr_eq_symm.
  eapply gr_eq_trans; [ apply gr_add_comm | ].
  eapply gr_eq_trans; [ apply gr_add_assoc | ].
  apply gr_eq_trans with (y := (x + 0)%G); simpl.
  *apply gr_add_compat; [ apply gr_eq_refl | apply gr_add_inv_l ].
  *apply gr_add_0_r.
-simpl; apply gr_add_mem; [ easy | ].
 apply gr_inv_mem.
 now apply f.
Qed.

Theorem Coker_add_compat {G H} : ∀ (f : HomGr G H) x y x' y',
  Coker_eq f x y → Coker_eq f x' y' → Coker_eq f (x + x')%G (y + y')%G.
Proof.
intros f x y x' y' (z & Hz & Hfz) (z' & Hz' & Hfz').
exists (z + z')%G.
split.
-now apply gr_add_mem.
-eapply gr_eq_trans; [ now apply f | ].
 apply gr_eq_trans with (y := ((x - y) + (x' - y'))%G); simpl.
 +now apply gr_add_compat.
 +eapply gr_eq_trans; [ apply gr_add_assoc | apply gr_eq_symm ].
  eapply gr_eq_trans; [ apply gr_add_assoc | apply gr_eq_symm ].
  apply gr_add_compat; [ apply gr_eq_refl | ].
  eapply gr_eq_trans; [ apply gr_add_comm | ].
  eapply gr_eq_trans; [ apply gr_add_assoc | ].
  apply gr_add_compat; [ apply gr_eq_refl | ].
  eapply gr_eq_trans; [ apply gr_add_comm | ].
  apply gr_eq_symm, gr_inv_add_distr.
Qed.

Theorem Coker_inv_compat {G H} :∀ (f : HomGr G H) x y,
  Coker_eq f x y → Coker_eq f (- x)%G (- y)%G.
Proof.
intros * (z & Hz & Hfz).
unfold Coker_eq; simpl.
exists (- z)%G.
split; [ now apply gr_inv_mem | ].
eapply gr_eq_trans; [ now apply H_inv | ].
apply gr_eq_trans with (y := (- (x - y))%G); simpl.
-now apply gr_inv_compat.
-apply gr_inv_add_distr.
Qed.

Definition Coker {G H : AbGroup} (f : HomGr G H) :=
  {| gr_set := gr_set H;
     gr_zero := gr_zero;
     gr_eq := Coker_eq f;
     gr_mem := gr_mem H;
     gr_add := @gr_add H;
     gr_inv := @gr_inv H;
     gr_zero_mem := @gr_zero_mem H;
     gr_add_mem := @gr_add_mem H;
     gr_add_0_l := Coker_add_0_l f;
     gr_add_assoc := Coker_add_assoc f;
     gr_inv_mem := gr_inv_mem H;
     gr_add_inv_r := Coker_add_inv_r f;
     gr_add_comm := Coker_add_comm f;
     gr_equiv := Coker_equiv f;
     gr_mem_compat := Coker_mem_compat f;
     gr_add_compat := Coker_add_compat f;
     gr_inv_compat := Coker_inv_compat f |}.

Inductive sequence {A : AbGroup} :=
  | Seq1 : sequence
  | Seq2 : ∀ {B} (f : HomGr A B), @sequence B → sequence.

Fixpoint exact_sequence {A : AbGroup} (S : sequence) :=
  match S with
  | Seq1 => True
  | Seq2 f S' =>
      match S' with
      | Seq1 => True
      | Seq2 g S'' => (∀ a, a ∈ Im f ↔ a ∈ Ker g) ∧ exact_sequence S'
      end
  end.

(*      f
    A------>B
    |       |
   g|       |h
    |       |
    v       v
    C------>D
        k
*)
Definition diagram_commutes {A B C D}
     (f : HomGr A B) (g : HomGr A C) (h : HomGr B D) (k : HomGr C D) :=
  ∀ x, H_app h (H_app f x) ≡ H_app k (H_app g x).

Theorem KK_mem_compat {A B A' B'} : ∀ (a : HomGr A A') (b : HomGr B B') f f',
  diagram_commutes f a b f'
  → ∀ x : gr_set (Ker a), x ∈ Ker a → H_app f x ∈ Ker b.
intros * Hc * Hx.
split; [ now apply f; simpl in Hx | ].
eapply gr_eq_trans; [ apply Hc | ].
apply gr_eq_trans with (y := H_app f' 0%G).
-apply f'; [ apply a, Hx | apply A' | apply Hx ].
-apply H_zero.
Qed.

Theorem KK_lin {A B A'} : ∀ (f : HomGr A B) (a : HomGr A A'),
  ∀ x y : gr_set (Ker a),
  x ∈ Ker a → y ∈ Ker a → (H_app f (x + y) = H_app f x + H_app f y)%G.
Proof.
intros * Hx Hx'; simpl in Hx, Hx'.
now apply f.
Qed.

Theorem KK_compat {A B A'} : ∀ (f : HomGr A B) (a : HomGr A A'),
  ∀ x y : gr_set (Ker a),
  x ∈ Ker a → y ∈ Ker a → (x = y)%G → (H_app f x = H_app f y)%G.
Proof.
intros * Hx Hy Hxy.
simpl in Hx, Hy.
now apply f.
Qed.

Definition HomGr_Ker_Ker {A B A' B'}
    (f : HomGr A B) (f' : HomGr A' B') (a : HomGr A A') (b : HomGr B B')
    (Hc : diagram_commutes f a b f') :=
  {| H_app (x : gr_set (Ker a)) := H_app f x : gr_set (Ker b);
     H_mem_compat := KK_mem_compat a b f f' Hc;
     H_linear := KK_lin f a;
     H_compat := KK_compat f a |}.

Theorem CC_mem_compat {A B A' B'} :
  ∀ (f' : HomGr A' B') (a : HomGr A A') (b : HomGr B B'),
  ∀ x : gr_set (Coker a), x ∈ Coker a → H_app f' x ∈ Coker b.
Proof.
intros * Hx.
now apply f'.
Qed.

Theorem CC_lin {A B A' B'} :
  ∀ (f' : HomGr A' B') (a : HomGr A A') (b : HomGr B B'),
  ∀ x y : gr_set (Coker a), x ∈ Coker a → y ∈ Coker a
  → @gr_eq (Coker b) (H_app f' (x + y))%G (H_app f' x + H_app f' y)%G.
Proof.
intros * Hx Hy; simpl in Hx, Hy.
exists 0%G.
split; [ apply B | ].
eapply gr_eq_trans; [ apply H_zero | apply B' ].
simpl; apply gr_sub_move_r.
apply B'.
eapply gr_eq_trans; [ apply gr_add_0_l | ].
now apply B', f'.
Qed.

Theorem CC_compat {A B A' B'} :
  ∀ (f : HomGr A B) (f' : HomGr A' B') (a : HomGr A A') (b : HomGr B B'),
  diagram_commutes f a b f'
  → ∀ x y : gr_set (Coker a),
  x ∈ Coker a → y ∈ Coker a → (x = y)%G
  → @gr_eq (Coker b) (H_app f' x) (H_app f' y)%G.
Proof.
intros * Hc * Hx Hy Hxy.
simpl in Hx, Hy, x, y, Hxy; simpl.
destruct Hxy as (z & Hz & Haz).
simpl; unfold Coker_eq; simpl.
exists (H_app f z).
split; [ now apply f | ].
eapply gr_eq_trans; [ apply Hc | ].
apply gr_eq_trans with (y := H_app f' (x - y)%G).
-apply H_compat; [ now apply a | | easy ].
 apply A'; [ easy | now apply A' ].
-eapply gr_eq_trans.
 +apply f'; [ easy | now apply A' ].
 +apply gr_add_compat; [ apply gr_eq_refl | now apply H_inv ].
Qed.

Definition HomGr_Coker_Coker {A B A' B'}
    (f : HomGr A B) (f' : HomGr A' B') (a : HomGr A A') (b : HomGr B B')
    (Hc : diagram_commutes f a b f') :=
  {| H_app (x : gr_set (Coker a)) := H_app f' x : gr_set (Coker b);
     H_mem_compat := CC_mem_compat f' a b;
     H_linear := CC_lin f' a b;
     H_compat := CC_compat f f' a b Hc |}.

Theorem exists_ker_C_to_B : ∀ B C C' g (c : HomGr C C') (cz : HomGr C Gr0),
  (∀ a : gr_set (Im g), a ∈ Im g ↔ a ∈ Ker cz)
  → ∀ x : gr_set (Ker c), ∃ y, x ∈ C → y ∈ B ∧ H_app g y ≡ x.
Proof.
intros * sg x.
destruct (MemDec C x) as [H2| H2]; [ | now exists 0%G ].
enough (H : x ∈ Im g). {
  simpl in H.
  destruct H as (y & Hy & Hyx).
  now exists y.
}
apply sg.
split; [ easy | ].
simpl in x; simpl.
destruct cz as (appcz, czin, czlin, czcomp).
simpl.
now destruct (appcz x).
Qed.

Lemma snake :
  ∀ (A B C A' B' C' : AbGroup)
     (f : HomGr A B) (g : HomGr B C)
     (f' : HomGr A' B') (g' : HomGr B' C')
     (a : HomGr A A') (b : HomGr B B') (c : HomGr C C')
     (cz : HomGr C Gr0) (za' : HomGr Gr0 A'),
  diagram_commutes f a b f'
  → diagram_commutes g b c g'
  → exact_sequence (Seq2 f (Seq2 g (Seq2 cz Seq1)))
  → exact_sequence (Seq2 za' (Seq2 f' (Seq2 g' Seq1)))
  → ∃ (fk : HomGr (Ker a) (Ker b)) (gk : HomGr (Ker b) (Ker c))
        (fk' : HomGr (Coker a) (Coker b)) (gk' : HomGr (Coker b) (Coker c)),
     ∃ (d : HomGr (Ker c) (Coker a)),
        exact_sequence (Seq2 fk (Seq2 gk (Seq2 d (Seq2 fk' (Seq2 gk' Seq1))))).
Proof.
intros *.
intros Hcff' Hcgg' s s'.
exists (HomGr_Ker_Ker f f' a b Hcff').
exists (HomGr_Ker_Ker g g' b c Hcgg').
exists (HomGr_Coker_Coker f f' a b Hcff').
exists (HomGr_Coker_Coker g g' b c Hcgg').
destruct s as (sf & sg & _).
destruct s' as (sf' & sg' & _).
specialize (exists_ker_C_to_B B C C' g c cz sg) as H1.
specialize (ClassicalChoice.choice _ H1) as (g₁, Hg₁).
assert
  (Hf'inj :
  ∀ x y, x ∈ A' → y ∈ A' → (H_app f' x = H_app f' y)%G → (x = y)%G). {
  intros * Hx Hy Hxy.
  (* it is because Im(cza')={0}=Ker(f') *)
  assert (H2 : (H_app f' x - H_app f' y = 0)%G). {
    apply gr_sub_move_r.
    eapply gr_eq_trans; [ apply Hxy | ].
    apply gr_eq_symm, gr_add_0_l.
  }
  assert (H3 : (H_app f' (x - y) = 0)%G). {
    eapply gr_eq_trans; [ | apply H2 ].
    eapply gr_eq_trans.
    -apply H_linear; [ easy | now apply A' ].
    -apply gr_add_compat; [ apply gr_eq_refl | now apply H_inv ].
  }
  assert (H4 : (x - y)%G ∈ Ker f'). {
    split; [ | apply H3 ].
    apply A'; [ easy | now apply A' ].
  }
  apply sf' in H4.
  simpl in H4.
  destruct H4 as (z & _ & H4).
  destruct z.
  assert (H5 : (x - y = 0)%G). {
    eapply gr_eq_trans; [ apply gr_eq_symm, H4 | ].
    apply H_zero.
  }
  apply gr_sub_move_r in H5.
  eapply gr_eq_trans; [ apply H5 | ].
  apply gr_add_0_l.
}
assert (Hcf'inj : ∀ x y, x ∈ Coker a → y ∈ Coker a → (H_app f' x = H_app f' y)%G → (x = y)%G). {
  intros * Hx Hy Hxy.
  simpl; unfold Coker_eq; simpl.
  exists 0; split; [ apply A | ].
  apply Hf'inj; [ apply a, A | | ].
  -apply A'; [ easy | now apply A' ].
  -apply gr_eq_trans with (y := H_app f' 0).
   +apply f'; [ apply a, A | apply A' | apply H_zero ].
   +eapply gr_eq_trans; [ apply H_zero | ].
    apply gr_eq_symm.
    eapply gr_eq_trans.
    *apply H_linear; [ easy | now apply A' ].
    *eapply gr_eq_trans.
    --apply gr_add_compat; [ apply gr_eq_refl | ].
      now apply H_inv.
    --apply gr_sub_move_r.
      eapply gr_eq_trans; [ apply Hxy | ].
      apply gr_eq_symm, gr_add_0_l.
}
assert (H7 : ∀ x, x ∈ C → g₁ x ∈ B). {
  intros z Hz; specialize (Hg₁ z) as H; now destruct H.
}
assert (H5 : ∀ x, x ∈ Ker c → (H_app g' (H_app b (g₁ x)) = 0)%G). {
  intros z (Hz, Hcz).
  specialize (Hg₁ z Hz) as H5.
  eapply gr_eq_trans.
  -apply gr_eq_symm, Hcgg'.
  -apply gr_eq_trans with (y := H_app c z); [ | easy ].
   apply H_compat; [ now apply g | easy | easy ].
}
assert
  (H2 :
   ∀ y', ∃ z',
   (∃ x, x ∈ Ker c ∧ (y' = H_app b (g₁ x))%G)
   → z' ∈ Coker a ∧ (H_app f' z' = y')%G). {
  intros y'.
  destruct (MemDec (Im b) y') as [Hy'| Hy'].
  -destruct (MemDec (Im f') y') as [(z' & Hz' & Hfz')| Hfy'].
   +exists z'; now intros (x' & Hx' & Hyx').
   +exists 0%G; intros (x' & Hx' & Hyx').
    exfalso; apply Hfy', sg'; simpl.
    split.
    *destruct Hy' as (y & Hy & Hby).
     eapply B'; [ apply Hby | now apply b ].
    *apply gr_eq_trans with (y := H_app g' (H_app b (g₁ x'))).
    --apply g'; [ | | easy ].
     ++destruct Hy' as (y & Hy & Hby).
       eapply B'; [ apply Hby | now apply b ].
     ++apply b, H7, Hx'.
    --eapply gr_eq_trans; [ apply gr_eq_symm, Hcgg' | ].
      destruct Hx' as (Hx', Hcx').
      specialize (Hg₁ x' Hx') as H2.
      destruct H2 as (Hgx', Hggx').
      apply gr_eq_trans with (y := H_app c x'); [ | easy ].
      apply c; [ now apply g, H7| easy | easy ].
  -exists 0%G; intros (x' & Hx' & Hyx').
   exfalso; apply Hy'.
   exists (g₁ x').
   split; [ apply H7; now simpl in Hx' | ].
   now apply gr_eq_symm.
}
specialize (ClassicalChoice.choice _ H2) as (f'₁, Hf'₁).
move f'₁ before g₁.
clear H1 H2.
set (d := λ x, f'₁ (H_app b (g₁ x))).
assert
  (Hcomp :
     ∀ x1 x2, x1 ∈ Ker c → x2 ∈ Ker c → (x1 = x2)%G → (d x1 = d x2)%G). {
  intros * Hx1 Hx2 Hxx.
  assert (Hgy1 : (H_app g (g₁ x1) = x1)%G) by apply Hg₁, Hx1.
  assert (Hgy2 : (H_app g (g₁ x2) = x2)%G) by apply Hg₁, Hx2.
  assert (Hgb1 : (H_app g' (H_app b (g₁ x1)) = 0)%G). {
    eapply gr_eq_trans; [ apply gr_eq_symm, Hcgg' | ].
    eapply gr_eq_trans; [ | apply Hx1 ].
    apply c; [ apply g, Hg₁, Hx1 | apply Hx1 | apply Hgy1 ].
  }
  assert (Hgb2 : (H_app g' (H_app b (g₁ x2)) = 0)%G). {
    eapply gr_eq_trans; [ apply gr_eq_symm, Hcgg' | ].
    eapply gr_eq_trans; [ | apply Hx2 ].
    apply c; [ apply g, Hg₁, Hx2 | apply Hx2 | apply Hgy2 ].
  }
  assert (H1 : H_app b (g₁ x1) ∈ Im f'). {
    apply sg'; split; [ apply b, H7, Hx1 | easy ].
  }
  assert (H2 : H_app b (g₁ x2) ∈ Im f'). {
    apply sg'; split; [ apply b, H7, Hx2 | easy ].
  }
  destruct H1 as (z'1 & Hz'1 & Hfz'1).
  destruct H2 as (z'2 & Hz'2 & Hfz'2).
  move z'2 before z'1; move Hz'2 before Hz'1.
  assert (H3 : (H_app f' (z'1 - z'2) = H_app b (g₁ x1 - g₁ x2))%G). {
    eapply gr_eq_trans.
    -apply f'; [ easy | now apply A' ].
    -apply gr_eq_symm.
     eapply gr_eq_trans.
     +apply b; [ apply H7, Hx1 | apply B, H7, Hx2 ].
     +apply gr_eq_symm, gr_add_compat; [ easy | ].
      eapply gr_eq_trans; [ now apply H_inv | ].
      apply gr_eq_symm.
      eapply gr_eq_trans; [ apply H_inv, H7, Hx2 | ].
      now apply gr_inv_compat, gr_eq_symm.
  }
  assert (H4 : g₁ x1 - g₁ x2 ∈ Im f). {
    apply sf.
    split.
    -apply B; [ apply H7, Hx1 | apply B, H7, Hx2 ].
    -eapply gr_eq_trans.
     +apply g; [ apply H7, Hx1 | apply B, H7, Hx2 ].
     +apply gr_eq_trans with (y := x1 - x2); simpl.
      *apply gr_add_compat; [ easy | ].
       eapply gr_eq_trans; [ apply H_inv, H7, Hx2 | ].
       now apply gr_inv_compat.
      *apply gr_sub_move_r, gr_eq_symm.
       eapply gr_eq_trans; [ apply gr_add_0_l | ].
       now apply gr_eq_symm.
  }
  destruct H4 as (z & Hz & Hfz).
  assert (H4 : (z'1 - z'2 = H_app a z)%G). {
    apply Hf'inj; [ | now apply a | ].
    -apply A'; [ easy | now apply A' ].
    -eapply gr_eq_symm, gr_eq_trans.
     +apply gr_eq_symm, Hcff'.
     +eapply gr_eq_trans.
      *apply H_compat with (y := g₁ x1 - g₁ x2); [ now apply f | | easy ].
       apply B; [ apply H7, Hx1 | apply B, H7, Hx2 ].
      *now apply gr_eq_symm.
  }
  assert (H6 : z'1 - z'2 ∈ Im a). {
    exists z; split; [ easy | now apply gr_eq_symm ].
  }
  assert (Hdx2 : (d x2 = z'2)%G). {
    simpl; unfold Coker_eq; simpl.
    exists 0.
    split; [ apply A | ].
    eapply gr_eq_trans; [ apply H_zero | ].
    apply gr_eq_symm, gr_sub_move_r, gr_eq_symm.
    eapply gr_eq_trans; [ apply gr_add_0_l | ].
    apply Hf'inj; [ easy | | ].
    -unfold d; apply Hf'₁; exists x2.
     split; [ easy | apply gr_eq_refl ].
    -eapply gr_eq_trans; [ apply Hfz'2 | ].
     apply gr_eq_symm, Hf'₁; exists x2; split; [ easy | apply gr_eq_refl ].
  }
  assert (Hdx1 : (d x1 = z'1)%G). {
    simpl; unfold Coker_eq; simpl.
    exists 0.
    split; [ apply A | ].
    eapply gr_eq_trans; [ apply H_zero | ].
    apply gr_eq_symm, gr_sub_move_r, gr_eq_symm.
    eapply gr_eq_trans; [ apply gr_add_0_l | ].
    apply Hf'inj; [ easy | | ].
    -unfold d; apply Hf'₁; exists x1.
     split; [ easy | apply gr_eq_refl ].
    -eapply gr_eq_trans; [ apply Hfz'1 | ].
     apply gr_eq_symm, Hf'₁; exists x1; split; [ easy | apply gr_eq_refl ].
  }
  assert (Hzz' : @gr_eq (@Coker A A' a) z'1 z'2). {
    destruct H6 as (zz & Hzz & Hazz).
    simpl; unfold Coker_eq; simpl.
    now exists zz; split.
  }
  eapply gr_eq_trans; [ apply Hdx1 | ].
  eapply gr_eq_trans; [ apply Hzz' | ].
  now apply gr_eq_symm.
}
assert
  (Hlin : ∀ x1 x2, x1 ∈ Ker c → x2 ∈ Ker c → (d (x1 + x2) = d x1 + d x2)%G). {
  intros x1 x2 Hx1 Hx2.
  set (x3 := (x1 + x2)%G).
  set (y1 := g₁ x1).
  set (y2 := g₁ x2).
  set (y3 := g₁ x3).
  set (z1 := d x1).
  set (z2 := d x2).
  set (z3 := d x3).
  assert (H1 : (H_app g y1 = x1)%G) by now apply Hg₁; simpl in Hx1.
  assert (H2 : (H_app g y2 = x2)%G) by now apply Hg₁; simpl in Hx2.
  assert (H3 : (H_app g (y1 + y2)%G = x3)%G). {
    eapply gr_eq_trans.
    -apply g.
     +now apply H7; simpl in Hx1.
     +now apply H7; simpl in Hx2.
    -eapply gr_eq_trans.
     +apply gr_add_compat; [ apply H1 | apply H2 ].
     +apply gr_eq_refl.
  }
  assert (Hy1 : y1 ∈ B) by apply H7, Hx1.
  assert (Hy2 : y2 ∈ B) by apply H7, Hx2.
  assert (Hy3 : y3 ∈ B) by (apply H7, C; [ apply Hx1 | apply Hx2 ]).
  assert (H4 : (y1 + y2 - y3)%G ∈ Ker g). {
    split.
    -now apply B; apply B.
    -eapply gr_eq_trans; [ now apply g; apply B | ].
     apply gr_eq_symm, gr_sub_move_r.
     eapply gr_eq_trans; [ apply gr_add_0_l | ].
     eapply gr_eq_trans; [ now apply gr_inv_compat, H_inv | ].
     eapply gr_eq_trans; [ apply gr_inv_inv | ].
     eapply gr_eq_trans.
     +apply Hg₁, C; [ apply Hx1 | apply Hx2 ].
     +eapply gr_eq_symm, gr_eq_trans; [ now apply g | ].
      eapply gr_eq_trans.
      *apply gr_add_compat; [ apply H1 | apply H2 ].
      *apply gr_eq_refl.
  }
  assert (Hfx1 : (H_app f' z1 = H_app b y1)%G). {
    apply Hf'₁; exists x1.
    split; [ easy | apply gr_eq_refl ].
  }
  assert (Hfx2 : (H_app f' z2 = H_app b y2)%G). {
    apply Hf'₁; exists x2.
    split; [ easy | apply gr_eq_refl ].
  }
  assert (Hfx3 : (H_app f' z3 = H_app b y3)%G). {
    unfold z3, y3.
    apply Hf'₁.
    exists x3.
    split; [ | apply gr_eq_refl ].
    unfold x3.
    now apply (Ker c).
  }
  assert
    (Hfzzz :
       (H_app f' (z1 + z2 - z3) = H_app b y1 + H_app b y2 - H_app b y3)%G). {
    assert (Hz1A' : z1 ∈ A' ∧ z2 ∈ A' ∧ z3 ∈ A'). {
      assert (H : z1 ∈ A' ∧ z2 ∈ A'). {
        split.
        -apply Hf'₁.
         exists x1; split; [ easy | apply gr_eq_refl ].
        -apply Hf'₁.
         exists x2; split; [ easy | apply gr_eq_refl ].
      }
      split; [ easy | ].
      split; [ easy | ].
      unfold z3.
      apply Hf'₁.
      exists x3; split; [ | apply gr_eq_refl ].
      unfold x3.
      now apply (Ker c).
    }
    eapply gr_eq_trans; simpl.
    -now apply H_linear; apply A'.
    -apply gr_add_compat.
     +eapply gr_eq_trans; [ now apply H_linear | ].
      now apply gr_add_compat.
     +eapply gr_eq_trans; [ now apply H_inv | ].
      now apply gr_inv_compat.
  }
  apply sf in H4.
  destruct H4 as (z & Hz & Hzf).
  assert (Hfz : (H_app f' (z1 + z2 - z3) = H_app f' (H_app a z))%G). {
    eapply gr_eq_trans; [ apply Hfzzz | ].
    eapply gr_eq_trans.
    -apply gr_add_compat; [ now apply gr_eq_symm, b | ].
     +now apply gr_eq_symm, H_inv.
    -eapply gr_eq_trans.
     +now apply gr_eq_symm, H_linear; apply B.
     +eapply gr_eq_trans.
      *apply H_compat; [ | | eapply gr_eq_symm, Hzf ].
      --now apply B; apply B.
      --now apply f.
      *apply Hcff'.
  }
  apply Hf'inj in Hfz.
  -simpl; unfold Coker_eq; simpl.
   exists (- z).
   split; [ now apply A | ].
   eapply gr_eq_trans; [ now apply H_inv | ].
   eapply gr_eq_trans; [ apply gr_inv_compat, gr_eq_symm, Hfz | ].
   eapply gr_eq_symm.
   eapply gr_eq_trans; [ apply gr_add_comm | ].
   eapply gr_eq_trans.
   +apply gr_add_compat; [ apply gr_inv_add_distr | apply gr_eq_refl ].
   +apply gr_eq_symm.
    eapply gr_eq_trans.
    *simpl; apply gr_inv_add_distr.
    *apply gr_add_compat; [ apply gr_inv_add_distr | ].
     apply gr_inv_inv.
  -apply A'.
   +apply A'.
    *apply Hf'₁; exists x1.
     split; [ easy | apply gr_eq_refl ].
    *apply Hf'₁; exists x2.
     split; [ easy | apply gr_eq_refl ].
   +apply A'.
    apply Hf'₁; exists x3.
    split; [ | apply gr_eq_refl ].
    unfold x3.
    now apply (Ker c).
  -now apply a.
}
assert (Hmemc : ∀ x, x ∈ Ker c → d x ∈ Coker a). {
  intros x Hx.
  apply Hf'₁.
  exists x; split; [ easy | apply gr_eq_refl ].
}
remember
  {| H_app := d; H_mem_compat := Hmemc; H_linear := Hlin; H_compat := Hcomp |}
    as dm.
exists dm.

...
  intros x1 x2 Hx1 Hx2.
  specialize (Hf'₁ (H_app b (g₁ x1))) as H1.
  assert (H : ∃ x, x ∈ Ker c ∧ (H_app b (g₁ x1) = H_app b (g₁ x))%G). {
    exists x1; split; [ easy | apply gr_eq_refl ].
  }
  specialize (H1 H) as (Hfx1, Hf'x1); clear H.
  assert (H : (H_app f' (d x1) = H_app b (g₁ x1))%G) by now subst d.
  clear Hf'x1; rename H into Hf'x1.
  specialize (Hf'₁ (H_app b (g₁ x2))) as H1.
  assert (H : ∃ x, x ∈ Ker c ∧ (H_app b (g₁ x2) = H_app b (g₁ x))%G). {
    exists x2; split; [ easy | apply gr_eq_refl ].
  }
  specialize (H1 H) as (Hfx2, Hf'x2); clear H.
  assert (H : (H_app f' (d x2) = H_app b (g₁ x2))%G) by now subst d.
  clear Hf'x2; rename H into Hf'x2.
  move Hfx2 before Hfx1.
  specialize (Hf'₁ (H_app b (g₁ (x1 + x2)%G))) as H1.
  assert (H : ∃ x, x ∈ Ker c ∧ (H_app b (g₁ (x1 + x2)) = H_app b (g₁ x))%G). {
    exists (x1 + x2)%G; split; [ | apply gr_eq_refl ].
    now apply (Ker c).
  }
  specialize (H1 H) as (Hfxy, Hf'xy); clear H.
  assert (H : (H_app f' (d (x1 + x2)) = H_app b (g₁ (x1 + x2)))%G). {
    now subst d.
  }
  clear Hf'xy; rename H into Hf'xy.
  move Hfxy before Hfx2.
  simpl; unfold Coker_eq; simpl.
  exists 0%G.
  split; [ apply A | ].
  eapply gr_eq_trans; [ apply H_zero | ].
  apply gr_eq_symm, gr_sub_move_l, gr_eq_symm.
  eapply gr_eq_trans; [ apply gr_add_0_r | ].
  simpl in Hx1, Hx2.
  apply gr_eq_symm, Hf'inj.
  -apply Hfxy.
  -now apply A'.
  -idtac.
...
  -eapply gr_eq_trans; [ apply Hf'xy | ].
   eapply gr_eq_symm.
   eapply gr_eq_trans.
   +now apply f'.
   +eapply gr_eq_trans.
    *apply gr_add_compat; [ apply Hf'x1 | apply Hf'x2 ].
    *eapply gr_eq_trans.
    --now apply gr_eq_symm, b; apply H7.
    --apply b; [ now apply B; apply H7 | now apply H7, C | ].
...
    *eapply gr_eq_symm, f'; rewrite Hd; [ apply Hfx | apply Hfy ].
    *idtac.
...
  intros * Hx Hy.
  specialize (Hf'₁ x Hx) as H1.
  destruct H1 as (Hfx, Hf'x).
  specialize (Hd y Hy) as H1.
  destruct H1 as (Hfy, Hf'y).
  enough (H1 : (H_app f' (d (x + y)) = H_app f' (d x + d y))%G). {
    destruct (MemDec A' (d (x + y)%G)) as [H2| H2].
     -apply Hf'inj in H1; [ | easy | ].
      +simpl; unfold Coker_eq; simpl.
       exists 0%G.
       split; [ apply A | ].
       eapply gr_eq_trans; [ apply H_zero | apply gr_eq_symm ].
       apply gr_sub_move_r.
       eapply gr_eq_trans; [ apply H1 | ].
       apply gr_eq_symm, gr_add_0_l.
      +simpl in Hfx.
       now apply A'.
     -assert (H : (x + y)%G ∈ Ker c) by now apply (Ker c).
      specialize (Hd (x + y)%G H) as H3; clear H.
      now simpl in H3.
  }
  assert (H : (x + y)%G ∈ Ker c) by now apply (Ker c).
  specialize (Hd (x + y)%G H) as H1; clear H.
  destruct H1 as (Hdxy, Hfd).
  eapply gr_eq_trans; [ apply Hfd | ].
  apply gr_eq_symm.
  assert (H2 : (H_app f' (d x + d y) = H_app f' (d x) + H_app f' (d y))%G). {
    now simpl; apply H_linear.
  }
  eapply gr_eq_trans; [ apply H2 | ].
  eapply gr_eq_trans.
  -apply gr_add_compat; [ apply Hf'x | apply Hf'y ].
  -destruct Hx as (Hx, Hcx).
   destruct Hy as (Hy, Hcy).
   eapply gr_eq_trans.
   +apply gr_eq_symm, H_linear.
    *now specialize (Hg₁ x Hx).
    *now specialize (Hg₁ y Hy).
   +specialize (Hg₁ (x + y)%G) as H1.
    specialize (Hg₁ x Hx) as H3.
    specialize (Hg₁ y Hy) as H4.
    assert (H6 : (H_app g' (H_app b (g₁ x + g₁ y)) = 0)%G). {
      eapply gr_eq_trans.
      -apply gr_eq_symm, Hcgg'.
      -apply gr_eq_trans with (y := H_app c (x + y)%G).
       +apply H_compat; [ apply g; now apply B | now apply C | ].
        eapply gr_eq_trans.
        *apply H_linear; easy.
        *apply gr_eq_trans with (y := (x + H_app g (g₁ y))%G); simpl.
         apply gr_add_compat; [ easy | apply gr_eq_refl ].
         apply gr_add_compat; [ apply gr_eq_refl | easy ].
       +eapply gr_eq_trans; simpl.
        *now apply H_linear.
        *apply gr_eq_trans with (y := (H_app c x + 0)%G).
        --apply gr_add_compat; [ apply gr_eq_refl | easy ].
        --eapply gr_eq_trans; [ apply gr_add_0_r | easy ].
    }
    eapply gr_eq_trans; [ now apply H_linear | ].
    assert
      (H8 : ∀ y₁ y₂, y₁ ∈ B → y₂ ∈ B →
         (H_app g y₁ = H_app g y₂)%G
         → (H_app b (g₁ (H_app g y₁)) = H_app b (g₁ (H_app g y₂)))%G). {
      clear x y Hy Hfy Hf'y Hdxy Hfd H2 H1 H4 H6 Hx Hfx Hf'x H3 Hcx Hcy.
      intros * Hy₁ Hy₂ Hyy.
exfalso.
      assert (H1 : (y₁ - y₂)%G ∈ Ker g). {
        split.
        -apply B; [ easy | now apply B ].
        -eapply gr_eq_trans.
         +apply g; [ easy | now apply B ].
         +apply gr_eq_symm, gr_sub_move_r.
          eapply gr_eq_trans; [ apply gr_add_0_l | ].
          eapply gr_eq_trans; [ now apply gr_eq_symm, H_inv, B | ].
          apply gr_eq_trans with (y := H_app g y₂).
          *apply g; [ now apply B, B | easy | apply gr_inv_inv ].
          *now apply gr_eq_symm.
      }
      apply sf in H1; simpl in H1.
      destruct H1 as (z & Hz & Hfz).
      assert (H1 : (H_app b (H_app f z) = H_app b (y₁ - y₂))%G). {
        apply b; [ now apply f | | easy ].
        apply B; [ easy | now apply B ].
      }
      assert (H2 : (H_app f' (H_app a z) = H_app b (y₁ - y₂))%G). {
        eapply gr_eq_trans; [ apply gr_eq_symm, Hcff' | easy ].
      }
      assert (H3 : (H_app f' (H_app a z) = H_app b y₁ - H_app b y₂)%G). {
        eapply gr_eq_symm.
        apply gr_eq_trans with (y := (H_app b y₁ + H_app b (- y₂))%G).
        -apply gr_add_compat; [ apply gr_eq_refl | ].
         now apply gr_eq_symm, H_inv.
        -eapply gr_eq_trans.
         +apply gr_eq_symm.
          apply H_linear; [ easy | now apply B ].
         +now apply gr_eq_symm.
      }
     assert (H4 : ∃ z₁, z₁ ∈ Coker a ∧ (H_app f' z₁ = H_app b y₁)%G). {

...
      assert (H3 : H_app b (y₁ - y₂)%G ∈ Im f'). {
        exists (H_app a z).
        split; [ now apply a | easy ].
      }
      apply sg' in H3.
      simpl in H3.
      destruct H3 as (Hby, Hgby).
      assert (H4 : (H_app c (H_app g (y₁ - y₂)) = 0)%G). {
        eapply gr_eq_trans; [ apply Hcgg' | easy ].
      }
(* ouais, non, c'est pas ça... *)
...
    assert (H8 : ∀ y, y ∈ B → (H_app b (g₁ (H_app g y)) = H_app b y)%G). {
      clear x y Hy Hfy Hf'y Hdxy Hfd H2 H1 H4 H6 Hx Hfx Hf'x H3.
      intros y Hy.
...

assert ((H_app g' (H_app b (g₁ x) + H_app b (g₁ y)) = 0)%G). {
eapply gr_eq_trans; [ | apply H ].
apply gr_eq_symm.
eapply gr_eq_trans.
apply gr_eq_symm, Hcgg'.
apply gr_eq_trans with (y := H_app c (x + y)%G).
apply H_compat.
apply g.
now apply B.
now apply C.
eapply gr_eq_trans.
apply H_linear; easy.
apply gr_eq_trans with (y := (x + H_app g (g₁ y))%G); simpl.
apply gr_add_compat; [ easy | apply gr_eq_refl ].
apply gr_add_compat; [ apply gr_eq_refl | easy ].
eapply gr_eq_trans; simpl.
now apply H_linear.
...
assert ((H_app g' (H_app b (g₁ x + g₁ y)) = H_app g' (H_app b (g₁ x) + H_app b (g₁ y)))%G). {
  ============================
  (H_app c (x + y) = H_app g' (H_app b (g₁ x) + H_app b (g₁ y)))%G
}
...
    apply H_compat; [ now apply B | easy | ].
    apply gr_eq_symm.
...
  ============================
  (g₁ (x + y) = g₁ x + g₁ y)%G
...
}
...
exists d.
simpl.
split; [ | split ].
-intros y.
 split.
 +intros (x & (Hx & Hax) & Hxy).
  split; [ split | ].
  *eapply B; [ apply Hxy | now apply f ].
  *destruct B' as (b's, b'i, b'eq, b'z, b'o, b'p).
   destruct b'p as (b'zi, b'c, b'id, b'a, b'co, b'eqv, b'imo, b'amo).
   destruct B as (bs, bi, beq, bz, bo, bp).
   destruct bp as (bzi, bc, bid, ba, bco, beqv, bimo, bamo).
   simpl in *.
   transitivity (H_app b (H_app f x)).
  --apply b.
   ++eapply bimo; [ apply Hxy | now apply f ].
   ++now apply f.
   ++now symmetry.
  --etransitivity; [ apply Hcff' | ].
    transitivity (H_app f' (gr_zero A')); [ | apply f' ].
    apply f'; [ now apply a | apply A' | easy ].
  *apply sf.
   exists x; easy.
 +intros ((Hy & Hby) & Hgy).
  assert (H : y ∈ Im f) by now apply sf; split.
  destruct H as (x & Hx & Hxy).
  exists x; split; [ | easy ].
  split; [ easy | ].
  specialize (sf' (H_app a x)) as (H1, H2).
  assert (H3 : H_app a x ∈ Ker f'). {
    split; [ now apply a | ].
    specialize (Hcff' x) as H3.
    destruct B' as (b's, b'i, b'eq, b'z, b'o, b'p).
    destruct b'p as (b'zi, b'c, b'id, b'a, b'co, b'eqv, b'imo, b'amo).
    simpl in *.
    etransitivity; [ symmetry; apply H3 | ].
    transitivity (H_app b y); [ | easy ].
    apply b; [ | easy | easy ].
    destruct B as (bs, bi, beq, bz, bo, bp).
    destruct bp as (bzi, bc, bid, ba, bco, beqv, bimo, bamo).
    simpl in *.
    eapply bimo; [ symmetry; apply Hxy | easy ].
  }
  specialize (H2 H3).
  destruct H2 as (z & _ & Hzz).
  destruct z.
  destruct A' as (a's, a'i, a'eq, a'z, a'o, a'p).
  destruct a'p as (a'zi, a'c, a'id, a'a, a'co, a'eqv, a'imo, a'amo).
  simpl in *.
  etransitivity; [ symmetry; apply Hzz | ].
  apply za'.
-intros y.
 split.
 +intros (x & (Hx & Hax) & Hxy).
  split; [ split | ].
  *eapply C; [ apply Hxy | now apply g ].
  *specialize (Hcgg' x) as H1.
   destruct C' as (c's, c'i, c'eq, c'z, c'o, c'p).
   destruct c'p as (c'zi, c'c, c'id, c'a, c'co, c'eqv, c'imo, c'amo).
   simpl in *.
   transitivity (H_app c (H_app g x)).
  --eapply c; [ | now apply g | now apply C ].
    eapply C; [ apply Hxy | now apply g ].
  --etransitivity; [ apply H1 | ].
    transitivity (H_app g' (gr_zero B')); [ | apply g' ].
    apply g'; [ now apply b | apply B' | easy ].
  *destruct A' as (a's, a'i, a'eq, a'z, a'o, a'p).
   destruct a'p as (a'zi, a'c, a'id, a'a, a'co, a'eqv, a'imo, a'amo).
   simpl in *.
   transitivity (H_app d (H_app g x)).
  --eapply d; [ | | now apply C ].
    split.
   ++eapply C; [ apply Hxy | now apply g ].
   ++destruct C' as (c's, c'i, c'eq, c'z, c'o, c'p).
     destruct c'p as (c'zi, c'c, c'id, c'a, c'co, c'eqv, c'imo, c'amo).
     simpl in *.
     transitivity (H_app c (H_app g x)).
    **eapply c; [ | now apply g | now apply C ].
      eapply C; [ apply Hxy | now apply g ].
    **etransitivity; [ apply Hcgg' | ].
      transitivity (H_app g' (gr_zero B')); [ | apply g' ].
      apply g'; [ now apply b | apply B' | easy ].
   ++split; [ now apply g | ].
     destruct C' as (c's, c'i, c'eq, c'z, c'o, c'p).
     destruct c'p as (c'zi, c'c, c'id, c'a, c'co, c'eqv, c'imo, c'amo).
     simpl in *.
     etransitivity; [ apply Hcgg' | ].
     transitivity (H_app g' (gr_zero B')); [ | apply g' ].
     apply g'; [ now apply b | apply B' | easy ].
  --destruct d as (appd, dp).
    destruct dp as (dz, din, dlin, dcomp); simpl in *.
...
   apply sg'; rewrite <- Hxy.
   exists x; easy.
 +intros ((Hy & Hby) & Hgy).
  assert (H : y ∈ Im f) by now apply sf; split.
  destruct H as (x & Hx & Hxy).
  exists x; split; [ | easy ].
  split; [ easy | ].
  rewrite <- Hxy, Hcff' in Hby.
  specialize (sf' (H_app a x)) as (H1, H2).
  assert (H3 : H_app a x ∈ Ker f') by now split; [ apply a | ].
  specialize (H2 H3).
  destruct H2 as (z & _ & Hzz).
  destruct z; rewrite <- Hzz.
  apply za'.
...


(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path.
From mathcomp Require Import ssralg fintype perm choice matrix bigop zmodp mxalgebra poly.

Require Import ssrcomplements stronglydiscrete coherent edr.

Import GRing.Theory.

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

Local Open Scope ring_scope.
Local Open Scope mxpresentation_scope.

Reserved Notation "{ 'fpmod' T }" (at level 0, format "{ 'fpmod' T }").
Reserved Notation "''Mor' ( M , N )" (at level 8, format "''Mor' ( M ,  N )").
Reserved Notation "''Mono' ( M , N )" (at level 8, format "''Mono' ( M ,  N )").
Reserved Notation "''Epi' ( M , N )" (at level 8, format "''Epi' ( M ,  N )").
Reserved Notation "''Iso' ( M , N )" (at level 8, format "''Iso' ( M ,  N )").
Reserved Notation "''End' ( M )" (at level 8, format "''End' ( M )").
Reserved Notation "''Aut' ( M )" (at level 8, format "''Aut' ( M )").
Reserved Notation "M %= N" (at level 70, no associativity).
Reserved Notation "A ** B" (at level 40, left associativity, format "A  **  B").
Reserved Notation "x ^^-1" (at level 3, left associativity, format "x ^^-1").

Section morphismDef.

Variable R : coherentRingType.

(** Module *)
Record fpmod := FPmod {
  nbrel : nat;
  nbgen : nat;
  pres  : 'M[R]_(nbrel, nbgen)
}.

Definition fpmod_of of phant R := fpmod.
(* Identity Coercion type_fpmod_of : fpmod_of >-> fpmod. *) (* Is this necessary? *)

(* We want morphism_of_rect so temporarily add this: *)
Set Nonrecursive Elimination Schemes.

(** Morphisms *)
Record morphism_of (M N : fpmod) :=
  Morphism { matrix_of_morphism : 'M[R]_(nbgen M,nbgen N);
             _ : (pres N %| pres M *m matrix_of_morphism)%MP }.

Unset Nonrecursive Elimination Schemes.

End morphismDef.

Notation "{ 'fpmod' T }" := (fpmod_of (Phant T)).
Coercion matrix_of_morphism : morphism_of >-> matrix.
Notation "M %:m" := (M : 'M__) (at level 2, format "M %:m").
Notation "''Mor' ( M , N )" := (morphism_of M N) : type_scope.
Notation "M %:mor" := (M : 'Mor(_,_)) (at level 2, format "M %:mor").
Notation "''End' ( M )" := (morphism_of M M) : type_scope.

Definition source (R : coherentRingType) (M N : {fpmod R}) (phi : 'Mor(M, N)) := M.
Definition target (R : coherentRingType) (M N : {fpmod R}) (phi : 'Mor(M, N)) := N.

Section morphismTheory.

Variable R : coherentRingType.
Local Open Scope mxpresentation_scope.

Section equality.
Variables (M N : {fpmod R}).
Definition eqmor (phi psi : 'Mor(M,N)) := pres N %| phi%:m - psi%:m.

Lemma eqmor_refl : reflexive eqmor.
Proof. by move=> phi; rewrite /eqmor subrr. Qed.
Hint Resolve eqmor_refl : core.

Lemma eqmorxx x : eqmor x x. Proof. exact. Qed.

Lemma eqmor_sym : symmetric eqmor.
Proof. by move=> phi1 phi2; rewrite /eqmor -dvdmxN opprB. Qed.
Hint Resolve eqmor_sym : core.

Lemma eqmor_trans : transitive eqmor.
Proof.
rewrite /eqmor => phi2 phi1 phi3 phi12 phi23.
by rewrite -[phi1%:m](addrNK phi2%:m) -addrA dvdmxD.
Qed.
Hint Resolve eqmor_trans : core.

Lemma eqmor_ltrans : left_transitive eqmor.
Proof. exact: sym_left_transitive. Qed.

Lemma eqmor_rtrans : right_transitive eqmor.
Proof. exact: sym_right_transitive. Qed.

End equality.

Section general.

Variables (M N K : {fpmod R}).

(* reexporting dvdmx_morphism *)
Lemma dvdmx_morphism (phi : 'Mor(M, N)) : (pres N %| pres M *m phi).
Proof. by case: phi. Qed.

(* Constructor for 1 morphism *)
Lemma morphism1_subproof x (X : 'M_(x, _)) : X %| pres N -> X %| pres N *m 1%:M.
Proof. by rewrite mulmx1. Qed.

Definition Morphism1 x (X : 'M_(x, nbgen N)) (dvdXN : X %| pres N) : 'Mor(N, FPmod X) :=
  @Morphism _ _ (FPmod X) _ (@morphism1_subproof x X dvdXN).

Variables (n : nat) (X : 'M[R]_(n, nbgen M)).

Definition source_of_mx := FPmod ((pres M).-ker X).

Lemma mor_of_mx_proof : pres M %| pres source_of_mx *m X.
Proof. by rewrite -dvd_ker. Qed.

Definition mor_of_mx := Morphism mor_of_mx_proof.

End general.

Section zmodType.

Variables (M N : {fpmod R}).

Canonical morphism_subType := Eval hnf in
  [subType for (@matrix_of_morphism _ _ _) by (@morphism_of_rect _ M N)].
Definition morphism_eqMixin := [eqMixin of 'Mor(M, N) by <:].
Canonical morphism_eqType := EqType 'Mor(M, N) morphism_eqMixin.
Definition morphism_choiceMixin := [choiceMixin of 'Mor(M, N) by <:].
Canonical morphism_choiceType := ChoiceType 'Mor(M, N) morphism_choiceMixin.

Implicit Types (phi : 'Mor(M, N)).

(** Zero *)
(* The zero morphism between two object *)
Fact zeromor_proof : pres N %| pres M *m 0.
Proof. by rewrite mulmx0 dvdmx0. Qed.

Definition zeromor : 'Mor(M,N) := Morphism zeromor_proof.

(** Addition *)
Fact addmor_proof phi1 phi2 :
  pres N %| pres M *m (phi1%:m + phi2%:m).
Proof. by rewrite mulmxDr dvdmxD // dvdmx_morphism. Qed.

Definition addmor phi1 phi2 : 'Mor(M, N) :=
  Morphism (addmor_proof phi1 phi2).

(** Subtraction *)
Fact oppmor_proof phi : pres N %| pres M *m (- phi%:m).
Proof. by rewrite mulmxN dvdmxN dvdmx_morphism. Qed.

Definition oppmor phi : 'Mor(M, N) := Morphism (oppmor_proof phi).

Fact addmA_subproof : associative addmor.
Proof. by move=> x y z; apply: val_inj; apply: addrA. Qed.
Fact addmC_subproof : commutative addmor.
Proof. by move=> x y; apply: val_inj; apply: addrC. Qed.
Fact add0m_subproof : left_id zeromor addmor.
Proof. by move=> x; apply: val_inj; apply: add0r. Qed.
Fact addNm_subproof : left_inverse zeromor oppmor addmor.
Proof. by move=> x; apply: val_inj; apply: addNr. Qed.

Definition morphism_zmodMixin :=
  ZmodMixin addmA_subproof addmC_subproof add0m_subproof addNm_subproof.
Canonical morphism_zmodType := ZmodType 'Mor(M, N) morphism_zmodMixin.

End zmodType.

Section category.

Section defs.

Variables (M N K : {fpmod R}).

(** Identity endomorphism *)
Definition idm : 'End(M) := Morphism (morphism1_subproof (dvdmx_refl _)).
Implicit Types (phi : 'Mor(M, N)) (psi : 'Mor(N, K)).

(** Composition *)
Fact mulmor_proof phi psi : pres K %| pres M *m (phi *m psi).
Proof.
rewrite mulmxA (dvdmx_trans (dvdmx_morphism psi)) //.
by rewrite dvdmxMr // dvdmx_morphism.
Qed.

Definition mulmor phi psi : 'Mor(M, K) := Morphism (mulmor_proof phi psi).

End defs.
Arguments idm {_}.
Infix "**" := mulmor : mxpresentation_scope.
Infix "%=" := eqmor : mxpresentation_scope.

Section theory.
Variables (M N P Q : {fpmod R}).

Lemma mul1mor (phi : 'Mor(M,P)) : idm ** phi = phi.
Proof. by apply: val_inj; rewrite /= mul1mx. Qed.

Lemma mulmor1 (phi : 'Mor(M,P)) : phi ** idm = phi.
Proof. by apply: val_inj; rewrite /= mulmx1. Qed.

Lemma mul0mor (phi : 'Mor(M,P)) : 0 ** phi = 0 :> 'Mor(N,P).
Proof. by apply: val_inj; rewrite /= mul0mx. Qed.

Lemma mulmor0 (phi : 'Mor(M,P)) : phi ** 0 = 0 :> 'Mor(M, Q).
Proof. by apply: val_inj; rewrite /= mulmx0. Qed.

Lemma mulmorA (psi : 'Mor(M,N)) (phi : 'Mor(N,P)) (kapa : 'Mor(P,Q)) :
  psi ** (phi ** kapa) = (psi ** phi) ** kapa.
Proof. by apply: val_inj; rewrite /= mulmxA. Qed.

Lemma mulmorDl (phi1 phi2 : 'Mor(M, N)) (psi : 'Mor(N, P)) :
  (phi1 + phi2) ** psi = phi1 ** psi + phi2 ** psi.
Proof. by apply: val_inj => /=; rewrite mulmxDl. Qed.

Lemma mulmorDr (psi : 'Mor(M, N)) (phi1 phi2 : 'Mor(N, P)) :
  psi ** (phi1 + phi2)= psi ** phi1 + psi ** phi2.
Proof. by apply: val_inj => /=; rewrite mulmxDr. Qed.

Lemma mulmorN (phi : 'Mor(M, N)) (psi : 'Mor(N, P)) :
  phi ** (- psi) = - (phi ** psi).
Proof. by apply: val_inj => /=; rewrite mulmxN. Qed.

Lemma mulNmor (phi : 'Mor(M, N)) (psi : 'Mor(N, P)) :
  (- phi) ** psi = - (phi ** psi).
Proof. by apply: val_inj => /=; rewrite mulNmx. Qed.

Lemma mulmorBl (phi1 phi2 : 'Mor(M, N)) (psi : 'Mor(N, P)) :
  (phi1 - phi2) ** psi = phi1 ** psi - phi2 ** psi.
Proof. by rewrite mulmorDl mulNmor. Qed.

Lemma mulmorBr (psi : 'Mor(M, N)) (phi1 phi2 : 'Mor(N, P)) :
  psi ** (phi1 - phi2) = psi ** phi1 - psi ** phi2.
Proof. by rewrite mulmorDr mulmorN. Qed.

Lemma eqmorMl (psi : 'Mor(M, N)) (phi1 phi2 : 'Mor(N, P)) :
  phi1 %= phi2 -> psi ** phi1 %= psi ** phi2.
Proof. by move=> phi12; rewrite /eqmor -mulmxBr dvdmxMl. Qed.

Lemma eqmorMr (psi : 'Mor(N, P)) (phi1 phi2 : 'Mor(M, N)) :
  phi1 %= phi2 -> phi1 ** psi %= phi2 ** psi.
Proof.
rewrite /eqmor=> phi12.
by rewrite -mulmxBl (dvdmx_trans (dvdmx_morphism psi)) ?dvdmxMr.
Qed.

End theory.
End category.

End morphismTheory.
Arguments idm {_ _}.
Infix "**" := mulmor.
Infix "%=" := eqmor.
#[export] Hint Resolve eqmorxx : core.

Section KernelAndCo.
Variable R : coherentRingType.
Variables (M N : {fpmod R}) (phi : 'Mor(M,N)).

(** Kernel

The kernel is the submodule defined by the monomorphism induced by N.-ker:

       pres kermod
     R ---------> "kermod"
     |            |
     |            | kernel := N.-ker phi
     v     M      v
     R ---------> R
     |            |
     |            | phi
     v     N      v
     R ---------> R

*)
Definition kermod := source_of_mx (((pres N).-ker) phi).
Definition kernel : 'Mor(kermod,_) := mor_of_mx ((pres N).-ker phi).
Definition injm := kernel %= 0.

(** Quotienting is just matrix stacking *)
Definition quot_by : {fpmod R} := FPmod (col_mx (pres N) phi).

Lemma dvd_quot_mx x (X : 'M_(x, _)) : pres N %| X -> pres quot_by %| X.
Proof. by move=> dvdNX; apply/dvd_col_mxP; exists 0; rewrite mul0mx subr0. Qed.

(** Cokernel
We have a commutative diagram:

          M
     R--------> R
     |          |
     |          | phi
     v    N     v
     R--------> R
     |          |
     |  ( N )   | 1
     v  (phi)   v
     R--------->R

The cokernel morphism is the 1 morphism of N onto pcoker *)
Definition coker : 'Mor(N, quot_by) := Morphism1 (dvd_quot_mx (dvdmx_refl _)).
Definition surjm := coker %= 0.
Definition isom := injm && surjm.

Lemma mulkmor : kernel ** phi %= 0.
Proof. by rewrite /eqmor subr0 ker_modK. Qed.

Lemma mulmorc : phi ** coker %= 0.
Proof. by rewrite /eqmor subr0 /= mulmx1 dvd_col_mxl. Qed.

End KernelAndCo.

(* Warning: kernel and coker are not compatible with %=, if we
   quotiented 'Mor by %=, we should always pick the kernel/coker wrt
   the canonical representative of the equivalence class *)

Section morphismProperties.

Variable R : coherentRingType.
Variables (M N : {fpmod R}) (phi : 'Mor(M, N)).

Definition is_mono :=
  forall (P : {fpmod R}) (psi : 'Mor(P, M)), psi ** phi %= 0 -> psi %= 0.

Definition is_epi  :=
  forall (P : {fpmod R}) (psi : 'Mor(N, P)), phi ** psi %= 0 -> psi %= 0.

(* A morphism is an isomorphism if it is both injective and surjective *)
Lemma monoP : reflect is_mono (kernel phi %= 0).
Proof.
apply: (iffP idP); last by apply; rewrite mulkmor.
rewrite /is_mono /eqmor subr0 => /= dvdMK P psi.
rewrite subr0 => dvd_phi_psi.
by rewrite (dvdmx_trans dvdMK) //= subr0 dvd_ker.
Qed.

Lemma epiP : reflect is_epi (coker phi %= 0).
Proof.
apply: (iffP idP); last by apply; rewrite mulmorc.
rewrite /is_epi /eqmor subr0.
(* should be shortened *)
move=> /dvd_col_mxP [X /dvdmxP [Z Z_def]] P psi.
rewrite !subr0 => /= /dvdmxP [Y] /(congr1 (mulmx X)).
rewrite !mulmxA -[X *m phi](addrNK 1%:M) mulmxDl mul1mx.
move/(canRL (addKr _)) ->.
rewrite -mulNmx opprB Z_def -mulmxA dvdmxD //; last first.
  by rewrite mulmxA dvdmxMl.
by rewrite -mulmxA dvdmxMl // dvdmx_morphism.
Qed.

Lemma rinv_inj (psi : 'Mor(N, M)) :
  phi ** psi %= idm -> kernel phi %= 0.
Proof.
move/(eqmorMl (kernel phi)); rewrite mulmorA mulmor1.
by rewrite (eqmor_ltrans (eqmorMr _ (mulkmor _))) mul0mor eqmor_sym.
Qed.

Lemma linv_surj (psi : 'Mor(N, M)) :
   psi ** phi %= idm -> coker phi %= 0.
Proof.
move/(eqmorMr (coker phi)); rewrite -mulmorA mul1mor.
by rewrite (eqmor_ltrans (eqmorMl _ (mulmorc _))) mulmor0 eqmor_sym.
Qed.

Definition isomorphisms (psi : 'Mor(N, M)) :=
    (phi ** psi %= idm) && (psi ** phi %= idm).

Lemma isoP : reflect (exists psi, isomorphisms psi) (isom phi).
Proof.
rewrite /isom /injm /surjm; apply: (iffP andP) => [[]|[psi]]; last first.
  by move=> /andP [/rinv_inj -> /linv_surj ->].
rewrite /eqmor !subr0.
move=> phi_inj /dvd_col_mxP /sig_eqW [X /= hX].
have Xmor : pres M %| pres N *m X.
  rewrite (dvdmx_trans phi_inj) // dvd_ker -mulmxA -[X *m _](subrK 1%:M).
  by rewrite mulmxDr dvdmxDl ?mulmx1 ?dvdmxMl // -dvdmxN opprB.
exists (Morphism Xmor); rewrite /isomorphisms andbC /eqmor -dvdmxN opprB hX.
rewrite /eqmor (dvdmx_trans phi_inj) // dvd_ker mulmxBl mul1mx.
by rewrite -mulmxA -[X in _ - X]mulmx1 -mulmxBr dvdmxMl // -dvdmxN opprB.
Qed.

End morphismProperties.

Section MonoEpi.

Variable R : coherentRingType.
Variables (M N : {fpmod R}).

Record monomorphism_of := Monomorphism  {
  morphism_of_mono :> 'Mor(M, N);
                 _ : injm morphism_of_mono
}.

Record epimorphism_of := Epimorphism {
  morphism_of_epi :> 'Mor(M, N);
                _ : surjm morphism_of_epi
}.

Record isomorphism_of := Isomorphism {
  morphism_of_iso :> 'Mor(M, N);
                _ : isom morphism_of_iso
}.

Fact split_andb (a b : bool) : a -> b -> a && b.
Proof. by move=> pa pb; apply/andP. Qed.

Definition mono_of phi (phi_mono : is_mono phi) :=
  @Monomorphism phi (@introTF _ _ true (monoP phi) phi_mono).

Definition epi_of phi (phi_epi : is_epi phi) :=
  @Epimorphism phi (@introTF _ _ true (epiP phi) phi_epi).

Definition iso_of_kc phi (k : kernel phi %= 0) (c : coker phi %= 0) :
  isomorphism_of := @Isomorphism phi (split_andb k c).

Definition iso_of_me phi (phi_mono : is_mono phi) (phi_epi : is_epi phi) :=
  @iso_of_kc phi (@introTF _ _ true (monoP phi) phi_mono)
                 (@introTF _ _ true (epiP phi) phi_epi).

Definition iso_of_isom phi psi (isom : @isomorphisms R M N phi psi) :=
  Isomorphism (@introTF _ _ true (isoP phi) (ex_intro _ psi isom)).

(** Helper for morphism reconstruction, à la tuple.v *)
Definition monomorphism phi MkMono : monomorphism_of :=
  MkMono (let: Monomorphism _ phi_inj := phi
          return injm phi in phi_inj).
Definition epimorphism  phi MkEpi  : epimorphism_of :=
  MkEpi  (let: Epimorphism _ phi_epi := phi
          return surjm phi in phi_epi).
Definition isomorphism phi MkIso : isomorphism_of :=
  MkIso (let: Isomorphism _ phi_iso := phi
          return isom phi in phi_iso).

Lemma eqmor_epi (phi psi : 'Mor(M, N)) :
   phi %= psi -> is_epi phi -> is_epi psi.
Proof.
move=> eqp phi_epi P kapa.
by rewrite -(eqmor_ltrans (eqmorMr _ eqp)) => /phi_epi.
Qed.

Lemma eqmor_mono (phi psi : 'Mor(M, N)) :
   phi %= psi -> is_mono phi -> is_mono psi.
Proof.
move=> eqp phi_mono P kapa.
by rewrite -(eqmor_ltrans (eqmorMl _ eqp)) => /phi_mono.
Qed.

End MonoEpi.

Notation "''Mono' ( M , N )" := (monomorphism_of M N) : type_scope.
Notation "''Epi' ( M , N )"  := (epimorphism_of M N) : type_scope.
Notation "''Iso' ( M , N )"  := (isomorphism_of M N) : type_scope.
Notation "''Aut' ( M )" := (isomorphism_of M M) : type_scope.
Notation "[Mono 'of' phi ]" :=
  (monomorphism (fun phi_mono => @Monomorphism _ _ _ phi phi_mono))
    (at level 0, format "[Mono  'of'  phi ]").
Notation "[Epi 'of' phi ]" :=
  (epimorphism (fun phi_epi => @Epimorphism _ _ _ phi phi_epi))
    (at level 0, format "[Epi  'of'  phi ]").
Notation "[Iso 'of' phi ]" :=
  (isomorphism (fun phi_iso => @Isomorphism _ _ _ phi phi_iso))
    (at level 0, format "[Iso  'of'  phi ]").
Arguments eqmor_mono {R M N phi psi} _ _ _ _ _.
Arguments eqmor_epi {R M N phi psi} _ _ _ _ _.

Section MonoTheory.
Variable (R : coherentRingType).

Section Mono1.
Variables (M N : {fpmod R}).

Lemma kernel_eq0 (phi : 'Mono(M,N)) : kernel phi %= 0.
Proof. by case: phi. Qed.
Hint Resolve kernel_eq0 : core.

Lemma mono (phi : 'Mono(M,N)) : is_mono phi.
Proof. exact/monoP. Qed.
Hint Resolve mono : core.

Lemma mulmono_eq0 (L : {fpmod R}) (phi : 'Mono(M,N)) (Y : 'Mor(L, M)) :
  (Y ** phi %= 0) = (Y %= 0).
Proof.
apply/idP/idP; first by move/mono.
by move=> /eqmorMr /eqmor_ltrans ->; rewrite mul0mor.
Qed.

Variables (n : nat) (X : 'M[R]_(n, nbgen M)).

Fact mor_of_mx_inj : kernel (mor_of_mx X) %= 0.
Proof. by apply/monoP=> P psi; rewrite /= /eqmor !subr0 -dvd_ker. Qed.

Canonical mono_of_mx := Monomorphism mor_of_mx_inj.
End Mono1.

Lemma left_mono (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) :
  is_mono (phi ** psi) -> is_mono phi.
Proof.
by move=> mmono K kapa /(eqmorMr psi); rewrite mul0mor -mulmorA => /mmono.
Qed.

End MonoTheory.

#[export] Hint Resolve kernel_eq0 : core.
#[export] Hint Resolve mono : core.

Section EpiTheory.
Variable (R : coherentRingType).

Section Epi1.
Variables (M N : {fpmod R}).

Lemma coker_eq0 (phi : 'Epi(M,N)) : coker phi %= 0.
Proof. by case: phi. Qed.
Hint Resolve coker_eq0 : core.

Lemma epi (phi : 'Epi(M,N)) : is_epi phi.
Proof. exact/epiP. Qed.

Lemma mulepi_eq0 (L : {fpmod R}) (phi : 'Epi(M,N)) (Y : 'Mor(N, L)) :
  (phi ** Y %= 0) = (Y %= 0).
Proof.
apply/idP/idP; first by move/epi.
by move/eqmorMl/eqmor_ltrans ->; rewrite mulmor0.
Qed.
End Epi1.

Lemma right_epi (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) :
  is_epi (phi ** psi) -> is_epi psi.
Proof.
by move=> mepi K kapa /(eqmorMl phi); rewrite mulmor0 mulmorA => /mepi.
Qed.

End EpiTheory.

#[export] Hint Resolve coker_eq0 : core.
#[export] Hint Resolve epi : core.

Section IsoTheory.
Variable (R : coherentRingType) (M N : {fpmod R}).

Fact iso_kernel_eq0 (phi : 'Iso(M,N)) : kernel phi %= 0.
Proof. by case: phi => /= ? /andP[]. Qed.
Hint Resolve iso_kernel_eq0 : core.

Fact iso_coker_eq0 (phi : 'Iso(M,N)) : coker phi %= 0.
Proof. by case: phi => /= ? /andP[]. Qed.
Hint Resolve iso_coker_eq0 : core.

Canonical mono_of_iso phi := Monomorphism (iso_kernel_eq0 phi).
Canonical epi_of_iso phi := Epimorphism (iso_coker_eq0 phi).

Definition invmor (phi : 'Iso(M,N)) :=
  projT1 (sigW (isoP phi (split_andb (kernel_eq0 [Mono of phi])
                                        (coker_eq0 [Epi of phi])))).
Notation "phi ^^-1" := (invmor phi).

Lemma mulVmor (phi : 'Iso(M,N)) : phi^^-1 ** phi %= idm.
Proof. by rewrite /invmor; case: sigW => /= psi /andP []. Qed.

Lemma mulmorV (phi : 'Iso(M,N)) : phi ** phi^^-1 %= idm.
Proof. by rewrite /invmor; case: sigW => /= psi /andP []. Qed.

End IsoTheory.
Notation "phi ^^-1" := (invmor phi) : mxpresentation_scope.

Section theory.

Local Open Scope mxpresentation_scope.

Variable R : coherentRingType.

(* Kernel is mono *)
Fact kernelK (M N : {fpmod R}) (phi : 'Mor(M,N)) : kernel (kernel phi) %= 0.
Proof. by rewrite kernel_eq0. Qed.

Canonical mono_of_kernel (M N : {fpmod R}) (phi : 'Mor(M,N)) :=
  Monomorphism (kernelK phi).

(* cokernel is epi *)
Lemma cokerK (M N : {fpmod R}) (phi : 'Mor(M,N)) : coker (coker phi) %= 0.
Proof. by rewrite /eqmor subr0 dvd_col_mxl. Qed.

Canonical epi_of_coker (M N : {fpmod R}) (phi : 'Mor(M,N)) :=
  Epimorphism (cokerK phi).

(* The identity morphism is an isomorphism *)
Lemma isomorphisms_idm (M : {fpmod R}) : isomorphisms (@idm _ M) idm.
Proof. by apply/andP; split; rewrite mulmor1. Qed.

Lemma mulmor11 (M : {fpmod R}) : (@idm _ M) ** idm %= idm.
Proof. by rewrite mul1mor. Qed.

Canonical idm_iso (M : {fpmod R}) :=
  iso_of_kc (rinv_inj (mulmor11 M)) (linv_surj (mulmor11 M)).

(** Kernel universal property *)
Definition is_kernel (M N K : {fpmod R}) (phi : 'Mor(M,N))
  (k : 'Mor(K,M)) :=
  ((k ** phi %= 0) *
  forall L (psi : 'Mor(L,M)),
    reflect (exists Y, Y ** k %= psi) (psi ** phi %= 0))%type.

(** Our kernel construction has the universal property *)
Lemma kernelP (M N : {fpmod R}) (phi : 'Mor(M,N)) :
  is_kernel phi (kernel phi).
Proof.
split; first by rewrite mulkmor.
move=> L X; apply: (iffP idP) => [|[Y]]; last first.
  move/eqmorMr/eqmor_ltrans <-; rewrite -mulmorA.
  by rewrite (eqmor_ltrans (eqmorMl _ (mulkmor _))) mulmor0.
rewrite /eqmor; rewrite subr0 -dvd_ker => /dvdmxP [Y Yeq].
have Ymor : pres (source (kernel phi)) %| pres L *m Y.
  by rewrite /= dvd_ker -mulmxA -Yeq dvdmx_morphism.
by exists (Morphism Ymor); rewrite Yeq subrr.
Qed.

(** Any monomorphism is a kernel of its cokernel *)
Lemma mono_ker (M N : {fpmod R}) (phi : 'Mono(M,N)) :
  is_kernel (coker phi) phi.
Proof.
split; first by rewrite mulmorc.
move=> L X; apply: (iffP idP); last first.
  move=> [Y /eqmorMr /eqmor_ltrans <-]; rewrite -mulmorA.
  by rewrite (eqmor_ltrans (eqmorMl _ (mulmorc _))) mulmor0.
rewrite /eqmor subr0 /= mulmx1 => /dvd_col_mxP [Y Ydef].
suff Ymor : pres M %| pres L *m Y.
  by exists (Morphism Ymor); rewrite /= -dvdmxN opprB.
have := kernel_eq0 phi; rewrite /eqmor subr0 /=.
move=> /dvdmx_trans -> //; rewrite dvd_ker.
rewrite -mulmxA -[Y *m phi](addrNK X%:m) mulmxDr dvdmxD ?dvdmx_morphism //.
by rewrite dvdmxMl // -dvdmxN opprB.
Qed.

(* Quotienting by a morphism may allow you to factor it out *)
Lemma lift_subproof (M N L : {fpmod R})
  (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) :
  phi ** psi %= 0 -> pres L %| pres (quot_by phi) *m psi.
Proof. by rewrite /eqmor subr0 /= mul_col_mx dvd_mx_col dvdmx_morphism. Qed.

(* Lifting a morphism psi wrt a quotient by phi *)
Definition lift (M N L : {fpmod R})
  (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) : 'Mor(quot_by phi,L) :=
  if (phi ** psi %= 0) =P true is ReflectT P
  then Morphism (lift_subproof P) else 0.

(* We can factor a morphism psi by its lifting *)
Lemma mul_lift (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) :
  phi ** psi %= 0 -> coker phi ** lift phi psi %= psi.
Proof.
rewrite /lift; case: eqP => //= p _.
by rewrite /eqmor /= mul1mx subrr.
Qed.

(* The lifting of an epi is an epi *)
Lemma lift_epi (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Epi(N,L)) :
  phi ** psi %= 0 -> is_epi (lift phi psi).
Proof.
move=> /mul_lift psiP K kapa; rewrite eqmor_sym in psiP.
suff lepi : is_epi (lift phi psi) by move/lepi.
apply: right_epi (coker phi) _ _.
exact: (@eqmor_epi _ _ _ psi).
Qed.

Lemma mul_klift (M N : {fpmod R}) (psi : 'Mor(M,N)) :
  coker (kernel psi) ** lift (kernel psi) psi %= psi.
Proof. by rewrite mul_lift // mulkmor. Qed.

(* The lifting of phi to the quotient of its kernel is a monomorphism *)
Lemma lift_mono (M N : {fpmod R}) (psi : 'Mor(M,N)) :
  is_mono (lift (kernel psi) psi).
Proof.
apply/monoP; rewrite /eqmor subr0 /=.
rewrite (dvdmx_trans (dvd_col_mxl _ _)) // /lift.
by case: eqP (mulkmor psi).
Qed.

(** Universal property of the cokernel *)
Definition is_coker (M N C : {fpmod R}) (phi : 'Mor(M,N))
  (c : 'Mor(N,C)) :=
  ((phi ** c %= 0) *
  forall L (psi : 'Mor(N,L)),
    reflect (exists Y, c ** Y %= psi) (phi ** psi %= 0))%type.

(** Our coker construction satisfies the universal property of cokernels *)
Lemma cokerP (M N : {fpmod R}) (phi : 'Mor(M,N)) : is_coker phi (coker phi).
Proof.
split; first by rewrite mulmorc.
move=> L X; apply: (iffP idP) => [phiX|[Y]]; last first.
  move/eqmorMl/eqmor_ltrans <-; rewrite mulmorA.
  by rewrite (eqmor_ltrans (eqmorMr _ (mulmorc _))) mul0mor.
by exists (lift phi X); rewrite mul_lift.
Qed.

(* Factorisation lemma *)
Lemma factor_proof (M N P : {fpmod R}) (phi : 'Mono(N,P)) (psi : 'Mor(M,P)) :
  reflect (exists kapa, kapa ** phi %= psi) (psi ** coker phi %= 0).
Proof.
apply: (iffP idP) => [|[c]]; last first.
  move/eqmorMr/eqmor_ltrans <-; rewrite -mulmorA.
  by rewrite (eqmor_ltrans (eqmorMl _ (mulmorc _))) mulmor0.
rewrite /eqmor /= subr0 mulmx1 => /dvd_col_mxP [X Xdef].
suff Xmor : pres N %| pres M *m X.
  by exists (Morphism Xmor); rewrite -dvdmxN opprB.
have /monoP := @mono _ _ _ phi.
rewrite /eqmor /= subr0 => /dvdmx_trans -> //.
rewrite dvd_ker -mulmxA -[X *m _](addrNK psi%:m).
by rewrite mulmxDr dvdmxD ?dvdmx_morphism // dvdmxMl // -dvdmxN opprB.
Qed.

(* extraction of the factor *)
Definition factor (M N P : {fpmod R})
  (phi : 'Mor(N,P)) (psi : 'Mor(M,P)) : 'Mor(M,N) :=
  if (kernel phi %= 0) =P true is ReflectT phi_inj
  then if factor_proof (Monomorphism phi_inj) psi is ReflectT P
  then projT1 (sig_eqW P) else 0
  else 0.

(* property of the factor *)
Lemma factorP (M N P : {fpmod R}) (phi : 'Mono(N,P)) (psi : 'Mor(M,P)) :
  psi ** coker phi %= 0 -> factor phi psi ** phi %= psi.
Proof.
have := kernel_eq0 phi; rewrite /factor.
case: eqP => // phi_inj _; case: factor_proof => //= p _.
by case: sig_eqW.
Qed.

Notation "phi %/ psi" := (quot_by (factor phi psi)).

(** Every epimorphism is a cokernel of its kernel *)
Lemma epi_coker (M N : {fpmod R}) (phi : 'Epi(M,N)) :
  is_coker (kernel phi) phi.
Proof.
split; first by rewrite mulkmor.
move=> L psi; apply: (iffP idP); last first.
  move=> [Y /eqmorMl /eqmor_ltrans <-]; rewrite mulmorA.
  by rewrite (eqmor_ltrans (eqmorMr _ (mulkmor _))) mul0mor.
move/mul_lift; have /mul_lift := mulkmor phi.
set phi' := lift _ phi; set psi' := lift _ psi.
move=> phi'E psi'E.
have phi'_mono : is_mono phi' by apply: lift_mono.
have phi'_epi : is_epi phi' by apply: lift_epi; rewrite mulkmor.
set phi'' := @iso_of_me _ _ _ phi' phi'_mono phi'_epi.
exists (phi''^^-1 ** psi').
rewrite -(eqmor_ltrans (eqmorMr _ phi'E)) -(eqmor_rtrans psi'E).
rewrite -mulmorA eqmorMl // mulmorA.
by rewrite (eqmor_ltrans (eqmorMr _ (mulmorV phi''))) mul1mor.
Qed.

(** Introduction of direct sum, which play the role of the kernel *)
(* and the cokernel *)
Section dsum.
Variables (M N : {fpmod R}).

Definition dsum := FPmod (block_mx (pres M) 0 0 (pres N)).

Fact proj1_proof : pres M %| pres dsum *m (col_mx 1%:M 0).
Proof.
by rewrite mul_block_col !mulmx0 !addr0 mul0mx mulmx1 dvd_mx_col dvdmx0 andbT.
Qed.
Definition proj1 : 'Mor(dsum, M) := Morphism proj1_proof.

Lemma proj1_is_epi : is_epi proj1.
Proof.
move=> P phi; rewrite /eqmor !subr0 /=.
by rewrite mul_col_mx mul0mx mul1mx dvd_mx_col => /andP[].
Qed.
Canonical proj1_epi := epi_of proj1_is_epi.

Definition proj2_proof : pres N %| pres dsum *m (col_mx 0 1%:M).
Proof.
by rewrite mul_block_col !mulmx0 !add0r mul0mx mulmx1 dvd_mx_col dvdmx0 /=.
Qed.
Definition proj2 : 'Mor(dsum, N) := Morphism proj2_proof.

Lemma proj2_is_epi : is_epi proj2.
Proof.
move=> P phi; rewrite /eqmor !subr0 /=.
by rewrite mul_col_mx mul0mx mul1mx dvd_mx_col => /andP[].
Qed.
Canonical proj2_epi := epi_of proj2_is_epi.

Lemma inj1_proof : pres dsum %| pres M *m (row_mx 1%:M 0).
Proof.
apply/dvdmxP; exists (row_mx 1%:M 0).
by rewrite mul_mx_row mul_row_block !(mulmx0, mul0mx) !addr0 mul1mx mulmx1.
Qed.
Definition inj1 : 'Mor(M,dsum) := Morphism inj1_proof.

Lemma inj1_is_mono : is_mono inj1.
Proof.
move=> P phi; rewrite /eqmor !subr0 /= mul_mx_row mulmx1 mulmx0.
move=> /dvdmxP [X]; rewrite -[X]hsubmxK mul_row_block.
by rewrite !mulmx0 addr0 add0r => /eq_row_mx[-> _]; rewrite dvdmxMl.
Qed.
Canonical inj1_mono := mono_of inj1_is_mono.

Lemma inj2_proof : pres dsum %| pres N *m (row_mx 0 1%:M).
Proof.
apply/dvdmxP; exists (row_mx 0 1%:M).
by rewrite mul_mx_row mul_row_block !(mulmx0, mul0mx) !add0r mul1mx mulmx1.
Qed.
Definition inj2 : 'Mor(N,dsum) := Morphism inj2_proof.

Lemma inj2_is_mono : is_mono inj2.
Proof.
move=> P phi; rewrite /eqmor !subr0 /= mul_mx_row mulmx1 mulmx0.
move=> /dvdmxP [X]; rewrite -[X]hsubmxK mul_row_block.
by rewrite !mulmx0 addr0 add0r => /eq_row_mx[_ ->]; rewrite dvdmxMl.
Qed.
Canonical inj2_mono := mono_of inj2_is_mono.

Lemma inj1_proj2 : inj1 ** proj2 = 0.
Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul0mx addr0. Qed.

Lemma inj2_proj1 : inj2 ** proj1 = 0.
Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul0mx addr0. Qed.

Lemma inj1_proj1 : inj1 ** proj1 = idm.
Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul1mx addr0. Qed.

Lemma inj2_proj2 : inj2 ** proj2 = idm.
Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul1mx add0r. Qed.

Lemma dsum_is_product (P : {fpmod R}) (p1 : 'Mor(P,M)) (p2 : 'Mor(P,N)) :
  exists phi : 'Mor(P,dsum), p1 = phi ** proj1 /\ p2 = phi ** proj2.
Proof.
exists (p1 ** inj1 + p2 ** inj2).
rewrite !mulmorDl -!mulmorA inj1_proj1 inj1_proj2 inj2_proj1 inj2_proj2.
by rewrite !mulmor1 !mulmor0 addr0 add0r.
Qed.

Lemma dsum_is_coproduct (P : {fpmod R}) (i1 : 'Mor(M,P)) (i2 : 'Mor(N,P)) :
  exists phi : 'Mor(dsum,P), i1 = inj1 ** phi /\ i2 = inj2 ** phi.
Proof.
exists (proj1 ** i1 + proj2 ** i2).
rewrite !mulmorDr !mulmorA inj1_proj1 inj1_proj2 inj2_proj1 inj2_proj2.
by rewrite !mul1mor !mul0mor addr0 add0r.
Qed.

End dsum.

Section homology.

Variables (M N P : {fpmod R}).
Variables (phi : 'Mor(M, N)) (psi : 'Mor(N, P)).

Hypothesis mul_phi_psi : phi ** psi %= 0.

Definition homology := kernel psi %/ phi.

(* Alternative definition of homology used in singular and homalg: *)
(*      http://link.springer.com/chapter/10.1007/3-540-28993-3_7         *)
(* The connection between the two definition is not worked out yet *)
Definition homology_alt_pres := (pres (quot_by phi)).-ker (kernel psi).

Lemma homology_dvd : homology_alt_pres %| pres homology.
Proof.
rewrite /homology /homology_alt_pres.
rewrite dvd_mx_col /= !dvd_ker dvd_quot_mx ?ker_modK //=.
rewrite -[X in _ %| X](subrK phi%:m) dvdmxDl ?dvd_col_mxl //=.
rewrite (dvdmx_trans (dvd_col_mxu _ _)) //.
have := @factorP _ _ _ [Mono of kernel psi] phi.
rewrite /eqmor /= subr0 mulmx1; apply.
rewrite (dvdmx_trans (dvd_col_mxl _ _)) // dvd_ker.
by move: mul_phi_psi; rewrite /eqmor subr0.
Qed.

(* Lemma homology_alt_dvd : pres homology %| homology_alt_pres. *)
(* Proof. *)
(* rewrite /homology /homology_alt_pres /=. *)
(* have factor_phi := @factorP _ _ _ [Mono of kernel psi] phi. *)
(* rewrite /eqmor /= subr0 mulmx1 in factor_phi. *)
(* apply/dvd_col_mxP => /=. *)
(* eexists. *)
(* (* rewrite (dvdmx_trans (dvd_col_mxu _ _)) //. *) *)
(* rewrite dvdmxB // !dvd_ker /=. *)
(* Abort. *)

End homology.

End theory.

Notation "phi %/ psi" := (quot_by (factor phi psi)).

Section smith_fpmod.

Local Open Scope mxpresentation_scope.

Variable R : edrType.

Variable M : {fpmod R}.

Let D := FPmod (diag_mx (pres M)).
Let P := (smith (pres M)).1.1.
Let Q := (smith (pres M)).2.

(*           M         *)
(*         ----->      *)
(*        |      |     *)
(*   P^-1 |      | Q   *)
(*        v  D   v     *)
(*         ----->      *)
Fact smith_subproof : pres D %| pres M *m Q.
Proof.
apply/dvdmxP; exists (invmx P).
by rewrite /D mulmx_diag_mx mulmxA mulKVmx ?col_ebase_unit // /row_ebase invmxK.
Qed.

Definition smithm : 'Mor(M, D) := Morphism smith_subproof.

Fact smith_inv_subproof : pres M %| pres D *m invmx Q.
Proof.
apply/dvdmxP; exists P.
by rewrite /D mulmx_diag_mx mulmxKV ?row_ebase_unit // /col_ebase invmxK.
Qed.

Definition smithm_inv : 'Mor(D, M) := Morphism smith_inv_subproof.

Lemma iso_smithm : isomorphisms smithm smithm_inv.
Proof.
have hQ_unit : Q \in unitmx by rewrite /Q; case: smithP.
by rewrite /isomorphisms /eqmor /= ?(mulmxV,mulVmx,subrr,dvdmx0).
Qed.

Canonical smith_iso : 'Iso(M, D) := iso_of_isom iso_smithm.

End smith_fpmod.


Require Import List.
Export ListNotations.

Require Import PeanoNat.

Require Import Ensembles.
Require Import BiInt_GHC.
Require Import BiInt_logics.

Lemma extens_diff_sBIH : forall (p : V),
    (sBIH_rules (Singleton _ (# p), Neg (wNeg (# p)))).
Proof.
intro p. apply DNs with (ps:=[(Singleton _ (# p), #p)]).
intros. inversion H. subst. apply Ids. apply IdRule_I. apply In_singleton.
inversion H0. apply DNsRule_I.
Qed.

Theorem sBIH_extens_wBIH : forall s,
    (wBIH_rules s) -> (sBIH_rules s).
Proof.
intros s D. induction D.
(* Id *)
- inversion H. subst. apply Ids. apply IdRule_I. auto.
(* Ax *)
- inversion H. subst. apply Axs. apply AxRule_I. auto.
(* MP *)
- inversion H1. subst. assert (J1: List.In (Γ, A → B) [(Γ, A → B); (Γ, A)]). apply in_eq.
  pose (H0 (Γ, A → B) J1). assert (J2: List.In (Γ, A) [(Γ, A → B); (Γ, A)]). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2). apply MPs with (ps:=[(Γ, A → B); (Γ, A)]).
  intros. inversion H1. subst. auto. apply MPRule_I.
(* DN *)
- inversion H1. subst. assert (J1: List.In (Empty_set (BPropF V), A) [(Empty_set (BPropF V), A)]). apply in_eq.
  pose (H0 (Empty_set (BPropF V), A) J1). assert (Included _ (Empty_set _) Γ).
  intro. intro. inversion H2. pose (@sBIH_monot (Empty_set _, A) s Γ H2).
  apply DNs with (ps:=[(Γ, A)]). intros. inversion H3. subst.
  assumption. inversion H4. apply DNsRule_I.
Qed.

Theorem pair_sBIH_extens_wBIH : forall P,
    (wpair_derrec P) -> (spair_derrec P).
Proof.
intros P wpair.
unfold spair_derrec. unfold wpair_derrec in wpair.
destruct wpair. destruct H. destruct H0. exists x. repeat split ; auto.
apply sBIH_extens_wBIH. auto.
Qed.

Theorem sBIH_same_thms_wBIH : forall s,
    (sBIH_rules s) ->
    (forall A, ((Empty_set _, A) = s) -> (wBIH_rules s)).
Proof.
intros s D. induction D.
(* Ids *)
- intros A id. inversion H. subst. inversion H2. subst.
  apply Id. apply IdRule_I. auto.
(* Axs *)
- intros A id. inversion H. subst. inversion H2. subst.
  apply Ax. apply AxRule_I. auto.
(* MPs *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (Empty_set (BPropF V), A0 → A) [(Empty_set (BPropF V), A0 → A); (Empty_set (BPropF V), A0)]). apply in_eq.
  pose (H0 (Empty_set (BPropF V), A0 → A) J1).
  assert (J2: List.In (Empty_set (BPropF V), A0) [(Empty_set (BPropF V), A0 → A); (Empty_set (BPropF V), A0)]). apply in_cons. apply in_eq.
  pose (H0 (Empty_set (BPropF V), A0) J2).
  apply MP with (ps:=[(Empty_set _, A0 → A); (Empty_set _, A0)]).
  intros. inversion H2. subst. apply w with (A1:=A0 → A). auto.
  inversion H4. subst. apply w0 with (A:=A0). auto. inversion H5. apply MPRule_I.
(* DNs *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (Empty_set (BPropF V), A0) [(Empty_set (BPropF V), A0)]). apply in_eq.
  pose (H0 (Empty_set (BPropF V), A0) J1).
  apply DNw with (ps:=[(Empty_set _, A0)]). intros. inversion H2. subst.
  apply w with (A:=A0). auto. inversion H4. apply DNwRule_I.
Qed.

Theorem wBIH_same_thms_sBIH : forall s,
    (wBIH_rules s) ->
    (forall A, ((Empty_set _, A) = s) -> (sBIH_rules s)).
Proof.
intros. apply sBIH_extens_wBIH. assumption.
Qed.

Theorem wBIH_sBIH_same_thms : forall A,
    wBIH_rules (Empty_set _, A) <-> sBIH_rules (Empty_set _, A).
Proof.
intros. split ; intro.
apply (wBIH_same_thms_sBIH _ H A) ; auto.
apply (sBIH_same_thms_wBIH _ H A) ; auto.
Qed.


(* * Basic definitions of decidablility and Functions
- includes basic Lemmas about said functions
 *)

Require Export Shared.Base.

(** * Definition of useful tactics *)

(** dec is used to destruct all decisions appearing in the goal or assumptions. *)
Ltac dec := repeat (destruct Dec).

(** This tactic completely solves listComplete goals for base types *)
Ltac listComplete := intros x; simpl; dec; destruct x; try congruence.
(** simplifies (decision x = x) *)
Ltac deq x := destruct (Dec (x=x)) as [[]  | isnotequal]; [> | contradict isnotequal; reflexivity] .

(** Function that takes two lists and returns the list of all pairs of elements from the two lists *)
Fixpoint prodLists {X Y: Type} (A: list X) (B: list Y) {struct A} :=
  match A with
  | nil => nil
  | cons x A' => map (fun y => (x,y)) B ++ prodLists A' B end.

(** Crossing any list with the empty list always yields the empty list *)
Lemma prod_nil (X Y: Type) (A: list X) :
  prodLists A ([]: list Y) = [].
Proof.
  induction A.
  - reflexivity.
  - cbn. assumption.
Qed.

(** This function takes a (A: list X) and yields a list (option X) which for every x in A contains Some x. The resultung list also contains None. The order is preserved. None is the first element of the resulting list. *)

Definition toOptionList {X: Type} (A: list X) :=
  None :: map (@Some _) A .

(** This function counts the number of occurences of an element in a given list and returns the result *)
Fixpoint count (X: Type) `{eq_dec X}  (A: list  X) (x:  X) {struct A} : nat :=
  match A with
  | nil => O
  | cons y A' =>  if Dec (x=y) then S(count A' x) else count A' x end.

Definition toSumList1 {X: Type}  (Y: Type) (A: list X): list (X + Y) :=
  map inl A.
Definition toSumList2 {Y: Type}  (X: Type) (A: list Y): list (X + Y) :=
  map inr A.

(** * Basic lemmas about functions *)

(** In the list containing all pairs of (x,y') with y' from a list B the pair (x,y) is contained exactly as many times as y is contained in the list B. *)

Lemma countMap (X Y: eqType) (x:X) (B: list Y) y :
  count ( map (fun y => (x,y)) B) (x, y) = count B y.
Proof.
  induction B.
  - reflexivity.
  - simpl. dec;  congruence.
Qed.

(** If a list is split somewhere in two list the number of occurences of an element in the list is equal to the sum of the number of occurences in the left and the right part. *)

Lemma countSplit (X: eqType) (A B: list X) (x: X)  : count A x + count B x = count (A ++ B) x.
Proof.
  induction A.
  - reflexivity.
  - cbn. decide (x=a).
    +cbn. f_equal; exact IHA.
    + exact IHA.
Qed.

(** In a list of tupels with x as a left element the number of tupels with something different from x as a left element is 0. *)
Lemma countMapZero  (X Y: eqType) (x x':X) (B: list Y) y : x' <> x -> count  ( map (fun y => (x,y)) B) (x', y) =0.
Proof.
  intros ineq. induction B.
  - reflexivity.
  -  simpl. dec.
     + inversion e; congruence.
     + exact IHB.
Qed.

Lemma notInZero (X: eqType) (x: X) A :
  not (x el A) <-> count A x = 0.
Proof.
  split; induction A.
  -  reflexivity.
  - intros H. cbn in *. dec.
    + exfalso. apply H. left. congruence.
    + apply IHA. intros F. apply H. now right.
  - tauto.
  - cbn. dec.
    + subst a. omega.
    + intros H [E | E].
      * now symmetry in E.
      * tauto.
Qed.

Lemma countIn (X:eqType) (x:X) A:
  count A x > 0 -> x el A.
Proof.
  induction A.
  - cbn. omega.
  - cbn.  dec.
    + intros. left. symmetry. exact e.
    + intros. right. apply IHA. exact H.
Qed.

Lemma InCount (X:eqType) (x:X) A:
  x el A -> count A x > 0.
Proof.
  induction A.
  - intros [].
  - intros [[] | E]; cbn.
    + deq a. omega.
    + specialize (IHA E). dec; omega.
Qed.

Lemma count_in_equiv (X: eqType) (x:X) A : count A x > 0 <-> x el A.
Proof.
  split.
  - apply countIn.
  - apply InCount.
Qed.

Lemma countApp (X: eqType) (x: X) (A B: list X) :
  count (A ++ x::B) x > 0.
Proof.
  auto using InCount.
Qed.

(**  Dupfree Lists containing every x countain x exactly once *)
Lemma dupfreeCount (X: eqType) (x:X) (A: list X) : dupfree A -> x el A -> count A x = 1.
Proof.
  intros D E. induction D.
  -  contradiction E.
  - cbn. dec.
    + f_equal. subst x0. now apply notInZero.
    + destruct E as [E | E]; [> congruence | auto].
Qed.

(** toSumlist1 does not change the number of occurences of an existing element in the list *)
Lemma toSumList1_count (X: eqType) (x: X) (Y: eqType) (A: list X) :
  count (toSumList1 Y A) (inl x) =  count A x .
Proof.
  induction A; simpl; dec; congruence.
Qed.

(** toSumlist2 odes not change the numbe of occurences of an existing element in the list *)
Lemma toSumList2_count (X Y: eqType) (y: Y) (A: list Y):
  count (toSumList2 X A) (inr y) = count A y.
Proof.
  induction A; simpl; dec; congruence.
Qed.

(** to sumList1 does not produce inr proofs *)
Lemma toSumList1_missing (X Y: eqType) (y: Y) (A: list X):
  count (toSumList1 Y A ) (inr y) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

(** toSumlist2 does not produce inl proofs *)
Lemma toSumList2_missing (X Y: eqType) (x: X) (A: list Y):
  count (toSumList2 X A ) (inl x) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

(** * Cardinality Lemmas for lists*)
Lemma cons_incll (X: Type) (A B: list X) (x:X) : x::A <<= B -> A <<= B.
Proof.
  unfold "<<=". auto.
Qed.

Lemma card_length_leq (X: eqType) (A: list X) : card A <= length A.
Proof.
  induction A; auto. cbn. dec; omega.
Qed.

(** * Various helpful Lemmas *)

(** If the concatenation of two lists is nil then each list was nil *)
Lemma appendNil (X: Type) (A B: list X) :
  A ++ B = nil -> A = nil /\ B = nil.
Proof.
  intros H. assert (|A ++ B| = 0) by now rewrite H.
  rewrite app_length in H0. rewrite <- !length_zero_iff_nil. omega.
Qed.

Lemma countZero (X: eqType) (x: X) (A: list X) : count A x = 0 -> not (x el A).
Proof.
  induction A; cbn in *; dec; firstorder congruence.
Qed.

(** The product of two numbers is greater zero if both numbers are greater zero *)
Lemma NullMul a b : a > 0 -> b > 0 -> a * b > 0.
Proof.
  induction 1; cbn; omega.
Qed.