(* Snake lemma *)

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

Require Import AbGroup.

(* Functor HomGr A B → HomGr (KerA) (KerB) *)

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 → Happ f x ∈ Ker b.
intros * Hc * (Hx & Hax).
split; [ now apply f | ].
rewrite Hc, <- (Hzero _ _ f').
apply f'; [ apply a, Hx | easy ].
Qed.

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

Theorem KK_additive {A B A'} : ∀ (f : HomGr A B) (a : HomGr A A'),
  ∀ x y : gr_set (Ker a),
  x ∈ Ker a → y ∈ Ker a → (Happ f (x + y) = Happ f x + Happ f y)%G.
Proof.
intros * Hx Hx'; simpl in Hx, Hx'.
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') :=
  {| Happ (x : gr_set (Ker a)) := Happ f x : gr_set (Ker b);
     Hmem_compat := KK_mem_compat a b f f' Hc;
     Happ_compat := KK_app_compat f a;
     Hadditive := KK_additive f a |}.

(* Functor f:HomGr A B → g:HomGr B C → HomGr (CoKer f) (Coker g) *)

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 → Happ f' x ∈ Coker b.
Proof.
intros * Hx.
now apply f'.
Qed.

Theorem CC_app_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
     → (x = y)%G
     → @gr_eq (Coker b) (Happ f' x) (Happ f' y)%G.
Proof.
intros * Hc * Hx Hxy.
assert (Hy : y ∈ Coker a) by now apply (gr_mem_compat _ x).
simpl in Hx, x, y, Hxy; simpl.
destruct Hxy as (z & Hz & Haz).
simpl; unfold Coker_eq; simpl.
exists (Happ f z).
split; [ now apply f | ].
rewrite Hc.
transitivity (Happ f' (x - y)%G).
-apply Happ_compat; [ now apply a | easy ].
-rewrite Hadditive; [ | easy | ].
 +apply gr_add_compat; [ easy | now apply Hopp ].
 +now apply A'.
Qed.

Theorem CC_additive {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) (Happ f' (x + y))%G (Happ f' x + Happ f' y)%G.
Proof.
intros * Hx Hy; simpl in Hx, Hy.
exists 0%G.
split; [ apply B | ].
rewrite Hzero; symmetry.
simpl; apply gr_sub_move_r.
rewrite gr_add_0_l.
now apply Hadditive.
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') :=
  {| Happ (x : gr_set (Coker a)) := Happ f' x : gr_set (Coker b);
     Hmem_compat := CC_mem_compat f' a b;
     Happ_compat := CC_app_compat f f' a b Hc;
     Hadditive := CC_additive f' a b |}.

(* Morphism g in snake lemma is surjective *)

Theorem g_is_surj {B C C' g} (c : HomGr C C') {cz : HomGr C Gr1} :
   Decidable_Membership
   → Im g == Ker cz
   → ∀ x : gr_set (Ker c), ∃ y, x ∈ C → y ∈ B ∧ (Happ g y = x)%G.
Proof.
intros * mem_dec sg x.
destruct (mem_dec 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 | ].
now destruct (Happ cz x).
Qed.

(* Morphism f' in snake lemma is injective *)

Theorem f'_is_inj {A' B'} {f' : HomGr A' B'} {za' : HomGr Gr1 A'} :
   Im za' == Ker f'
   → ∀ x y, x ∈ A' → y ∈ A' → (Happ f' x = Happ f' y)%G → (x = y)%G.
Proof.
intros * sf' * Hx Hy Hxy.
assert (H2 : (Happ f' x - Happ f' y = 0)%G). {
  apply gr_sub_move_r.
  now rewrite gr_add_0_l.
}
assert (H3 : (Happ f' (x - y) = 0)%G). {
  rewrite Hadditive; [ | easy | now apply A' ].
  rewrite Hxy, Hopp; [ | easy ].
  apply gr_add_opp_r.
}
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). {
  rewrite <- H4.
  apply Hzero.
}
apply gr_sub_move_r in H5.
rewrite H5.
apply gr_add_0_l.
Qed.

(* Morphism f' (on cokernel) in snake lemma is injective *)

Theorem f'c_is_inj
    {A A' B'} {f' : HomGr A' B'} {a : HomGr A A'} {za' : HomGr Gr1 A'} :
  Im za' == Ker f'
  → ∀ x y, x ∈ Coker a → y ∈ Coker a →
     (Happ f' x = Happ f' y)%G → (x = y)%G.
Proof.
intros * sf' * Hx Hy Hxy.
simpl; unfold Coker_eq; simpl.
exists 0; split; [ apply A | ].
eapply (f'_is_inj sf'); [ apply a, A | | ].
-apply A'; [ easy | now apply A' ].
-transitivity (Happ f' 0).
 +apply f'; [ apply a, A | apply Hzero ].
 +rewrite Hzero; symmetry.
  rewrite Hadditive; [ | easy | now apply A' ].
  rewrite Hxy, Hopp; [ | easy ].
  apply gr_add_opp_r.
Qed.

(* Property of g₁ function, inverse of snake lemma function g *)

Definition g₁_prop {B C C'} g (c : HomGr C C') g₁ :=
  ∀ x : gr_set (Ker c), x ∈ C → g₁ x ∈ B ∧ (Happ g (g₁ x) = x)%G.

(* Property of f'₁ function, inverse of snake lemma function f' *)

Definition f'₁_prop
    {A A' B C B' C'} (a : HomGr A A') (b : HomGr B B') {c : HomGr C C'}
    (f' : HomGr A' B') g₁ f'₁ :=
  ∀ x : gr_set B',
  (∃ x1 : gr_set (Ker c), x1 ∈ Ker c ∧ (x = Happ b (g₁ x1))%G)
  → f'₁ x ∈ Coker a ∧ (Happ f' (f'₁ x) = x)%G.

Theorem g₁_in_B : ∀ {B C C' g} {c : HomGr C C'} {g₁},
  g₁_prop g c g₁ → ∀ x, x ∈ C → g₁ x ∈ B.
Proof.
intros * Hg₁ * Hx.
now specialize (Hg₁ x Hx) as H.
Qed.

(* *)

Theorem exists_B'_to_Coker_a : ∀ {A A' B B' C C' g f'}
  {g' : HomGr B' C'} (a : HomGr A A') {b : HomGr B B'} {c : HomGr C C'} {g₁},
  Decidable_Membership
  → Im f' == Ker g'
  → g₁_prop g c g₁
  → diagram_commutes g b c g'
  → ∀ y', ∃ z',
    (∃ x, x ∈ Ker c ∧ (y' = Happ b (g₁ x))%G)
    → z' ∈ Coker a ∧ (Happ f' z' = y')%G.
Proof.
intros * mem_dec sg' Hg₁ Hcgg' *.
destruct (mem_dec (Im b) y') as [Hy'| Hy'].
-destruct (mem_dec (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 ].
  *transitivity (Happ g' (Happ b (g₁ x'))).
  --apply Happ_compat; [ | easy ].
    destruct Hy' as (y & Hy & Hby).
    eapply B'; [ apply Hby | now apply b ].
  --rewrite <- Hcgg'.
    destruct Hx' as (Hx', Hcx').
    specialize (Hg₁ x' Hx') as H2.
    destruct H2 as (Hgx', Hggx').
    transitivity (Happ c x'); [ | easy ].
    apply c; [ now apply g, (g₁_in_B Hg₁) | easy ].
-exists 0%G; intros (x' & Hx' & Hyx').
 exfalso; apply Hy'.
 exists (g₁ x').
 split; [ apply (g₁_in_B Hg₁); now simpl in Hx' | ].
 now symmetry.
Qed.

(* Connecting homomorphism: d *)

Theorem d_mem_compat
     {A A' B B' C C'} {a : HomGr A A'} {b : HomGr B B'} {c : HomGr C C'}
     {f' : HomGr A' B'} {g₁ f'₁} :
  let d := λ x, f'₁ (Happ b (g₁ x)) in
  f'₁_prop a b f' g₁ f'₁
  → ∀ x, x ∈ Ker c → d x ∈ Coker a.
Proof.
intros * Hf'₁ * Hx.
apply Hf'₁.
now exists x.
Qed.

Theorem d_app_compat
    {A A' B B' C C'} {a : HomGr A A'} {b : HomGr B B'} {c : HomGr C C'}
    {f : HomGr A B} {g : HomGr B C} {f' : HomGr A' B'} {g' : HomGr B' C'}
    {za' : HomGr Gr1 A'} {g₁ f'₁} :
  diagram_commutes f a b f'
  → diagram_commutes g b c g'
  → Im f == Ker g
  → Im za' == Ker f'
  → Im f' == Ker g'
  → g₁_prop g c g₁
  → f'₁_prop a b f' g₁ f'₁
  → let d := λ x, f'₁ (Happ b (g₁ x)) in
     ∀ x1 x2, x1 ∈ Ker c → (x1 = x2)%G → (d x1 = d x2)%G.
Proof.
intros * Hcff' Hcgg' sf sf' sg' Hg₁ Hf'₁ * Hx1 Hxx.
assert (Hx2 : x2 ∈ Ker c) by now apply (gr_mem_compat _ x1).
assert (Hgy1 : (Happ g (g₁ x1) = x1)%G) by apply Hg₁, Hx1.
assert (Hgy2 : (Happ g (g₁ x2) = x2)%G) by apply Hg₁, Hx2.
assert (Hgb1 : (Happ g' (Happ b (g₁ x1)) = 0)%G). {
  rewrite <- Hcgg'.
  etransitivity; [ | apply Hx1 ].
  apply c; [ apply g, Hg₁, Hx1 | apply Hgy1 ].
}
assert (Hgb2 : (Happ g' (Happ b (g₁ x2)) = 0)%G). {
  rewrite <- Hcgg'.
  etransitivity; [ | apply Hx2 ].
  apply c; [ apply g, Hg₁, Hx2 | apply Hgy2 ].
}
assert (H1 : Happ b (g₁ x1) ∈ Im f'). {
  apply sg'; split; [ apply b, (g₁_in_B Hg₁), Hx1 | easy ].
}
assert (H2 : Happ b (g₁ x2) ∈ Im f'). {
  apply sg'; split; [ apply b, (g₁_in_B Hg₁), 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 : (Happ f' (z'1 - z'2) = Happ b (g₁ x1 - g₁ x2))%G). {
  rewrite Hadditive; [ | easy | now apply A' ].
  rewrite Hadditive.
  -apply gr_add_compat; [ apply Hfz'1 | ].
   rewrite Hopp; [ | easy ].
   rewrite Hopp; [ | apply Hg₁, Hx2 ].
   now rewrite Hfz'2.
  -apply (g₁_in_B Hg₁), Hx1.
  -apply B, (g₁_in_B Hg₁), Hx2.
}
assert (H4 : g₁ x1 - g₁ x2 ∈ Im f). {
  apply sf.
  split.
  -apply B; [ apply (g₁_in_B Hg₁), Hx1 | apply B, (g₁_in_B Hg₁), Hx2 ].
  -rewrite Hadditive; [ | apply Hg₁, Hx1 | apply B, Hg₁, Hx2 ].
   rewrite Hopp; [ | apply Hg₁, Hx2 ].
   apply gr_sub_move_r.
   now rewrite Hgy1, Hgy2, gr_add_0_l.
}
destruct H4 as (z & Hz & Hfz).
assert (H4 : (z'1 - z'2 = Happ a z)%G). {
  apply (f'_is_inj sf'); [ | now apply a | ].
  -apply A'; [ easy | now apply A' ].
  -rewrite <- Hcff', H3.
   apply b; [ | now symmetry ].
   apply B; [ apply (g₁_in_B Hg₁), Hx1 | apply B, (g₁_in_B Hg₁), Hx2 ].
}
assert (H6 : z'1 - z'2 ∈ Im a). {
  exists z; split; [ easy | now symmetry ].
}
assert (Hdx2 : (d x2 = z'2)%G). {
  simpl; unfold Coker_eq; simpl.
  exists 0.
  split; [ apply A | ].
  rewrite Hzero; symmetry.
  apply gr_sub_move_r; symmetry.
  rewrite gr_add_0_l.
  apply (f'_is_inj sf'); [ easy | now apply Hf'₁; exists x2 | ].
  rewrite Hfz'2; symmetry.
  now apply Hf'₁; exists x2.
}
assert (Hdx1 : (d x1 = z'1)%G). {
  simpl; unfold Coker_eq; simpl.
  exists 0.
  split; [ apply A | ].
  rewrite Hzero; symmetry.
  apply gr_sub_move_r; symmetry.
  rewrite gr_add_0_l.
  apply (f'_is_inj sf'); [ easy | now apply Hf'₁; exists x1 | ].
  rewrite Hfz'1.
  now symmetry; apply Hf'₁; exists x1.
}
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.
}
now rewrite Hdx1, Hzz'; symmetry.
Qed.

Theorem d_additive
    {A A' B B' C C'} {f : HomGr A B} {g : HomGr B C} {f' : HomGr A' B'}
    {a : HomGr A A'} {b : HomGr B B'} {c : HomGr C C'} {za' : HomGr Gr1 A'}
    {g₁ f'₁} :
  diagram_commutes f a b f'
  → Im f == Ker g
  → Im za' == Ker f'
  → g₁_prop g c g₁
  → f'₁_prop a b f' g₁ f'₁
  → let d := λ x, f'₁ (Happ b (g₁ x)) in
     ∀ x1 x2, x1 ∈ Ker c → x2 ∈ Ker c → (d (x1 + x2) = d x1 + d x2)%G.
Proof.
intros * Hcff' sf sf' Hg₁ Hf'₁ * 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 : (Happ g y1 = x1)%G) by now apply Hg₁; simpl in Hx1.
assert (H2 : (Happ g y2 = x2)%G) by now apply Hg₁; simpl in Hx2.
assert (H3 : (Happ g (y1 + y2)%G = x3)%G). {
  rewrite Hadditive; [ now rewrite H1, H2 | | ].
  -apply (g₁_in_B Hg₁), Hx1.
  -apply (g₁_in_B Hg₁), Hx2.
}
assert (Hy1 : y1 ∈ B) by apply (g₁_in_B Hg₁), Hx1.
assert (Hy2 : y2 ∈ B) by apply (g₁_in_B Hg₁), Hx2.
assert (Hy3 : y3 ∈ B) by (apply (g₁_in_B Hg₁), C; [ apply Hx1 | apply Hx2 ]).
assert (H4 : (y1 + y2 - y3)%G ∈ Ker g). {
  split; [ now apply B; apply B | ].
  rewrite Hadditive; [ | now apply B | now apply B ].
  symmetry; apply gr_sub_move_r.
  rewrite gr_add_0_l, Hopp; [ | easy ].
  rewrite gr_opp_involutive, H3.
  apply Hg₁, C; [ apply Hx1 | apply Hx2 ].
}
assert (Hfx1 : (Happ f' z1 = Happ b y1)%G). {
  now apply Hf'₁; exists x1.
}
assert (Hfx2 : (Happ f' z2 = Happ b y2)%G). {
  now apply Hf'₁; exists x2.
}
assert (Hfx3 : (Happ f' z3 = Happ b y3)%G). {
  unfold z3, y3.
  apply Hf'₁.
  exists x3.
  split; [ now apply (Ker c)| easy ].
}
assert
  (Hfzzz :
     (Happ f' (z1 + z2 - z3) = Happ b y1 + Happ b y2 - Happ b y3)%G). {
  assert (Hz1A' : z1 ∈ A' ∧ z2 ∈ A' ∧ z3 ∈ A'). {
    assert (H : z1 ∈ A' ∧ z2 ∈ A'). {
      split.
      -now apply Hf'₁; exists x1.
      -now apply Hf'₁; exists x2.
    }
    split; [ easy | ].
    split; [ easy | ].
    unfold z3.
    apply Hf'₁.
    exists x3; split; [ now apply (Ker c) | easy ].
  }
  simpl; rewrite Hadditive; [ | now apply A' | now apply A' ].
  apply gr_add_compat.
  -rewrite Hadditive; [ now apply gr_add_compat | easy | easy ].
  -rewrite Hopp; [ now apply gr_opp_compat | easy ].
}
apply sf in H4.
destruct H4 as (z & Hz & Hzf).
assert (Hfz : (Happ f' (z1 + z2 - z3) = Happ f' (Happ a z))%G). {
  rewrite Hfzzz.
  etransitivity.
  -apply gr_add_compat; [ now symmetry; apply b | now symmetry; apply Hopp ].
  -rewrite <- Hadditive; [ | now apply B | now apply B ].
   rewrite <- Hcff'.
   apply b; [ | now apply B; apply B ].
   rewrite <- Hzf.
   now apply f.
}
apply (f'_is_inj sf') in Hfz; [ | | now apply a ].
-simpl; unfold Coker_eq; simpl.
 exists (- z).
 split; [ now apply A | ].
 rewrite Hopp; [ | easy ].
 rewrite <- Hfz.
 symmetry; rewrite gr_add_comm.
 rewrite gr_opp_add_distr.
 apply gr_eq_opp_l.
 rewrite gr_opp_add_distr.
 simpl; apply gr_add_compat; [ | easy ].
 rewrite gr_opp_add_distr.
 now do 2 rewrite gr_opp_involutive.
-apply A'.
 +apply A'; [ now apply Hf'₁; exists x1 | now apply Hf'₁; exists x2 ].
 +apply A'.
  apply Hf'₁; exists x3.
  split; [ now apply (Ker c) | easy ].
Qed.

(* 1/ proof exact sequence: Ker a → Ker b → Ker c *)

Theorem exact_sequence_1 {A B C A' B' C'} :
  ∀ (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') (za' : HomGr Gr1 A')
     (Hcff' : diagram_commutes f a b f') (Hcgg' : diagram_commutes g b c g'),
  Im f == Ker g
  → Im za' == Ker f'
  → Im (HomGr_Ker_Ker a b Hcff') == Ker (HomGr_Ker_Ker b c Hcgg').
Proof.
intros * sf sf'.
split.
+intros y (x & (Hx & Hax) & Hxy).
 split; [ split | ].
 *eapply B; [ apply Hxy | now apply f ].
 *transitivity (Happ b (Happ f x)).
 --apply b; [ | now symmetry ].
   eapply gr_mem_compat; [ apply Hxy | now apply f ].
 --rewrite Hcff'.
   transitivity (Happ f' (@gr_zero A')); [ | apply Hzero ].
   apply f'; [ now apply a | easy ].
 *now apply sf; exists x.
+intros y ((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 (proj2 sf' (Happ a x)) as H1.
 assert (H3 : Happ a x ∈ Ker f'). {
   split; [ now apply a | ].
   rewrite <- Hcff'.
   transitivity (Happ b y); [ | easy ].
   apply b; [ now apply f | easy ].
 }
 specialize (H1 H3).
 destruct H1 as (z & _ & Hzz).
 rewrite <- Hzz.
 destruct z.
 apply Hzero.
Qed.

(* 2/ proof exact sequence: Ker b → Ker c → CoKer a *)

Theorem exact_sequence_2 {A B C A' B' C'} :
  ∀ (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') (za' : HomGr Gr1 A')
    (g₁ : gr_set (Ker c) → gr_set B) (f'₁ : gr_set B' → gr_set (Coker a))
    (sf : Im f == Ker g) (sf' : Im za' == Ker f')
    (Hcff' : diagram_commutes f a b f')
    (Hcgg' : diagram_commutes g b c g')
    (Hg₁ : g₁_prop g c g₁) (Hf'₁ : f'₁_prop a b f' g₁ f'₁),
 let d := λ x : gr_set (Ker c), f'₁ (Happ b (g₁ x)) in
 ∀ (dm : HomGr (Ker c) (Coker a)), Happ dm = d
 → Im (HomGr_Ker_Ker b c Hcgg') == Ker dm.
Proof.
intros *.
intros sf sf' Hcff' Hcgg' Hg₁ Hf'₁ d.
intros * Hd.
split.
-intros x (y & (Hy & Hay) & Hyx).
 split; [ split | ].
 +eapply C; [ apply Hyx | now apply g ].
 +specialize (Hcgg' y) as H1.
  transitivity (Happ c (Happ g y)).
  *eapply c; [ | now apply C ].
   eapply C; [ apply Hyx | now apply g ].
  *rewrite H1.
   transitivity (Happ g' (@gr_zero B')); [ | apply Hzero ].
   apply g'; [ now apply b | easy ].
 +simpl in Hyx.
  assert (Hgy : Happ g y ∈ Ker c). {
    split; [ now apply g | ].
    rewrite Hcgg'.
    etransitivity; [ | apply Hzero ].
    apply g'; [ now apply b | easy ].
  }
  assert (Hxk : x ∈ Ker c). {
    assert (Hx : x ∈ C). {
      eapply gr_mem_compat; [ apply Hyx | now apply g ].
    }
    split; [ easy | ].
    etransitivity; [ | apply Hgy ].
    apply c; [ easy | now symmetry ].
  }
  assert (Hyk : g₁ x - y ∈ Ker g). {
    split.
    -apply B; [ apply (g₁_in_B Hg₁), Hxk | now apply B ].
    -rewrite Hadditive; [ | apply (g₁_in_B Hg₁), Hxk | now apply B ].
     etransitivity.
     *apply gr_add_compat; [ apply Hg₁, Hxk | ].
      now simpl; apply Hopp.
     *apply gr_sub_move_r; rewrite <- Hyx.
      symmetry; apply gr_add_0_l.
  }
  apply sf in Hyk.
  destruct Hyk as (z & Hz & Haz).
  assert (Hdx : (d x = Happ a z)%G). {
    apply (f'c_is_inj sf'); [ | now apply a | ].
    -now apply (d_mem_compat Hf'₁).
    -etransitivity; [ apply Hf'₁; now exists x | ].
     rewrite <- Hcff'; symmetry.
     etransitivity.
     +apply Happ_compat; [ apply Hmem_compat, Hz | apply Haz ].
     +rewrite Hadditive; [ | apply (g₁_in_B Hg₁), Hxk | now apply B ].
      etransitivity.
      *apply gr_add_compat; [ easy | now simpl; apply Hopp ].
      *etransitivity.
      --apply gr_add_compat; [ easy | apply gr_opp_compat, Hay ].
      --rewrite gr_sub_0_r.
        apply b; [ apply (g₁_in_B Hg₁), Hxk | easy ].
  }
  rewrite Hd.
  simpl; rewrite Hdx.
  exists z; split; [ easy | ].
  now simpl; rewrite gr_sub_0_r.
-intros x (Hx & z & Hz & Haz).
 rewrite Hd in Haz.
 simpl in x, Haz.
 move z before x; move Hz before Hx.
 rewrite gr_sub_0_r in Haz.
 enough (∃ y, (y ∈ B ∧ (Happ b y = 0)%G) ∧ (Happ g y = x)%G) by easy.
 apply (Happ_compat _ _ f') in Haz; [ | now apply a ].
 rewrite <- Hcff' in Haz.
 exists (g₁ x - Happ f z).
 split; [ split | ].
 +apply B; [ apply Hg₁, Hx | now apply B, f ].
 +rewrite Hadditive; [ | apply Hg₁, Hx | now apply B, f ].
  etransitivity.
  *apply gr_add_compat; [ easy | now apply Hopp, f ].
  *apply gr_sub_move_r; rewrite gr_add_0_l; symmetry.
   now rewrite Haz; apply Hf'₁; exists x.
 +rewrite Hadditive; [ | apply Hg₁, Hx | now apply B, f ].
  *etransitivity.
  --apply gr_add_compat; [ easy | now apply Hopp, f ].
  --apply gr_sub_move_l.
    etransitivity; [ apply Hg₁, Hx | ].
    rewrite <- gr_add_0_l at 1.
    apply gr_add_compat; [ | easy ].
    enough (H1 : Happ f z ∈ Ker g) by now simpl in H1.
    now apply sf; exists z.
Qed.

(* 3/ proof exact sequence: Ker c → CoKer a → Coker b *)

Theorem exact_sequence_3 {A B C A' B' C'} :
  ∀ (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') (za' : HomGr Gr1 A')
    (Hcff' : diagram_commutes f a b f')
    (Hcgg' : diagram_commutes g b c g')
    (sf : Im f == Ker g) (sf' : Im za' == Ker f') (sg' : Im f' == Ker g')
    (g₁ : gr_set (Ker c) → gr_set B)
    (f'₁ : gr_set B' → gr_set (Coker a))
    (Hg₁ : g₁_prop g c g₁)
    (Hf'₁ : f'₁_prop a b f' g₁ f'₁),
  let d := λ x : gr_set (Ker c), f'₁ (Happ b (g₁ x)) in
  ∀ (dm : HomGr (Ker c) (Coker a)), Happ dm = d →
  Im dm == Ker (HomGr_Coker_Coker a b Hcff').
Proof.
intros *.
intros Hcgg' sf sf' sg' * Hg₁ Hf'₁ * Hdm.
split.
-intros z' Hz'.
 destruct Hz' as (x & Hx & z & Hz & Haz).
 move z before x.
 rewrite Hdm in Haz.
 simpl in Haz.
 assert (Hz' : z' ∈ A'). {
   apply gr_mem_compat with (x := d x - Happ a z).
   -transitivity (d x - (d x - z')); simpl.
    +apply gr_add_compat; [ easy | now apply gr_opp_compat ].
    +apply gr_sub_move_l.
     rewrite gr_add_assoc; symmetry.
     etransitivity; [ | apply gr_add_0_r ].
     apply gr_add_compat; [ easy | ].
     apply gr_add_opp_l.
   -apply A'; [ now apply Hf'₁; exists x | now apply A', a ].
 }
 simpl; split; [ easy | ].
 unfold Coker_eq; simpl.
 enough (H : ∃ y, y ∈ B ∧ (Happ b y = Happ f' z')%G). {
   destruct H as (y & Hy & Hby).
   exists y.
   split; [ easy | now rewrite gr_sub_0_r ].
 }
 simpl in z'.
 exists (g₁ x - Happ f z).
 split.
 +apply B; [ apply Hg₁, Hx | now apply B, f ].
 +apply (Happ_compat _ _ f') in Haz; [ | now apply a ].
  rewrite Hadditive; [ | apply Hg₁, Hx | now apply B, f ].
  etransitivity.
  *apply gr_add_compat; [ easy | now apply Hopp, f ].
  *etransitivity.
  --apply gr_add_compat; [ easy | ].
    apply gr_opp_compat, Hcff'.
  --apply gr_sub_move_r.
    etransitivity; [ now symmetry; apply Hf'₁; exists x | ].
    fold (d x).
    apply gr_sub_move_l.
    etransitivity.
   ++apply gr_add_compat; [ easy | now symmetry; apply Hopp ].
   ++rewrite <- Hadditive; [ now symmetry | | now apply A' ].
     now apply Hf'₁; exists x.
-intros z' (Hz' & y & Hy & Hby).
 simpl in z', Hz', Hby.
 rewrite gr_sub_0_r in Hby.
 simpl; unfold Coker_eq; simpl.
 rewrite Hdm.
 enough (H :
  ∃ x, x ∈ C ∧ (Happ c x = 0)%G ∧
  ∃ z, z ∈ A ∧ (Happ a z = d x - z')%G). {
   destruct H as (x & Hx).
   now exists x.
 }
 exists (Happ g y).
 split; [ now apply g | ].
 split.
 +rewrite Hcgg'.
  etransitivity.
  *apply Happ_compat; [ now apply b | apply Hby ].
  *assert (H : Happ f' z' ∈ Im f') by now exists z'.
   now apply sg' in H; simpl in H.
 +assert (H : g₁ (Happ g y) - y ∈ Ker g). {
    split.
    -apply B; [ now apply Hg₁, g | now apply B ].
    -rewrite Hadditive; [ | now apply Hg₁, g | now apply B ].
     rewrite <- gr_add_opp_r.
     apply gr_add_compat; [ now apply Hg₁, g | now apply Hopp ].
  }
  apply sf in H.
  destruct H as (z & Hz & Hfz).
  exists z; split; [ easy | ].
  apply (Happ_compat _ _ b) in Hfz; [ | now apply f ].
  rewrite Hadditive in Hfz; [ | now apply Hg₁, g | now apply B ].
  rewrite Hcff' in Hfz.
  *apply (f'_is_inj sf'); [ now apply a | | ].
  --apply A'; [ | now apply A' ].
    apply Hf'₁.
    exists (Happ g y); split; [ | easy ].
    split; [ now apply g | ].
    rewrite Hcgg'.
    etransitivity.
   ++apply Happ_compat; [ now apply b | apply Hby ].
   ++assert (H : Happ f' z' ∈ Im f') by (exists z'; easy).
     now apply sg' in H; simpl in H.
  --rewrite Hfz.
    symmetry; simpl; rewrite Hadditive; [ | | now apply A' ].
   ++apply gr_add_compat.
    **apply Hf'₁.
      exists (Happ g y); split; [ | easy ].
      split; [ now apply g | ].
      rewrite Hcgg'.
      etransitivity.
    ---apply Happ_compat; [ now apply b | apply Hby ].
    ---assert (H : Happ f' z' ∈ Im f') by (exists z'; easy).
       now apply sg' in H; simpl in H.
    **rewrite Hopp; [ | easy ].
      rewrite Hopp; [ | easy ].
      apply gr_opp_compat.
      now symmetry.
   ++apply Hf'₁; exists (Happ g y); split; [ | easy ].
     split; [ now apply g | ].
     rewrite Hcgg'.
     etransitivity.
    **apply Happ_compat; [ now apply b | apply Hby ].
    **assert (H : Happ f' z' ∈ Im f') by (exists z'; easy).
      now apply sg' in H; simpl in H.
Qed.

(* 4/ proof exact sequence: CoKer a → CoKer b → Coker c *)

Theorem exact_sequence_4 {A B C A' B' C'} :
  ∀ (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')
    (Hcff' : diagram_commutes f a b f')
    (Hcgg' : diagram_commutes g b c g')
    (sg' : Im f' == Ker g')
    (g₁ : gr_set (Ker c) → gr_set B)
    (Hg₁ : g₁_prop g c g₁),
  Im (HomGr_Coker_Coker a b Hcff') == Ker (HomGr_Coker_Coker b c Hcgg').
Proof.
intros.
split.
-simpl.
 intros y' (z' & Hz' & y & Hy & Hby).
 simpl in Hby.
 assert (Hb' : y' ∈ B'). {
   symmetry in Hby.
   apply gr_sub_move_r in Hby.
   rewrite gr_add_comm in Hby.
   apply gr_sub_move_r in Hby.
   rewrite <- Hby.
   apply B'; [ now apply f' | now apply B', b ].
 }
 split; [ easy | ].
 unfold Coker_eq; simpl.
 enough (H : ∃ x, x ∈ C ∧ (Happ c x = Happ g' y')%G). {
   destruct H as (x & Hx & Hcx).
   exists x; split; [ easy | ].
   rewrite Hcx; symmetry.
   apply gr_sub_0_r.
 }
 exists (- Happ g y).
 split; [ now apply C, g | ].
 rewrite Hopp, Hcgg'; [ | now apply g ].
 apply gr_eq_opp_l.
 rewrite <- Hopp; [ | easy ].
 symmetry.
 transitivity (Happ g' (Happ f' z' - y')).
 +rewrite Hadditive; [ | now apply f' | now apply B' ].
  rewrite <- gr_add_0_l at 1.
  apply gr_add_compat; [ | easy ].
  symmetry.
  assert (H : Happ f' z' ∈ Im f') by (exists z'; easy).
  now apply sg' in H; simpl in H.
 +apply g'; [ | now symmetry ].
  apply B'; [ now apply f' | now apply B' ].
-simpl; intros y' (Hy' & x & Hx & Hcx).
 simpl in Hcx; rewrite gr_sub_0_r in Hcx.
 unfold Coker_eq; simpl.
 enough (H : ∃ y z', y ∈ B ∧ z' ∈ A' ∧ (Happ b y = Happ f' z' - y')%G). {
   destruct H as (y & z' & Hz' & Hy & Hby).
   exists z'; split; [ easy | ].
   now exists y.
 }
 assert (Hby : y' - Happ b (g₁ x) ∈ Ker g'). {
   split.
   -apply B'; [ easy | now apply B', b, Hg₁ ].
   -rewrite Hadditive; [ | easy | now apply B', b, Hg₁ ].
    rewrite <- Hcx, Hopp; [ | now apply b, Hg₁ ].
    rewrite <- Hcgg'.
    etransitivity; [ | apply gr_add_opp_r ].
    apply gr_add_compat; [ easy | ].
    apply gr_opp_compat.
    apply Happ_compat; [ now apply g, Hg₁ | now apply Hg₁ ].
 }
 apply sg' in Hby.
 destruct Hby as (z' & Hz' & Hfz').
 exists (- g₁ x), z'.
 split; [ now apply B, Hg₁ | ].
 split; [ easy | ].
 rewrite Hfz', gr_add_comm, <- gr_add_assoc, gr_add_opp_l, gr_add_0_l.
 now apply Hopp, Hg₁.
Qed.

(* The snake lemma
                f      g       cz
            A------>B------>C------>0
            |       |       |
           a|      b|      c|
            |       |       |
            v       v       v
     0----->A'----->B'----->C'
       za'      f'      g'

  If 1/ the diagram is commutative,
     2/ (f, g, cz) and (za', f', g') are exact sequences,
  Then
     there exists a morphism d from Ker c to Coker a, such that
     Ker a→Ker b→Ker c→Coker a→Coker b→Coker c is an exact sequence.
*)

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 Gr1) (za' : HomGr Gr1 A'),
  Decidable_Membership * Choice
  → diagram_commutes f a b f'
  → diagram_commutes g b c g'
  → exact_sequence [f; g; cz]
  → exact_sequence [za'; f'; g']
  → ∃ (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 (Seq fk (Seq gk (Seq d (Seq fk' (Seq gk' SeqEnd))))).
Proof.
intros *.
intros (mem_dec, choice) Hcff' Hcgg' s s'.
exists (HomGr_Ker_Ker a b Hcff').
exists (HomGr_Ker_Ker b c Hcgg').
exists (HomGr_Coker_Coker a b Hcff').
exists (HomGr_Coker_Coker b c Hcgg').
destruct s as (sf & sg & _).
destruct s' as (sf' & sg' & _).
specialize (g_is_surj c mem_dec sg) as H1.
specialize (choice _ _ _ H1) as H; destruct H as (g₁, Hg₁).
specialize (exists_B'_to_Coker_a a mem_dec sg' Hg₁ Hcgg') as H2.
specialize (choice _ _ _ H2) as H; destruct H as (f'₁, Hf'₁).
fold (g₁_prop g c g₁) in Hg₁.
fold (f'₁_prop a b f' g₁ f'₁) in Hf'₁.
move f'₁ before g₁.
clear H1 H2.
set (d := λ x, f'₁ (Happ b (g₁ x))).
set
  (dm :=
   {| Happ := d;
      Hmem_compat := d_mem_compat Hf'₁;
      Happ_compat := d_app_compat Hcff' Hcgg' sf sf' sg' Hg₁ Hf'₁;
      Hadditive := d_additive Hcff' sf sf' Hg₁ Hf'₁ |}).
exists dm.
split; [ now eapply exact_sequence_1 | ].
split; [ now eapply exact_sequence_2; try easy | ].
split; [ now eapply exact_sequence_3; try easy | ].
split; [ eapply exact_sequence_4; try easy; apply Hg₁ | easy ].
Qed.

Check snake.

(*
Print Assumptions snake.
*)


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Cartesian.
Require Export Category.Instance.Sets.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Closed.

Context {C : Category}.
Context `{@Cartesian C}.

Class Closed := {
  exponent_obj : obj -> obj -> obj    (* internal homs *)
    where "y ^ x" := (exponent_obj x y);

  exp_iso {x y z} : x × y ~> z ≊ x ~> z^y;

  curry'   {x y z} := to (@exp_iso x y z);
  uncurry' {x y z} := from (@exp_iso x y z);

  eval' {x y} : y^x × x ~> y := uncurry' _ _ _ id;

  ump_exponents' {x y z} (f : x × y ~> z) :
    eval' ∘ first (curry' _ _ _ f) ≈ f
}.

Notation "y ^ x" := (exponent_obj x y)
  (at level 30, right associativity) : object_scope.

Context `{@Closed}.

Definition curry   {x y z} := @curry' _ x y z.
Definition uncurry {x y z} := @uncurry' _ x y z.
Arguments curry' {_ _ _ _} /.
Arguments uncurry' {_ _ _ _} /.

Definition eval {x y} : y^x × x ~> y := uncurry id.
Arguments eval' {_ _ _} /.

Definition ump_exponents {x y z} (f : x × y ~> z) :
  eval ∘ first (curry f) ≈ f := @ump_exponents' _ x y z f.

Global Program Instance parametric_morphism_curry (a b c : C) :
  Proper (equiv ==> equiv) (@curry a b c).
Next Obligation.
  proper.
  unfold curry; simpl in *.
  destruct exp_iso; simpl in *.
  destruct to; simpl in *.
  rewrites; reflexivity.
Qed.

Global Program Instance parametric_morphism_uncurry (a b c : C) :
  Proper (equiv ==> equiv) (@uncurry a b c).
Next Obligation.
  proper.
  unfold uncurry; simpl in *.
  destruct exp_iso; simpl in *.
  destruct from; simpl in *.
  rewrites; reflexivity.
Qed.

Corollary curry_uncurry {x y z} (f : x ~> z^y) :
  curry (uncurry f) ≈ f.
Proof.
  replace (curry (uncurry f)) with ((curry ∘ uncurry) f) by auto.
  unfold curry, uncurry; simpl.
  pose proof (iso_to_from (@exp_iso _ x y z)) as HA.
  unfold equiv in HA; simpl in HA.
  autounfold in HA.
  unfold equiv in HA; simpl in HA.
  apply HA.
Qed.

Corollary uncurry_curry {x y z} (f : x × y ~> z) :
  uncurry (curry f) ≈ f.
Proof.
  replace (uncurry (curry f)) with ((uncurry ∘ curry) f) by auto.
  unfold curry, uncurry; simpl.
  pose proof (iso_from_to (@exp_iso _ x y z)) as HA.
  simpl in HA.
  unfold equiv in HA; simpl in HA.
  autounfold in HA.
  unfold equiv in HA; simpl in HA.
  apply HA.
Qed.

Hint Rewrite @curry_uncurry : categories.
Hint Rewrite @uncurry_curry : categories.
Hint Rewrite @ump_exponents : categories.

Definition flip {x y z : C} `(f : x ~> z ^ y) : y ~> z ^ x :=
  curry (uncurry f ∘ swap).

Corollary eval_curry {x y z w : C} (f : y × z ~> w) (g : x ~> y) (h : x ~> z) :
  eval ∘ ((curry f ∘ g) △ h) ≈ f ∘ g △ h.
Proof.
  intros.
  rewrite <- (ump_exponents f) at 2.
  rewrite <- comp_assoc.
  unfold first.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
Qed.

Hint Rewrite @eval_curry : categories.

Corollary curry_eval {x y : C} :
  curry eval ≈ @id _ (y^x).
Proof.
  intros; unfold eval; simpl; cat.
Qed.

Hint Rewrite @curry_eval : categories.

Corollary eval_first {x y z : C} (f : x ~> z^y) :
  eval ∘ first f ≈ uncurry f.
Proof.
  rewrite <- (curry_uncurry f); cat.
Qed.

Corollary curry_inj {x y z : C} (f g : x × y ~> z) :
  curry f ≈ curry g -> f ≈ g.
Proof.
  intros.
  rewrite <- (uncurry_curry f).
  rewrite <- (uncurry_curry g).
  rewrites; reflexivity.
Qed.

Corollary uncurry_inj {x y z : C} (f g : x ~> z^y) :
  uncurry f ≈ uncurry g -> f ≈ g.
Proof.
  intros.
  rewrite <- (curry_uncurry f).
  rewrite <- (curry_uncurry g).
  rewrites; reflexivity.
Qed.

Corollary curry_comp_l {x y z w : C} (f : y × z ~> w) (g : x ~> y) :
  curry f ∘ g ≈ curry (f ∘ first g).
Proof.
  apply uncurry_inj; cat.
  rewrite <- (ump_exponents (uncurry (curry f ∘ g))).
  rewrite curry_uncurry.
  unfold first in *.
  rewrite <- comp_assoc.
  rewrite eval_curry.
  reflexivity.
Qed.

Corollary curry_comp {x y z w : C} (f : z ~> w) (g : x × y ~> z) :
  curry (f ∘ g) ≈ curry (f ∘ eval) ∘ curry g.
Proof.
  rewrite curry_comp_l.
  rewrite <- comp_assoc.
  rewrite eval_first; cat.
Qed.

Corollary uncurry_comp_r {x y z w : C} (f : z ~> w) (g : x ~> z^y) :
  f ∘ uncurry g ≈ uncurry (curry (f ∘ eval) ∘ g).
Proof.
  rewrite curry_comp_l; cat.
  rewrite <- comp_assoc.
  rewrite eval_first; reflexivity.
Qed.

Corollary uncurry_comp {x y z w : C} (f : y ~> w^z) (g : x ~> y) :
  uncurry (f ∘ g) ≈ uncurry f ∘ first g.
Proof.
  intros.
  apply curry_inj; cat.
  rewrite <- curry_comp_l; cat.
Qed.

Theorem curry_id {x y z : C} (f : x ~> y) :
  curry (@id _ (y × z)) ∘ f ≈ curry (first f).
Proof.
  intros.
  rewrite curry_comp_l.
  apply uncurry_inj; cat.
Qed.

Global Program Instance exp_respects_iso {x y z : C} :
  Proper (Isomorphism ==> Isomorphism ==> Isomorphism) exponent_obj.
Next Obligation.
  proper.
  transitivity (y1 ^ x0). {
    isomorphism.
    - apply (curry (to X0 ∘ eval)).
    - apply (curry (from X0 ∘ eval)).
    - rewrite <- curry_comp.
      rewrite comp_assoc.
      rewrite iso_to_from, id_left.
      rewrite curry_eval.
      reflexivity.
    - rewrite <- curry_comp.
      rewrite comp_assoc.
      rewrite iso_from_to, id_left.
      rewrite curry_eval.
      reflexivity.
  }
  isomorphism.
  - apply (curry (eval ∘ second (from X))).
  - apply (curry (eval ∘ second (to X))).
  - rewrite curry_comp_l.
    rewrite <- comp_assoc.
    rewrite <- first_second.
    rewrite comp_assoc.
    rewrite eval_first.
    rewrite uncurry_curry.
    rewrite <- comp_assoc.
    rewrite <- second_comp.
    rewrite iso_to_from.
    rewrite second_id, id_right.
    rewrite curry_eval.
    reflexivity.
  - rewrite curry_comp_l.
    rewrite <- comp_assoc.
    rewrite <- first_second.
    rewrite comp_assoc.
    rewrite eval_first.
    rewrite uncurry_curry.
    rewrite <- comp_assoc.
    rewrite <- second_comp.
    rewrite iso_from_to.
    rewrite second_id, id_right.
    rewrite curry_eval.
    reflexivity.
Qed.

Global Program Instance exp_prod_l {x y z : C} :
  z^(x × y) ≅ (z^y)^x := {
  to   := curry (curry (eval ∘ to prod_assoc));
  from := curry (uncurry eval ∘ from prod_assoc)
}.
Next Obligation.
  rewrite curry_comp_l.
  unfold first.
  rewrite curry_comp_l.
  unfold first.
  rewrite <- comp_assoc.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  rewrite comp_assoc; cat.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite comp_assoc; cat.
  rewrite comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite fork_comp; cat.
Qed.
Next Obligation.
  rewrite curry_comp_l.
  apply uncurry_inj; cat.
  rewrite <- comp_assoc.
  rewrite <- eval_first.
  rewrite <- comp_assoc.
  rewrite (comp_assoc (first eval)).
  unfold first at 1.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  unfold first.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp; cat.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite fork_comp; cat.
Qed.

Hint Rewrite @exp_prod_l : isos.

Global Program Instance exp_prod_r {x y z : C} :
  (y × z)^x ≅ y^x × z^x := {
  to   := curry (exl ∘ eval) △ curry (exr ∘ eval);
  from := curry (uncurry exl △ uncurry exr)
}.
Next Obligation.
  rewrite <- fork_comp.
  rewrite <- fork_exl_exr.
  apply fork_inv; split;
  rewrite <- curry_comp; cat;
  pose proof (@eval_first) as HA;
  unfold first in HA;
  rewrites; cat.
Qed.
Next Obligation.
  apply uncurry_inj.
  rewrite uncurry_comp; cat.
  rewrite <- fork_comp.
  rewrite <- !eval_first.
  rewrite <- !comp_assoc.
  rewrite <- !first_comp; cat.
  rewrite fork_comp; cat.
  unfold first; cat.
Qed.

Hint Rewrite @exp_prod_r : isos.

Local Obligation Tactic := program_simpl.

Global Program Instance exp_swap {x y z : C} :
  (z^y)^x ≅ (z^x)^y := {
  to   := to exp_prod_l
        ∘ to (@exp_respects_iso x y z _ _ (@prod_comm _ _ x y) z z iso_id)
        ∘ from exp_prod_l;
  from := to exp_prod_l
        ∘ from (@exp_respects_iso x y z _ _ (@prod_comm _ _ x y) z z iso_id)
        ∘ from exp_prod_l
}.
Next Obligation.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc (curry _) (curry _)).
  rewrite (iso_from_to exp_prod_l), id_left.
  rewrite (comp_assoc (exp_respects_iso _ _ _ _ _ _)).
  rewrite iso_to_from, id_left.
  apply (iso_to_from exp_prod_l).
Defined.
Next Obligation.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc (curry _) (curry _)).
  rewrite (iso_from_to exp_prod_l), id_left.
  rewrite (comp_assoc _ (exp_respects_iso _ _ _ _ _ _)).
  rewrite iso_from_to, id_left.
  apply (iso_to_from exp_prod_l).
Defined.

Lemma curry_fork {x y z w : C} (f : x × y ~> z) (g : x × y ~> w) :
  curry (f △ g) ≈ from exp_prod_r ∘ curry f △ curry g.
Proof.
  simpl.
  apply uncurry_inj; cat.
  rewrite uncurry_comp; cat.
  unfold first.
  rewrite <- fork_comp.
  apply fork_inv; split;
  rewrite <- eval_curry;
  rewrite curry_uncurry;
  rewrite comp_assoc; cat.
Qed.

Corollary curry_unfork {x y z w : C} (f : x × y ~> z) (g : x × y ~> w) :
  curry f △ curry g ≈ to exp_prod_r ∘ curry (f △ g).
Proof.
  rewrite curry_fork.
  rewrite comp_assoc.
  rewrite iso_to_from; cat.
Qed.

Context `{@Terminal C}.

Global Program Instance exp_one {x : C} :
  x^1 ≅ x := {
  to   := eval ∘ id △ one;
  from := curry exl
}.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite <- fork_comp; cat.
  rewrite <- (id_right (curry exl)); cat.
Qed.
Next Obligation.
  rewrite comp_assoc.
  rewrite !curry_comp_l.
  apply uncurry_inj; cat.
  unfold first, eval; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp.
  rewrite id_left.
  cut (@one _ _ (x^1) ∘ exl ≈ exr).
    intros; rewrites; cat.
  cat.
Qed.

Hint Rewrite @exp_one : isos.

Global Program Instance one_exp {x : C} :
  1^x ≅ 1 := {
  to   := one;
  from := curry one
}.
Next Obligation. apply one_unique. Qed.
Next Obligation.
  rewrite curry_comp_l.
  rewrite one_comp.
  apply uncurry_inj.
  rewrite uncurry_curry.
  apply one_unique.
Qed.

Hint Rewrite @one_exp : isos.

End Closed.

Notation "y ^ x" := (exponent_obj x y) : category_scope.

Hint Rewrite @curry_uncurry : categories.
Hint Rewrite @uncurry_curry : categories.
Hint Rewrite @ump_exponents : categories.
Hint Rewrite @eval_curry : categories.
Hint Rewrite @curry_eval : categories.
Hint Rewrite @exp_prod_l : isos.
Hint Rewrite @exp_prod_r : isos.
Hint Rewrite @exp_one : isos.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq.
Require Import fintype.

Lemma test15: forall (y : nat) (x : 'I_2), y < 1 -> val x = y -> Some x = insub y.
move=> y x le_1 defx; rewrite insubT ?(leq_trans le_1) // => ?.
by congr (Some _); apply: val_inj=> /=; exact: defx.
Qed.

Axiom P : nat -> Prop.
Axiom Q : forall n, P n -> Prop.
Definition R := fun (x : nat) (p : P x) m (q : P (x+1)) => m > 0.

Inductive myEx : Type := ExI : forall n (pn : P n) pn', Q n pn -> R n pn n pn' -> myEx.

Variable P1 : P 1.
Variable P11 : P (1 + 1).
Variable Q1 : forall P1, Q 1 P1.

Lemma testmE1 : myEx.
Proof.
apply: ExI 1 _ _ _ _.
  match goal with |- P 1 => exact: P1 | _ => fail end.
  match goal with |- P (1+1) => exact: P11 | _ => fail end.
  match goal with |- forall p : P 1, Q 1 p => move=>*; exact: Q1 | _ => fail end.
match goal with |- forall (p : P 1) (q : P (1+1)), is_true (R 1 p 1 q) => done | _ => fail end.
Qed.

Lemma testE2 : exists y : { x | P x }, sval y = 1.
Proof.
apply: ex_intro (exist _ 1 _) _.
  match goal with |- P 1 => exact: P1 | _ => fail end.
match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end.
Qed.

Lemma testE3 : exists y : { x | P x }, sval y = 1.
Proof.
have := (ex_intro _ (exist _ 1 _) _); apply.
  match goal with |- P 1 => exact: P1 | _ => fail end.
match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end.
Qed.

Lemma testE4 : P 2 -> exists y : { x | P x }, sval y = 2.
Proof.
move=> P2; apply: ex_intro (exist _ 2 _) _.
match goal with |- @sval _ _ (@exist _ _ 2 P2) = 2 => done | _ => fail end.
Qed.

Hint Resolve P1.

Lemma testmE12 : myEx.
Proof.
apply: ExI 1 _ _ _ _.
  match goal with |- P (1+1) => exact: P11 | _ => fail end.
  match goal with |- Q 1 P1 => exact: Q1 | _ => fail end.
match goal with |- forall (q : P (1+1)), is_true (R 1 P1 1 q) => done | _ => fail end.
Qed.

Create HintDb SSR.

Hint Resolve P11 : SSR.

Ltac ssrautoprop := trivial with SSR.

Lemma testmE13 : myEx.
Proof.
apply: ExI 1 _ _ _ _.
  match goal with |- Q 1 P1 => exact: Q1 | _ => fail end.
match goal with |- is_true (R 1 P1 1 P11) => done | _ => fail end.
Qed.

Definition R1 := fun (x : nat) (p : P x) m (q : P (x+1)) (r : Q x p) => m > 0.

Inductive myEx1 : Type :=
  ExI1 : forall n (pn : P n) pn' (q : Q n pn), R1 n pn n pn' q -> myEx1.

Hint Resolve (Q1 P1) : SSR.

(* tests that goals in prop are solved in the right order, propagating instantiations,
   thus the goal Q 1 ?p1 is faced by trivial after ?p1, and is thus evar free *)
Lemma testmE14 : myEx1.
Proof.
apply: ExI1 1 _ _ _ _.
match goal with |- is_true (R1 1 P1 1 P11 (Q1 P1)) => done | _ => fail end.
Qed.


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.
From Category.Instances Require Import Univ.FunctorComp.

Set Universe Polymorphism.

Program Definition Cats : Category :=
  {|
    Obj := Category;
    Hom := fun (C D : Category) => Functor C D;
    Hom_Id := fun (C : Category) => IdFunctor C;
    Hom_comp := fun (C1 C2 C3 : Category) => fun (F1 : Functor C2 C3) (F2 : Functor C1 C2) => Functor_Comp F1 F2
  |}.
Next Obligation.
Proof.
  exact: Functor_Comp_assoc.
Qed.
Next Obligation.
  exact: Functor_Comp_IdL.
Qed.
Next Obligation.
  exact: Functor_Comp_IdR.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

Require Import Reals.
Require Import mathcomp.ssreflect.ssreflect.
Require Import Rcomplements.

(** This file contains the definition and properties of the set
 [R] # ∪ {+ ∞} ∪ {- ∞} # denoted by [Rbar]. We have defined:
  - coercions from [R] to [Rbar] and vice versa ([Finite] gives [R0] at infinity points)
  - an order [Rbar_lt] and [Rbar_le]
  - total operations: [Rbar_opp], [Rbar_plus], [Rbar_minus], [Rbar_inv], [Rbar_min] and [Rbar_abs]
  - lemmas about the decidability of the order and properties of the operations (such as [Rbar_plus_comm] or [Rbar_plus_lt_compat])
 *)

Open Scope R_scope.

(** * Definitions *)

Inductive Rbar :=
  | Finite : R -> Rbar
  | p_infty : Rbar
  | m_infty : Rbar.
Definition real (x : Rbar) :=
  match x with
    | Finite x => x
    | _ => 0
  end.
Coercion Finite : R >-> Rbar.
Coercion real : Rbar >-> R.

Definition is_finite (x : Rbar) := Finite (real x) = x.
Lemma is_finite_correct (x : Rbar) :
  is_finite x <-> exists y : R, x = Finite y.
Proof.
  rewrite /is_finite ;
  case: x => /= ; split => // H.
  by exists r.
  by case: H.
  by case: H.
Qed.

(** ** Order *)

Definition Rbar_lt (x y : Rbar) : Prop :=
  match x,y with
    | p_infty, _ | _, m_infty => False
    | m_infty, _ | _, p_infty => True
    | Finite x, Finite y => Rlt x y
  end.

Definition Rbar_le (x y : Rbar) : Prop :=
  match x,y with
    | m_infty, _ | _, p_infty => True
    | p_infty, _ | _, m_infty => False
    | Finite x, Finite y => Rle x y
  end.

(** ** Operations *)
(** *** Additive operators *)

Definition Rbar_opp (x : Rbar) :=
  match x with
    | Finite x => Finite (-x)
    | p_infty => m_infty
    | m_infty => p_infty
  end.

Definition Rbar_plus' (x y : Rbar) :=
  match x,y with
    | p_infty, m_infty | m_infty, p_infty => None
    | p_infty, _ | _, p_infty => Some p_infty
    | m_infty, _ | _, m_infty => Some m_infty
    | Finite x', Finite y' => Some (Finite (x' + y'))
  end.
Definition Rbar_plus (x y : Rbar) :=
  match Rbar_plus' x y with Some z => z | None => Finite 0 end.
Arguments Rbar_plus !x !y /.
Definition is_Rbar_plus (x y z : Rbar) : Prop :=
  Rbar_plus' x y = Some z.
Definition ex_Rbar_plus (x y : Rbar) : Prop :=
  match Rbar_plus' x y with Some _ => True | None => False end.
Arguments ex_Rbar_plus !x !y /.

Lemma is_Rbar_plus_unique (x y z : Rbar) :
  is_Rbar_plus x y z -> Rbar_plus x y = z.
Proof.
  unfold is_Rbar_plus, ex_Rbar_plus, Rbar_plus.
  case: Rbar_plus' => // a Ha.
  by inversion Ha.
Qed.
Lemma Rbar_plus_correct (x y : Rbar) :
  ex_Rbar_plus x y -> is_Rbar_plus x y (Rbar_plus x y).
Proof.
  unfold is_Rbar_plus, ex_Rbar_plus, Rbar_plus.
  by case: Rbar_plus'.
Qed.

Definition Rbar_minus (x y : Rbar) := Rbar_plus x (Rbar_opp y).
Arguments Rbar_minus !x !y /.
Definition is_Rbar_minus (x y z : Rbar) : Prop :=
  is_Rbar_plus x (Rbar_opp y) z.
Definition ex_Rbar_minus (x y : Rbar) : Prop :=
  ex_Rbar_plus x (Rbar_opp y).
Arguments ex_Rbar_minus !x !y /.

(** *** Multiplicative operators *)

Definition Rbar_inv (x : Rbar) : Rbar :=
  match x with
    | Finite x => Finite (/x)
    | _ => Finite 0
  end.

Definition Rbar_mult' (x y : Rbar) :=
  match x with
    | Finite x => match y with
      | Finite y => Some (Finite (x * y))
      | p_infty => match (Rle_dec 0 x) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some p_infty | right _ => None end
        | right _ => Some m_infty
      end
      | m_infty => match (Rle_dec 0 x) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some m_infty | right _ => None end
        | right _ => Some p_infty
      end
    end
    | p_infty => match y with
      | Finite y => match (Rle_dec 0 y) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some p_infty | right _ => None end
        | right _ => Some m_infty
      end
      | p_infty => Some p_infty
      | m_infty => Some m_infty
    end
    | m_infty => match y with
      | Finite y => match (Rle_dec 0 y) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some m_infty | right _ => None end
        | right _ => Some p_infty
      end
      | p_infty => Some m_infty
      | m_infty => Some p_infty
    end
  end.
Definition Rbar_mult (x y : Rbar) :=
  match Rbar_mult' x y with Some z => z | None => Finite 0 end.
Arguments Rbar_mult !x !y /.

Definition is_Rbar_mult (x y z : Rbar) : Prop :=
  Rbar_mult' x y = Some z.
Definition ex_Rbar_mult (x y : Rbar) : Prop :=
  match x with
    | Finite x => match y with
      | Finite y => True
      | p_infty => x <> 0
      | m_infty => x <> 0
    end
    | p_infty => match y with
      | Finite y => y <> 0
      | p_infty => True
      | m_infty => True
    end
    | m_infty => match y with
      | Finite y => y <> 0
      | p_infty => True
      | m_infty => True
    end
  end.
Arguments ex_Rbar_mult !x !y /.

Definition Rbar_mult_pos (x : Rbar) (y : posreal) :=
  match x with
    | Finite x => Finite (x*y)
    | _ => x
  end.

Lemma is_Rbar_mult_unique (x y z : Rbar) :
  is_Rbar_mult x y z -> Rbar_mult x y = z.
Proof.
  unfold is_Rbar_mult ;
  case: x => [x | | ] ;
  case: y => [y | | ] ;
  case: z => [z | | ] //= H ;
  inversion H => // ;
  case: Rle_dec H => // H0 ;
  case: Rle_lt_or_eq_dec => //.
Qed.
Lemma Rbar_mult_correct (x y : Rbar) :
  ex_Rbar_mult x y -> is_Rbar_mult x y (Rbar_mult x y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= H ;
  apply sym_not_eq in H ;
  unfold is_Rbar_mult ; simpl ;
  case: Rle_dec => // H0 ;
  case: Rle_lt_or_eq_dec => //.
Qed.
Lemma Rbar_mult_correct' (x y z : Rbar) :
  is_Rbar_mult x y z -> ex_Rbar_mult x y.
Proof.
  unfold is_Rbar_mult ;
  case: x => [x | | ] ;
  case: y => [y | | ] //= ;
  case: Rle_dec => //= H ; try (case: Rle_lt_or_eq_dec => //=) ; intros.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
Qed.

Definition Rbar_div (x y : Rbar) : Rbar :=
  Rbar_mult x (Rbar_inv y).
Arguments Rbar_div !x !y /.
Definition is_Rbar_div (x y z : Rbar) : Prop :=
  is_Rbar_mult x (Rbar_inv y) z.
Definition ex_Rbar_div (x y : Rbar) : Prop :=
  ex_Rbar_mult x (Rbar_inv y).
Arguments ex_Rbar_div !x !y /.
Definition Rbar_div_pos (x : Rbar) (y : posreal) :=
  match x with
    | Finite x => Finite (x/y)
    | _ => x
  end.

(** * Compatibility with real numbers *)
(** For equality and order.
The compatibility of addition and multiplication is proved in Rbar_seq *)

Lemma Rbar_finite_eq (x y : R) :
  Finite x = Finite y <-> x = y.
Proof.
  split ; intros.
  apply Rle_antisym ; apply Rnot_lt_le ; intro.
  assert (Rbar_lt (Finite y) (Finite x)).
  simpl ; apply H0.
  rewrite H in H1 ; simpl in H1 ; by apply Rlt_irrefl in H1.
  assert (Rbar_lt (Finite x) (Finite y)).
  simpl ; apply H0.
  rewrite H in H1 ; simpl in H1 ; by apply Rlt_irrefl in H1.
  rewrite H ; reflexivity.
Qed.
Lemma Rbar_finite_neq (x y : R) :
  Finite x <> Finite y <-> x <> y.
Proof.
  split => H ; contradict H ; by apply Rbar_finite_eq.
Qed.

(** * Properties of order *)

(** ** Relations between inequalities *)

Lemma Rbar_lt_not_eq (x y : Rbar) :
  Rbar_lt x y -> x<>y.
Proof.
  destruct x ; destruct y ; simpl ; try easy.
  intros H H0.
  apply Rbar_finite_eq in H0 ; revert H0 ; apply Rlt_not_eq, H.
Qed.

Lemma Rbar_not_le_lt (x y : Rbar) :
  ~ Rbar_le x y -> Rbar_lt y x.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
Qed.

Lemma Rbar_lt_not_le (x y : Rbar) :
  Rbar_lt y x -> ~ Rbar_le x y.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
  apply (Rlt_irrefl r0).
  now apply Rlt_le_trans with (1 := H).
Qed.

Lemma Rbar_not_lt_le (x y : Rbar) :
  ~ Rbar_lt x y -> Rbar_le y x.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
  now apply Rnot_lt_le.
Qed.

Lemma Rbar_le_not_lt (x y : Rbar) :
  Rbar_le y x -> ~ Rbar_lt x y.
Proof.
  destruct x ; destruct y ; simpl ; intuition ; contradict H0.
  now apply Rle_not_lt.
Qed.

Lemma Rbar_le_refl :
  forall x : Rbar, Rbar_le x x.
Proof.
intros [x| |] ; try easy.
apply Rle_refl.
Qed.

Lemma Rbar_lt_le :
  forall x y : Rbar,
  Rbar_lt x y -> Rbar_le x y.
Proof.
  intros [x| |] [y| |] ; try easy.
  apply Rlt_le.
Qed.

(** ** Decidability *)

Lemma Rbar_total_order (x y : Rbar) :
  {Rbar_lt x y} + {x = y} + {Rbar_lt y x}.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
  destruct (total_order_T r r0) ; intuition.
Qed.

Lemma Rbar_eq_dec (x y : Rbar) :
  {x = y} + {x <> y}.
Proof.
  intros ; destruct (Rbar_total_order x y) as [[H|H]|H].
  right ; revert H ; destruct x as [x| |] ; destruct y as [y| |] ; simpl ; intros H ;
  try easy.
  contradict H.
  apply Rbar_finite_eq in H ; try apply Rle_not_lt, Req_le ; auto.
  left ; apply H.
  right ; revert H ; destruct x as [x| |] ; destruct y as [y| |] ; simpl ; intros H ;
  try easy.
  contradict H.
  apply Rbar_finite_eq in H ; apply Rle_not_lt, Req_le ; auto.
Qed.

Lemma Rbar_lt_dec (x y : Rbar) :
  {Rbar_lt x y} + {~Rbar_lt x y}.
Proof.
  destruct (Rbar_total_order x y) as [H|H] ; [ destruct H as [H|H]|].
  now left.
  right ; rewrite H ; clear H ; destruct y ; auto ; apply Rlt_irrefl ; auto.
  right ; revert H ; destruct x as [x | | ] ; destruct y as [y | | ] ; intros H ; auto ;
  apply Rle_not_lt, Rlt_le ; auto.
Qed.

Lemma Rbar_lt_le_dec (x y : Rbar) :
  {Rbar_lt x y} + {Rbar_le y x}.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  now left.
  right.
  rewrite H.
  apply Rbar_le_refl.
  right.
  now apply Rbar_lt_le.
Qed.

Lemma Rbar_le_dec (x y : Rbar) :
  {Rbar_le x y} + {~Rbar_le x y}.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  left.
  now apply Rbar_lt_le.
  left.
  rewrite H.
  apply Rbar_le_refl.
  right.
  now apply Rbar_lt_not_le.
Qed.

Lemma Rbar_le_lt_dec (x y : Rbar) :
  {Rbar_le x y} + {Rbar_lt y x}.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  left.
  now apply Rbar_lt_le.
  left.
  rewrite H.
  apply Rbar_le_refl.
  now right.
Qed.

Lemma Rbar_le_lt_or_eq_dec (x y : Rbar) :
  Rbar_le x y -> { Rbar_lt x y } + { x = y }.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  now left.
  now right.
  intros K.
  now elim (Rbar_le_not_lt _ _ K).
Qed.

(** ** Transitivity *)

Lemma Rbar_lt_trans (x y z : Rbar) :
  Rbar_lt x y -> Rbar_lt y z -> Rbar_lt x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rlt_trans with r0.
Qed.

Lemma Rbar_lt_le_trans (x y z : Rbar) :
  Rbar_lt x y -> Rbar_le y z -> Rbar_lt x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rlt_le_trans with r0.
Qed.

Lemma Rbar_le_lt_trans (x y z : Rbar) :
  Rbar_le x y -> Rbar_lt y z -> Rbar_lt x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rle_lt_trans with r0.
Qed.

Lemma Rbar_le_trans (x y z : Rbar) :
  Rbar_le x y -> Rbar_le y z -> Rbar_le x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rle_trans with r0.
Qed.

Lemma Rbar_le_antisym (x y : Rbar) :
  Rbar_le x y -> Rbar_le y x -> x = y.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
Qed.

(** * Properties of operations *)
(** ** Additive operators *)
(** *** Rbar_opp *)

Lemma Rbar_opp_involutive (x : Rbar) : (Rbar_opp (Rbar_opp x)) = x.
Proof.
  destruct x as [x| | ] ; auto ; simpl ; rewrite Ropp_involutive ; auto.
Qed.

Lemma Rbar_opp_lt (x y : Rbar) : Rbar_lt (Rbar_opp x) (Rbar_opp y) <-> Rbar_lt y x.
Proof.
  destruct x as [x | | ] ; destruct y as [y | | ] ;
  split ; auto ; intro H ; simpl ; try left.
  apply Ropp_lt_cancel ; auto.
  apply Ropp_lt_contravar ; auto.
Qed.

Lemma Rbar_opp_le (x y : Rbar) : Rbar_le (Rbar_opp x) (Rbar_opp y) <-> Rbar_le y x.
Proof.
  destruct x as [x| |] ; destruct y as [y| |] ; simpl ; intuition.
Qed.

Lemma Rbar_opp_eq (x y : Rbar) : (Rbar_opp x) = (Rbar_opp y) <-> x = y.
Proof.
  split ; intros H.
  rewrite <- (Rbar_opp_involutive x), H, Rbar_opp_involutive ; reflexivity.
  rewrite H ; reflexivity.
Qed.

Lemma Rbar_opp_real (x : Rbar) : real (Rbar_opp x) = - real x.
Proof.
  destruct x as [x | | ] ; simpl ; intuition.
Qed.

(** *** Rbar_plus *)

Lemma Rbar_plus'_comm :
  forall x y, Rbar_plus' x y = Rbar_plus' y x.
Proof.
intros [x| |] [y| |] ; try reflexivity.
apply (f_equal (fun x => Some (Finite x))), Rplus_comm.
Qed.

Lemma ex_Rbar_plus_comm :
  forall x y,
  ex_Rbar_plus x y -> ex_Rbar_plus y x.
Proof.
now intros [x| |] [y| |].
Qed.

Lemma ex_Rbar_plus_opp (x y : Rbar) :
  ex_Rbar_plus x y -> ex_Rbar_plus (Rbar_opp x) (Rbar_opp y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] => //.
Qed.

Lemma Rbar_plus_0_r (x : Rbar) : Rbar_plus x (Finite 0) = x.
Proof.
  case: x => //= ; intuition.
Qed.
Lemma Rbar_plus_0_l (x : Rbar) : Rbar_plus (Finite 0) x = x.
Proof.
  case: x => //= ; intuition.
Qed.

Lemma Rbar_plus_comm (x y : Rbar) : Rbar_plus x y = Rbar_plus y x.
Proof.
  case x ; case y ; intuition.
  simpl.
  apply f_equal, Rplus_comm.
Qed.

Lemma Rbar_plus_lt_compat (a b c d : Rbar) :
  Rbar_lt a b -> Rbar_lt c d -> Rbar_lt (Rbar_plus a c) (Rbar_plus b d).
Proof.
  case: a => [a | | ] // ; case: b => [b | | ] // ;
  case: c => [c | | ] // ; case: d => [d | | ] // ;
  apply Rplus_lt_compat.
Qed.

Lemma Rbar_plus_le_compat (a b c d : Rbar) :
  Rbar_le a b -> Rbar_le c d -> Rbar_le (Rbar_plus a c) (Rbar_plus b d).
Proof.
  case: a => [a | | ] // ; case: b => [b | | ] // ;
  case: c => [c | | ] // ; case: d => [d | | ] //.
  apply Rplus_le_compat.
  intros _ _.
  apply Rle_refl.
  intros _ _.
  apply Rle_refl.
Qed.

Lemma Rbar_plus_opp (x y : Rbar) :
  Rbar_plus (Rbar_opp x) (Rbar_opp y) = Rbar_opp (Rbar_plus x y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= ; apply f_equal ; ring.
Qed.

(** *** Rbar_minus *)

Lemma Rbar_minus_eq_0 (x : Rbar) : Rbar_minus x x = 0.
Proof.
  case: x => //= x ; by apply f_equal, Rcomplements.Rminus_eq_0.
Qed.
Lemma Rbar_opp_minus (x y : Rbar) :
  Rbar_opp (Rbar_minus x y) = Rbar_minus y x.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //=.
  by rewrite Ropp_minus_distr'.
  by rewrite Ropp_0.
  by rewrite Ropp_0.
Qed.

(** ** Multiplicative *)

(** *** Rbar_inv *)

Lemma Rbar_inv_opp (x : Rbar) :
  x <> 0 -> Rbar_inv (Rbar_opp x) = Rbar_opp (Rbar_inv x).
Proof.
  case: x => [x | | ] /= Hx.
  rewrite Ropp_inv_permute => //.
  contradict Hx.
  by rewrite Hx.
  by rewrite Ropp_0.
  by rewrite Ropp_0.
Qed.

(** *** Rbar_mult *)

Lemma Rbar_mult'_comm (x y : Rbar) :
  Rbar_mult' x y = Rbar_mult' y x.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //=.
  by rewrite Rmult_comm.
Qed.

Lemma Rbar_mult'_opp_r (x y : Rbar) :
  Rbar_mult' x (Rbar_opp y) = match Rbar_mult' x y with Some z => Some (Rbar_opp z) | None => None end.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= ;
  (try case: Rle_dec => Hx //=) ;
  (try case: Rle_lt_or_eq_dec => //= Hx0).
  by rewrite Ropp_mult_distr_r_reverse.
  rewrite -Ropp_0 in Hx0.
  apply Ropp_lt_cancel in Hx0.
  case Rle_dec => Hy //=.
  now elim Rle_not_lt with (1 := Hy).
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Rlt_not_le with (1 := Hy0).
  apply Ropp_le_cancel.
  by rewrite Ropp_0.
  elim Hy.
  apply Ropp_le_cancel.
  rewrite -Hx0 Ropp_0.
  apply Rle_refl.
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Hx.
  rewrite -Hy0 Ropp_0.
  apply Rle_refl.
  elim Hx.
  rewrite -Ropp_0.
  apply Ropp_le_contravar.
  apply Rlt_le.
  now apply Rnot_le_lt.
  case Rle_dec => Hy //=.
  elim Rlt_not_le with (1 := Hx0).
  rewrite -Ropp_0.
  now apply Ropp_le_contravar.
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Rlt_not_le with (1 := Hy0).
  apply Ropp_le_cancel.
  rewrite -Hx0 Ropp_0.
  apply Rle_refl.
  elim Hy.
  apply Ropp_le_cancel.
  rewrite -Hx0 Ropp_0.
  apply Rle_refl.
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Hx.
  rewrite -Hy0 Ropp_0.
  apply Rle_refl.
  elim Hx.
  rewrite -Ropp_0.
  apply Ropp_le_contravar.
  apply Rlt_le.
  now apply Rnot_le_lt.
Qed.

Lemma Rbar_mult_comm (x y : Rbar) :
  Rbar_mult x y = Rbar_mult y x.
Proof.
  unfold Rbar_mult.
  by rewrite Rbar_mult'_comm.
Qed.
Lemma Rbar_mult_opp_r (x y : Rbar) :
  Rbar_mult x (Rbar_opp y) = (Rbar_opp (Rbar_mult x y)).
Proof.
  unfold Rbar_mult.
  rewrite Rbar_mult'_opp_r.
  case Rbar_mult' => //=.
  apply f_equal, eq_sym, Ropp_0.
Qed.
Lemma Rbar_mult_opp_l (x y : Rbar) :
  Rbar_mult (Rbar_opp x) y = Rbar_opp (Rbar_mult x y).
Proof.
  rewrite ?(Rbar_mult_comm _ y).
  by apply Rbar_mult_opp_r.
Qed.
Lemma Rbar_mult_opp (x y : Rbar) :
  Rbar_mult (Rbar_opp x) (Rbar_opp y) = Rbar_mult x y.
Proof.
  by rewrite Rbar_mult_opp_l -Rbar_mult_opp_r Rbar_opp_involutive.
Qed.
Lemma Rbar_mult_0_l (x : Rbar) : Rbar_mult 0 x = 0.
Proof.
  case: x => [x | | ] //=.
  by rewrite Rmult_0_l.
  case: Rle_dec (Rle_refl 0) => // H _.
  case: Rle_lt_or_eq_dec (Rlt_irrefl 0) => // _ _.
  case: Rle_dec (Rle_refl 0) => // H _.
  case: Rle_lt_or_eq_dec (Rlt_irrefl 0) => // _ _.
Qed.
Lemma Rbar_mult_0_r (x : Rbar) : Rbar_mult x 0 = 0.
Proof.
  rewrite Rbar_mult_comm ; by apply Rbar_mult_0_l.
Qed.

Lemma Rbar_mult_eq_0 (y x : Rbar) :
  Rbar_mult x y = 0 -> x = 0 \/ y = 0.
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //= ;
  (try case: Rle_dec => //= H) ;
  (try case: Rle_lt_or_eq_dec => //=) ;
  (try (left ; by apply f_equal)) ;
  (try (right ; by apply f_equal)).
  intros H.
  apply (f_equal real) in H.
  simpl in H.
  apply Rmult_integral in H ; case: H => ->.
  by left.
  by right.
Qed.

Lemma ex_Rbar_mult_sym (x y : Rbar) :
  ex_Rbar_mult x y -> ex_Rbar_mult y x.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //.
Qed.
Lemma ex_Rbar_mult_opp_l (x y : Rbar) :
  ex_Rbar_mult x y -> ex_Rbar_mult (Rbar_opp x) y.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= Hx ;
  by apply Ropp_neq_0_compat.
Qed.
Lemma ex_Rbar_mult_opp_r (x y : Rbar) :
  ex_Rbar_mult x y -> ex_Rbar_mult x (Rbar_opp y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= Hx ;
  by apply Ropp_neq_0_compat.
Qed.

Lemma is_Rbar_mult_sym (x y z : Rbar) :
  is_Rbar_mult x y z -> is_Rbar_mult y x z.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] ;
  case: z => [z | | ] //= ;
  unfold is_Rbar_mult, Rbar_mult' ;
  try (case: Rle_dec => // H) ;
  try (case: Rle_lt_or_eq_dec => // H0) ;
  try (case => <-) ; try (move => _).
  by rewrite Rmult_comm.
Qed.
Lemma is_Rbar_mult_opp_l (x y z : Rbar) :
  is_Rbar_mult x y z -> is_Rbar_mult (Rbar_opp x) y (Rbar_opp z).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] ;
  case: z => [z | | ] //= ;
  unfold is_Rbar_mult, Rbar_mult' ;
  try (case: Rle_dec => // H) ;
  try (case: Rle_lt_or_eq_dec => // H0) ;
  try (case => <-) ; try (move => _).
  apply (f_equal (@Some _)), f_equal ; ring.
  apply Ropp_lt_contravar in H0 ; rewrite Ropp_0 in H0 ;
  now move/Rlt_not_le: H0 ; case: Rle_dec.
  apply Rnot_le_lt, Ropp_lt_contravar in H ; rewrite Ropp_0 in H ;
  move/Rlt_le: (H) ; case: Rle_dec => // H0 _ ;
  now move/Rlt_not_eq: H ; case: Rle_lt_or_eq_dec.
  apply Rnot_le_lt, Ropp_lt_contravar in H ; rewrite Ropp_0 in H ;
  move/Rlt_le: (H) ; case: Rle_dec => // H0 _ ;
  now move/Rlt_not_eq: H ; case: Rle_lt_or_eq_dec.
  apply Ropp_lt_contravar in H0 ; rewrite Ropp_0 in H0 ;
  now move/Rlt_not_le: H0 ; case: Rle_dec.
Qed.
Lemma is_Rbar_mult_opp_r (x y z : Rbar) :
  is_Rbar_mult x y z -> is_Rbar_mult x (Rbar_opp y) (Rbar_opp z).
Proof.
  move/is_Rbar_mult_sym => H.
  now apply is_Rbar_mult_sym, is_Rbar_mult_opp_l.
Qed.

Lemma is_Rbar_mult_p_infty_pos (x : Rbar) :
  Rbar_lt 0 x -> is_Rbar_mult p_infty x p_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_le _ _ Hx) => // Hx' _.
  now case: Rle_lt_or_eq_dec (Rlt_not_eq _ _ Hx).
Qed.
Lemma is_Rbar_mult_p_infty_neg (x : Rbar) :
  Rbar_lt x 0 -> is_Rbar_mult p_infty x m_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_not_le _ _ Hx) => // Hx' _.
Qed.
Lemma is_Rbar_mult_m_infty_pos (x : Rbar) :
  Rbar_lt 0 x -> is_Rbar_mult m_infty x m_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_le _ _ Hx) => // Hx' _.
  now case: Rle_lt_or_eq_dec (Rlt_not_eq _ _ Hx).
Qed.
Lemma is_Rbar_mult_m_infty_neg (x : Rbar) :
  Rbar_lt x 0 -> is_Rbar_mult m_infty x p_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_not_le _ _ Hx) => // Hx' _.
Qed.

(** Rbar_div *)

Lemma is_Rbar_div_p_infty (x : R) :
  is_Rbar_div x p_infty 0.
Proof.
  apply (f_equal (@Some _)).
  by rewrite Rmult_0_r.
Qed.
Lemma is_Rbar_div_m_infty (x : R) :
  is_Rbar_div x m_infty 0.
Proof.
  apply (f_equal (@Some _)).
  by rewrite Rmult_0_r.
Qed.

(** Rbar_mult_pos *)

Lemma Rbar_mult_pos_eq (x y : Rbar) (z : posreal) :
  x = y <-> (Rbar_mult_pos x z) = (Rbar_mult_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H ; apply Rbar_finite_eq in H.
  by rewrite H.
  apply Rbar_finite_eq, (Rmult_eq_reg_r (z)) => // ;
  by apply Rgt_not_eq.
Qed.

Lemma Rbar_mult_pos_lt (x y : Rbar) (z : posreal) :
  Rbar_lt x y <-> Rbar_lt (Rbar_mult_pos x z) (Rbar_mult_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply (Rmult_lt_compat_r (z)) => //.
  apply (Rmult_lt_reg_r (z)) => //.
Qed.

Lemma Rbar_mult_pos_le (x y : Rbar) (z : posreal) :
  Rbar_le x y <-> Rbar_le (Rbar_mult_pos x z) (Rbar_mult_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply Rmult_le_compat_r with (2 := H).
  now apply Rlt_le.
  now apply Rmult_le_reg_r with (2 := H).
Qed.

(** Rbar_div_pos *)

Lemma Rbar_div_pos_eq (x y : Rbar) (z : posreal) :
  x = y <-> (Rbar_div_pos x z) = (Rbar_div_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H ; apply Rbar_finite_eq in H.
  by rewrite H.
  apply Rbar_finite_eq, (Rmult_eq_reg_r (/z)) => // ;
  by apply Rgt_not_eq, Rinv_0_lt_compat.
Qed.

Lemma Rbar_div_pos_lt (x y : Rbar) (z : posreal) :
  Rbar_lt x y <-> Rbar_lt (Rbar_div_pos x z) (Rbar_div_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply (Rmult_lt_compat_r (/z)) => // ; by apply Rinv_0_lt_compat.
  apply (Rmult_lt_reg_r (/z)) => // ; by apply Rinv_0_lt_compat.
Qed.

Lemma Rbar_div_pos_le (x y : Rbar) (z : posreal) :
  Rbar_le x y <-> Rbar_le (Rbar_div_pos x z) (Rbar_div_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply Rmult_le_compat_r with (2 := H).
  now apply Rlt_le, Rinv_0_lt_compat.
  apply Rmult_le_reg_r with (2 := H).
  now apply Rinv_0_lt_compat.
Qed.

(** * Rbar_min *)

Definition Rbar_min (x y : Rbar) : Rbar :=
  match x, y with
  | z, p_infty | p_infty, z => z
  | _ , m_infty | m_infty, _ => m_infty
  | Finite x, Finite y => Rmin x y
  end.

Lemma Rbar_lt_locally (a b : Rbar) (x : R) :
  Rbar_lt a x -> Rbar_lt x b ->
  exists delta : posreal,
    forall y, Rabs (y - x) < delta -> Rbar_lt a y /\ Rbar_lt y b.
Proof.
  case: a => [ a /= Ha | | _ ] //= ; (try apply Rminus_lt_0 in Ha) ;
  case: b => [ b Hb | _ | ] //= ; (try apply Rminus_lt_0 in Hb).
  assert (0 < Rmin (x - a) (b - x)).
    by apply Rmin_case.
  exists (mkposreal _ H) => y /= Hy ; split.
  apply Rplus_lt_reg_r with (-x).
  replace (a+-x) with (-(x-a)) by ring.
  apply (Rabs_lt_between (y - x)).
  apply Rlt_le_trans with (1 := Hy).
  by apply Rmin_l.
  apply Rplus_lt_reg_r with (-x).
  apply (Rabs_lt_between (y - x)).
  apply Rlt_le_trans with (1 := Hy).
  by apply Rmin_r.
  exists (mkposreal _ Ha) => y /= Hy ; split => //.
  apply Rplus_lt_reg_r with (-x).
  replace (a+-x) with (-(x-a)) by ring.
  by apply (Rabs_lt_between (y - x)).
  exists (mkposreal _ Hb) => y /= Hy ; split => //.
  apply Rplus_lt_reg_r with (-x).
  by apply (Rabs_lt_between (y - x)).
  exists (mkposreal _ Rlt_0_1) ; by split.
Qed.

Lemma Rbar_min_comm (x y : Rbar) : Rbar_min x y = Rbar_min y x.
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //=.
  by rewrite Rmin_comm.
Qed.

Lemma Rbar_min_r (x y : Rbar) : Rbar_le (Rbar_min x y) y.
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //=.
  by apply Rmin_r.
  by apply Rle_refl.
Qed.

Lemma Rbar_min_l (x y : Rbar) : Rbar_le (Rbar_min x y) x.
Proof.
  rewrite Rbar_min_comm.
  by apply Rbar_min_r.
Qed.

Lemma Rbar_min_case (x y : Rbar) (P : Rbar -> Type) :
  P x -> P y -> P (Rbar_min x y).
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //=.
  by apply Rmin_case.
Qed.
Lemma Rbar_min_case_strong (r1 r2 : Rbar) (P : Rbar -> Type) :
  (Rbar_le r1 r2 -> P r1) -> (Rbar_le r2 r1 -> P r2)
    -> P (Rbar_min r1 r2).
Proof.
  case: r1 => [x | | ] //= ;
  case: r2 => [y | | ] //= Hx Hy ;
  (try by apply Hx) ; (try by apply Hy).
  by apply Rmin_case_strong.
Qed.

(** * Rbar_abs *)

Definition Rbar_abs (x : Rbar) :=
  match x with
    | Finite x => Finite (Rabs x)
    | _ => p_infty
  end.

Lemma Rbar_abs_lt_between (x y : Rbar) :
  Rbar_lt (Rbar_abs x) y <-> (Rbar_lt (Rbar_opp y) x /\ Rbar_lt x y).
Proof.
  case: x => [x | | ] ; case: y => [y | | ] /= ; try by intuition.
  by apply Rabs_lt_between.
Qed.

Lemma Rbar_abs_opp (x : Rbar) :
  Rbar_abs (Rbar_opp x) = Rbar_abs x.
Proof.
  case: x => [x | | ] //=.
  by rewrite Rabs_Ropp.
Qed.

Lemma Rbar_abs_pos (x : Rbar) :
  Rbar_le 0 x -> Rbar_abs x = x.
Proof.
  case: x => [x | | ] //= Hx.
  by apply f_equal, Rabs_pos_eq.
Qed.
Lemma Rbar_abs_neg (x : Rbar) :
  Rbar_le x 0 -> Rbar_abs x = Rbar_opp x.
Proof.
  case: x => [x | | ] //= Hx.
  rewrite -Rabs_Ropp.
  apply f_equal, Rabs_pos_eq.
  now rewrite -Ropp_0 ; apply Ropp_le_contravar.
Qed.