Require Export GeoCoq.Elements.OriginalProofs.lemma_supplements.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglesreflexive.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglesflip.
Require Export GeoCoq.Elements.OriginalProofs.lemma_angleorderrespectscongruence.
Require Export GeoCoq.Elements.OriginalProofs.lemma_angleorderrespectscongruence2.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_supplementinequality :
   forall A B C D F a b c d f,
   Supp A B C D F -> Supp a b c d f -> LtA a b c A B C ->
   LtA D B F d b f.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists P Q R, (BetS P R Q /\ Out B A P /\ Out B C Q /\ CongA a b c A B R)) by (conclude_def LtA );destruct Tf as [P[Q[R]]];spliter.
assert (nCol A B R) by (conclude lemma_equalanglesNC).
assert ((Out B C D /\ BetS A B F)) by (conclude_def Supp ).
assert (BetS Q R P) by (conclude axiom_betweennesssymmetry).
assert (BetS F B A) by (conclude axiom_betweennesssymmetry).
assert ((BetS B P A \/ eq A P \/ BetS B A P)) by (conclude lemma_ray1).
assert (BetS F B P).
by cases on (BetS B P A \/ eq A P \/ BetS B A P).
{
 assert (BetS F B P) by (conclude axiom_innertransitivity).
 close.
 }
{
 assert (BetS F B P) by (conclude cn_equalitysub).
 close.
 }
{
 assert (BetS F B P) by (conclude lemma_3_7b).
 close.
 }
(** cases *)
assert (~ Col F P Q).
 {
 intro.
 assert (Col B A P) by (conclude lemma_rayimpliescollinear).
 assert (Col A B F) by (conclude_def Col ).
 assert (neq A B) by (forward_using lemma_betweennotequal).
 assert (Col A B P) by (forward_using lemma_collinearorder).
 assert (Col B F P) by (conclude lemma_collinear4).
 assert (Col F P B) by (forward_using lemma_collinearorder).
 assert (neq F P) by (forward_using lemma_betweennotequal).
 assert (Col P Q B) by (conclude lemma_collinear4).
 assert (Col P B Q) by (forward_using lemma_collinearorder).
 assert (Col P B A) by (forward_using lemma_collinearorder).
 assert (neq B P) by (forward_using lemma_betweennotequal).
 assert (neq P B) by (conclude lemma_inequalitysymmetric).
 assert (Col B Q A) by (conclude lemma_collinear4).
 assert (Col P R Q) by (conclude_def Col ).
 assert (Col P Q R) by (forward_using lemma_collinearorder).
 assert (Col P Q B) by (forward_using lemma_collinearorder).
 assert (neq P Q) by (forward_using lemma_betweennotequal).
 assert (Col Q R B) by (conclude lemma_collinear4).
 assert (Col Q B R) by (forward_using lemma_collinearorder).
 assert (Col Q B A) by (forward_using lemma_collinearorder).
 assert (neq B Q) by (conclude lemma_raystrict).
 assert (neq Q B) by (conclude lemma_inequalitysymmetric).
 assert (Col B R A) by (conclude lemma_collinear4).
 assert (Col A B R) by (forward_using lemma_collinearorder).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists M, (BetS F M R /\ BetS Q M B)) by (conclude postulate_Pasch_inner);destruct Tf as [M];spliter.
assert (eq R R) by (conclude cn_equalityreflexive).
assert (~ eq B R).
 {
 intro.
 assert (Col A B R) by (conclude_def Col ).
 contradict.
 }
assert (Out B R R) by (conclude lemma_ray4).
assert (Supp A B R R F) by (conclude_def Supp ).
assert (CongA A B R a b c) by (conclude lemma_equalanglessymmetric).
assert (CongA R B F d b f) by (conclude lemma_supplements).
assert (neq B F) by (forward_using lemma_betweennotequal).
assert (eq F F) by (conclude cn_equalityreflexive).
assert (Out B F F) by (conclude lemma_ray4).
assert (CongA d b f R B F) by (conclude lemma_equalanglessymmetric).
assert (nCol R B F) by (conclude lemma_equalanglesNC).
assert (~ Col F B Q).
 {
 intro.
 assert (Col Q B F) by (forward_using lemma_collinearorder).
 assert (Col Q M B) by (conclude_def Col ).
 assert (Col Q B M) by (forward_using lemma_collinearorder).
 assert (neq Q B) by (forward_using lemma_betweennotequal).
 assert (Col B F M) by (conclude lemma_collinear4).
 assert (Col F M R) by (conclude_def Col ).
 assert (Col M F B) by (forward_using lemma_collinearorder).
 assert (Col M F R) by (forward_using lemma_collinearorder).
 assert (neq F M) by (forward_using lemma_betweennotequal).
 assert (neq M F) by (conclude lemma_inequalitysymmetric).
 assert (Col F B R) by (conclude lemma_collinear4).
 assert (Col R B F) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA F B Q F B Q) by (conclude lemma_equalanglesreflexive).
assert (BetS B M Q) by (conclude axiom_betweennesssymmetry).
assert (neq B M) by (forward_using lemma_betweennotequal).
assert (Out B M Q) by (conclude lemma_ray4).
assert (Out B Q M) by (conclude lemma_ray5).
assert (CongA F B Q F B M) by (conclude lemma_equalangleshelper).
assert (BetS R M F) by (conclude axiom_betweennesssymmetry).
assert (LtA F B Q F B R) by (conclude_def LtA ).
assert (CongA f b d F B R) by (conclude lemma_equalanglesflip).
assert (CongA F B R f b d) by (conclude lemma_equalanglessymmetric).
assert (LtA F B Q f b d) by (conclude lemma_angleorderrespectscongruence).
assert (Out B Q D) by (conclude lemma_ray3).
assert (CongA F B Q F B D) by (conclude lemma_equalangleshelper).
assert (~ Col F B D).
 {
 intro.
 assert (Col B Q D) by (conclude lemma_rayimpliescollinear).
 assert (Col D B Q) by (forward_using lemma_collinearorder).
 assert (Col D B F) by (forward_using lemma_collinearorder).
 assert (neq B D) by (conclude lemma_raystrict).
 assert (neq D B) by (conclude lemma_inequalitysymmetric).
 assert (Col B Q F) by (conclude lemma_collinear4).
 assert (Col F B Q) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA F B D D B F) by (conclude lemma_ABCequalsCBA).
assert (CongA F B Q D B F) by (conclude lemma_equalanglestransitive).
assert (CongA D B F F B Q) by (conclude lemma_equalanglessymmetric).
assert (LtA D B F f b d) by (conclude lemma_angleorderrespectscongruence2).
assert (nCol f b d) by (conclude lemma_equalanglesNC).
assert (~ Col d b f).
 {
 intro.
 assert (Col f b d) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA d b f f b d) by (conclude lemma_ABCequalsCBA).
assert (LtA D B F d b f) by (conclude lemma_angleorderrespectscongruence).
close.
Qed.

End Euclid.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require map.Map.
Require int.Int.

Axiom ident : Type.
Parameter ident_WhyType : WhyType ident.
Existing Instance ident_WhyType.

Axiom ident_eq_dec : forall (i1:ident) (i2:ident), (i1 = i2) \/ ~ (i1 = i2).

Parameter mk_ident: Z -> ident.

Axiom mk_ident_inj : forall (i:Z) (j:Z), ((mk_ident i) = (mk_ident j)) ->
  (i = j).

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator .
Axiom operator_WhyType : WhyType operator.
Existing Instance operator_WhyType.

(* Why3 assumption *)
Inductive expr  :=
  | Econst : Z -> expr
  | Evar : ident -> expr
  | Ebin : expr -> operator -> expr -> expr .
Axiom expr_WhyType : WhyType expr.
Existing Instance expr_WhyType.

(* Why3 assumption *)
Inductive stmt  :=
  | Sskip : stmt
  | Sassign : ident -> expr -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : expr -> stmt -> stmt -> stmt
  | Swhile : expr -> stmt -> stmt .
Axiom stmt_WhyType : WhyType stmt.
Existing Instance stmt_WhyType.

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

(* Why3 assumption *)
Definition state  := (map.Map.map ident Z).

(* Why3 assumption *)
Definition eval_bin(x:Z) (op:operator) (y:Z): Z :=
  match op with
  | Oplus => (x + y)%Z
  | Ominus => (x - y)%Z
  | Omult => (x * y)%Z
  end.

(* Why3 assumption *)
Fixpoint eval_expr(s:(map.Map.map ident Z)) (e:expr) {struct e}: Z :=
  match e with
  | (Econst n) => n
  | (Evar x) => (map.Map.get s x)
  | (Ebin e1 op e2) => (eval_bin (eval_expr s e1) op (eval_expr s e2))
  end.

(* Why3 assumption *)
Inductive one_step : (map.Map.map ident Z) -> stmt -> (map.Map.map ident Z)
  -> stmt -> Prop :=
  | one_step_assign : forall (s:(map.Map.map ident Z)) (x:ident) (e:expr),
      (one_step s (Sassign x e) (map.Map.set s x (eval_expr s e)) Sskip)
  | one_step_seq : forall (s:(map.Map.map ident Z)) (s':(map.Map.map ident
      Z)) (i1:stmt) (i1':stmt) (i2:stmt), (one_step s i1 s' i1') ->
      (one_step s (Sseq i1 i2) s' (Sseq i1' i2))
  | one_step_seq_skip : forall (s:(map.Map.map ident Z)) (i:stmt),
      (one_step s (Sseq Sskip i) s i)
  | one_step_if_true : forall (s:(map.Map.map ident Z)) (e:expr) (i1:stmt)
      (i2:stmt), (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Sif e i1 i2) s
      i1)
  | one_step_if_false : forall (s:(map.Map.map ident Z)) (e:expr) (i1:stmt)
      (i2:stmt), ((eval_expr s e) = 0%Z) -> (one_step s (Sif e i1 i2) s i2)
  | one_step_while_true : forall (s:(map.Map.map ident Z)) (e:expr) (i:stmt),
      (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Swhile e i) s (Sseq i
      (Swhile e i)))
  | one_step_while_false : forall (s:(map.Map.map ident Z)) (e:expr)
      (i:stmt), ((eval_expr s e) = 0%Z) -> (one_step s (Swhile e i) s Sskip).

Axiom progress : forall (s:(map.Map.map ident Z)) (i:stmt),
  (~ (i = Sskip)) -> exists s':(map.Map.map ident Z), exists i':stmt,
  (one_step s i s' i').

(* Why3 assumption *)
Inductive many_steps : (map.Map.map ident Z) -> stmt -> (map.Map.map ident Z)
  -> stmt -> Z -> Prop :=
  | many_steps_refl : forall (s:(map.Map.map ident Z)) (i:stmt),
      (many_steps s i s i 0%Z)
  | many_steps_trans : forall (s1:(map.Map.map ident Z)) (s2:(map.Map.map
      ident Z)) (s3:(map.Map.map ident Z)) (i1:stmt) (i2:stmt) (i3:stmt)
      (n:Z), (one_step s1 i1 s2 i2) -> ((many_steps s2 i2 s3 i3 n) ->
      (many_steps s1 i1 s3 i3 (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (s1:(map.Map.map ident Z)) (s2:(map.Map.map
  ident Z)) (i1:stmt) (i2:stmt) (n:Z), (many_steps s1 i1 s2 i2 n) ->
  (0%Z <= n)%Z.

Axiom many_steps_seq : forall (s1:(map.Map.map ident Z)) (s3:(map.Map.map
  ident Z)) (i1:stmt) (i2:stmt) (n:Z), (many_steps s1 (Sseq i1 i2) s3 Sskip
  n) -> exists s2:(map.Map.map ident Z), exists n1:Z, exists n2:Z,
  (many_steps s1 i1 s2 Sskip n1) /\ ((many_steps s2 i2 s3 Sskip n2) /\
  (n = ((1%Z + n1)%Z + n2)%Z)).

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : expr -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla .
Axiom fmla_WhyType : WhyType fmla.
Existing Instance fmla_WhyType.

(* Why3 assumption *)
Fixpoint eval_fmla(s:(map.Map.map ident Z)) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => ~ ((eval_expr s e) = 0%Z)
  | (Fand f1 f2) => (eval_fmla s f1) /\ (eval_fmla s f2)
  | (Fnot f1) => ~ (eval_fmla s f1)
  | (Fimplies f1 f2) => (eval_fmla s f1) -> (eval_fmla s f2)
  end.

Parameter subst_expr: expr -> ident -> expr -> expr.

Axiom subst_expr_def : forall (e:expr) (x:ident) (t:expr),
  match e with
  | (Econst _) => ((subst_expr e x t) = e)
  | (Evar y) => ((x = y) -> ((subst_expr e x t) = t)) /\ ((~ (x = y)) ->
      ((subst_expr e x t) = e))
  | (Ebin e1 op e2) => ((subst_expr e x t) = (Ebin (subst_expr e1 x t) op
      (subst_expr e2 x t)))
  end.

(* Why3 goal *)
Theorem eval_subst_expr : forall (s:(map.Map.map ident Z)) (e:expr) (x:ident)
  (t:expr), ((eval_expr s (subst_expr e x t)) = (eval_expr (map.Map.set s x
  (eval_expr s t)) e)).
Proof.
intros s e x t.
induction e.
(* case Econst *)
rewrite (subst_expr_def (Econst z) x t).
now simpl.
(* case Evar *)
generalize (subst_expr_def (Evar i) x t).
intros (H1,H2).
case (ident_eq_dec x i).
(* subcase x=i *)
simpl; intro; subst x.
rewrite Map.Select_eq; auto.
now rewrite H1.
(* subcase x<>i *)
simpl; intro.
rewrite Map.Select_neq; auto.
now rewrite H2.
(* case Ebin *)
rewrite (subst_expr_def (Ebin e1 o e2) x t).
simpl.
rewrite IHe2.
now rewrite IHe1.
Qed.


(**
MathComp になぜ公理がないか
======
2019/08/14

この文書のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_axiom_free.v

 *)

(**
OCaml 4.07.1, Coq 8.9.0, MathComp 1.9.0
 *)

From mathcomp Require Import all_ssreflect.

(**
----------------
# MathComp は排中律を仮定しているのか

Stackoverflow (英語版）に、こんな質問がありました([1.])。

``forall A: Prop, A \/ ~A``

の証明を教えてほしいという趣旨です。クローズしているようなのですが、
その回答にあるように、MathComp のライブラリには排中律の公理が定義されていないので、
任意の ``A : Prop`` については証明できません。

もちろん、排中律の公理を自分で定義するか、
Standard CoqのClassical.vを導入すればよいのですが、
そもそも MathComp のライブラリには公理、すなわち、証明なしで導入される
命題はひとつも含まれていないのです。

このことは [2.] の3.3節に説明があって、

The Mathematical Components library is axiom free. This makes the
library compatible with any combination of axioms that is known to be
consistent with the Calculus of Inductive Constructions.

要するに（Standard Coqと違って）、
CICとの互換性が保たれない（かもしれない）命題は一切入れないのだ、
ということのようです。これを "axiom free" というのだそうです。

では、排中律ががなくて困ることはないのでしょうか？
代わりの仕組みがあるのでしょうか？
そもそも、Standard Coqはどんな「公理」を導入していて、
MathComp はそれぞれをどうしているのでしょうか？

結論からいうと、命題をbool値の式に変換（リフレクト）して、
決定性のあるbool値の上では、古典論理に基づいた証明ができるからなのですが、
そのような、「MathCompの考え方」を調べてみましょう。
 *)

(**
----------------
# 古典論理

Standard Coq では Classical.v で次のように定義されています。
排中律(classic)が公理として定義され、それから二重否定除去(NNPP)が証明されています。

（補足）今回は、排中律から二重否定除去を導くことについては説明しません。
興味のあるかたは [3.] を参照してください（補足終わり）。
 *)
Require Import Classical.
Check classic : forall P : Prop, P \/ ~ P.  (* Axiom *)
Check NNPP : forall p : Prop, ~ ~ p -> p.   (* Lemma *)

(**
これに対して、MathComp では、ssrbool.v において、
公理としてではなく、次の補題が証明されています。
*)
Check classicP : forall P : Prop, classically P <-> ~ ~ P. (* Lemma *)
Check classic_EM : forall P : Prop, classically (decidable P). (* Lemma *)

(**
----------------
## 二重否定除去
*)

(**
classicP は、``classically P`` の成り立つ P について二重否定除去が成り立つということです。

``classically := fun P : Type => forall b : bool, (P -> b) -> b``

ここで仮に P を Prop型の等式 ``P : m = n`` に限って考えるとしましょう。

そして m と n が eqType型の型であるとして、
``b : m == n`` とおくと、次の補題が成り立ちます。
*)

Lemma classic_eq {eT : eqType} (m n : eT) : classically (m = n) -> m = n.
Proof.
  move=> Hc.
  apply/eqP/Hc.                           (* case: (Hc (m == n)) *)
    by move/eqP.
Qed.
(**
classicP と この補題を使うと、``m = n`` について二重否定除去が証明できます。
当然、m と n はeqType型の型（たとえば nat_eqType で nat）である必要があります。
  *)

Lemma ssr_nnpp : forall (m n : nat), ~ ~ m = n -> m = n.
Proof.
  move=> m n Hnn.
  apply: classic_eq.
    by apply/classicP.
Qed.
(* 逆は自明であり、classic_eq は不要である。 *)

(* classically の成り立つ条件を一般化する。 *)
(* 命題 P をリフレクトできる ブール式 b があれば、classically P は成り立つ。 *)
Lemma classic_p (P : Prop) (b : bool) : reflect P b -> classically P -> P.
Proof.
  move=> Hr Hc.
  apply/Hr.
  apply: Hc.
  move/Hr.
  done.
Qed.

(* 命題 P をリフレクトできる ブール式 b があれば、二重否定除去は成り立つ。 *)
Lemma nnpp_p (P : Prop) (b : bool) : reflect P b -> ~ ~ P -> P.
Proof.
  move=> Hr Hnn.
  apply: classic_p.
  - by apply: Hr.
  - by apply/classicP.
Qed.

(**
Standard Coq のライブラリを使う場合は、NNPPを使って証明できます。
*)
Lemma coq_nnpp : forall (m n : nat), ~ m <> n -> m = n.
Proof.
  move=> m n Hnn.
    by apply: NNPP.
Qed.

(**
----------------
## 排中律
*)

(**
classic_EM は、``decidable := fun P : Prop => {P} + {~ P}`` は、
classically が成り立つということです。

ここで P を Prop型の等式 ``P : m = n`` に限って考え、
そして m と n が eqType型の型であるとすると、decidable は成立します。
そのため、eqType型の型の等式については、classic_EM を使用せずに、排中律を証明できます。

ただし、これはMathCompの趣旨とことなるため、見直す。
*)

Check classic_EM : forall P : Prop, classically ({P} + {~ P}). (* Lemma *)
Check classic_EM : forall P : Prop, classically (decidable P). (* Lemma *)

Check sumboolP : forall (Q : Prop) (decQ : decidable Q), reflect Q decQ.
Check decP : forall (P : Prop) (b : bool), reflect P b -> decidable P.

Lemma dec_eq (m n : nat) : decidable (m = n).
Proof.
  apply: (@decP (m = n) (m == n)).
  apply: (iffP idP); by move/eqP.
Qed.

Lemma ssr_EM (m n : nat) : m = n \/ m <> n.
Proof.
    by case: (dec_eq m n); [left | right].
Qed.

(**
Standard Coq のライブラリを使う場合は、classicを使って証明できます。
*)
Lemma coq_EM (m n : nat) : m = n \/ m <> n.
Proof.
  by apply: classic.
Qed.

(**
-------
# 関数拡張 (functional_extensionality)

Standard Coq では FunctionalExtensionality.v で定義されています。

これは、関数に等しさをいうものです。Coqでは定義が同じでなければ同じであるとは言えません
（ライプニッツの等号）。しかし、引数に対してすべて同じ値をとる関数どうしは「同じ」である
と言いたい場合があります。
 *)

Require Import FunctionalExtensionality.
Check @functional_extensionality_dep        (* Axiom *)
  : forall (A : Type) (B : A -> Type) (f g : forall x : A, B x),
    (forall x : A, f x = g x) -> f = g.
Check @functional_extensionality            (* Lemma *)
  : forall (A B : Type) (f g : A -> B), (forall x : A, f x = g x) -> f = g.

(**
これに対して、MathComp では 有限ドメインの関数 finfun が定義されていて、
そこで定義された一階の等号の「=1」については、intros 操作だけで関数拡張できます。
定義域が有限ならば、すべてのxについて、f x = g x が成り立つことを調べることができ、
それが成り立つなら、f = g といえるからです。

eq_ffun は 関数どうしの「=1」の等式にする補題です。
*)

Check @eq_ffun : forall (aT : finType) (rT : Type) (g1 g2 : aT -> rT),
    g1 =1 g2 -> [ffun x => g1 x] = [ffun x => g2 x].

Definition predI' {fT : finType} (s1 s2 : fT -> bool) := [ffun x => s1 x && s2 x].
Lemma ssr_fext {fT : finType} (s1 s2 : pred fT) : predI' s1 s2 = predI' s2 s1.
Proof.
  apply/eq_ffun.
  move=> x /=.
    (* Goal : s1 x && s2 x = s2 x && s1 x *)
    by rewrite Bool.andb_comm.
Qed.

(**
Standard Coq のライブラリを使う場合は、functional_extensionalityを 使って証明できます。
*)
Definition predI'' {fT : finType} (s1 s2 : fT -> bool) := (fun x => s1 x && s2 x).
Lemma coq_fext {fT : finType} (s1 s2 : pred fT) : predI'' s1 s2 = predI'' s2 s1.
Proof.
  rewrite /predI''.
  apply: functional_extensionality => x.
    (* Goal : s1 x && s2 x = s2 x && s1 x *)
    by rewrite Bool.andb_comm.
Qed.

(**
--------
# proof irrelevance (的外れ、見当違いの意味)

Standard Coq では ProofIrrelevance.v でで定義されています。

*)
Require Import ProofIrrelevance.
Check proof_irrelevance                     (* Axiom *)
  : forall (P : Prop) (p1 p2 : P), p1 = p2.

(**
これに対して、MathComp では eqtype.v で次の補題が証明されています。
*)

Check eq_irrelevance                        (* 補題 *)
  : forall (T : eqType) (x y : T) (e1 e2 : x = y), e1 = e2.

(**
たとえば、p1 が ``n = 3`` のとき、これは ``n == 3`` と同値で、
booleanなら、その証明はひとつだけといえるからです（補足すること）。
あるいは、bool_irrelevance を直接証明してみる。

より特殊な場合についても補題が用意されています。
 *)
Check bool_irrelevance : forall (b : bool) (p1 p2 : b), p1 = p2.
Check nat_irrelevance : forall (x y : nat) (E E' : x = y), E = E'.
Check le_irrelevance : forall (m n : nat) (le_mn1 le_mn2 : (m <= n)%coq_nat),
    le_mn1 = le_mn2.
Check lt_irrelevance : forall (m n : nat) (lt_mn1 lt_mn2 : (m < n)%coq_nat),
    lt_mn1 = lt_mn2.

(**
自然数(witness)と、それが奇数である証拠(evidence)の組からなる依存型 odds を定義します。
依存型はsigma typeとも言います。また、証拠のところがbool型の論理式であるので、
boolean sigma type と呼びます。
 *)

Definition odds := {x : nat | odd x}.       (* booelan sigma type *)

(**
ここで、証人(witness) が同じでも、証拠(evidence) の異なるふたつの数、
one_odd1とone_odd2 があるとします。
  *)
Definition one_odd1 : odds.
Proof.
    by exists 1.
Defined.
Print one_odd1.    (* = exist (fun x : nat => odd x) 1 is_true_true *)
Check is_true_true
  : true = true.                            (* 証拠の型 *)

Definition one_odd2 : odds.
Proof.
    by exists 1; rewrite -(addn0 1) addn0.  (* 1+0-0 *)
Defined.
Print one_odd2.    (* = exist (fun x : nat => odd x) 1 ...略... *)
Check ((fun x : odd (1 + 0) =>
          eq_ind (1 + 0) (fun y : nat => odd y) x 1
                 (addn0 1))
         ((fun x : odd 1 =>
             eq_ind_r (fun y : nat => odd y) x (addn0 1))
            is_true_true))
  : odd 1 = true.                           (* 証拠の型 *)

(**
one_odd1 の証拠は ``is_true_true`` でその型は ``true = true``。

one_odd2 の証拠も同様に ``odd 1 = true`` というboolの値どうしの等式の形です。

同じ型の等式 どうしは等しいという定理 irrelevance を使って証明できます。
 *)

Lemma ssr_odds : one_odd1 = one_odd2.
Proof.
  try reflexivity.                       (* still not convertible *)
  congr exist.                           (* is_true_true = 略 *)
    by apply: bool_irrelevance.
Qed.

(**
Standard Coq のライブラリを使う場合は、proof_irrelevance を使って証明できます。
*)
Lemma coq_odds : one_odd1 = one_odd2.
Proof.
  congr exist.                           (* is_true_true = 略 *)
    by apply: proof_irrelevance.
Qed.

(**
---------------
# 文献

[1.] Does ssreflect assume excluded middle?

https://stackoverflow.com/questions/34520944/does-ssreflect-assume-excluded-middle

[2.] Mathematical Components Book

https://math-comp.github.io/mcb/

[3.] Classical_Logic

https://github.com/suharahiromichi/coq/blob/master/ssr/ssr_classical_logic.v

 *)

(* END *)


(* ***********************************************************************)
(*                                                                       *)
(*   Synchronously executed Interpreted Time Petri Nets (SITPNs)         *)
(*                                                                       *)
(*                                                                       *)
(*   Copyright Université de Montpellier, contributor(s): Vincent        *)
(*   Iampietro, David Andreu, David Delahaye (May 2020)                  *)
(*                                                                       *)
(*   This software is governed by the CeCILL-C license under French law  *)
(*   and abiding by the rules of distribution of free software.  You can *)
(*   use, modify and/ or redistribute the software under the terms of    *)
(*   the CeCILL-C license as circulated by CEA, CNRS and INRIA at the    *)
(*   following URL "http://www.cecill.info".  The fact that you are      *)
(*   presently reading this means that you have had knowledge of the     *)
(*   CeCILL-C license and that you accept its terms.                     *)
(*                                                                       *)
(* ***********************************************************************)

(** * SITPN global types. *)

(** Defines the global types used in the definition of the SITPN
    structure and the SITPN semantics. *)

Require Import Coqlib.
Require Import NatSet.
Require Import GlobalTypes.

(** Defines the type representing the disjoint union N ⊔ {+∞}. *)

Inductive natinf : Set :=
| niinf : natinf
| ninat : nat -> natinf.

Coercion ninat : nat >-> natinf.
Notation "i+" := niinf (at level 0).

(** Equality is decidable for natinf. *)

Definition eq_natinf_dec : forall x y : natinf, {x = y} + {x <> y}. do 2 (decide equality). Defined.

(** Decrements a natinf. Does nothing if [ni] is +∞. *)

Lemma neqinf : i+ <> i+ -> False. congruence. Defined.

Definition dec_natinf (ni : natinf) : ni <> i+ -> natinf :=
  match ni return ni <> i+ -> natinf with
  | i+ => (fun pf : i+ <> i+ => match neqinf pf with end)
  | ninat n => (fun _ => ninat (n - 1))
  end.

(** Defines the less than or equal relation between a nat and a
    natinf. *)

Definition le_nat_natinf (n : nat) (ni : natinf) : ni <> i+ -> Prop :=
  match ni return ni <> i+ -> Prop with
  | i+ => (fun pf : i+ <> i+ => match neqinf pf with end)
  | ninat m => (fun _ => n <= m)
  end.

(** States that N is dijoint from {+∞}. *)

Definition nat_diff_inf : forall n, ninat n <> i+. congruence. Defined.

(** Defines the type of well-formed intervals [a,b] where
    a ∈ N and b ∈ N ⊔ {+∞} and a <= b.
 *)

Inductive NatInfInterval : Set :=
  MkNatInfItval {
      a : nat;
      b : natinf;
      is_well_formed : forall notinf, le_nat_natinf a b notinf;
    }.

Notation "'<|' a , b '|>'" := (MkNatInfItval a b _) (b at level 69).

(** Equivalence relation between NatInfInterval. *)

Definition eq_niit (x y : NatInfInterval) : Prop :=
  (a x) = (a y) /\ if eq_natinf_dec (b x) (b y) then True else False.

(** For every NatInfInterval [a, b], if [a, b] is well-formed, that is
    a <= b \/ b = ∞, then [a - 1, b - 1] is well-formed. *)

Lemma decr_natinf_is_well_formed :
  forall a b notinf,
    le_nat_natinf a b notinf ->
    forall notinf', le_nat_natinf (a - 1) (dec_natinf b notinf) notinf'.
Proof.
  intros a b. induction b; intros.
  - contradiction.
  - simpl. apply Nat.sub_le_mono_r. assumption.
Defined.

Lemma le_nat_le_natinf :
  forall a b, a <= b -> forall notinf, le_nat_natinf a b notinf.
Proof.
  unfold le_nat_natinf. intros; assumption.
Defined.

(** Defines some NatInfInterval. *)

Definition ditval00 := MkNatInfItval 0 0 (le_nat_le_natinf 0 0 (le_n 0)).

(** Defines the type of time interval ≡ I+
    [a,b] ∈ I+, where a ∈ N* and b ∈ N ⊔ {∞}
    and a <= b *)

Structure StaticTimeInterval : Set :=
  MkSTimeItval {
      itval : NatInfInterval;
      lower_is_natstar : (a itval) > 0;
    }.

(** Defines the type of dynamic time intervals ≡ I+ ⊔ {ψ} *)

Inductive DynamicTimeInterval : Set :=
| active : NatInfInterval -> DynamicTimeInterval
| blocked : DynamicTimeInterval.

Coercion active : NatInfInterval >-> DynamicTimeInterval.

Lemma absurd_natinf : forall a b, b = i+ -> (forall bneqinf, le_nat_natinf a b bneqinf).
  intros a b beqinf bneqinf; contradiction.
Defined.

(** Returns a time interval equals to interval [i] with the value of
    its bounds decremented. *)

Definition dec_itval (i : NatInfInterval) : DynamicTimeInterval.
  refine (match eq_natinf_dec (b i) i+ with
          | left beqinf => MkNatInfItval ((a i) - 1) (b i) (absurd_natinf ((a i) - 1) (b i) beqinf)
          | right bneqinf => MkNatInfItval ((a i) - 1) (dec_natinf (b i) bneqinf) _
          end); apply decr_natinf_is_well_formed; apply (is_well_formed i).
Defined.

Notation "i '--'" := (dec_itval i) (at level 0).

(** Equivalence relation between DynamicTimeInterval. *)

Definition eq_ditval (x y : DynamicTimeInterval) : Prop :=
  match x, y with
  | blocked, blocked => True
  | active a, active b => eq_niit a b
  | _, _ => False
  end.

(** Defines the set {0,1,-1}, useful to express the association of
    condition and barred condition to transition. *)

Inductive MOneZeroOne : Set := mone | zero | one.

(** Clock events set. *)

Inductive Clk := rising_edge | falling_edge.


Require Export Base.

(* Unbundle Equivalence and setoid *)
Class Equiv A := equiv: relation A.
Typeclasses Transparent Equiv.

Infix "=" := equiv : type_scope.
Notation "(=)" := equiv (only parsing) : nominal_scope.
Notation "( x =)" := (equiv x) (only parsing) : nominal_scope.
Notation "(= x )" := (λ y, equiv y x) (only parsing) : nominal_scope.
Notation "(≠)" := (λ x y, ¬x = y) (only parsing) : nominal_scope.
Notation "x ≠ y":= (¬x = y): type_scope.
Notation "( x ≠)" := (λ y, x ≠ y) (only parsing) : nominal_scope.
Notation "(≠ x )" := (λ y, y ≠ x) (only parsing) : nominal_scope.

Ltac auto_symm :=
  match goal with
    [ H: ?R ?x ?y |- ?R ?y ?x] => apply (symmetry H)
  end.
Ltac auto_trans :=
  match goal with
    [ H: ?R ?x ?y, I: ?R ?y ?z |- ?R ?x ?z] => apply (transitivity H I)
  end.
Hint Extern 2 (?x = ?x) => reflexivity: core.
Hint Extern 2 (?x = ?y) => auto_symm: core.
Hint Extern 2 (?x = ?y) => auto_trans: core.

Definition ext_equiv `{Equiv A} `{Equiv B} : Equiv (A → B) := ((=) ==> (=))%signature.
Hint Extern 10 (Equiv (_ → _)) => apply @ext_equiv : typeclass_instances.
Hint Extern 10 (Equiv (relation _)) => apply @ext_equiv : typeclass_instances.

(* (* Coq sometimes uses an incorrect DefaultRelation, so we override it. *) *)
(* Instance equiv_default_relation `{Equiv A} : DefaultRelation (=) | 3 := {}. *)

Class Setoid A {Ae : Equiv A} : Prop := setoid_eq :> Equivalence (@equiv A Ae).


(** * Short exact sequences *)
(** ** Contents
- Definitions
 - ShortShortExact sequences
 - Remark on monics, epis, kernels, and cokernels
 - LeftShortExact sequences
 - RightShortExact sequences
 - ShortExact sequences
- Opposite category and (short/left/right)exacts
- A criteria for ShortShortExact
 - Cokernel from ShortShortExact
 - isCoequalizer to ShortShortExact
- Correspondence between ShortExact and ShortShortExact
 - ShortExact from ShortShortExact
 - ShortShortExact criteria
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.coequalizers.
Require Import UniMath.CategoryTheory.limits.Opp.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.Morphisms.
Require Import UniMath.CategoryTheory.CategoriesWithBinOps.
Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops.
Require Import UniMath.CategoryTheory.PreAdditive.
Require Import UniMath.CategoryTheory.Additive.
Require Import UniMath.CategoryTheory.Abelian.
Require Import UniMath.CategoryTheory.AbelianToAdditive.

Require Import UniMath.CategoryTheory.limits.kernels.
Require Import UniMath.CategoryTheory.limits.cokernels.
Require Import UniMath.CategoryTheory.limits.BinDirectSums.

Local Open Scope cat.

(** * Introduction
  Short exact sequences consist of three objects and two morphisms such that the first morphism is a
  monic, the second morphism is an epi, and an image of the first morphism gives a kernel of the
  second morphism. These sequences are classically denoted by a diagram
                           0 -> A -> B -> C -> 0
  We call such diagrams [ShortExact].

  To define short exact sequences we first define short short exact sequences, [ShortShortExact],
  left short exact sequences, [LeftShortExact], and right short exact sequences, [RightShortExact].
  These correspond to the diagrams
          A -> B -> C,  0 -> A -> B -> C,  and,  A -> B -> C -> 0,
  respectively.

  The definition of [ShortShortExact] says that the image of A -> B is the kernel of B -> C. This is
  equivalent to saying that the coimage of B -> C is the cokernel of A -> B. We prove this
  correspondence in the Section [shortshortexact_coequalizer].

    Next, in the section [shortexact_correspondence] we prove a correspondence between
  [ShortShortExact] and [ShortExact] by using the factorization formula for morphisms in abelian
  precategories. We construct [ShortExact] from [ShortShortExact] and we give a criteria to
  construct [ShortShortExact] from properties similar to [ShortExact]. *)

(** * Definition of short exact sequences *)
Section def_shortexactseqs.

  Variable A : AbelianPreCat.
  Let hs : has_homsets A := homset_property A.

  (** Image of the first morphism and equality of morphisms associated to it. *)
  Definition Image (SSED : ShortShortExactData A (to_Zero A)) :
    Kernel (to_Zero A) (CokernelArrow (Abelian.Cokernel (Mor1 SSED))) := Image (Mor1 SSED).

  Lemma isExact_Eq {x y z : ob A} (f : x --> y) (g : y --> z)
        (H : f · g = ZeroArrow (to_Zero A) _ _) :
    KernelArrow (Abelian.Image f) · g = ZeroArrow (to_Zero A) _ _.
  Proof.
    unfold Abelian.Image.
    set (fact := factorization1 f).
    unfold factorization1_monic in fact. cbn in fact.
    apply (factorization1_is_epi f).
    rewrite ZeroArrow_comp_right.
    rewrite assoc. rewrite fact in H. clear fact.
    exact H.
  Qed.

  Definition isExact {x y z : ob A} (f : x --> y) (g : y --> z)
             (H : f · g = ZeroArrow (to_Zero A) _ _) : UU :=
    isKernel (to_Zero A) (KernelArrow (Abelian.Image f)) g (isExact_Eq f g H).

  Lemma Image_Eq (SSED : ShortShortExactData A (to_Zero A)) :
    (KernelArrow (Image SSED)) · (Mor2 SSED) = ZeroArrow (to_Zero A) _ _.
  Proof.
    exact (isExact_Eq (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)).
  Defined.

  (** Coimage of the second morphism and equality of morphisms associated to it. *)
  Definition CoImage (SSED : ShortShortExactData A (to_Zero A)) :
    Cokernel (to_Zero A) (KernelArrow (Abelian.Kernel (Mor2 SSED))) := CoImage (Mor2 SSED).

  Lemma isExact'_Eq {x y z : ob A} (f : x --> y) (g : y --> z)
        (H : f · g = ZeroArrow (to_Zero A) _ _) :
    f · CokernelArrow (Abelian.CoImage g) = ZeroArrow (to_Zero A) _ _.
  Proof.
    unfold Abelian.CoImage.
    set (fact := factorization2 g).
    unfold factorization2_epi in fact. cbn in fact. unfold Abelian.CoImage in fact.
    apply (factorization2_is_monic g).
    rewrite ZeroArrow_comp_left.
    rewrite <- assoc. apply (maponpaths (λ gg : _, f · gg)) in fact.
    use (pathscomp0 (! fact)). exact H.
  Qed.

  Definition isExact' {x y z : ob A} (f : x --> y) (g : y --> z)
             (H : f · g = ZeroArrow (to_Zero A) _ _) : UU :=
    isCokernel (to_Zero A) f (CokernelArrow (Abelian.CoImage g)) (isExact'_Eq f g H).

  Lemma CoImage_Eq (SSED : ShortShortExactData A (to_Zero A)) :
    (Mor1 SSED) · (CokernelArrow (CoImage SSED)) = ZeroArrow (to_Zero A) _ _.
  Proof.
    exact (isExact'_Eq (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)).
  Defined.

  (** ** Transform isExact to isExact' and isExact' to isExact *)

  Local Lemma isExact_to_isExact'_Eq {x y z : ob A} {f : x --> y} {g : y --> z}
        {H' : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact f g H') (w0 : A)
        (h : A ⟦y, w0⟧) (H : f · h = ZeroArrow (to_Zero A) _ _) :
    KernelArrow (Abelian.Kernel g) · h = ZeroArrow (to_Zero A) (Abelian.Kernel g) w0.
  Proof.
    unfold isExact in iE.
    set (K := make_Kernel _ _ _ _ iE).
    set (i := iso_from_Kernel_to_Kernel (to_Zero A) K (Abelian.Kernel g)).
    use (is_iso_isEpi A i (pr2 i)). rewrite ZeroArrow_comp_right. rewrite assoc.
    cbn. unfold from_Kernel_to_Kernel. rewrite KernelCommutes.
    use (factorization1_is_epi f). cbn.
    set (tmp := factorization1 f).
    unfold factorization1_epi in tmp.
    unfold factorization1_monic in tmp.
    cbn in tmp. rewrite assoc. rewrite <- tmp. clear tmp.
    rewrite ZeroArrow_comp_right.
    exact H.
  Qed.

  Lemma isExact_to_isExact' {x y z : ob A} {f : x --> y} {g : y --> z}
        {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact f g H) : isExact' f g H.
  Proof.
    unfold isExact in iE. unfold isExact'.
    use make_isCokernel.
    intros w0 h H'.
    use unique_exists.
    (* Construction of the morphism *)
    - use CokernelOut.
      + exact h.
      + cbn. exact (isExact_to_isExact'_Eq iE w0 h H').
    (* Commutativity *)
    - apply CokernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y'. apply hs.
    (* Uniqueness *)
    - intros y' T. cbn in T.
      apply CokernelOutsEq.
      rewrite T. apply pathsinv0.
      apply CokernelCommutes.
  Qed.

  Local Lemma isExact'_to_isExact_Eq {x y z : ob A} {f : x --> y} {g : y --> z}
        {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact' f g H) {w0 : ob A}
        (h : A⟦ w0, y ⟧)  (H' : h · g = ZeroArrow (to_Zero A) w0 z) :
    h · CokernelArrow (Abelian.Cokernel f) = ZeroArrow (to_Zero A) w0 (Abelian.Cokernel f).
  Proof.
    unfold isExact' in iE.
    set (CK := make_Cokernel _ _ _ _ iE).
    set (i := iso_from_Cokernel_to_Cokernel (to_Zero A) (Abelian.Cokernel f) CK).
    use (is_iso_isMonic A i (pr2 i)). rewrite ZeroArrow_comp_left. rewrite <- assoc.
    cbn. unfold from_Cokernel_to_Cokernel. rewrite CokernelCommutes.
    use (factorization2_is_monic g). cbn.
    set (tmp := factorization2 g).
    unfold factorization2_monic in tmp.
    unfold factorization2_epi in tmp.
    cbn in tmp. rewrite <- assoc. rewrite <- tmp. clear tmp.
    rewrite ZeroArrow_comp_left.
    exact H'.
  Qed.

  Lemma isExact'_to_isExact {x y z : ob A} {f : x --> y} {g : y --> z}
        {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact' f g H) : isExact f g H.
  Proof.
    unfold isExact' in iE. unfold isExact.
    use make_isKernel.
    intros w0 h H'.
    use unique_exists.
    (* Construction of the morphism *)
    - use KernelIn.
      + exact h.
      + cbn. exact (isExact'_to_isExact_Eq iE h H').
    (* Commutativity *)
    - apply KernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y'. apply hs.
    (* Uniqueness *)
    - intros y' T. cbn in T.
      apply KernelInsEq.
      rewrite T. apply pathsinv0.
      apply KernelCommutes.
  Qed.

  Lemma isExactisMonic {x y : ob A} {f : x --> y} (isM : isMonic f)
        (H : ZeroArrow (to_Zero A) (to_Zero A) x · f = ZeroArrow (to_Zero A) (to_Zero A) y) :
    isExact (ZeroArrow (to_Zero A) (to_Zero A) x) f H.
  Proof.
    unfold isExact.
    use make_isKernel.
    - intros w h H'.
      use unique_exists.
      + use KernelIn.
        * exact h.
        * rewrite <- (ZeroArrow_comp_left _ _ _ _ _ f) in H'. apply isM in H'.
          rewrite H'. apply ZeroArrow_comp_left.
      + cbn. use KernelCommutes.
      + intros y'. apply hs.
      + intros y' X. cbn in X. cbn.
        use (KernelArrowisMonic (to_Zero A) (Abelian.Image (ZeroArrow (to_Zero A) (to_Zero A) x))).
        rewrite X. apply pathsinv0. use KernelCommutes.
  Qed.

  Lemma isExactisEpi {x y : ob A} {f : x --> y} (isE : isEpi f)
        (H : f · ZeroArrow (to_Zero A) y (to_Zero A) = ZeroArrow (to_Zero A) x (to_Zero A)) :
    isExact f (ZeroArrow (to_Zero A) y (to_Zero A)) H.
  Proof.
    unfold isExact.
    use make_isKernel.
    - intros w h H'.
      use unique_exists.
      + use KernelIn.
        * exact h.
        * rewrite <- (ZeroArrow_comp_right _ _ _ _ _ h). apply cancel_precomposition.
          apply isE. rewrite CokernelCompZero. rewrite ZeroArrow_comp_right.
          apply idpath.
      + cbn. use KernelCommutes.
      + intros y'. apply hs.
      + intros y' X. cbn. cbn in X.
        use (KernelArrowisMonic (to_Zero A) (Abelian.Image f)).
        rewrite X. apply pathsinv0. use KernelCommutes.
  Qed.

  (** ** [Short Short Exact]
    [ShortShortData] such that the image of the first morphism is the kernel of the second morphism.
    Informally, an exact sequence
                               A -> B -> C
   *)

  Definition ShortShortExact : UU :=
    ∑ SSED : ShortShortExactData A (to_Zero A),
             isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED).

  Definition make_ShortShortExact (SSED : ShortShortExactData A (to_Zero A))
             (H : isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED)) :
    ShortShortExact := tpair _ SSED H.

  (** Accessor functions *)
  Definition ShortShortExact_ShortShortExactData (SSE : ShortShortExact) :
    ShortShortExactData A (to_Zero A) := pr1 SSE.
  Coercion ShortShortExact_ShortShortExactData : ShortShortExact >-> ShortShortExactData.

  Definition ShortShortExact_isKernel (SSE : ShortShortExact) :
    isKernel (to_Zero A) (KernelArrow (Image SSE)) (Mor2 SSE) (Image_Eq SSE) := pr2 SSE.

  Definition ShortShortExact_Kernel (SSE : ShortShortExact) : Kernel (to_Zero A) (Mor2 SSE) :=
    make_Kernel (to_Zero A) (KernelArrow (Image SSE)) (Mor2 SSE) (Image_Eq SSE)
               (ShortShortExact_isKernel SSE).

  (** ** Remark
    In Abelian.v we have already shown that a morphism is a monic if and only if its kernel is
    zero, and dually is an epi if and only if its cokernel is zero. See the results
    - Abelian_MonicKernelZero_isEqualizer, Abelian_MonicKernelZero
    - Abelian_EpiCokernelZero_isCoequalizer, Abelian_EpiCokernelZero
    - Abelian_KernelZeroisMonic, Abelian_KernelZeroMonic
    - Abelian_CokernelZeroisEpi, Abelian_CokernelZeroEpi
   in CategoryTheory/Abelian.v. Thus, to define short exact sequeces, it suffices to assume that
   the first morphism is a monic and the second morphism is an epi. Similarly for left short exact
   and right short exact.
   *)

  (** ** [LeftShortExact]
    [ShortShortExact] such that the first morphism is a monic. Informally, an exact sequence
                            0 -> A -> B -> C
  *)

  Definition LeftShortExact : UU := ∑ SSE : ShortShortExact, isMonic (Mor1 SSE).

  Definition make_LeftShortExact (SSE : ShortShortExact) (isM : isMonic (Mor1 SSE)) :
    LeftShortExact := tpair _ SSE isM.

  (** Accessor functions *)
  Definition LeftShortExact_ShortShortExact (LSE : LeftShortExact) : ShortShortExact := pr1 LSE.
  Coercion LeftShortExact_ShortShortExact : LeftShortExact >-> ShortShortExact.

  Definition isMonic (LSE : LeftShortExact) : isMonic (Mor1 LSE) := pr2 LSE.

  (** ** [RightShortExact]
    [ShortShortExact] such that the second morphism is an epi. Informally, an exact sequece
                               A -> B -> C -> 0
   *)

  Definition RightShortExact : UU := ∑ SSE : ShortShortExact, isEpi (Mor2 SSE).

  Definition make_RightShortExact (SSE : ShortShortExact) (isE : isEpi (Mor2 SSE)) :
    RightShortExact := tpair _ SSE isE.

  (** Accessor functions *)
  Definition RightShortExact_ShortShortExact (RSE : RightShortExact) : ShortShortExact := pr1 RSE.
  Coercion RightShortExact_ShortShortExact : RightShortExact >-> ShortShortExact.

  Definition isEpi (RSE : RightShortExact) : isEpi (Mor2 RSE) := pr2 RSE.

  (** ** [ShortExact]
    [ShortShortExact] such that the first morphism is monic and the second morphism is an epi.
    Informally, an exact sequece
                            0 -> A -> B -> C -> 0
  *)

  Definition ShortExact : UU :=
    ∑ SSE : ShortShortExact, Monics.isMonic (Mor1 SSE) × Epis.isEpi (Mor2 SSE).

  Definition make_ShortExact (SSE : ShortShortExact) (isM : Monics.isMonic (Mor1 SSE))
             (isE : Epis.isEpi (Mor2 SSE)) : ShortExact := (SSE,,(isM,,isE)).

  (** [LeftShortExact] and [RightShortExact] from [ShortExact] *)
  Definition ShortExact_LeftShortExact (SE : ShortExact) : LeftShortExact.
  Proof.
    use make_LeftShortExact.
    - exact (pr1 SE).
    - exact (dirprod_pr1 (pr2 SE)).
  Defined.
  Coercion ShortExact_LeftShortExact : ShortExact >-> LeftShortExact.

  Definition ShortExact_RightShortExact (SE : ShortExact) : RightShortExact.
  Proof.
    use make_RightShortExact.
    - exact (pr1 SE).
    - exact (dirprod_pr2 (pr2 SE)).
  Defined.
  Coercion ShortExact_RightShortExact : ShortExact >-> RightShortExact.

End def_shortexactseqs.
Arguments Image [A] _.
Arguments Image_Eq [A] _.
Arguments CoImage [A] _.
Arguments CoImage_Eq [A] _.
Arguments make_ShortShortExact [A] _ _.
Arguments ShortShortExact_isKernel [A] _ _ _ _.
Arguments ShortShortExact_Kernel [A] _.
Arguments make_LeftShortExact [A] _ _.
Arguments isMonic [A] _ _ _ _ _.
Arguments make_RightShortExact [A] _ _ .
Arguments isEpi [A] _ _ _ _ _ .
Arguments make_ShortShortExact [A] _ _.

(** * [ShortShortExact] criteria
  In this section we show that for [ShortShortExact] a coimage of the second morphism is a cokernel
  of the first morphism and give a way to construct [ShortShortExact] from certain isCokernel. *)
Section shortshortexact_cokernel.

  Variable A : AbelianPreCat.
  Let hs : has_homsets A := homset_property A.

  (** ** [ShortShortExact] implies isCoequalizer.
    Note that in the definition of [ShortShortExact] we use isEqualizer to say that an image of the
    first morphism is a kernel of the second morphism. We show that also the coimage of the second
    morphism is a cokernel of the first morphism. Informally, this follows directly from the fact
    that the opposite category of an abelian category is an abelian category and that taking the
    opposite category twice, we get the same category. *)

  Local Lemma ShortShortExact_isCokernel_eq1 (SSE : ShortShortExact A) (w0 : A)
        (h : A ⟦Ob2 SSE, w0⟧) (H : Mor1 SSE · h = ZeroArrow (to_Zero A) _ _) :
    (KernelArrow (ShortShortExact_Kernel SSE)) · h = ZeroArrow (to_Zero A) _ _.
  Proof.
    apply (factorization1_is_epi (Mor1 SSE)).
    set (tmp := factorization1 (Mor1 SSE)).
    unfold factorization1_epi in tmp.
    unfold factorization1_monic in tmp.
    cbn in tmp. rewrite assoc. unfold ShortShortExact_Kernel.
    cbn. unfold Image. rewrite <- tmp. clear tmp.
    rewrite ZeroArrow_comp_right.
    exact H.
  Qed.

  Local Lemma ShortShortExact_isCokernel_eq2 (SSE : ShortShortExact A) (w0 : A)
        (h : A ⟦Ob2 SSE, w0⟧) (H : Mor1 SSE · h = ZeroArrow (to_Zero A) _ _) :
    KernelArrow (Abelian.Kernel (Mor2 SSE)) · h = ZeroArrow (to_Zero A) _ _.
  Proof.
    set (i := iso_from_Kernel_to_Kernel (to_Zero A) (ShortShortExact_Kernel SSE)
                                        (Abelian.Kernel (Mor2 SSE))).
    set (epi := is_iso_Epi A i (pr2 i)).
    apply (pr2 epi). cbn. rewrite ZeroArrow_comp_right.
    rewrite assoc. unfold from_Kernel_to_Kernel.
    rewrite KernelCommutes.
    apply (ShortShortExact_isCokernel_eq1 SSE w0 h H).
  Qed.

  Local Lemma ShortShortExact_isCokernel (SSE : ShortShortExact A) :
    isCokernel (to_Zero A) (Mor1 SSE) (CokernelArrow (CoImage SSE)) (CoImage_Eq SSE).
  Proof.
    use make_isCokernel.
    intros w0 h H'.
    use unique_exists.
    (* Construction of the morphism *)
    - exact (CokernelOut
               (to_Zero A) (CoImage SSE) w0 h (ShortShortExact_isCokernel_eq2 SSE w0 h H')).
    (* Commutativity *)
    - apply CokernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T.
      apply CokernelOutsEq.
      rewrite T. apply pathsinv0.
      apply CokernelCommutes.
  Qed.

  Definition ShortShortExact_Cokernel (SSE : ShortShortExact A) :
    Cokernel (to_Zero A) (Mor1 SSE) := make_Cokernel (to_Zero A) (Mor1 SSE) (CokernelArrow (CoImage SSE))
                                               (CoImage_Eq SSE)
                                               (ShortShortExact_isCokernel SSE).

  (** ** From isCokernel to [ShortShortExact]
    We show that we can construct [ShortShortExact] from the isCokernel property proved above. *)

  Local Lemma ShortShortExact_from_isCokernel_eq1 (SSED : ShortShortExactData A (to_Zero A))
        (w : A) (h : A ⟦w, Ob2 SSED⟧)
        (H : (h · (CokernelArrow (Abelian.CoImage (Mor2 SSED)))) = ZeroArrow (to_Zero A) _ _)
        (H' : isCokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED)) :
    h · CokernelArrow (Abelian.Cokernel (Mor1 SSED)) = ZeroArrow (to_Zero A) _ _.
  Proof.
    set (coker := make_Cokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED))
                              (CoImage_Eq SSED) H').
    set (i := iso_from_Cokernel_to_Cokernel (to_Zero A) (Abelian.Cokernel (Mor1 SSED)) coker).
    set (isM := is_iso_Monic A i (pr2 i)). apply (pr2 isM). cbn.
    rewrite ZeroArrow_comp_left. rewrite <- assoc.
    unfold from_Cokernel_to_Cokernel.
    rewrite CokernelCommutes.
    unfold coker. cbn. unfold CoImage.
    exact H.
  Qed.

  Local Lemma ShortShortExact_from_isCokernel_eq2 (SSED : ShortShortExactData A (to_Zero A))
        (w : A) (h : A ⟦w, Ob2 SSED⟧) (H : h · Mor2 SSED = ZeroArrow (to_Zero A) _ _)
        (H' : isCokernel
                (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED)) :
    h · CokernelArrow (Abelian.CoImage (Mor2 SSED)) = ZeroArrow (to_Zero A) _ _.
  Proof.
    apply (factorization2_is_monic (Mor2 SSED)).
    set (tmp := factorization2 (Mor2 SSED)).
    unfold factorization2_epi in tmp.
    unfold factorization2_monic in tmp.
    cbn in tmp. rewrite <- assoc. rewrite <- tmp.
    clear tmp.
    rewrite ZeroArrow_comp_left.
    exact H.
  Qed.

  Lemma ShortShortExact_from_isCokernel_isKernel
        (SSED : ShortShortExactData A (to_Zero A))
        (H : isCokernel
               (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED)) :
    isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED).
  Proof.
    use make_isKernel.
    intros w h H'.
    use unique_exists.
    (* Construction of the morphism *)
    - apply (KernelIn (to_Zero A) (Image SSED) w h
                      (ShortShortExact_from_isCokernel_eq1
                         SSED w h (ShortShortExact_from_isCokernel_eq2 SSED w h H' H) H)).
    (* Commutativity *)
    - apply KernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T.
      apply KernelInsEq.
      rewrite T. apply pathsinv0.
      apply KernelCommutes.
  Qed.

  Definition ShortShortExact_from_isCokernel (SSED : ShortShortExactData A (to_Zero A))
             (H : isCokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED))
                             (CoImage_Eq SSED)) : ShortShortExact A :=
    make_ShortShortExact SSED (ShortShortExact_from_isCokernel_isKernel SSED H).

End shortshortexact_cokernel.
Arguments ShortShortExact_Cokernel [A] _ .
Arguments ShortShortExact_from_isCokernel [A] _ _.

(** * Correspondence of shortexact in A an A^op *)
Section shortexact_opp.

  Local Opaque ZeroArrow isKernel isCokernel.

  Lemma isExact_opp_Eq {A : AbelianPreCat} {x y z : ob A} {f : x --> y}
        {g : y --> z} (H : f · g = ZeroArrow (to_Zero A) _ _) :
    (g : (Abelian_opp A)⟦_, _⟧) · (f : (Abelian_opp A)⟦_, _⟧) =
    @ZeroArrow (Abelian_opp A) (Zero_opp A (to_Zero A)) _ _.
  Proof.
    cbn. use (pathscomp0 H). use ZeroArrow_opp.
  Qed.

  Unset Kernel Term Sharing.
  Lemma isExact_opp {A : AbelianPreCat} {x y z : ob A} {f : x --> y}
             {g : y --> z} {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact A f g H) :
    isExact (Abelian_opp A) g f (isExact_opp_Eq H).
  Proof.
    unfold isExact.
    use isKernel_opp.
    - exact (to_Zero A).
    - exact (isExact'_Eq A f g H).
    - exact (isExact_to_isExact' A iE).
  Qed.
  Set Kernel Term Sharing.

  Definition ShortShortExact_opp {A : AbelianPreCat}
             (SSE : ShortShortExact A) : ShortShortExact (Abelian_opp A).
  Proof.
    use make_ShortShortExact.
    - exact (ShortShortExactData_opp SSE).
    - cbn. use isKernel_opp.
      + exact (to_Zero A).
      + exact (CoImage_Eq SSE).
      + exact (CokernelisCokernel (to_Zero A) (ShortShortExact_Cokernel SSE)).
  Defined.

  Unset Kernel Term Sharing.
  Local Lemma opp_ShortShortExact_isKernel {A : AbelianPreCat}
        (SSE : ShortShortExact (Abelian_opp A)) :
    isKernel (to_Zero A) (KernelArrow (Image (opp_ShortShortExactData SSE)))
             (Mor2 (opp_ShortShortExactData SSE))
             (Image_Eq (opp_ShortShortExactData SSE)).
  Proof.
    cbn. use opp_isKernel.
    - exact (Zero_opp A (to_Zero A)).
    - exact (CoImage_Eq SSE).
    - exact (@CokernelisCokernel
               (Abelian_opp A) (Zero_opp A (to_Zero A)) _ _ _
               (ShortShortExact_Cokernel SSE)).
  Qed.
  Set Kernel Term Sharing.

  Definition opp_ShortShortExact {A : AbelianPreCat}
             (SSE : ShortShortExact (Abelian_opp A)) : ShortShortExact A.
  Proof.
    use make_ShortShortExact.
    - exact (opp_ShortShortExactData SSE).
    - exact (opp_ShortShortExact_isKernel SSE).
  Defined.

  Definition LeftShortExact_opp {A : AbelianPreCat} (LSE : LeftShortExact A) :
    RightShortExact (Abelian_opp A).
  Proof.
    use make_RightShortExact.
    - exact (ShortShortExact_opp LSE).
    - use isMonic_opp. exact (isMonic LSE).
  Defined.

  Definition opp_LeftShortExact {A : AbelianPreCat}
             (LSE : LeftShortExact (Abelian_opp A)) : RightShortExact A.
  Proof.
    use make_RightShortExact.
    - exact (opp_ShortShortExact LSE).
    - use opp_isMonic. exact (isMonic LSE).
  Defined.

  Definition RightShortExact_opp {A : AbelianPreCat}
             (RSE : RightShortExact A) : LeftShortExact (Abelian_opp A).
  Proof.
    use make_LeftShortExact.
    - exact (ShortShortExact_opp RSE).
    - use isEpi_opp. exact (isEpi RSE).
  Defined.

  Definition opp_RightShortExact {A : AbelianPreCat}
             (RSE : RightShortExact (Abelian_opp A)) : LeftShortExact A.
  Proof.
    use make_LeftShortExact.
    - exact (opp_ShortShortExact RSE).
    - use opp_isEpi. exact (isEpi RSE).
  Defined.

  Definition ShortExact_opp {A : AbelianPreCat} (SE : ShortExact A) :
    ShortExact (Abelian_opp A).
  Proof.
    use make_ShortExact.
    - exact (ShortShortExact_opp SE).
    - use isEpi_opp. exact (isEpi SE).
    - use isMonic_opp. exact (isMonic SE).
  Defined.

  Definition opp_ShortExact {A : AbelianPreCat}
             (SE : ShortExact (Abelian_opp A)) : ShortExact A.
  Proof.
    use make_ShortExact.
    - exact (opp_ShortShortExact SE).
    - use opp_isEpi. exact (isEpi SE).
    - use opp_isMonic. exact (isMonic SE).
  Defined.

End shortexact_opp.

(** * [LeftShortExact] and [RightShortExact] from a [ShortShortExact] with extra properties *)
Section shortshortexact_to_leftshortexact.

  Variable A : AbelianPreCat.

  Definition LeftShortExact_from_ShortShortExact (SSE : ShortShortExact A)
             (isK : isKernel
                      (to_Zero A) (Mor1 SSE) (Mor2 SSE) (ShortShortExactData_Eq (to_Zero A) SSE)) :
    LeftShortExact A.
  Proof.
    use make_LeftShortExact.
    - exact SSE.
    - exact (KernelArrowisMonic _ (make_Kernel _ _ _ _ isK)).
  Defined.

  Definition RightShortExact_from_ShortShortExact (SSE : ShortShortExact A)
             (isCK : isCokernel
                       (to_Zero A) (Mor1 SSE) (Mor2 SSE) (ShortShortExactData_Eq (to_Zero A) SSE)) :
    RightShortExact A.
  Proof.
    use make_RightShortExact.
    - exact SSE.
    - exact (CokernelArrowisEpi _ (make_Cokernel _ _ _ _ isCK)).
  Defined.

End shortshortexact_to_leftshortexact.

(** * Correspondence between [ShortShortExact] and [ShortExact]
  In this section we prove correspondence between [ShortShortExact] and
  [ShortExact]. *)
Section shortexact_correspondence.

  Variable A : AbelianPreCat.

  (** ** Construction of [ShortExact] from [ShortShortExact]
    By using the factorization property of morphisms in abelian categories, we show that we can
    construct a [ShortExact] from [ShortShortExact] in a canonical way. More precisely, such
    [ShortExact] is given by taking the first morphism to be the image of the first morphism of the
    [ShortShortExact] and the second morphism to be the coimage of the second morphism of the
    [ShortShortExact]. *)

  Local Lemma ShortExact_from_ShortShortExact_eq (SSE : ShortShortExact A) :
    (KernelArrow (Abelian.Image (Mor1 SSE))) · (CokernelArrow (Abelian.CoImage (Mor2 SSE))) =
    ZeroArrow (to_Zero A) _ _.
  Proof.
    (* Work on mor1 using factorization *)
    apply (factorization1_is_epi (Mor1 SSE)).
    rewrite assoc.
    set (fact := factorization1 (Mor1 SSE)).
    rewrite ZeroArrow_comp_right.
    unfold factorization1_monic in fact. cbn in fact. rewrite <- fact. clear fact.
    (* Work on mor2 using factorization *)
    apply (factorization2_is_monic (Mor2 SSE)).
    rewrite <- assoc.
    set (fact := factorization2 (Mor2 SSE)).
    unfold factorization2_epi in fact. cbn in fact. rewrite <- fact. clear fact.
    rewrite ZeroArrow_comp_left.
    (* Follows now from the Eq *)
    apply (ShortShortExactData_Eq (to_Zero A) SSE).
  Qed.

  Local Lemma ShortExact_ShortShortExact_isKernel_Eq (SSE : ShortShortExact A) (w : A)
             (h : A ⟦w, Ob2 SSE⟧)
             (H' : h · CokernelArrow (Abelian.CoImage (Mor2 SSE)) = ZeroArrow (to_Zero A) _ _) :
    let Im := Abelian.Image (Mor1 SSE) in
    h · (CokernelArrow (Abelian.Cokernel (KernelArrow Im))) = ZeroArrow (to_Zero A) _ _.
  Proof.
    cbn zeta.
    assert (X : h · Mor2 SSE = ZeroArrow (to_Zero A) _ _).
    {
      rewrite (factorization2 (Mor2 SSE)).
      unfold factorization2_epi. cbn.
      set (tmp := factorization2_monic A (Mor2 SSE)).
      apply (maponpaths (λ h' : _, h' · tmp)) in H'. unfold tmp in H'.
      clear tmp. rewrite ZeroArrow_comp_left in H'. rewrite <- assoc in H'.
      unfold factorization2_monic in H'. cbn in H'.
      exact H'.
    }
    set (comm1 := KernelCommutes (to_Zero A) (Abelian.Kernel (Mor2 SSE)) w h X).
    set (ker := ShortShortExact_Kernel SSE).
    set (tmp := Abelian.Kernel (Mor2 SSE)).
    set (tmp_eq := (KernelCompZero (to_Zero A) tmp)).
    set (comm2 := KernelCommutes (to_Zero A) ker tmp (KernelArrow tmp) tmp_eq).
    unfold tmp in comm2. rewrite <- comm2 in comm1. clear comm2.
    rewrite <- comm1. rewrite <- assoc. rewrite <- assoc.
    rewrite CokernelCompZero. rewrite ZeroArrow_comp_right.
    rewrite ZeroArrow_comp_right. apply idpath.
  Qed.

  Local Lemma ShortExact_ShortShortExact_isKernel (SSE : ShortShortExact A) :
    let Im := Abelian.Image (Mor1 SSE) in
    let CoIm := Abelian.CoImage (Mor2 SSE) in
    let MP := make_MorphismPair (KernelArrow Im) (CokernelArrow CoIm) in
    let SSED := make_ShortShortExactData (to_Zero A) MP (ShortExact_from_ShortShortExact_eq SSE) in
    isKernel (to_Zero A) (KernelArrow (Image SSED)) (CokernelArrow CoIm) (Image_Eq SSED).
  Proof.
    intros Im CoIm MP SSED.
    use make_isKernel.
    intros w h H'.
    use unique_exists.
    (* Construction of the morphism *)
    - use KernelIn.
      + exact h.
      + apply (ShortExact_ShortShortExact_isKernel_Eq SSE w h H').
    (* Commutativity *)
    - apply KernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply homset_property.
    (* Uniqueness *)
    - intros y T. cbn in T. apply KernelInsEq.
      use (pathscomp0 T). apply pathsinv0.
      apply KernelCommutes.
  Qed.

  Definition ShortExact_from_ShortShortExact (SSE : ShortShortExact A) : ShortExact A.
  Proof.
    use make_ShortExact.
    - use make_ShortShortExact.
      + use make_ShortShortExactData.
        * use make_MorphismPair.
          -- exact (Abelian.Image (Mor1 SSE)).
          -- exact (Ob2 SSE).
          -- exact (Abelian.CoImage (Mor2 SSE)).
          -- exact (KernelArrow (Abelian.Image (Mor1 SSE))).
          -- exact (CokernelArrow (Abelian.CoImage (Mor2 SSE))).
        * exact (ShortExact_from_ShortShortExact_eq SSE).
      + exact (ShortExact_ShortShortExact_isKernel SSE).
    - exact (KernelArrowisMonic (to_Zero A) _).
    - exact (CokernelArrowisEpi (to_Zero A) _).
  Defined.

  (** ** [ShortShortExact] from data of [ShortExact]
    We construct a [ShortShortExact] from data corresponding to [ShortExact]. For a more precise
    statement, see the comment above [ShortShortExact_from_isShortExact]. *)

  Local Lemma ShortShortExact_from_isSortExact_eq {a b c : A} (f : a --> b) (g : b --> c)
             (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g))
                  = ZeroArrow (to_Zero A) _ _)
             (isEq : isKernel (to_Zero A) (KernelArrow (Abelian.Image f))
                              (CokernelArrow (Abelian.CoImage g)) H) :
    f · g = ZeroArrow (to_Zero A) _ _.
  Proof.
    set (tmp := maponpaths (λ h : _, CokernelArrow (Abelian.CoImage f) · (CoIm_to_Im f) · h) H).
    cbn in tmp. rewrite ZeroArrow_comp_right in tmp.
    apply (maponpaths (λ h : _, h · (CoIm_to_Im g) · ((KernelArrow (Abelian.Image g))))) in tmp.
    rewrite ZeroArrow_comp_left in tmp.
    rewrite assoc in tmp.
    (* Work on f in tmp *)
    set (fact := factorization2 f).
    unfold factorization2_epi in fact. cbn in fact.
    rewrite assoc in fact. rewrite <- fact in tmp. clear fact.
    (* Work of g in tmp *)
    set (fact := factorization1 g).
    unfold factorization2_monic in fact. cbn in fact.
    rewrite <- assoc in tmp. rewrite <- assoc in tmp. rewrite <- assoc in fact.
    rewrite <- fact in tmp. clear fact.
    (* Follows from tmp *)
    rewrite ZeroArrow_comp_left in tmp. exact tmp.
  Qed.

  Local Lemma ShortShortExact_from_isShortExact_isKernel_eq {a b c : A} (f : a --> b) (g : b --> c)
        (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g)) =
             ZeroArrow (to_Zero A) _ _)
        (isEq : isKernel (to_Zero A) (KernelArrow (Abelian.Image f))
                         (CokernelArrow (Abelian.CoImage g)) H)
        (w : A) (h : A ⟦w, b⟧) (H' : h · g = ZeroArrow (to_Zero A) w c) :
    h · CokernelArrow (Abelian.Cokernel f) = ZeroArrow (to_Zero A) w (Abelian.Cokernel f).
  Proof.
    set (ker := make_Kernel (to_Zero A) (KernelArrow (Abelian.Image f))
                          (CokernelArrow (Abelian.CoImage g)) H isEq).
    (* Rewrite g in H' *)
    set (fact := factorization2 g).
    unfold factorization2_epi in fact. cbn in fact.
    rewrite fact in H'. clear fact.
    (* Use commutativity of ker *)
    rewrite assoc in H'.
    assert (X : h · CokernelArrow (Abelian.CoImage g) = ZeroArrow (to_Zero A) _ _).
    {
      apply (factorization2_is_monic g).
      rewrite ZeroArrow_comp_left.
      apply H'.
    }
    set (comm1 := KernelCommutes (to_Zero A) ker w h X).
    unfold ker in comm1. cbn in comm1. rewrite <- comm1. clear comm1.
    (* Follows from KernelCompZero *)
    unfold Image. rewrite <- assoc.
    rewrite KernelCompZero. apply ZeroArrow_comp_right.
  Qed.

  Local Lemma ShortShortExact_from_isShortExact_isKernel {a b c : A} (f : a --> b) (g : b --> c)
        (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g)) =
             ZeroArrow (to_Zero A) _ _)
        (isK : isKernel (to_Zero A) (KernelArrow (Abelian.Image f))
                        (CokernelArrow (Abelian.CoImage g)) H) :
    let SSED := make_ShortShortExactData (to_Zero A) (make_MorphismPair f g)
                                       (ShortShortExact_from_isSortExact_eq f g H isK) in
    isKernel (to_Zero A) (KernelArrow (Image SSED)) g (Image_Eq SSED).
  Proof.
    intros SSED.
    use make_isKernel.
    intros w h H'.
    use unique_exists.
    (* Construction of the arrow *)
    - use KernelIn.
      + exact h.
      + exact (ShortShortExact_from_isShortExact_isKernel_eq f g H isK w h H').
    (* Comutativity *)
    - apply KernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply homset_property.
    (* Uniqueness *)
    - intros y T. apply KernelInsEq.
      rewrite T. apply pathsinv0.
      apply KernelCommutes.
  Qed.

  (** To see how the assumptions correspond to [ShortExact] note that every kernel is a monic and
     every cokernel is an epi. Also, the assumption H says that an image of f is the kernel of a
     coimage of g. In abelian categories every monic is the kernel of its cokernel, and thus one
     can show that in isE the kernelarrow can be "replaced" by the kernelarrow of the image of the
     kernelarrow. Thus the assumptions are similar to assumptions of [ShortExact]. *)
  Definition ShortShortExact_from_isShortExact {a b c : A} (f : a --> b) (g : b --> c)
             (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g)) =
                  ZeroArrow (to_Zero A) _ _)
             (isEq : isKernel (to_Zero A) (KernelArrow (Abelian.Image f))
                              (CokernelArrow (Abelian.CoImage g)) H) :
    ShortShortExact A.
  Proof.
    use make_ShortShortExact.
    - use make_ShortShortExactData.
      + use make_MorphismPair.
        * exact a.
        * exact b.
        * exact c.
        * exact f.
        * exact g.
      + exact (ShortShortExact_from_isSortExact_eq f g H isEq).
    - exact (ShortShortExact_from_isShortExact_isKernel f g H isEq).
  Defined.

End shortexact_correspondence.
Arguments ShortExact_from_ShortShortExact [A] _ .
Arguments ShortShortExact_from_isShortExact [A] _ _ _ _ _ _ _ .

(** * [ShortShortExact] from isKernel and isCokernel *)
(** ** Introduction
In this section we construct [ShortShortExact] from a pair of morphisms where the first morphism is
the kernel of the second morphisms and where the second morphism is the cokernel of the first
morphism.
 *)
Section shortshortexact_iskernel_iscokernel.

  Variable A : AbelianPreCat.

  Lemma make_ShortShortExact_isKernel_isKernel (SSED : ShortShortExactData A (to_Zero A))
        (H : isKernel
               (to_Zero A) (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)) :
    isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED).
  Proof.
    set (K := make_Kernel _ _ _ _ H).
    set (e1 := factorization1 (Mor1 SSED)). cbn in e1. unfold Image.
    assert (e : is_z_isomorphism (CokernelArrow (Abelian.CoImage (Mor1 SSED))
                                                · CoIm_to_Im (Mor1 SSED))).
    {
      use monic_epi_is_iso.
      - use isMonic_postcomp.
        + exact (Ob2 SSED).
        + exact (KernelArrow (Abelian.Image (Mor1 SSED))).
        + rewrite <- e1. use (KernelArrowisMonic (to_Zero A) K).
      - exact (factorization1_is_epi (Mor1 SSED)).
    }
    use Kernel_up_to_iso_isKernel.
    + exact K.
    + exact (z_iso_inv (make_z_iso _ _ e)).
    + apply (maponpaths (λ g : _, (inv_from_z_iso (make_z_iso _ _ e)) · g)) in e1.
      use (pathscomp0 _ (! e1)). clear e1. rewrite assoc.
      cbn. rewrite (is_inverse_in_precat2 e). rewrite id_left. apply idpath.
  Qed.

  Definition make_ShortShortExact_isKernel (SSED : ShortShortExactData A (to_Zero A))
             (H : isKernel (to_Zero A) (Mor1 SSED) (Mor2 SSED)
                           (ShortShortExactData_Eq (to_Zero A) SSED)) :
    ShortShortExact A.
  Proof.
    use make_ShortShortExact.
    - exact SSED.
    - exact (make_ShortShortExact_isKernel_isKernel SSED H).
  Defined.

  Lemma make_ShortShortExact_isCokernel_isKernel (SSED : ShortShortExactData A (to_Zero A))
        (H : isCokernel
               (to_Zero A) (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)) :
    isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED).
  Proof.
    use ShortShortExact_from_isCokernel_isKernel.
    set (CK := make_Cokernel _ _ _ _ H).
    set (e1 := factorization2 (Mor2 SSED)). cbn in e1. unfold CoImage.
    assert (e : is_z_isomorphism (CoIm_to_Im (Mor2 SSED)
                                             · KernelArrow (Abelian.Image (Mor2 SSED)))).
    {
      use monic_epi_is_iso.
      - exact (factorization2_is_monic (Mor2 SSED)).
      - use isEpi_precomp.
        + exact (Ob2 SSED).
        + exact (CokernelArrow (Abelian.CoImage (Mor2 SSED))).
        + rewrite <- e1. use (CokernelArrowisEpi (to_Zero A) CK).
    }
    use Cokernel_up_to_iso_isCokernel.
    + exact CK.
    + exact (z_iso_inv (make_z_iso _ _ e)).
    + apply (maponpaths (λ g : _, g · (inv_from_z_iso (make_z_iso _ _ e)))) in e1.
      use (pathscomp0 _ (! e1)). clear e1. rewrite <- assoc. cbn.
      rewrite (is_inverse_in_precat1 e). rewrite id_right. apply idpath.
  Qed.

  Definition make_ShortShortExact_isCokernel (SSED : ShortShortExactData A (to_Zero A))
             (H : isCokernel (to_Zero A) (Mor1 SSED) (Mor2 SSED)
                             (ShortShortExactData_Eq (to_Zero A) SSED)) :
    ShortShortExact A.
  Proof.
    use make_ShortShortExact.
    - exact SSED.
    - exact (make_ShortShortExact_isCokernel_isKernel SSED H).
  Defined.

End shortshortexact_iskernel_iscokernel.

(** * [LeftShortExact] (resp. [RightShortExact]) construction for derived functors *)
(** ** Introduction
Let f : A --> B and g : A --> C be morphisms. In this section we construct a right short exact
sequence of the form
                     A --(f · i_1 - g · i_2)--> B ⊕ C --> W --> 0
where B ⊕ C --> W is the coequalizer of f · i_1 and g · i_2. Similarly for left short exact
sequences and equalizers.
 *)
Section left_right_shortexact_and_pullbacks_pushouts.

  Variable A : AbelianPreCat.

  Local Opaque Abelian.Equalizer.
  Local Opaque Abelian.Coequalizer.
  Local Opaque to_BinDirectSums.
  Local Opaque to_binop to_inv.

  (** ** [LeftShortExact] containing an equalizer *)

  Definition LeftShortExact_Equalizer_ShortShortExactData {x1 x2 y : ob A} (f : x1 --> y)
             (g : x2 --> y) : ShortShortExactData A (to_Zero A).
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) x1 x2).
    set (E := Abelian.Equalizer A (to_Pr1 DS · f) (to_Pr2 DS · g)).
    set (PA := (AbelianToAdditive A) : PreAdditive).
    use make_ShortShortExactData.
    - use make_MorphismPair.
      + exact E.
      + exact DS.
      + exact y.
      + exact (EqualizerArrow E).
      + use (@to_binop PA).
        * exact (to_Pr1 DS · f).
        * exact (@to_inv PA _ _ (to_Pr2 DS · g)).
    - cbn. exact (AdditiveEqualizerToKernel_eq1 (AbelianToAdditive A) _ _ E).
  Defined.

  Definition LeftShortExact_Equalizer_ShortShortExact {x1 x2 y : ob A} (f : x1 --> y)
             (g : x2 --> y) : ShortShortExact A.
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) x1 x2).
    set (E := Abelian.Equalizer A (to_Pr1 DS · f) (to_Pr2 DS · g)).
    use make_ShortShortExact.
    - exact (LeftShortExact_Equalizer_ShortShortExactData f g).
    - cbn. cbn in E. fold DS. fold E.
      use make_ShortShortExact_isKernel_isKernel.
      exact (AdditiveEqualizerToKernel_isKernel (AbelianToAdditive A) _ _ E).
  Defined.

  Definition LeftShortExact_Equalizer {x1 x2 y : ob A} (f : x1 --> y) (g : x2 --> y) :
    LeftShortExact A.
  Proof.
    use make_LeftShortExact.
    - exact (LeftShortExact_Equalizer_ShortShortExact f g).
    - use EqualizerArrowisMonic.
  Defined.

  (** ** [RightShortExact] containing a coequalizer *)

  Definition RightShortExact_Coequalizer_ShortShortExactData {x y1 y2 : ob A} (f : x --> y1)
             (g : x --> y2) : ShortShortExactData A (to_Zero A).
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) y1 y2).
    set (CE := Abelian.Coequalizer A (f · to_In1 DS) (g · to_In2 DS)).
    set (PA := (AbelianToAdditive A) : PreAdditive).
    use make_ShortShortExactData.
    - use make_MorphismPair.
      + exact x.
      + exact DS.
      + exact CE.
      + use (@to_binop PA).
        * exact (f · to_In1 DS).
        * exact (@to_inv PA _ _ (g · to_In2 DS)).
      + exact (CoequalizerArrow CE).
    - cbn. exact (AdditiveCoequalizerToCokernel_eq1 (AbelianToAdditive A) _ _ CE).
  Defined.

  Definition RightShortExact_Coequalizer_ShortShortExact {x y1 y2 : ob A} (f : x --> y1)
             (g : x --> y2) : ShortShortExact A.
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) y1 y2).
    set (CE := Abelian.Coequalizer A (f · to_In1 DS) (g · to_In2 DS)).
    use make_ShortShortExact.
    - exact (RightShortExact_Coequalizer_ShortShortExactData f g).
    - cbn. cbn in CE. fold DS. fold CE.
      use make_ShortShortExact_isCokernel_isKernel.
      exact (AdditiveCoequalizerToCokernel_isCokernel (AbelianToAdditive A) _ _ CE).
  Defined.

  Definition RightShortExact_Coequalizer {x y1 y2 : ob A} (f : x --> y1) (g : x --> y2) :
    RightShortExact A.
  Proof.
    use make_RightShortExact.
    - exact (RightShortExact_Coequalizer_ShortShortExact f g).
    - use CoequalizerArrowisEpi.
  Defined.

End left_right_shortexact_and_pullbacks_pushouts.