(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural := Succ y.


From Coq Require Import List Arith.
Open Scope nat_scope.

(* Universidade de Brasília
    Instituto de Ciências Exatas
    Departamento de Ciência da Computação
    Projeto e Análise de Algoritmos - turma B - 2020/2
    Professor: Flávio L. C. de Moura *)

(*
  Nome: Lucas Dalle Rocha
  Matrícula: 17/0016641
  Nome: Matheus Breder Branquinho
  Matrícula: 17/0018997
*)

(** * A correção do algoritmo mergesort *)

(** O algoritmo mergesort é um algoritmo de ordenação que utiliza a técnica de divisão e conquista, que consiste das seguintes etapas:
%\begin{enumerate}
   \item {\bf Divisão}: O algoritmo divide a lista $l$ recebida como argumento ao meio, obtendo as listas $l_1$ e $l_2$.
   \item {\bf Conquista}: O algoritmo é aplicado recursivamente às listas $l_1$ e $l_2$ gerando, respectivamente, as listas ordenadas $l_1'$ e $l_2'$.
   \item {\bf Combinação}: O algoritmo combina as listas $l_1'$ e $l_2'$ através da função merge que então gera a saída do algoritmo.
 \end{enumerate}%
Por exemplo, ao receber a lista (4 :: 2 :: 1 :: 3 :: nil), este algoritmo inicialmente divide esta lista em duas sublistas, a saber (4 :: 2 :: nil) e (1 :: 3 :: nil). O algoritmo é aplicado recursivamente às duas sublistas para ordená-las, e ao final deste processo, teremos duas listas ordenadas (2 :: 4 :: nil) e (1 :: 3 :: nil). Estas listas são, então, combinadas para gerar a lista de saída (1 :: 2 :: 3 :: 4 :: nil). *)

(** * Descrição do projeto *)

(** A prova da correção de um algoritmo de ordenação consiste de duas etapas. Inicialmente, provaremos que o algoritmo efetivamente ordena os elementos da lista dada como argumento, e em seguida mostraremos que a lista de saída é uma permutação da lista de entrada. Neste projeto trabalharemos com listas de números naturais. *)

(* begin hide *)
Require Import Arith List Recdef.
Require Import Coq.Program.Wf.
Require Import Permutation.
(* end hide *)

(** ** Primeira parte: *)

(** Nesta primeira etapa do projeto, apresentaremos as definições e lemas relacionados à noção de ordenação de listas de números naturais. Para isto, precisamos inicialmente definir formalmente o que entendemos por "lista ordenada". O predicado [sorted] a seguir consiste na definição formal de ordenação que utilizaremos neste projeto. Note que este predicado é definido indutivamente e que possui três construtores, ou três regras como veremos a seguir: *)

Inductive sorted :list nat -> Prop :=
  | nil_sorted : sorted nil
  | one_sorted: forall n:nat, sorted (n :: nil)
  | all_sorted : forall (x y: nat) (l:list nat), sorted (y :: l) -> x <= y -> sorted (x :: y :: l).

(** O predicado [sorted] possui três construtores, a saber [nil_sorted], [one_sorted] and [all_sorted]. Os dois primeiros construtores são axiomas que afirmam que a lista vazia e que listas unitárias estão ordenadas:
 %\begin{mathpar} \inferrule*[Right={$(nil\_sorted)$}]{~}{sorted\ nil} \and
  \inferrule*[Right={$(one\_sorted)$}]{~}{\forall n, sorted (n :: nil)} \end{mathpar}%
O terceiro construtor, i.e. [all_sorted] estabelece as condições para que uma lista com pelo menos dois elementos esteja ordenada. Assim, quaisquer que sejam os elementos $x$ e $y$, e a lista $l$, temos:
%\begin{mathpar} \inferrule*[Right={$(all\_sorted)$}]{sorted (y :: l) \and x \leq y}{sorted (x :: y :: l)}\end{mathpar}%
Ou seja, para provarmos que a lista $x :: y :: l$ está ordenada, precisamos provar que $x \leq y$ e que a lista $y :: l$ também está ordenada.
 *)

(** Agora que temos um definição formal da noção de ordenação, vamos explorar algumas noções auxiliares que serão utilizadas na formalização. A primeira delas é o predicado [le_all] que recebe um natural [x] e uma lista [l] como argumentos, e a fórmula [le_all x l] possui uma prova quando [x] é menor ou igual a todos os elementos de [l]. *)

Definition le_all x l := forall y, In y l -> x <= y.

(** printing <=* $\leq *$ *)
(** Escreveremos  [x <=* l] ao invés de [le_all x l]. *)
(* begin hide *)
Infix "<=*" := le_all (at level 70, no associativity).
(* end hide *)

(** Lemas são resultados auxiliares que podem ser usados em outras provas. É importante se lembrar dos lemas que ficaram para trás porque eles podem ser úteis em diversas provas. O primeiro lema auxiliar que veremos afirma que se a lista (a :: l) está ordenada então a sua cauda (tail) também está ordenada. A prova é feita por análise de casos. *)

Lemma tail_sorted: forall l a, sorted (a :: l) -> sorted l.
(* begin hide *)
Proof.
  intro l.
  case l.
  - intros a H.
    apply nil_sorted.
  - intros n l' a H.
    inversion H; subst.
    assumption.
Qed.

(** OBS: Seguem alguns exemplos de busca de teoremas com o comando [Search]: *)
(** Search (_ > _ -> _ <= _). *)
(** Search (~ _ <= _ -> _). *)
(** Search "lt_sub_lt_add". *)
(** Search ( ( _ / _) < _). *)
(** Search ( ( _ / _) <= _). *)
(** Search (0 < ( _ / _) ).*)
(** Search (1 < 2). *)
(** Search (0 < 2). *)
(** Search ( _ - _ < _). *)
(** Search (S _ + _ = S _).*)
(* end hide *)

(** *** Questão 1: *)
(** A primeira questão consiste em provar que se [a] é menor ou igual a todo elemento de [l], e [l] é uma lista ordenada então a lista (a :: l) também está ordenada: *)

Lemma le_all_sorted: forall l a, a <=* l -> sorted l -> sorted (a :: l).
Proof.
  intros l a H H0.
  induction l.
  - apply one_sorted.
  - apply all_sorted.
    + exact H0.
    + destruct H with (y := a0).
      * simpl.
        left.
        apply eq_refl.
      * apply Nat.le_refl.
      * apply le_S.
        exact l0.
Qed.

(** O lema a seguir é bem parecido com o lema [tail_sorted] visto anteriormente, mas ao invés de remover o primeiro elemento de uma lista ordenada, este lema remove o segundo elemento de uma lista ordenada (com pelo menos dois elementos), e após esta remoção a lista resultante ainda está ordenada. Veja que a prova é por análise de casos. *)

Lemma remove_sorted: forall l a1 a2, sorted (a1 :: a2 :: l) -> sorted (a1 :: l).
(* begin hide *)
Proof.
  intro l; case l.
  - intros a1 a2 H.
    apply one_sorted.
  - intros n l' a1 a2 H.
    inversion H; subst.
    inversion H2; subst.
    apply all_sorted.
    + assumption.
    + apply Nat.le_trans with a2; assumption.
Qed.
(* end hide *)

(** *** Questão 2 *)
(** A segunda questão consiste em provar que, se a lista [(a :: l)] está ordenada então [a] é menor ou igual a todo elemento de [l]. A dica é fazer indução na estrutura da lista [l]. *)

Lemma sorted_le_all: forall l a, sorted(a :: l) -> a <=* l.
Proof.
  induction l.
  - intros a H y H0.
    destruct H0.
  - intros a0 H y H0.
    destruct H0.
    + inversion H; subst.
      exact H5.
    + apply remove_sorted in H.
      apply IHl in H.
      unfold "<=*" in H.
      apply H in H0.
      exact H0.
Qed.

(** ** Segunda parte: *)
(** Agora definiremos a noção de permutação e apresentaremos alguns lemas relacionados. A noção de permutação que será utilizada neste projeto é baseada no número de ocorrências de um elemento. A função recursiva [num_oc n l] retorna o número de ocorrências do natural [n] na lista [l]. A palavra reservada [Fixpoint] é usada para definir funções recursivas, enquanto que [Definition] é usada para funções não-recursivas como foi o caso do predicado [le_all] visto anteriormente. *)

Fixpoint num_oc n l  :=
  match l with
    | nil => 0
    | h :: tl =>
      if n =? h then S(num_oc n tl) else  num_oc n tl
  end.

(** Dizemos então que duas listas [l] e [l'] são permutações uma da outra se qualquer natural [n] possui o mesmo número de ocorrências em ambas as listas. *)

Definition perm l l' := forall n:nat, num_oc n l = num_oc n l'.

(** A reflexividade é uma propriedade que pode ser obtida a partir desta definição: uma lista é sempre permutação dela mesma. *)

Lemma perm_refl: forall l, perm l l.
(* begin hide *)
Proof.
intro l. unfold perm. intro. reflexivity.
Qed.
(* end hide *)

(** O lema a seguir é um resultado técnico, mas que pode ser utilizado em provas futuras. Ele diz que o número de ocorrências de um natural [n] no append das listas [l1] e [l2] (notação [l1 ++ l2]) é igual à soma das ocorrências de [n] em [l1] com as ocorrências de [n] em [l2]: *)

Lemma num_oc_append: forall n l1 l2, num_oc n l1 + num_oc n l2 = num_oc n (l1 ++ l2).
(* begin hide *)
Proof.
  intros. induction l1.
  - simpl num_oc. trivial.
  - simpl. destruct (n =? a).
    + rewrite <- IHl1. apply Peano.plus_Sn_m.
    + assumption.
Qed.
(* end hide *)

(** *** Terceira parte: *)
(** Nesta parte definiremos o algoritmo mergesort. Iniciaremos pela função [merge] que faz a etapa de combinação descrita anteriormente. A função [merge] recebe como argumento um par de listas de naturais ordenadas e gera uma nova lista ordenada contendo exatamente os elementos das duas listas recebidas como argumento. Iniciamos então com a definição do predicado [sorted_pair_lst] que recebe um par de listas e retorna a conjunção expressando o fato de que cada lista que compõe o par está ordenada: *)

Definition sorted_pair_lst (p: list nat * list nat) :=
sorted (fst p) /\ sorted (snd p).

(** Agora necessitamos de uma métrica para definirmos a função [merge]. Esta métrica consiste no tamanho do par que contém duas listas e é definido como sendo a soma do comprimento de cada uma das listas: *)

Definition len (p: list nat * list nat) :=
   length (fst p) + length (snd p).

(** Agora podemos definir a função recursiva [merge]. Dado um par [p] de listas de naturais, se alguma das listas que compõem este par é a lista vazia então a função simplesmente retorna o outro elemento do par. Quando ambas as listas que compõem o par são não-vazias então os primeiros elementos de cada lista são comparados e o menor deles será o colocado na lista final, e o processo se repete recursivamente para o par sem este menor elemento. Para garantirmos que esta função está bem definida, precisamos que as chamadas recursivas se aproximem do ponto de parada (chamadas sem recursão) que ocorre quando alguma das listas do par é a lista vazia. Esta garantia é dada pelo medida (ou métrica) definida anteriormente: o comprimento do par que [merge] recebe como argumento: *)
(* printing *)
(** printing <=? $\leq ?$ *)

Function merge (p: list nat * list nat) {measure len p} :=
match p with
  | (nil, l2) => l2
  | (l1, nil) => l1
  | ((hd1 :: tl1) as l1, (hd2 :: tl2) as l2) =>
if hd1 <=? hd2 then hd1 :: merge (tl1, l2)
      else hd2 :: merge (l1, tl2)
   end.

(** A palavra reservada [Function] é utilizada para definir funções recursivas mais sofisticadas, ou seja, para funções recursivas cuja boa definição não pode ser inferida automaticamente pelo Coq. Neste caso, precisamos provar que nossa medida realmente decresce nas chamadas recursivas. *)
(* begin hide *)
Proof.
  - intros. unfold len. unfold fst. unfold snd. simpl length.
    apply plus_lt_compat_r. auto.
  - intros. unfold len. unfold fst. unfold snd. simpl length.
    apply plus_lt_compat_l. auto.
Qed.
(* end hide *)

(** O lema [merge_in] a seguir será bastante útil em provas futuras. Ele estabelece que se [y] é um elemento da lista [merge p] então [y] está em alguma das listas que compõem o par [p]. *)

Lemma merge_in: forall y p, In y (merge p) -> In y (fst p) \/ In y (snd p).
(* begin hide *)
Proof.
intros. functional induction (merge p).
  - right. unfold snd. assumption.
    - left. unfold fst. assumption.
    - simpl in H. destruct H as [H1 | H2].
    + left. unfold fst. unfold In. left. assumption.
        + destruct IHl.
        * assumption.
          * left. unfold fst. unfold fst in H. simpl In. right. assumption.
          * right. simpl. simpl in H. assumption.
    - simpl in H. destruct H as [H1 | H2].
    + right. simpl snd. simpl In. left. assumption.
        + destruct IHl.
        * assumption.
          * left. unfold fst. unfold fst in H. assumption.
          * right. simpl. simpl in H. right. assumption.
Qed.
(* end hide *)

(** *** Questão 3 *)
(** Esta questão é a mais importante do projeto. Ela estabelece que se as listas que compõem o par [p] estão ordenadas então [merge p] também está ordenada. Como [merge] é uma função recursiva mais sofisticada, as propriedades envolvendo esta função também terão provas mais complexas. Como você pode ver, esta prova é composta de quatro casos, dos quais dois estão provados, e dois fazem parte do exercício. Cada caso deixado como exercício é semelhante ao caso anterior, então use estas subprovas que estão feitas como ideias para completar a prova deste teorema. Os lemas anteriores também podem ser úteis! *)

Theorem merge_sorts: forall p, sorted_pair_lst p -> sorted (merge p).
(* begin hide *)
Proof.
  intro p. functional induction (merge p).
  - unfold sorted_pair_lst. intro. destruct H.
    unfold snd in H0. assumption.
  - unfold sorted_pair_lst. intro. destruct H.
    unfold fst in H. assumption.
  - intro. apply le_all_sorted.
    + unfold le_all. intro. intro. apply merge_in in H0.
      destruct H0 as [H1 | H2].
      * simpl fst in H1. unfold sorted_pair_lst in H. destruct H as [H2 H3].
        simpl fst in H2. apply sorted_le_all in H2. unfold le_all in H2.
        apply H2. assumption.
      * simpl snd in H2. apply Nat.le_trans with hd2.
        -- apply Nat.leb_le. assumption.
        -- unfold sorted_pair_lst in H. destruct H as [H3 H4]. simpl snd in H4.
           apply sorted_le_all in H4. simpl In in H2. destruct H2 as [H5 | H6].
           ** rewrite H5. trivial.
           ** unfold le_all in H4. apply H4. assumption.
    + apply IHl. unfold sorted_pair_lst. split.
      * simpl fst. unfold sorted_pair_lst in H. destruct H as [H1 H2].
        simpl fst in H1. apply tail_sorted in H1. assumption.
      * simpl snd. unfold sorted_pair_lst in H. destruct H as [H1 H2].
        simpl snd in H2. assumption.
  - intro. apply le_all_sorted.
    + unfold le_all. intro. intro. apply merge_in in H0.
      destruct H0 as [H1 | H2].
      * simpl fst in H1. unfold sorted_pair_lst in H. destruct H as [H2 H3].
        simpl fst in H2. apply sorted_le_all in H2. unfold le_all in H2.
        simpl in H1. destruct H1 as [H4 | H5].
        ** rewrite <- H4. apply leb_complete_conv in e0. apply Nat.lt_le_incl in e0. assumption.
        ** apply H2 in H5. apply leb_complete_conv in e0. apply Nat.lt_le_incl in e0. rewrite <- H5. assumption.
      * simpl snd in H2. apply Nat.le_trans with hd2.
        -- trivial.
        -- unfold sorted_pair_lst in H. destruct H as [H3 H4]. simpl snd in H4.
           apply sorted_le_all in H4. unfold le_all in H4. apply H4 in H2. assumption.
    + apply IHl. unfold sorted_pair_lst. split.
      * simpl fst. unfold sorted_pair_lst in H. destruct H as [H1 H2].
        simpl fst in H1. assumption.
      * simpl snd. unfold sorted_pair_lst in H. destruct H as [H1 H2].
        simpl snd in H2. apply tail_sorted in H2. assumption.
Qed.

(* end hide *)

(** Agora vamos definir a função [mergesort] que recebe uma lista [l] como argumento. Se esta lista for vazia ou unitária, o algoritmo não faz nada. Caso contrário, a lista é dividida ao meio, cada sublista é ordenada recursivamente, e no final as sublistas ordenadas são fundidas com a função [merge]. *)

Function mergesort (l: list nat) {measure length l}:=
  match l with
  | nil => nil
  | hd :: nil => l
  | hd :: tail =>
     let n := length(l) / 2 in
     let l1 := firstn n l in
     let l2 := skipn n l in
     let sorted_l1 := mergesort(l1) in
     let sorted_l2 := mergesort(l2) in
     merge (sorted_l1, sorted_l2)
  end.

(** Analogamente à definição da função [merge], precisamos provar que [mergesort] está bem definida. *)
(* begin hide *)
Proof.
- intros. rewrite skipn_length. apply Nat.sub_lt.
  + apply Nat.lt_le_incl. apply Nat.div_lt.
    * simpl. apply Nat.lt_0_succ.
      * apply Nat.lt_1_2.
    + apply Nat.div_str_pos. simpl. split.
    * apply Nat.lt_0_2.
      * apply Peano.le_n_S. apply Peano.le_n_S. apply Peano.le_0_n.
  - intros. rewrite firstn_length. rewrite min_l.
  + apply Nat.div_lt.
    * simpl. apply Nat.lt_0_succ.
      * apply Nat.lt_1_2.
    + apply Nat.lt_le_incl. apply Nat.div_lt.
    * simpl. apply Nat.lt_0_succ.
      * apply Nat.lt_1_2.
Defined.
(* end hide *)

(** *** Questão 4 *)
(** Agora prove que a função [mergesort] realmente ordena a lista recebida como argumento. *)

Theorem mergesort_sorts: forall l, sorted (mergesort l).
Proof.
  induction l.
  - apply nil_sorted.
  - functional induction (mergesort (a :: l)).
    + apply nil_sorted.
    + apply one_sorted.
    + apply merge_sorts.
      unfold sorted_pair_lst.
      split.
      * unfold fst.
        assumption.
      * unfold snd.
        assumption.
Qed.

(** O lema a seguir é um lema técnico que pode ser usado nas questões seguintes. Este lema estabelece que o número de ocorrências de um elemento [n] no par de listas [p] é igual à soma das ocorrências de [n] em cada lista do par. *)

Lemma merge_num_oc: forall n p, num_oc n (merge p) = num_oc n (fst p) + num_oc n (snd p).
(* begin hide *)
Proof.
intros. functional induction (merge p).
  - simpl fst. simpl snd. simpl num_oc. trivial.
  - simpl fst. simpl snd. simpl num_oc. trivial.
  - simpl fst. simpl snd. simpl num_oc at 1 2. destruct (n =? hd1).
    + rewrite IHl. apply Peano.plus_Sn_m.
    + rewrite IHl. simpl fst. simpl snd. trivial.
  - simpl fst. simpl snd. simpl num_oc at 1 3. (destruct (n =? hd2)).
      + rewrite IHl. simpl fst. simpl snd. apply Peano.plus_n_Sm.
      + rewrite IHl. simpl fst. simpl snd. trivial.
Qed.
(* end hide *)

(** *** Questão 5 *)
(** Prove que [mergesort] gera uma permutação da lista recebida como argumento. *)

Theorem mergesort_is_perm: forall l, perm l (mergesort l).
Proof.
  intros. functional induction (mergesort l).
  - apply perm_refl.
  - apply perm_refl.
  - unfold perm. intros. rewrite merge_num_oc.
    unfold fst. unfold snd.
    replace (num_oc n (mergesort (firstn (length (hd :: tail) / 2) (hd :: tail)))) with (num_oc n (firstn (length (hd :: tail) / 2) (hd :: tail))).
    replace (num_oc n (mergesort (skipn (length (hd :: tail) / 2) (hd :: tail)))) with (num_oc n (skipn (length (hd :: tail) / 2) (hd :: tail))).
    + rewrite num_oc_append. rewrite firstn_skipn. reflexivity.
    + destruct mergesort.
      * unfold perm in *. rewrite -> IHl1. reflexivity.
      * unfold perm in *. rewrite -> IHl1. reflexivity.
    + unfold perm in *. rewrite -> IHl0. reflexivity.
Qed.

(** *** Questão 6 *)
(** Por fim, prove que [mergesort] é correto. *)

Theorem mergesort_is_correct: forall l, perm l (mergesort l) /\ sorted (mergesort l).
Proof.
  split.
  - apply mergesort_is_perm.
  - apply mergesort_sorts.
Qed.

(** ** Extração de código *)
(** Uma das vantagens de formalizar um algoritmo é que você pode extrair o código certificado do algoritmo. O algoritmo de extração garante que o código extraído satisfaz todas as propriedades provadas. Vamos extrair automaticamente o código do algoritmo mergesort? *)

Require Extraction.

(** As opções de linguagens fornecidas pelo Coq são: OCaml, Haskell, Scheme e JSON. *)

Extraction Language OCaml.

(** Extração apenas da função [mergesort]: *)

Extraction mergesort.

(** Extração do programa inteiro: *)

Recursive Extraction mergesort.

(** Extração para um arquivo: *)

Extraction "mergesort" mergesort.


Require Import Init.Init.
Require Import Relation.Relation.
Require Import Structure.Structure.
Require Import Nat.Inductive.
Require Import Nat.Nature.
Require Import Nat.Recursion.
Require Import Nat.Arith.

(* Order *)
Definition nat_order := {x: ω ⨉ ω| ∃ m, ∃ n, x = ⟨m, n⟩ ∧ m ∈ n}.
Notation   "m <ₙ n"  := (m <[nat_order] n).
Notation   "m ≮ₙ n"  := (m ≮[nat_order] n).
Notation   "m ≤ₙ n"  := (m ≤[nat_order] n).
Notation   "m ≰ₙ n"  := (m ≰[nat_order] n).

Lemma nat_less_e: ∀ m, ∀ n, m <ₙ n → m ∈ n.
Proof.
  intros m n P1.
  destruct (sub_e _ _ _ P1) as [_ [m' [n' [P4 P5]]]].
  apply (eq_cr (λ x, x ∈ _) (opair_eq_el _ _ _ _ P4)).
  apply (eq_cr (λ x, _ ∈ x) (opair_eq_er _ _ _ _ P4)).
  apply P5.
Qed.

Lemma nat_less_i: ∀ m, ∀ n, m ∈ ω → n ∈ ω → m ∈ n → m <ₙ n.
Proof.
  intros m n P1 P2 P3.
  apply sub_i.
  + apply (cp_i _ _ _ _ P1 P2).
  + exists m.
    exists n.
    apply (and_i (eq_r _) P3).
Qed.

Lemma suc_less_i: ∀ m, ∀ n, m ∈ ω → n ∈ ω → m <ₙ n → S(m) <ₙ S(n).
Proof.
  intros m n P1 P2 P3.
  pose (λ k, ∀ p, p ∈ ω → p <ₙ k → S(p) <ₙ S(k)) as P.
  assert (P 𝟢) as I1.
  { intros m1 _ Q1.
    apply bot_e.
    apply (empty_i _ (nat_less_e _ _ Q1)). }
  assert (induction_step P) as I2.
  { intros k Q1 Q2 m2 Q3 Q4.
    destruct (suc_e _ _ (nat_less_e _ _ Q4)) as [Q5 | Q5].
    + apply (eq_cr (λ x, S(x) <ₙ _) Q5).
      apply (nat_less_i _ _ (suc_is_nat _ Q1) (suc_is_nat _ (suc_is_nat _ Q1))).
      apply suc_i1.
    + apply (nat_less_i _ _ (suc_is_nat _ Q3) (suc_is_nat _ (suc_is_nat _ Q1))).
      apply (nat_is_trans _ (suc_is_nat _ (suc_is_nat _ Q1)) _ (S(k))).
      - apply (nat_less_e _ _ (Q2 _ Q3 (nat_less_i _ _ Q3 Q1 Q5))).
      - apply suc_i1. }
  apply (induction_principle _ I1 I2 _ P2 _ P1 P3).
Qed.

Lemma nat_less_suc: ∀ m, ∀ n, m ∈ ω → n ∈ ω → m <ₙ S(n) → m ≤ₙ n.
Proof.
  intros m n P1 P2 P3.
  pose (nat_less_e _ _ P3) as P4.
  destruct (suc_e _ _ P4) as [P5 | P5].
  + right.
    apply P5.
  + left.
    apply (nat_less_i _ _ P1 P2 P5).
Qed.

Lemma less_suc: ∀ m, m ∈ ω → m <ₙ S(m).
Proof.
  intros m P1.
  apply (nat_less_i _ _ P1 (suc_is_nat _ P1)).
  apply suc_i1.
Qed.

Lemma suc_le_nat: ∀ m, ∀ n, m ∈ ω → n ∈ ω → m <ₙ n → S(m) ≤ₙ n.
Proof.
  intros m n P1 P2 P3.
  destruct (suc_e n (S(m))) as [P4 | P4].
  + apply nat_less_e.
    apply (suc_less_i _ _ P1 P2 P3).
  + right.
    apply P4.
  + left.
    apply (nat_less_i _ _ (suc_is_nat _ P1) P2 P4).
Qed.

Lemma suc_less_e: ∀ m, ∀ n, m ∈ ω → n ∈ ω → S(m) <ₙ S(n) → m <ₙ n.
Proof.
  intros m n P1 P2 P3.
  destruct (nat_less_suc _ _ (suc_is_nat _ P1) P2 P3) as [P4 | P4].
  + apply (nat_less_i _ _ P1 P2).
    apply (nat_is_trans _ P2 _ (S(m)) (suc_i1 _) (nat_less_e _ _ P4)).
  + apply (eq_cl (λ x, m <ₙ x) P4).
    apply (less_suc _ P1).
Qed.

Lemma nat_less_trans: r_trans nat_order ω.
Proof.
  intros m n p P1 P2 P3 P4 P5.
  pose (nat_less_e _ _ P4) as P6.
  pose (nat_less_e _ _ P5) as P7.
  apply (nat_less_i _ _  P1 P3).
  apply (nat_is_trans _ P3 _ _ P6 P7).
Qed.

Lemma nat_less_irrefl: r_irrefl nat_order ω.
Proof.
  intros n P1 P2.
  apply (nin_self n).
  apply (nat_less_e _ _ P2).
Qed.

Lemma nat_less_tricho_weak: tricho_weak nat_order ω.
Proof.
  intros m n P1 P2.
  pose (λ k, k ∈ ω → k <ₙ n ∨ k = n ∨ n <ₙ k) as P.
  assert (P 𝟢) as I1.
  { intros Q1.
    destruct (LEM (n = 𝟢)) as [Q2 | Q2].
    + right. left.
      apply (eq_s Q2).
    + left.
      apply (nat_less_i _ _ empty_is_nat P2 (empty_in_nat _ P2 Q2)). }
  assert (induction_step P) as I2.
  { intros k Q1 Q2 Q3.
    destruct (Q2 Q1) as [Q4 | [Q4 | Q4]].
    + destruct (suc_le_nat _ _ Q1 P2 Q4) as [Q5 | Q5].
      - left.
        apply Q5.
      - right. left.
        apply Q5.
    + right. right.
      apply (eq_cl (λ x, x <ₙ S(k)) Q4).
      apply (less_suc _ Q1).
    + right. right.
      apply (nat_less_i _ _ P2 Q3).
      apply (nat_is_trans _ Q3 _ _ (nat_less_e _ _ Q4) (suc_i1 _)). }
  apply (induction_principle _ I1 I2 _ P1 P1).
Qed.

Lemma nat_less_tricho: tricho nat_order ω.
Proof.
  apply weak_to_tricho.
  + apply nat_less_tricho_weak.
  + apply nat_less_irrefl.
  + apply nat_less_trans.
Qed.

Lemma empty_less: ∀ n, n ∈ ω → n ≠ 𝟢 → 𝟢 <ₙ n.
Proof.
  intros n P1 P2.
  apply (nat_less_i _ _ empty_is_nat P1).
  apply (empty_in_nat _ P1 P2).
Qed.

Lemma not_less_empty: ∀ n, n ∈ ω → n ≠ 𝟢 → n ≮ₙ 𝟢.
Proof.
  intros n P1 P2.
  destruct (nat_less_tricho _ _ empty_is_nat P1)
    as [[_ [_ Q1]] | [[_ [Q1 _]] | [Q1 _]]].
  + apply Q1.
  + apply bot_e.
    apply (P2 (eq_s Q1)).
  + apply bot_e.
    apply (Q1 (empty_less _ P1 P2)).
Qed.

Lemma nat_po: po nat_order ω.
Proof.
  split.
  + apply nat_less_trans.
  + apply nat_less_irrefl.
Qed.

Lemma nat_lo: lo nat_order ω.
Proof.
  split.
  + apply nat_less_trans.
  + apply nat_less_tricho.
Qed.

Lemma nat_less_least_prop: least_prop nat_order ω.
Proof.
  intros S P1 P2.
  apply nn_e.
  intros P3.
  (*pose (ω \ S) as K.*)
  pose (λ k, k ∈ ω → ∀ k', k' ∈ ω → k' <ₙ k → k' ∉ S) as P.
  assert (P 𝟢) as I1.
  { intros Q1 k' Q2 Q3 Q4.
    destruct (LEM (k' = 𝟢)) as [Q5 | Q5].
    + apply (nat_less_irrefl _ Q2).
      apply (eq_cr (λ x, k' <ₙ x) Q5 Q3).
    + apply (not_less_empty _ Q2 Q5 Q3). }
  assert (induction_step P) as I2.
  { intros k Q1 Q2 Q3 k' Q4 Q5 Q6.
    apply P3.
    exists k'.
    split.
    + apply Q6.
    + intros x Q7.
      apply (lo_nl_e _ _ _ _ nat_lo (P1 _ Q7) Q4).
      intros Q8.
      destruct (nat_less_suc _ _ Q4 Q1 Q5) as [Q9 | Q9].
      - apply (Q2 Q1 _ (P1 _ Q7)
          (l_l_t _ _ _ _ _ nat_less_trans (P1 _ Q7) Q4 Q1 Q8 Q9)).
        apply Q7.
      - apply (Q2 Q1 _ (P1 _ Q7) (eq_cl (λ y, x <ₙ y) Q9 Q8)).
        apply Q7. }
  apply P2.
  apply empty_unique.
  intros x P4.
  pose (P1 _ P4) as P5.
  apply (induction_principle _ I1 I2 _ (suc_is_nat _ P5)
    (suc_is_nat _ P5) _ P5 (less_suc _ P5)).
  apply P4.
Qed.

Lemma nat_wo: wo nat_order ω.
Proof.
  split.
  + apply nat_lo.
  + apply nat_less_least_prop.
Qed.

Lemma nat_l_l_t: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m <ₙ n → n <ₙ p
  → m <ₙ p.
Proof.
  intros m n p.
  apply (l_l_t _ _ _ _ _ nat_less_trans).
Qed.

Lemma nat_le_l_t: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m ≤ₙ n → n <ₙ p
  → m <ₙ p.
Proof.
  intros m n p.
  apply (le_l_t _ _ _ _ _ nat_less_trans).
Qed.

Lemma nat_l_le_t: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m <ₙ n → n ≤ₙ p
  → m <ₙ p.
Proof.
  intros m n p.
  apply (l_le_t _ _ _ _ _ nat_less_trans).
Qed.

Lemma nat_le_le_t: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m ≤ₙ n → n ≤ₙ p
  → m ≤ₙ p.
Proof.
  intros m n p.
  apply (le_le_t _ _ _ _ _ nat_less_trans).
Qed.
(*----------------------------------------------------------------------------*)

(* Arith *)
Lemma nat_add_l: ∀ m, ∀ p, m ∈ ω → p ∈ ω → m <ₙ m +ₙ S(p).
Proof.
  intros m p P1 P2.
  apply (eq_cr (λ x, m <ₙ x) (nat_add_redr _ _ P1 P2)).
  pose (λ k, m <ₙ S(m +ₙ k)) as P.
  assert (P 𝟢) as I1.
  { apply (eq_cr (λ x, m <ₙ S(x)) (nat_add_zeror _ P1)).
    apply (less_suc _ P1). }
  assert (induction_step P) as I2.
  { intros k Q1 Q2.
    pose (suc_is_nat _ (nat_add_close _ _ P1 Q1)) as Q3.
    apply (eq_cr (λ x, m <ₙ S(x)) (nat_add_redr _ _ P1 Q1)).
    apply (l_l_t _ _ _ _ _ nat_less_trans P1 Q3 (suc_is_nat _ Q3)).
    + apply Q2.
    + apply (less_suc _ Q3). }
  apply (induction_principle _ I1 I2 _ P2).
Qed.

Lemma nat_add_le: ∀ m, ∀ p, m ∈ ω → p ∈ ω → m ≤ₙ m +ₙ p.
Proof.
  intros m p P1 P2.
  destruct (LEM (p = 𝟢)) as [P3 | P3].
  + apply (eq_cr (λ x, m ≤ₙ(m +ₙ x)) P3).
    apply (eq_cr (λ x, m ≤ₙ x) (nat_add_zeror _ P1)).
    right.
    apply eq_r.
  + destruct (nat_is_suc _ P2 P3) as [x [P4 P5]].
    apply (eq_cr (λ x, m ≤ₙ (m +ₙ x)) P5).
    left.
    apply (nat_add_l _ _ P1 P4).
Qed.

Lemma nat_add_ex_l: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m +ₙ S(p) = n
  → m <ₙ n.
Proof.
  intros m n p P1 P2 P3 P4.
  apply (eq_cl (λ x, m <ₙ x) P4).
  apply (nat_add_l _ _ P1 P3).
Qed.

Lemma nat_add_l_ex: ∀ m, ∀ n, m ∈ ω → n ∈ ω → m <ₙ n
  → ∃ p, p ∈ ω ∧ m +ₙ S(p) = n.
Proof.
  intros m n P1 P2 P3.
  pose (λ k, k <ₙ m ∨ m = k ∨ ∃ p, p ∈ ω ∧ m +ₙ S(p) = k) as P.
  assert (P 𝟢) as I1.
  { destruct (LEM (m = 𝟢)) as [P4 | P4].
    + right. left.
      apply P4.
    + left.
      apply (empty_less _ P1 P4). }
  assert (induction_step P) as I2.
  { intros k Q1 [Q2 | [Q2 | Q2]].
    + destruct (suc_le_nat _ _ Q1 P1 Q2) as [Q3 | Q3].
      - left.
        apply Q3.
      - right. left.
        apply (eq_s Q3).
    + right. right.
      exists 𝟢.
      split.
      - apply empty_is_nat.
      - apply (eq_cr (λ x, x = _) (nat_add_redr _ _ P1 empty_is_nat)).
        apply (eq_cr (λ x, S(x) = _) (nat_add_zeror _ P1)).
        apply (eq_cr (λ x, S(x) = _) Q2).
        apply eq_r.
    + destruct Q2 as [p [Q3 Q4]].
      right. right.
      exists (S(p)).
      split.
      - apply (suc_is_nat _ Q3).
      - apply (eq_cr (λ x, x = S(k)) (nat_add_redr _ _ P1 (suc_is_nat _ Q3))).
        apply (eq_cr (λ x, S(x) = S(k)) Q4).
        apply eq_r. }
  destruct (induction_principle _ I1 I2 _ P2) as [P4 | [P4 | P4]].
  + apply bot_e.
    apply (nat_less_irrefl _ P1 (nat_l_l_t _ _ _ P1 P2 P1 P3 P4)).
  + apply bot_e.
    apply (nat_less_irrefl _ P1 (eq_cr (λ x, m <ₙ x) P4 P3)).
  + apply P4.
Qed.

Lemma nat_add_l_cancel: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω
  → m +ₙ p <ₙ n +ₙ p → m <ₙ n.
Proof.
  intros m n p P1 P2 P3 P4.
  destruct (nat_add_l_ex _ _
    (nat_add_close _ _ P1 P3) (nat_add_close _ _ P2 P3) P4) as [r [P5 P6]].
  apply (nat_add_ex_l _ _ r P1 P2 P5).
  apply (nat_add_cancel _ _ _
    (nat_add_close _ _ P1 (suc_is_nat _ P5)) P2 P3).
  apply (eq_t (nat_add_132 _ _ _ P1 (suc_is_nat _ P5) P3) P6).
Qed.

Lemma nat_add_l_eqr: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m <ₙ n
  → m +ₙ p <ₙ n +ₙ p.
Proof.
  intros m n p P1 P2 P3 P4.
  pose (λ k, (m +ₙ k) <ₙ (n +ₙ k)) as P.
  assert (P 𝟢) as I1.
  { red.
    apply (eq_cr (λ x, x <ₙ _) (nat_add_zeror _ P1)).
    apply (eq_cr (λ x, _ <ₙ x) (nat_add_zeror _ P2)).
    apply P4. }
  assert (induction_step P) as I2.
  { intros k Q1 Q2.
    red.
    apply (eq_cr (λ x, x <ₙ _) (nat_add_redr _ _ P1 Q1)).
    apply (eq_cr (λ x, _ <ₙ x) (nat_add_redr _ _ P2 Q1)).
    apply (suc_less_i _ _ (nat_add_close _ _ P1 Q1) (nat_add_close _ _ P2 Q1)).
    apply Q2. }
  apply (induction_principle _ I1 I2 _ P3).
Qed.

Lemma nat_add_l_eql: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m <ₙ n
  → p +ₙ m <ₙ p +ₙ n.
Proof.
  intros m n p P1 P2 P3 P4.
  apply (eq_cr (λ x, x <ₙ _) (nat_add_commu _ _ P3 P1)).
  apply (eq_cr (λ x, _ <ₙ x) (nat_add_commu _ _ P3 P2)).
  apply (nat_add_l_eqr _ _ _ P1 P2 P3 P4).
Qed.

Lemma nat_add_l_preserve: ∀ m, ∀ n, ∀ p, ∀ q, m ∈ ω → n ∈ ω → p ∈ ω → q ∈ ω
  → m <ₙ n → p <ₙ q → m +ₙ p <ₙ n +ₙ q.
Proof.
  intros m n p q P1 P2 P3 P4 P5 P6.
  pose (nat_add_l_eqr _ _ _ P1 P2 P3 P5) as P7.
  pose (nat_add_l_eql _ _ _ P3 P4 P2 P6) as P8.
  apply (nat_l_l_t _ (n +ₙ p)).
  all: is_nat.
Qed.

Lemma nat_mul_l: ∀ m, ∀ n, ∀ p, m ∈ ω → n ∈ ω → p ∈ ω → m <ₙ n → 𝟢 <ₙ p
  → m ×ₙ p <ₙ n ×ₙ p.
Proof.
  intros m n p P1 P2 P3 P4 P5.
  pose (λ k, k = 𝟢 ∨ m ×ₙ k <ₙ n ×ₙ k) as P.
  assert (P 𝟢) as I1.
  { left.
    apply eq_r. }
  assert (induction_step P) as I2.
  { intros k Q1 [Q2 | Q2].
    + right.
      apply (eq_cr (λ k, _ ×ₙ S(k) <ₙ _ ×ₙ S(k)) Q2).
      apply (eq_cr (λ x, x <ₙ _) (nat_mul_oner _ P1)).
      apply (eq_cr (λ x, _ <ₙ x) (nat_mul_oner _ P2)).
      apply P4.
    + right.
      apply (eq_cr (λ x, x <ₙ _) (nat_mul_redr _ _ P1 Q1)).
      apply (eq_cr (λ x, _ <ₙ x) (nat_mul_redr _ _ P2 Q1)).
      apply nat_add_l_preserve.
      all: is_nat. }
  destruct (induction_principle _ I1 I2 _ P3) as [P6 | P6].
  + apply bot_e.
    apply (nat_less_irrefl _ P3).
    apply (eq_cr (λ x, x <ₙ _) P6 P5).
  + apply P6.
Qed.

(*Lemma less_nat_preserve: ∀ m, ∀ n, m ∈ ω → n < ω → 𝟢 < m → 𝟢 < n → 0 < m ×ₙ m.*)
(*Lemma mul_order_l: ∀ m, ∀ n, ∀ p, ∀ q, m ∈ ω → n ∈ ω → p ∈ ω → q ∈ ω →*)
  (*m <ₙ n → p <ₙ q → m ×ₙ q +ₙ n ×ₙ p <ₙ m ×ₙ p +ₙ n ×ₙ q.*)
(*Proof.*)
  (*intros m n p q P1 P2 P3 P4 P5 P6.*)
  (*destruct (less_ex _ _ P1 P2 P5) as [s1 [P7 P8]].*)
  (*destruct (less_ex _ _ P3 P4 P6) as [s2 [P9 P10]].*)
  (*apply (eq_cl (λ x, _ ×ₙ x +ₙ _ <ₙ _ +ₙ n ×ₙ x) P10).*)
  (*apply (eq_cr (λ x, x +ₙ _ <ₙ _) (distr_l _ _ _ P1 P3 (suc_is_nat _ P9))).*)
  (*apply (eq_cr (λ x, _ <ₙ _ +ₙ x) (distr_l _ _ _ P2 P3 (suc_is_nat _ P9))).*)
  (*apply (eq_cl (λ x, x <ₙ _) (add_assoc _ _ _ (mul_is_nat _ _ P1 P3)*)
    (*(mul_is_nat _ _ P1 (suc_is_nat _ P9)) (mul_is_nat _ _ P2 P3))).*)
  (*apply (less_add_eq_l).*)
  (*all: is_nat.*)
  (*apply (eq_cr (λ x, x <ₙ _) (add_commu _ _*)
    (*(mul_is_nat _ _ P1 (suc_is_nat _ P9)) (mul_is_nat _ _ P2 P3))).*)
  (*apply (less_add_eq_l).*)
  (*all: is_nat.*)
  (*apply (eq_cl (λ x, _ <ₙ x ×ₙ _) P8).*)
  (*apply (eq_cr (λ x, _ <ₙ x) (distr_r _ _ _ P1 (suc_is_nat _ P7)*)
    (*(suc_is_nat _ P9))).*)
  (*apply (eq_cl (λ x, x <ₙ _) (add_zero _ (mul_is_nat _ _ P1 (suc_is_nat _ P9)))).*)
  (*apply (less_add_eq_l).*)
  (*all: is_nat.*)
  (*destruct (nat_less_tricho_weak _ _ empty_is_nat (mul_is_nat _ _ (suc_is_nat _ P7) (suc_is_nat _ P9))) as [Q1 | [Q1 | Q1]].*)
  (*+ apply Q1.*)
  (*+ destruct (mul_eq_zero _ _ (suc_is_nat _ P7) (suc_is_nat _ P9) (eq_s Q1)) as [Q2 | Q2].*)
    (*- *)

  (*rewrite <- P10.*)
  (*rewrite (distributive_l (m +ₙ S(s1)) p (S(s2))).*)
  (*rewrite (distributive_l m p (S(s2))).*)
  (*rewrite (distributive_r m (S(s1)) p).*)
  (*rewrite (distributive_r m (S(s1)) (S(s2))).*)
  (*rewrite (add_associative (m ×ₙ p +ₙ S( s1) ×ₙ p) (m ×ₙ S( s2)) (S( s1) ×ₙ S( s2))).*)
  (*rewrite (add_commutative (m ×ₙ p +ₙ S( s1) ×ₙ p) (m ×ₙ S( s2))).*)
  (*rewrite (add_associative (m ×ₙ p)*)
    (*(m ×ₙ S( s2) +ₙ (m ×ₙ p +ₙ S( s1) ×ₙ p)) (S( s1) ×ₙ S( s2))).*)
  (*rewrite (add_associative (m ×ₙ p) (m ×ₙ S( s2)) (m ×ₙ p +ₙ S( s1) ×ₙ p)).*)
  (*rewrite (multi_red _ _ (suc_is_nat _ P7) P9).*)
  (*rewrite (add_associative ((m ×ₙ p +ₙ m ×ₙ S( s2)) +ₙ (m ×ₙ p +ₙ S( s1) ×ₙ p))*)
    (*(S(s1)) (S(s1) ×ₙ s2)).*)
  (*apply (less_le_less _ *)
    (*(((m ×ₙ p +ₙ m ×ₙ S( s2)) +ₙ (m ×ₙ p +ₙ S( s1) ×ₙ p)) +ₙ S( s1)) _).*)
  (*all: is_nat.*)
  (*apply add_less.*)
  (*all: is_nat.*)
  (*apply add_less_equal.*)
  (*all: is_nat.*)
(*Qed.*)

(*Lemma less_multi_eq: forall m n p, m ∈ ω -> n ∈ ω -> p ∈ ω -> m <ₙ n ->*)
  (*(m ×ₙ S(p)) <ₙ (n ×ₙ S(p)).*)
(*Proof.*)
  (*intros m n p P1 P2 P3 P4.*)
  (*pose (fun k => (m ×ₙ S(k)) <ₙ (n ×ₙ S(k))) as P.*)
  (*assert (P 𝟢) as I1.*)
  (*{ red. *)
    (*rewrite (multi_one _ P1).*)
    (*rewrite (multi_one _ P2).*)
    (*apply P4. }*)
  (*assert (induction_step P) as I2.*)
  (*{ intros k Q1 Q2.*)
    (*red.*)
    (*rewrite (multi_red _ _ P1 (suc_is_nat _ Q1)).*)
    (*rewrite (multi_red _ _ P2 (suc_is_nat _ Q1)).*)
    (*apply (less_add_less m n (m ×ₙ S(k)) (n ×ₙ S(k))).*)
    (*all: is_nat. }*)
  (*apply (induction_principle _ I1 I2 _ P3).*)
(*Qed.*)

(*Lemma equal_less_less: forall m n p q, m ∈ ω -> n ∈ ω -> p ∈ ω -> q ∈ ω ->*)
  (*(m +ₙ p) = (n +ₙ q) -> m <ₙ n -> q <ₙ p.*)
(*Proof.*)
  (*intros m n p q P1 P2 P3 P4 P5 P6.*)
  (*destruct (less_ex _ _ P1 P2 P6) as [r [P7 P8]].*)
  (*rewrite <- P8 in P5.*)
  (*rewrite (add_commutative _ _ P1 P3) in P5.*)
  (*rewrite (add_commutative _ _ P1 (suc_is_nat _ P7)) in P5.*)
  (*rewrite (add_cyc _ _ _ (suc_is_nat _ P7) P1 P4) in P5.*)
  (*rewrite (add_commutative _ _ (suc_is_nat _ P7) P4) in P5.*)
  (*symmetry in P5.*)
  (*apply (ex_less _ _ r P4 P3 P7).*)
  (*apply (add_cancellation _ _ _ *)
    (*(add_is_nat _ _ P4 (suc_is_nat _ P7)) P3 P1 P5).*)
(*Qed.*)

(*Lemma less_multi_cancellation: forall m n p, m ∈ ω -> n ∈ ω -> p ∈ ω -> *)
  (*(m ×ₙ S(p)) <ₙ (n ×ₙ S(p)) -> m <ₙ n.*)
(*Proof.*)
  (*intros m n p P1 P2 P3 P4.*)
  (*destruct (nat_trichotomy _ _ P1 P2) as [[P5 _] | [[_ [P5 _]] | [_ [_ P5]]]].*)
  (*+ apply P5.*)
  (*+ rewrite P5 in P4.*)
    (*pose (nat_not_in_self _ (multi_is_nat _ _ P2 (suc_is_nat _ P3))) as P6.*)
    (*contradiction.*)
  (*+ pose (less_multi_eq _ _ _ P2 P1 P3 P5) as P6.*)
    (*absurd (m ×ₙ S( p) <ₙ m ×ₙ S( p)).*)
    (*- apply nat_not_in_self.*)
      (*is_nat.*)
    (*- apply (less_less_less _ (n ×ₙ S(p)) _).*)
      (*all: is_nat.*)
(*Qed.*)

(*Lemma not_equal_less: forall m n, m ∈ ω -> n ∈ ω -> m <> n -> *)
  (*m <ₙ n \/ n <ₙ m.*)
(*Proof.*)
  (*intros m n P1 P2 P3.*)
  (*destruct (nat_trichotomy _ _ P1 P2) as [P4|[P4|P4]].*)
  (*+ destruct P4 as [P4 _].*)
    (*left. *)
    (*apply P4.*)
  (*+ destruct P4 as [_ [P4 _]].*)
    (*contradiction.*)
  (*+ destruct P4 as [_ [_ P4]].*)
    (*right.*)
    (*apply P4.*)
(*Qed.*)

(*Lemma less_not_equal_1: forall m n, m ∈ ω -> n ∈ ω -> m <ₙ n ->*)
  (*m <> n.*)
(*Proof.*)
  (*intros m n P1 P2 P3.*)
  (*destruct (nat_trichotomy _ _ P1 P2) as [P4|[P4|P4]].*)
  (*+ destruct P4 as [_ [P4 _]].*)
    (*apply P4.*)
  (*+ destruct P4 as [P4 _].*)
    (*contradiction.*)
  (*+ destruct P4 as [_ [P4 _]].*)
    (*apply P4.*)
(*Qed.*)

(*Lemma less_not_equal_2: forall m n, m ∈ ω -> n ∈ ω -> m <ₙ n ->*)
  (*n <> m.*)
(*Proof.*)
  (*intros m n P1 P2 P3 P4.*)
  (*symmetry in P4.*)
  (*apply (less_not_equal_1 _ _ P1 P2 P3 P4).*)
(*Qed.*)

(*Lemma multi_cancellation: forall m n p, m ∈ ω -> n ∈ ω -> p ∈ ω ->*)
  (*m ×ₙ S(p) = n ×ₙ S(p) -> m = n.*)
(*Proof.*)
  (*intros m n p P1 P2 P3 P4.*)
  (*destruct (nat_trichotomy _ _ P1 P2) as [[P5 _] | [[_ [P5 _]] | [_ [_ P5]]]].*)
  (*+ absurd (m ×ₙ S(p) = n ×ₙ S(p)).*)
    (*- apply less_not_equal_1.*)
      (*all: is_nat.*)
      (*apply (less_multi_eq _ _ p P1 P2 P3 P5).*)
    (*- apply P4.*)
  (*+ apply P5.*)
  (*+ absurd (m ×ₙ S(p) = n ×ₙ S(p)).*)
    (*- apply less_not_equal_2.*)
      (*all: is_nat.*)
      (*apply (less_multi_eq _ _ p P2 P1 P3 P5).*)
    (*- apply P4.*)
(*Qed.*)

(*Lemma not_equal_cyc_equal: forall m n p q, m ∈ ω -> n ∈ ω -> p ∈ ω -> q ∈ ω ->*)
  (*p <> q -> m ×ₙ p +ₙ n ×ₙ q = m ×ₙ q +ₙ n ×ₙ p -> m = n.*)
(*Proof.*)
  (*intros m n p q P1 P2 P3 P4 P5 P6.*)
  (*destruct (not_equal_less _ _ P3 P4 P5) as [P7|P7].*)
  (*+ destruct (less_ex _ _ P3 P4 P7) as [x [P8 P9]].*)
    (*rewrite <- P9 in P6.*)
    (*rewrite (distributive_l n p (S(x))) in P6.*)
    (*rewrite (add_associative (m ×ₙ p) (n ×ₙ p) (n ×ₙ S( x))) in P6.*)
    (*rewrite (add_commutative (m ×ₙ p +ₙ n ×ₙ p) (n ×ₙ S( x))) in P6.*)
    (*rewrite (distributive_l m p (S(x))) in P6.*)
    (*rewrite (add_cyc (m ×ₙ p) (m ×ₙ S( x)) (n ×ₙ p)) in P6.*)
    (*rewrite (add_commutative (m ×ₙ p +ₙ n ×ₙ p) (m ×ₙ S( x))) in P6.*)
    (*assert (n ×ₙ S( x) = m ×ₙ S( x)) as P10.*)
    (*{ apply (add_cancellation _ _ (m ×ₙ p +ₙ n ×ₙ p)).*)
      (*all: is_nat. }*)
    (*symmetry.*)
    (*apply (multi_cancellation _ _ x).*)
    (*all: is_nat.*)
  (*+ destruct (less_ex _ _ P4 P3 P7) as [x [P8 P9]].*)
    (*rewrite <- P9 in P6.*)
    (*rewrite (distributive_l m q (S(x))) in P6.*)
    (*rewrite (add_cyc (m ×ₙ q) (m ×ₙ S(x)) (n ×ₙ q)) in P6.*)
    (*rewrite (add_commutative (m ×ₙ q +ₙ n ×ₙ q) (m ×ₙ S(x))) in P6.*)
    (*rewrite (distributive_l n q (S(x))) in P6.*)
    (*rewrite (add_associative (m ×ₙ q) (n ×ₙ q) (n ×ₙ S( x))) in P6.*)
    (*rewrite (add_commutative (m ×ₙ q +ₙ n ×ₙ q) (n ×ₙ S( x))) in P6.*)
    (*assert (m ×ₙ S( x) = n ×ₙ S( x)) as P10.*)
    (*{ apply (add_cancellation _ _ (m ×ₙ q +ₙ n ×ₙ q)).*)
      (*all: is_nat. }*)
    (*apply (multi_cancellation _ _ x).*)
    (*all: is_nat.*)
(*Qed.*)
(*----------------------------------------------------------------------------*)


Require Import BigO.Notation.
Require Import BigO.Util.DecField.
Require Import BigO.Util.Vectorspace.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.interfaces.vectorspace.
Require Import MathClasses.orders.semirings.
Require Import MathClasses.orders.dec_fields.

(**
 All notations absorb constant multiples.
 *)

Section Constants.
  Context `{@SemiNormedSpace
              K V
              Ke Kle Kzero Knegate Kabs Vnorm Ke Kplus Kmult Kzero Kone Knegate Krecip
              Ve Vop Vunit Vnegate smkv
           }.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.
  Context `{forall x y : K, Decision (x = y)}.

  Lemma big_O_absorbs_constants : ∀ f g : (V → V),
      f ∈ O(g) -> forall c : K, 0 < c -> (fun n => c · f n) ∈ O(g).
    intros f g f_O_g c.
    destruct f_O_g as [k [zero_lt_k [n0 [zero_lt_n0 f_O_h]]]].
    unfold big_O.
    exists (c * k); split; try now apply (pseudo_srorder_pos_mult_compat c k).
    exists n0; split; try assumption.
    intros n n0_le_n.
    rewrite sm_and_mult; try assumption.
    rewrite <- associativity.
    apply order_preserving_mult_le; try assumption.
    now apply f_O_h.
  Qed.

  Lemma big_Omega_absorbs_constants : ∀ f g : (V → V),
      f ∈ Ω(g) -> forall c : K, 0 < c -> (fun n => c · f n) ∈ Ω(g).
    intros f g f_O_g c.
    destruct f_O_g as [k [zero_lt_k [n0 [zero_lt_n0 f_O_h]]]].
    unfold big_Omega.
    exists (c * k); split; try now apply (pseudo_srorder_pos_mult_compat c k).
    exists n0; split; try assumption.
    intros n n0_le_n.
    rewrite sm_and_mult; try assumption.
    rewrite <- associativity.
    apply order_preserving_mult_le; try assumption.
    now apply f_O_h.
  Qed.

  Lemma dec_recip_inverse_gt : ∀ c : K, 0 < c -> c / c = 1.
    intros c zero_lt_c.
    apply dec_recip_inverse.
    apply trivial_apart.
    apply apart_iff_total_lt.
    now right.
  Qed.

  Lemma little_o_absorbs_constants : ∀ f g : (V → V),
      f ∈ o(g) -> forall c : K, 0 < c -> (fun n => c · f n) ∈ o(g).
    intros f g f_o_g c zero_lt_c.
    unfold little_o.
    intros k zero_lt_k.
    destruct (f_o_g (/c * k)) as [n0 [zero_lt_n0 f_o_g']].
    - (apply pos_mult_compat; try trivial; try now apply pos_dec_recip_compat).
    - exists n0; split; try assumption.
      intros n n0_le_n.
      assert (∥ f n ∥ ≤ /c * k * (∥ g n ∥)) by (now apply f_o_g').
      rewrite sm_and_mult; try assumption.
      setoid_replace k with (1 * k) by (now rewrite left_identity).
      setoid_replace 1 with (c * /c) by (symmetry; now apply dec_recip_inverse_gt).
      do 2 (rewrite <- associativity).
      apply (order_preserving_mult_le (∥ f n ∥) (/ c * (k * (∥ g n ∥))) c);
        try assumption.
      now rewrite associativity.
  Qed.

  Lemma little_omega_absorbs_constants : ∀ f g : (V → V),
      f ∈ ω(g) -> forall c : K, 0 < c -> (fun n => c · f n) ∈ ω(g).
    intros f g f_ω_g c zero_lt_c.
    unfold little_omega.
    intros k zero_lt_k.
    destruct (f_ω_g (/c * k)) as [n0 [zero_lt_n0 f_ω_g']].
    - (apply pos_mult_compat; try trivial; try now apply pos_dec_recip_compat).
    - exists n0; split; try assumption.
      intros n n0_le_n.
      assert (/c * k * (∥g n∥) ≤ ∥f n∥) by (now apply f_ω_g').
      rewrite sm_and_mult; try assumption.
      setoid_replace k with (1 * k) by (now rewrite left_identity).
      setoid_replace 1 with (c * /c) by (symmetry; now apply dec_recip_inverse_gt).
      do 2 (rewrite <- associativity).
      apply (order_preserving_mult_le (/ c * (k * (∥ g n ∥))) (∥f n∥) c);
        try assumption.
      now rewrite associativity.
  Qed.
End Constants.


Require Import Basics.
Require Import Pointed.Core.
Require Import Colimits.Pushout.

(* Here we define the Wedge sum of two pointed types *)

Local Open Scope pointed_scope.

Definition Wedge (X Y : pType) : pType
  := Build_pType
    (Pushout (fun _ : Unit => point X) (fun _ => point Y))
    (pushl (point X)).

Notation "X \/ Y" := (Wedge X Y) : pointed_scope.

Definition wglue {X Y : pType}
  : pushl (point X) = (pushr (point Y) : X \/ Y) := pglue tt.

Definition wedge_incl {X Y : pType} : X \/ Y -> X * Y :=
 Pushout_rec _ (fun x => (x, point Y)) (fun y => (point X, y))
  (fun _ : Unit => idpath).


(**************************************************************************)
(*  Copyright 2010 2011, Thomas Braibant                                  *)
(*                                                                        *)
(**************************************************************************)

(** Generalized n-ary disjoint sums  *)

Require Import Common EqT Finite.
Require List.

Section Sumn.
  Variable A : Type.

  Fixpoint sumn (n : nat) : Type :=
    match n with
      | 0 => zero
      | S n => (A + sumn n  )%type
    end.

  Definition expand  n  (x : sumn  (S n) ) : (A + sumn   n)%type := id x.
  Definition compact n (x : A + sumn  n) : sumn (S n) := id x.

  Fixpoint  sumn_add x y {struct x}:
    sumn x + sumn  y ->  sumn  (x+y) :=
    match x with
      | 0 => fun e => match e with inl e => match e with end | inr e => e end
      | S p => fun e =>
        match e with
          |inl asp =>
            let asp := expand p asp in
              match asp with
                | inl el => inl  el
                | inr t => inr  (sumn_add _ _ (inl t))
              end
          |inr ay => inr  (sumn_add _ _ (inr  ay))
      end
  end.

  Fixpoint sumn_add' x y {struct x}:   sumn (x+y) -> sumn  x + sumn  y :=
    match x with
      | 0 => fun e => inr  e
      | S p => fun e =>
        match e with
          | inl e => inl (inl  e)
          | inr t =>
            let t' := sumn_add' _ _ t in
              match t' with
                | inl t0 => inl  (inr t0)
                | inr t0 => inr t0
              end
        end
    end.

  Definition sumn_1 : sumn  1 -> A := fun e =>
    match e with
      | inl e => e
      | inr e => match e with end
    end.

End Sumn.

Notation " ! " := (zero_rect _ _).

Section ops.
  Variable A B : Type.
  Definition sumn_zip  n : sumn A n + sumn B n -> sumn (A+B) n.
  Proof.
    induction n; firstorder.
  Defined.

  Definition sumn_unzip n : sumn (A + B) n -> sumn A n + sumn B n.
  Proof.
    induction n; firstorder.
  Defined.

  Definition sumn_forget_left n: sumn A n -> sumn (A + B) n .
  Proof.
    induction n.
    intros [].
    intros X; apply compact; apply expand in X; destruct X as [X |X].
    repeat left; apply X.
    right. apply (IHn X).
  Defined.

  Definition sumn_forget_right n : sumn B n -> sumn (A + B) n .
  Proof.
    induction n.
    intros [].
    intros X; apply compact; apply expand in X; destruct X as [X |X].
    auto.
    auto.
  Defined.

  Fixpoint sumn_map n (f : A -> B): sumn A n -> sumn B n  :=
    match n with
      | 0 => fun e => match e with end
      | S p => fun e => match expand A p e with
                     | inl e => inl (f e)
                     | inr e => inr (sumn_map p f e)
                      end
    end.

  Fixpoint sumn_repeat n : sumn A n -> A :=
    match n with
      | 0 => fun e => match e with end
      | S p => fun e => match expand A p e with
                        | inl e => e
                        | inr e => sumn_repeat p e
                      end
    end.

End ops.

Section Eq.
  Context `{eqT}.

  Fixpoint eqb_sumn n : sumn A n -> sumn A n -> bool := (* bug avec Program : insere des obligations *)
    match n with
      | 0 => fun x _ => match x with end
      | S p => fun x y => match x, y with
                          | inl a, inl b => equal a b
                          | inr a, inr b => eqb_sumn p a b
                          | _ , _  => false
                        end
    end.

  Lemma eqb_sumn_reflect n :
      forall x y : sumn A n, Bool.reflect (x = y) (eqb_sumn n x y).
  Proof.
        induction n.
    simpl; intros; tauto.
    simpl sumn.
    intros [x|x] [y|y];
    simpl eqb_sumn.
    case (_eqr); intros Hxy; constructor.
    subst. reflexivity.
    intros H'.  injection H'. clear H'; intros H'; subst; tauto.

    constructor. discriminate.
    constructor. discriminate.
    specialize (IHn x y).
    revert IHn.
    case (eqb_sumn n x y); intros H'; inversion H'.  subst. constructor. reflexivity.

    constructor.
    intros H''.  injection H''. clear H''; intros H''; subst; tauto.
  Qed.
  Global Instance eqT_sumn {n}: eqT (sumn A n) :=
    {| equal := eqb_sumn n|}.
  Proof.
    apply eqb_sumn_reflect.
  Defined.

End Eq.

Fixpoint flatten A (l : list (list A)) : list A :=
    match l with
      | nil => nil
      | cons t q => List.app t (flatten A q)
    end.

Section Fin_sumn.
  Context {A : Type} {F : Fin A}.

  Fixpoint enum_sumn n : list (sumn A n) :=
    match n with
      | 0 => [ :: ]%list
      | S p => enum_sum (enum A) (enum_sumn p)
    end.
  Instance local {n}: eqT (sumn A n) :=
    let f := F in match f with
                    | {| eq_fin := eq_fin |} => eqT_sumn
                  end.

  Lemma fin_sumn_axiom n:  forall x : sumn A n, count (equal x) (enum_sumn n) = 1.
  Proof.
        induction n. simpl; tauto.
    simpl.
    intros [x|x];
    unfold enum_sum;
    rewrite count_app.
    assert (H' := @axiom A F x).
    rewrite <- H'.
    match goal with
      |- ?x + ?y = _ => replace y with 0
    end.
    Require Import Arith.
    rewrite plus_0_r.
    apply count_map.
    intros a.
    do 2 case _eqr; try  reflexivity; intros; subst; try tauto.
    injection e. tauto.

    symmetry.
    clear. induction (enum_sumn n); simpl; try reflexivity.
    case _eqr.     intros; discriminate. intros. auto.

    match goal with
      |- ?y + ?x = _ => replace y with 0
    end.
    Require Import Arith.
    rewrite plus_0_l.
    rewrite <- (IHn x).
    apply count_map.
    intros a.
    do 2 case _eqr; try  reflexivity; intros; subst; try tauto.
    injection e. tauto.

    symmetry.
    clear. induction (enum A); simpl; try reflexivity.
    case _eqr.     intros; discriminate. intros. auto.
  Qed.
  Global Instance Fin_sumn {n} : Fin (sumn A n) :=
    {|
      eq_fin := local;
      enum := enum_sumn n
    |}.
  Proof.
    apply fin_sumn_axiom.
  Defined.
End Fin_sumn.


Require Import List.
Import ListNotations.

(* elementary category *)
Definition elem_cat: Type := nat.

Inductive formula :=
| var (a: elem_cat)
| leftDiv (a b: formula)
| rightDiv (a b: formula)
| mul (a b: formula).

Notation "x ° y" := (mul x y) (at level 40, left associativity).
Notation "x // y" := (rightDiv x y) (at level 40, no associativity).
Notation "x \\ y" := (leftDiv x y) (at level 40, no associativity).

Definition str := list formula.
Definition sequent: Type := (str * formula).

Definition nonEmptySequent (s: sequent) :=
  match s with
    (x, A) => x <> []
  end.

Notation "s ⇒ c" := (s, c) (at level 50, no associativity).

Inductive genProof (Γ: list sequent): sequent -> Prop :=
| inGamma (s: sequent) (_: In s Γ) (_: nonEmptySequent s): genProof Γ s
| identity (a: formula): genProof Γ ([a], a)
| leftArrow (y: str) (X: formula) (x: str) (A B: formula) (z: str) (C: formula)
            (p1: genProof Γ ((X::x) ⇒ A))
            (p2: genProof Γ ((y ++ B :: z) ⇒ C))
  : genProof Γ ((y ++ (X::x) ++ (A \\ B) :: z) ⇒ C)
| arrowLeft (X: formula) (x: str) (A B: formula) (p: genProof Γ ((A :: X :: x), B))
  : genProof Γ ((X::x) ⇒ A \\ B)
| rightArrow (y: str) (B A: formula) (X: formula) (x z: str) (C: formula)
             (p1: genProof Γ ((X::x) ⇒ A))
             (p2: genProof Γ ((y ++ B::z) ⇒ C))
  : genProof Γ ((y ++ (B // A) :: X :: x ++ z) ⇒ C)
| arrowRight (X: formula) (x: str) (A B: formula) (p: genProof Γ ((X :: x ++ [A]) ⇒ B))
  : genProof Γ ((X::x) ⇒ B // A)
| mulArrow (x: str) (A B: formula) (y: str) (C: formula)
           (p: genProof Γ ((x ++ A :: B :: y) ⇒ C))
  : genProof Γ ((x ++ (A ° B) :: y) ⇒ C)
| arrowMul (X: formula) (x: str) (Y: formula) (y: str) (A B: formula)
           (p1: genProof Γ ((X::x) ⇒ A))
           (p2: genProof Γ ((Y::y) ⇒ B))
  : genProof Γ ((X :: x ++ Y :: y) ⇒ A ° B).

Definition proofWithNonEmptyPremises (Γ: list sequent) (s: sequent): Prop :=
  (forall (s': sequent), In s' Γ -> nonEmptySequent s') /\
  genProof Γ s.

Notation "Γ ⊢ s" := (proofWithNonEmptyPremises Γ s) (at level 60, no associativity).


Module RedBlackTree.

Inductive Color: Set := Red | Black.

Inductive Node {T: Type}: Type :=
  | make_node: Color -> T -> Node.

Definition GetColor {T: Type} (n: @Node T): Color :=
  match n with
  | make_node Red _ => Red
  | make_node Black _ => Black
  end.

Definition NatNode: Set := @Node nat.

Example redTwo: NatNode := make_node Red 2.
Example blackThree: NatNode := make_node Black 3.

Compute GetColor redTwo.
Compute GetColor blackThree.

Record Tree (T: Type): Type := make_tree {
  get_root: @Node T
}.

Example twoTree: Tree nat := make_tree nat redTwo.


Require Import HSet WildCat.
Require Import Groups.QuotientGroup Groups.ShortExactSequence.
Require Import AbelianGroup AbGroups.Biproduct AbHom.
Require Import Homotopy.ExactSequence Pointed.
Require Import Modalities.ReflectiveSubuniverse.

Local Open Scope pointed_scope.
Local Open Scope type_scope.
Local Open Scope mc_add_scope.

(** * Short exact sequences of abelian groups *)

(** A short exact sequence of abelian groups consists of a monomorphism [i : A -> E] and an epimorphism [p : E -> B] such that the image of [i] equals the kernel of [p]. Later we will consider short exact sequences up to isomorphism by 0-truncating the type [AbSES] defined below. An isomorphism class of short exact sequences is called an extension. *)

Declare Scope abses_scope.
Local Open Scope abses_scope.

(** The type of short exact sequences [A -> E -> B] of abelian groups. We decorate it with (') to reserve the undecorated name for the structured version. *)
Record AbSES' {B A : AbGroup@{u}} := Build_AbSES {
    middle :  AbGroup@{u};
    inclusion : A $-> middle;
    projection : middle $-> B;
    isembedding_inclusion : IsEmbedding inclusion;
    issurjection_projection : IsSurjection projection;
    isexact_inclusion_projection : IsExact (Tr (-1)) inclusion projection;
  }.

(** Given a short exact sequence [A -> E -> B : AbSES B A], we coerce it to [E]. *)
Coercion middle : AbSES' >-> AbGroup.

Global Existing Instances isembedding_inclusion issurjection_projection isexact_inclusion_projection.

Arguments AbSES' B A : clear implicits.
Arguments Build_AbSES {B A}.

(** TODO Figure out why printing this term eats memory and seems to never finish. *)
Local Definition issig_abses_do_not_print {B A : AbGroup} : _ <~> AbSES' B A := ltac:(issig).

(** [make_equiv] is slow if used in the context of the next result, so we give the abstract form of the goal here. *)
Local Definition issig_abses_helper {AG : Type} {P : AG -> Type} {Q : AG -> Type}
      {R : forall E, P E -> Type} {S : forall E, Q E -> Type} {T : forall E, P E -> Q E -> Type}
  : {X : {E : AG & P E * Q E} & R _ (fst X.2) * S _ (snd X.2) * T _ (fst X.2) (snd X.2)}
      <~> {E : AG & {H0 : P E & {H1 : Q E & {_ : R _ H0 & {_ : S _ H1 & T _ H0 H1}}}}}
  := ltac:(make_equiv).

(** A more useful organization of [AbSES'] as a sigma-type. *)
Definition issig_abses {B A : AbGroup}
  : {X : {E : AbGroup & (A $-> E) * (E $-> B)} &
           (IsEmbedding (fst X.2)
            * IsSurjection (snd X.2)
            * IsExact (Tr (-1)) (fst X.2) (snd X.2))}
      <~> AbSES' B A
  := issig_abses_do_not_print oE issig_abses_helper.

Definition iscomplex_abses {A B : AbGroup} (E : AbSES' B A)
  : IsComplex (inclusion E) (projection E)
  := cx_isexact.

(** [AbSES' B A] is pointed by the split sequence [A -> A+B -> B]. *)
Global Instance ispointed_abses {B A : AbGroup@{u}}
  : IsPointed (AbSES' B A).
Proof.
  rapply (Build_AbSES (ab_biprod A B) ab_biprod_inl ab_biprod_pr2).
  snrapply Build_IsExact.
  - srapply phomotopy_homotopy_hset; reflexivity.
  - intros [[a b] p]; cbn; cbn in p.
    rapply contr_inhabited_hprop.
    apply tr.
    exists a.
    rapply path_sigma_hprop; cbn.
    exact (path_prod' idpath p^).
Defined.

(** The pointed type of short exact sequences. *)
Definition AbSES (B A : AbGroup@{u}) : pType
  := [AbSES' B A, _].

(** ** Paths in [AbSES B A] *)

Definition abses_path_data_iso
  {B A : AbGroup@{u}} (E F : AbSES B A)
  := {phi : GroupIsomorphism E F
            & (phi $o inclusion _ == inclusion _)
              * (projection _ == projection _ $o phi)}.

(** Having the path data in a slightly different form is useful for [equiv_path_abses_iso]. *)
Local Lemma shuffle_abses_path_data_iso `{Funext}
  {B A : AbGroup@{u}} (E F : AbSES B A)
  : (abses_path_data_iso E F)
      <~> {phi : GroupIsomorphism E F
                 & (phi $o inclusion _ == inclusion _)
                   * (projection _ $o grp_iso_inverse phi
                      == projection _)}.
Proof.
  srapply equiv_functor_sigma_id; intro phi.
  srapply equiv_functor_prod'.
  1: exact equiv_idmap.
  srapply (equiv_functor_forall' phi^-1); intro e; cbn.
  apply equiv_concat_r.
  exact (ap _ (eisretr _ _)).
Defined.

(** Paths in [AbSES] correspond to isomorphisms between the [middle]s respecting [inclusion] and [projection]. Below we prove the stronger statement [equiv_path_abses], which uses this result. *)
Proposition equiv_path_abses_iso `{Univalence}
  {B A : AbGroup@{u}} {E F : AbSES' B A}
  : abses_path_data_iso E F <~> E = F.
Proof.
  refine (_ oE shuffle_abses_path_data_iso E F).
  refine (equiv_ap_inv issig_abses _ _ oE _).
  refine (equiv_path_sigma_hprop _ _ oE _).
  refine (equiv_path_sigma _ _ _ oE _).
  srapply equiv_functor_sigma'.
  1: exact equiv_path_abgroup.
  intro q; lazy beta.
  snrefine (equiv_concat_l _ _ oE _).
  1: exact (q $o inclusion _, projection _ $o grp_iso_inverse q).
  2: { refine (equiv_path_prod _ _ oE _).
       exact (equiv_functor_prod'
                equiv_path_grouphomomorphism
                equiv_path_grouphomomorphism). }
  refine (transport_prod _ _ @ _).
  apply path_prod'.
  - apply transport_iso_abgrouphomomorphism_from_const.
  - apply transport_iso_abgrouphomomorphism_to_const.
Defined.

(** It follows that [AbSES B A] is 1-truncated. *)
Global Instance istrunc_abses `{Univalence} {B A : AbGroup@{u}}
  : IsTrunc 1 (AbSES B A).
Proof.
  intros E F.
  refine (istrunc_equiv_istrunc _ equiv_path_abses_iso (n:=0)).
  rapply istrunc_sigma.
  apply ishset_groupisomorphism.
Defined.

Definition path_abses_iso `{Univalence} {B A : AbGroup@{u}}
  {E F : AbSES B A}
  (phi : GroupIsomorphism E F) (p : phi $o inclusion _ == inclusion _)
  (q : projection _ == projection _ $o phi)
  : E = F := equiv_path_abses_iso (phi; (p,q)).

(** Given [p] and [q], the map [phi] just above is automatically an isomorphism. Showing this requires the "short five lemma." *)

(** A special case of the "short 5-lemma" where the two outer maps are (definitionally) identities. *)
Lemma short_five_lemma {B A : AbGroup@{u}}
  {E F : AbSES B A} (phi : GroupHomomorphism E F)
  (p0 : phi $o inclusion E == inclusion F) (p1 : projection E == projection F $o phi)
  : IsEquiv phi.
Proof.
  apply isequiv_surj_emb.
  - intro f.
    rapply contr_inhabited_hprop.
    (** Since [projection E] is epi, we can pull [projection F f] back to [e0 : E].*)
    assert (e0 : Tr (-1) (hfiber (projection E) (projection F f))).
    1: apply issurjection_projection.
    strip_truncations.
    (** The difference [f - (phi e0.1)] is sent to [0] by [projection F], hence lies in [A]. *)
    assert (a : Tr (-1) (hfiber (inclusion F) (f + (- phi e0.1)))).
    1: { refine (isexact_preimage (Tr (-1)) (inclusion F) (projection F) _ _).
         refine (grp_homo_op _ _ _ @ _).
         refine (ap _ (grp_homo_inv _ _) @ _).
         apply (grp_moveL_1M)^-1.
         exact (e0.2^ @ p1 e0.1). }
    strip_truncations.
    refine (tr (inclusion E a.1 + e0.1; _)).
    refine (grp_homo_op _ _ _ @ _).
    refine (ap (fun x => x + phi e0.1) (p0 a.1 @ a.2) @ _).
    refine ((grp_assoc _ _ _)^ @ _).
    refine (ap _ (left_inverse (phi e0.1)) @ _).
    apply grp_unit_r.
  - apply isembedding_grouphomomorphism.
    intros e p.
    assert (a : Tr (-1) (hfiber (inclusion E) e)).
    1: { refine (isexact_preimage _ (inclusion E) (projection E) _ _).
         exact (p1 e @ ap (projection F) p @ grp_homo_unit _). }
    strip_truncations.
    refine (a.2^ @ ap (inclusion E ) _ @ grp_homo_unit (inclusion E)).
    rapply (isinj_embedding (inclusion F) _ _).
    refine ((p0 a.1)^ @ (ap phi a.2) @ p @ (grp_homo_unit _)^).
Defined.

(** Below we prove that homomorphisms respecting [projection] and [inclusion] correspond to paths in [AbSES B A]. We refer to such homomorphisms simply as path data in [AbSES B A]. *)
Definition abses_path_data {B A : AbGroup@{u}} (E F : AbSES B A)
  := {phi : GroupHomomorphism E F
            & (phi $o inclusion _ == inclusion _)
              * (projection _ == projection _ $o phi)}.

Definition abses_path_data_to_iso `{Funext} {B A : AbGroup@{u}} (E F: AbSES B A)
  : abses_path_data E F -> abses_path_data_iso E F.
Proof.
  - intros [phi [p q]].
    exact ({| grp_iso_homo := phi; isequiv_group_iso := short_five_lemma phi p q |}; (p, q)).
Defined.

Proposition equiv_path_abses_data `{Funext} {B A : AbGroup@{u}} (E F: AbSES B A)
  : abses_path_data E F <~> abses_path_data_iso E F.
Proof.
  srapply equiv_adjointify.
  - apply abses_path_data_to_iso.
  - srapply (functor_sigma (grp_iso_homo _ _)).
    exact (fun _ => idmap).
  - intros [phi [p q]].
    apply path_sigma_hprop.
    by apply equiv_path_groupisomorphism.
  - reflexivity.
Defined.

Definition equiv_path_abses `{Univalence} {B A : AbGroup@{u}} {E F : AbSES B A}
  : abses_path_data E F <~> E = F
  := equiv_path_abses_iso oE equiv_path_abses_data E F.

Definition path_abses `{Univalence} {B A : AbGroup@{u}}
  {E F : AbSES B A} (phi : middle E $-> F)
  (p : phi $o inclusion _ == inclusion _) (q : projection _ == projection _ $o phi)
  : E = F := equiv_path_abses (phi; (p,q)).

(** *** The wildcat of short exact sequences *)

Global Instance isgraph_abses_path_data {A B : AbGroup@{u}} (E F : AbSES B A)
  : IsGraph (abses_path_data_iso E F)
  := isgraph_induced (grp_iso_homo _ _ o pr1).

Global Instance is01cat_abses_path_data {A B : AbGroup@{u}} (E F : AbSES B A)
  : Is01Cat (abses_path_data_iso E F)
  := is01cat_induced (grp_iso_homo _ _ o pr1).

Global Instance is0gpd_abses_path_data {A B : AbGroup@{u}} (E F : AbSES B A)
  : Is0Gpd (abses_path_data_iso E F)
  := is0gpd_induced (grp_iso_homo _ _ o pr1).

Global Instance isgraph_abses {A B : AbGroup@{u}} : IsGraph (AbSES B A)
  := Build_IsGraph _ abses_path_data_iso.

(** The path data corresponding to [idpath]. *)
Definition abses_path_data_1 {B A : AbGroup@{u}} (E : AbSES B A)
  : E $-> E := (grp_iso_id; (fun _ => idpath, fun _ => idpath)).

(** We can compose path data in [AbSES B A]. *)
Definition abses_path_data_compose {B A : AbGroup@{u}} {E F G : AbSES B A}
           (p : E $-> F) (q : F $-> G) : E $-> G
  := (q.1 $oE p.1; ((fun x => ap q.1 (fst p.2 x) @ fst q.2 x),
                     (fun x => snd p.2 x @ snd q.2 (p.1 x)))).

Global Instance is01cat_abses {A B : AbGroup@{u}}
  : Is01Cat (AbSES B A)
  := Build_Is01Cat _ _ abses_path_data_1
       (fun _ _ _ q p => abses_path_data_compose p q).

Definition abses_path_data_inverse
  {B A : AbGroup@{u}} {E F : AbSES B A}
  : (E $-> F) -> (F $-> E).
Proof.
  intros [phi [p q]].
  srefine (_; (_,_)).
  - exact (grp_iso_inverse phi).
  - intro a.
    exact (ap _ (p a)^ @ eissect _ (inclusion E a)).
  - intro a; simpl.
    exact (ap (projection F) (eisretr _ _)^ @ (q _)^).
Defined.

Global Instance is0gpd_abses
  {A B : AbGroup@{u}} : Is0Gpd (AbSES B A)
  := {| gpd_rev := fun _ _ => abses_path_data_inverse |}.

Global Instance is2graph_abses
  {A B : AbGroup@{u}} : Is2Graph (AbSES B A)
  := fun E F => isgraph_abses_path_data E F.

(** [AbSES B A] forms a 1Cat *)
Global Instance is1cat_abses {A B : AbGroup@{u}}
  : Is1Cat (AbSES B A).
Proof.
  snrapply Build_Is1Cat.
  1: intros ? ?; apply is01cat_abses_path_data.
  1: intros ? ?; apply is0gpd_abses_path_data.
  3-5: cbn; reflexivity.
  1,2: intros E F G f;
  srapply Build_Is0Functor;
  intros p q h e; cbn.
  - exact (ap f.1 (h e)).
  - exact (h (f.1 e)).
Defined.

Global Instance is1gpd_abses {A B : AbGroup@{u}}
  : Is1Gpd (AbSES B A).
Proof.
  rapply Build_Is1Gpd;
    intros E F p e; cbn.
  - apply eissect.
  - apply eisretr.
Defined.

Global Instance hasmorext_abses `{Funext} {A B : AbGroup@{u}}
  : HasMorExt (AbSES B A).
Proof.
  srapply Build_HasMorExt;
    intros E F f g.
  srapply isequiv_homotopic'; cbn.
  1: exact (((equiv_path_groupisomorphism _ _)^-1%equiv)
              oE (equiv_path_sigma_hprop _ _)^-1%equiv).
  intro p; by induction p.
Defined.

(** *** Path data lemmas *)

(** We need to be able to work with path data as if they're paths. Our preference is to state things in terms of [abses_path_data_iso], since this lets us keep track of isomorphisms whose inverses compute. The "abstract" inverses produced by [short_five_lemma] do not compute well. *)

Definition equiv_path_abses_1 `{Univalence} {B A : AbGroup@{u}} {E : AbSES B A}
  : equiv_path_abses_iso (abses_path_data_1 E) = idpath.
Proof.
  apply (equiv_ap_inv' equiv_path_abses_iso).
  refine (eissect _ _ @ _).
  srapply path_sigma_hprop; simpl.
  srapply equiv_path_groupisomorphism.
  reflexivity.
Defined.

Definition equiv_path_absesV_1 `{Univalence} {B A : AbGroup@{u}} {E : AbSES B A}
  : (@equiv_path_abses_iso _ B A E E)^-1 idpath = Id E.
Proof.
  apply moveR_equiv_M; symmetry.
  apply equiv_path_abses_1.
Defined.

Definition abses_path_data_V `{Univalence} {B A : AbGroup@{u}} {E F : AbSES B A}
           (p : abses_path_data_iso E F)
  : (equiv_path_abses_iso p)^ = equiv_path_abses_iso (abses_path_data_inverse p).
Proof.
  revert p.
  equiv_intro (equiv_path_abses_iso (E:=E) (F:=F))^-1 p; induction p.
  refine (ap _ (eisretr _ _) @ _); symmetry.
  nrefine (ap (equiv_path_abses_iso o abses_path_data_inverse) equiv_path_absesV_1 @ _).
  refine (ap equiv_path_abses_iso gpd_strong_rev_1 @ _).
  exact equiv_path_abses_1.
Defined.

(** Composition of path data corresponds to composition of paths. *)
Definition abses_path_compose_beta `{Univalence} {B A : AbGroup@{u}} {E F G : AbSES B A}
          (p : E = F) (q : F = G)
 : p @ q = equiv_path_abses_iso
             (abses_path_data_compose
                (equiv_path_abses_iso^-1 p) (equiv_path_abses_iso^-1 q)).
Proof.
  induction p, q.
  refine (equiv_path_abses_1^ @ _).
  apply (ap equiv_path_abses_iso).
  apply path_sigma_hprop.
  by apply equiv_path_groupisomorphism.
Defined.

(** A second beta-principle where you start with path data instead of actual paths. *)
Definition abses_path_data_compose_beta `{Univalence} {B A : AbGroup@{u}} {E F G : AbSES B A}
           (p : abses_path_data_iso E F) (q : abses_path_data_iso F G)
  : equiv_path_abses_iso p @ equiv_path_abses_iso q
    = equiv_path_abses_iso (abses_path_data_compose p q).
Proof.
  generalize p, q.
  equiv_intro ((equiv_path_abses_iso (E:=E) (F:=F))^-1) x.
  equiv_intro ((equiv_path_abses_iso (E:=F) (F:=G))^-1) y.
  refine ((eisretr _ _ @@ eisretr _ _) @ _).
  rapply abses_path_compose_beta.
Defined.

(** *** Homotopies of path data *)

Definition equiv_path_data_homotopy `{Univalence} {X : Type} {B A : AbGroup@{u}}
           (f g : X -> AbSES B A) : (f $=> g) <~> f == g.
Proof.
  srapply equiv_functor_forall_id; intro x; cbn.
  srapply equiv_path_abses_iso.
Defined.

Definition pmap_abses_const {B' A' B A : AbGroup@{u}} : AbSES B A -->* AbSES B' A'
  := Build_BasepointPreservingFunctor (const pt) (Id pt).

Definition to_pointed `{Univalence} {B' A' B A : AbGroup@{u}}
  : (AbSES B A -->* AbSES B' A') -> (AbSES B A ->* AbSES B' A')
  := fun f => Build_pMap _ _ f (equiv_path_abses_iso (bp_pointed f)).

Lemma pmap_abses_const_to_pointed `{Univalence} {B' A' B A : AbGroup@{u}}
  : pconst ==* to_pointed (@pmap_abses_const B' A' B A).
Proof.
  srapply Build_pHomotopy.
  1: reflexivity.
  apply moveL_pV.
  refine (concat_1p _ @ _).
  apply equiv_path_abses_1.
Defined.

Lemma abses_ap_fmap `{Univalence} {B0 B1 A0 A1 : AbGroup@{u}}
      (f : AbSES B0 A0 -> AbSES B1 A1) `{!Is0Functor f, !Is1Functor f}
      {E F : AbSES B0 A0} (p : E $== F)
  : ap f (equiv_path_abses_iso p) = equiv_path_abses_iso (fmap f p).
Proof.
  revert p.
  apply (equiv_ind equiv_path_abses_iso^-1%equiv);
    intro p.
  induction p.
  refine (ap (ap f) (eisretr _ _) @ _).
  nrefine (_ @ ap equiv_path_abses_iso _).
  2: { rapply path_hom.
       srefine (_ $@ fmap2 _ _).
       2: exact (Id E).
       2: intro x; reflexivity.
       exact (fmap_id f _)^$. }
  exact equiv_path_abses_1^.
Defined.

Definition to_pointed_compose `{Univalence} {B0 B1 B2 A0 A1 A2 : AbGroup@{u}}
           (f : AbSES B0 A0 -->* AbSES B1 A1) (g : AbSES B1 A1 -->* AbSES B2 A2)
           `{!Is1Functor f, !Is1Functor g}
  : to_pointed g o* to_pointed f ==* to_pointed (g $o* f).
Proof.
  srapply Build_pHomotopy.
  1: reflexivity.
  lazy beta.
  nrapply moveL_pV.
  nrefine (concat_1p _ @ _).
  unfold pmap_compose, Build_pMap, pointed_fun, point_eq, dpoint_eq.
  refine (_ @ ap (fun x => x @ _) _^).
  2: apply (abses_ap_fmap g).
  nrefine (_ @ (abses_path_data_compose_beta _ _)^).
  nrapply (ap equiv_path_abses_iso).
  rapply path_hom.
  reflexivity.
Defined.

Definition equiv_ptransformation_phomotopy `{Univalence} {B' A' B A : AbGroup@{u}}
           {f g : AbSES B A -->* AbSES B' A'}
  : f $=>* g <~> to_pointed f ==* to_pointed g.
Proof.
  refine (issig_pforall _ _ oE _).
  apply (equiv_functor_sigma' (equiv_path_data_homotopy f g)); intro h.
  refine (equiv_concat_r _ _ oE _).
  1: exact ((abses_path_data_compose_beta _ _)^ @ ap (fun x => _ @ x) (abses_path_data_V _)^).
  refine (equiv_ap' equiv_path_abses_iso _ _ oE _).
  refine (equiv_path_sigma_hprop _ _ oE _).
  apply equiv_path_groupisomorphism.
Defined.

(** *** Characterisation of loops of short exact sequences *)

(** Endomorphisms of the trivial short exact sequence in [AbSES B A] correspond to homomorphisms [B -> A]. *)
Lemma abses_endomorphism_trivial `{Funext} {B A : AbGroup@{u}}
  : {phi : GroupHomomorphism (point (AbSES B A)) (point (AbSES B A)) &
             (phi o inclusion _ == inclusion _)
             * (projection _ == projection _ o phi)}
      <~> (B $-> A).
Proof.
  srapply equiv_adjointify.
  - intros [phi _].
    exact (ab_biprod_pr1 $o phi $o ab_biprod_inr).
  - intro f.
    snrefine (_;_).
    + refine (ab_biprod_rec ab_biprod_inl _).
      refine (ab_biprod_corec f grp_homo_id).
    + split; intro x; cbn.
      * apply path_prod; cbn.
        -- exact (ap _ (grp_homo_unit f) @ right_identity _).
        -- exact (right_identity _).
      * exact (left_identity _)^.
  - intro f.
    rapply equiv_path_grouphomomorphism; intro b; cbn.
    exact (left_identity _).
  - intros [phi [p q]].
    apply path_sigma_hprop; cbn.
    rapply equiv_path_grouphomomorphism; intros [a b]; cbn.
    apply path_prod; cbn.
    + rewrite (ab_biprod_decompose a b).
      refine (_ @ (grp_homo_op (ab_biprod_pr1 $o phi) _ _)^).
      apply grp_cancelR; symmetry.
      exact (ap fst (p a)).
    + rewrite (ab_biprod_decompose a b).
      refine (_ @ (grp_homo_op (ab_biprod_pr2 $o phi) _ _)^); cbn; symmetry.
      exact (ap011 _ (ap snd (p a)) (q (group_unit, b))^).
Defined.

(** Consequently, the loop space of [AbSES B A] is [GroupHomomorphism B A]. (In fact, [B $-> A] are the loops of any short exact sequence, but the trivial case is easiest to show.) *)
Definition loops_abses `{Univalence} {A B : AbGroup}
  : (B $-> A) <~> loops (AbSES B A)
  := equiv_path_abses oE abses_endomorphism_trivial^-1.

(** We can transfer a loop of the trivial short exact sequence to any other. *)
Definition hom_loops_data_abses `{Univalence} {A B : AbGroup} (E : AbSES B A)
  : (B $-> A) -> abses_path_data E E.
Proof.
  intro phi.
  srefine (_; (_, _)).
  - exact (ab_homo_add grp_homo_id (inclusion E $o phi $o projection E)).
  - intro a; cbn.
    refine (ap (fun x => _ + inclusion E (phi x)) _ @ _).
    1: apply iscomplex_abses.
    refine (ap (fun x => _ + x) (grp_homo_unit (inclusion E $o phi)) @ _).
    apply grp_unit_r.
  - intro e; symmetry.
    refine (grp_homo_op (projection E) _ _ @ _); cbn.
    refine (ap (fun x => _ + x) _ @  _).
    1: apply iscomplex_abses.
    apply grp_unit_r.
Defined.

(** ** Morphisms of short exact sequences *)

(** A morphism between short exact sequences is a natural transformation between the underlying diagrams. *)
Record AbSESMorphism {A X B Y : AbGroup@{u}}
  {E : AbSES B A} {F : AbSES Y X} := {
    component1 : A $-> X;
    component2 : middle E $-> middle F;
    component3 : B $-> Y;
    left_square : (inclusion _) $o component1 == component2 $o (inclusion _);
    right_square : (projection _) $o component2 == component3 $o (projection _);
  }.

Arguments AbSESMorphism {A X B Y} E F.
Arguments Build_AbSESMorphism {_ _ _ _ _ _} _ _ _ _ _.

Definition issig_AbSESMorphism {A X B Y : AbGroup@{u}}
           {E : AbSES B A} {F : AbSES Y X}
  : { f : (A $-> X) * (middle E $-> middle F) * (B $-> Y)
          & ((inclusion _) $o (fst (fst f)) == (snd (fst f)) $o (inclusion _))
            * ((projection F) $o (snd (fst f)) == (snd f) $o (projection _)) }
      <~> AbSESMorphism E F := ltac:(make_equiv).

(** The identity morphism from [E] to [E]. *)
Lemma abses_morphism_id {A B : AbGroup@{u}} (E : AbSES B A)
  : AbSESMorphism E E.
Proof.
  snrapply (Build_AbSESMorphism grp_homo_id grp_homo_id grp_homo_id).
  1,2: reflexivity.
Defined.

Definition absesmorphism_compose {A0 A1 A2 B0 B1 B2 : AbGroup@{u}}
           {E : AbSES B0 A0} {F : AbSES B1 A1} {G : AbSES B2 A2}
           (g : AbSESMorphism F G) (f : AbSESMorphism E F)
  : AbSESMorphism E G.
Proof.
  rapply (Build_AbSESMorphism (component1 g $o component1 f)
                              (component2 g $o component2 f)
                              (component3 g $o component3 f)).
  - intro x; cbn.
    exact (left_square g _ @ ap _ (left_square f _)).
  - intro x; cbn.
    exact (right_square g _ @ ap _ (right_square f _)).
Defined.

(** ** Characterization of split short exact sequences *)

(* We characterize trivial short exact sequences in [AbSES] as those for which [projection] splits. *)

(** If [projection E] splits, we get an induced map [fun e => e - s (projection E e)] from [E] to [ab_kernel (projection E)]. *)
Definition projection_split_to_kernel {B A : AbGroup} (E : AbSES B A)
           {s : B $-> E} (h : projection _ $o s == idmap)
  : (middle E) $-> (@ab_kernel E B (projection _)).
Proof.
  snrapply (grp_kernel_corec (G:=E) (A:=E)).
  - refine (ab_homo_add grp_homo_id
              (grp_homo_compose ab_homo_negation (s $o (projection _)))).
  - intro x; simpl.
    refine (grp_homo_op (projection _) x _ @ _).
    refine (ap (fun y => (projection _) x + y) _ @ right_inverse ((projection _) x)).
    refine (grp_homo_inv _ _ @ ap (-) _ ).
    apply h.
Defined.

(** The composite [A -> E -> ab_kernel (projection E)] is [grp_cxfib]. *)
Lemma projection_split_to_kernel_beta {B A : AbGroup} (E : AbSES B A)
      {s : B $-> E} (h : (projection _) $o s == idmap)
  : (projection_split_to_kernel E h) $o (inclusion _) == grp_cxfib cx_isexact.
Proof.
  intro a.
  apply path_sigma_hprop; cbn.
  apply grp_cancelL1.
  refine (ap (fun x => - s x) _ @ _).
  1: rapply cx_isexact.
  exact (ap _ (grp_homo_unit _) @ negate_mon_unit).
Defined.

(** The induced map [E -> ab_kernel (projection E) + B] is an isomorphism. We suffix it with 1 since it is the first composite in the desired isomorphism [E -> A + B]. *)
Definition projection_split_iso1 {B A : AbGroup} (E : AbSES B A)
           {s : GroupHomomorphism B E} (h : (projection _) $o s == idmap)
  : GroupIsomorphism E (ab_biprod (@ab_kernel E B (projection _)) B).
Proof.
  srapply Build_GroupIsomorphism.
  - refine (ab_biprod_corec _ (projection _)).
    exact (projection_split_to_kernel E h).
  - srapply isequiv_adjointify.
    + refine (ab_biprod_rec _ s).
      rapply subgroup_incl.
    + intros [a b]; simpl.
      apply path_prod'.
      * srapply path_sigma_hprop; cbn.
        refine ((associativity _ _ _)^ @ _).
        apply grp_cancelL1.
        refine (ap _ _ @ right_inverse _).
        apply (ap (-)).
        apply (ap s).
        refine (grp_homo_op (projection _) a.1 (s b) @ _).
        exact (ap (fun y => y + _) a.2 @ left_identity _ @ h b).
      * refine (grp_homo_op (projection _) a.1 (s b) @ _).
        exact (ap (fun y => y + _) a.2 @ left_identity _ @ h b).
    + intro e; simpl.
      by apply grp_moveR_gM.
Defined.

(** The full isomorphism [E -> A + B]. *)
Definition projection_split_iso {B A : AbGroup@{u}}
  (E : AbSES B A) {s : GroupHomomorphism B E}
  (h : (projection _) $o s == idmap)
  : GroupIsomorphism E (ab_biprod A B).
Proof.
  etransitivity (ab_biprod (ab_kernel _) B).
  - exact (projection_split_iso1 E h).
  - srapply (equiv_functor_ab_biprod
               (grp_iso_inverse _) grp_iso_id).
    rapply grp_iso_cxfib.
Defined.

Proposition projection_split_beta {B A : AbGroup} (E : AbSES B A)
            {s : B $-> E} (h : (projection _) $o s == idmap)
  : projection_split_iso E h o (inclusion _) == ab_biprod_inl.
Proof.
  intro a.
  refine (ap _ (ab_corec_beta _ _ _ _) @ _).
  refine (ab_biprod_functor_beta _ _ _ _ _ @ _).
  nrapply path_prod'.
  2: rapply cx_isexact.
  refine (ap _ (projection_split_to_kernel_beta E h a) @ _).
  apply eissect.
Defined.

(** A short exact sequence [E] in [AbSES B A] is trivial if and only if [projection E] splits. *)
Proposition iff_abses_trivial_split `{Univalence}
  {B A : AbGroup@{u}} (E : AbSES B A)
  : {s : B $-> E & (projection _) $o s == idmap}
    <-> (E = point (AbSES B A)).
Proof.
  refine (iff_compose _ (iff_equiv equiv_path_abses_iso)); split.
  - intros [s h].
    exists (projection_split_iso E h).
    split.
    + nrapply projection_split_beta.
    + reflexivity.
  - intros [phi [g h]].
    exists (grp_homo_compose (grp_iso_inverse phi) ab_biprod_inr).
    intro x; cbn.
    exact (h _ @ ap snd (eisretr _ _)).
Defined.

(** ** Constructions of short exact sequences *)

(** Any inclusion [i : A $-> E] determines a short exact sequence by quotienting. *)
Definition abses_from_inclusion `{Univalence}
  {A E : AbGroup@{u}} (i : A $-> E) `{IsEmbedding i}
  : AbSES (QuotientAbGroup E (grp_image_embedding i)) A.
Proof.
  srapply (Build_AbSES E i).
  1: exact grp_quotient_map.
  1: exact _.
  srapply Build_IsExact.
  - srapply phomotopy_homotopy_hset.
    intro x.
    apply qglue; cbn.
    exists (-x).
    exact (grp_homo_inv _ _ @ (grp_unit_r _)^).
  - snrapply (conn_map_homotopic (Tr (-1)) (B:=grp_kernel (@grp_quotient_map E _))).
    + exact (grp_kernel_quotient_iso _ o ab_image_in_embedding i).
    + intro a.
      by rapply (isinj_embedding (subgroup_incl _)).
    + rapply conn_map_isequiv.
Defined.

(** Conversely, given a short exact sequence [A -> E -> B], [A] is the kernel of [E -> B]. (We don't need exactness at [B], so we drop this assumption.) *)
Lemma abses_kernel_iso `{Funext} {A E B : AbGroup} (i : A $-> E) (p : E $-> B)
  `{IsEmbedding i, IsExact (Tr (-1)) _ _ _ i p}
  : GroupIsomorphism A (ab_kernel p).
Proof.
  snrapply Build_GroupIsomorphism.
  - apply (grp_kernel_corec i).
    rapply cx_isexact.
  - apply isequiv_surj_emb.
    2: rapply (cancelL_mapinO _ (grp_kernel_corec _ _) _).
    intros [y q].
    assert (a : Tr (-1) (hfiber i y)).
    1: by rapply isexact_preimage.
    strip_truncations; destruct a as [a r].
    rapply contr_inhabited_hprop.
    refine (tr (a; _)); cbn.
    apply path_sigma_hprop; cbn.
    exact r.
Defined.

(** A computation rule for the inverse of [abses_kernel_iso i p]. *)
Lemma abses_kernel_iso_inv_beta `{Funext} {A E B : AbGroup} (i : A $-> E) (p : E $-> B)
  `{IsEmbedding i, IsExact (Tr (-1)) _ _ _ i p}
  : i o (abses_kernel_iso i p)^-1 == subgroup_incl _.
Proof.
  rapply (equiv_ind (abses_kernel_iso i p)); intro a.
  exact (ap i (eissect (abses_kernel_iso i p) _)).
Defined.

(* Any surjection [p : E $-> B] induces a short exact sequence by taking the kernel. *)
Lemma abses_from_surjection {E B : AbGroup@{u}} (p : E $-> B) `{IsSurjection p}
  : AbSES B (ab_kernel p).
Proof.
  srapply (Build_AbSES E _ p).
  1: exact (subgroup_incl _).
  1: exact _.
  snrapply Build_IsExact.
  - apply phomotopy_homotopy_hset.
    intros [e q]; cbn.
    exact q.
  - rapply conn_map_isequiv.
Defined.

(** Conversely, given a short exact sequence [A -> E -> B], [B] is the cokernel of [A -> E]. In fact, we don't need exactness at [A], so we drop this from the statement. *)
Lemma abses_cokernel_iso `{Funext}
  {A E B : AbGroup@{u}} (f : A $-> E) (g : GroupHomomorphism E B)
  `{IsSurjection g, IsExact (Tr (-1)) _ _ _ f g}
  : GroupIsomorphism (ab_cokernel f) B.
Proof.
  snrapply Build_GroupIsomorphism.
  - snrapply (quotient_abgroup_rec _ _ g).
    intros e; rapply Trunc_rec; intros [a p].
    refine (ap _ p^ @ _).
    rapply cx_isexact.
  - apply isequiv_surj_emb.
    1: rapply cancelR_conn_map.
    apply isembedding_isinj_hset.
    srapply Quotient_ind_hprop; intro x.
    srapply Quotient_ind_hprop; intro y.
    intro p.
    apply qglue; cbn.
    refine (isexact_preimage (Tr (-1)) _ _ (-x + y) _).
    refine (grp_homo_op _ _ _ @ _).
    rewrite grp_homo_inv.
    apply grp_moveL_M1^-1.
    exact p^.
Defined.

Definition abses_cokernel_iso_inv_beta `{Funext}
  {A E B : AbGroup} (f : A $-> E) (g : GroupHomomorphism E B)
  `{IsSurjection g, IsExact (Tr (-1)) _ _ _ f g}
  : (abses_cokernel_iso f g)^-1 o g == grp_quotient_map.
Proof.
  intro x; by apply moveR_equiv_V.
Defined.