(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Finite map library *)

(** This file proposes interfaces for finite maps *)

Require Export Bool DecidableType OrderedType.
Set Implicit Arguments.
Unset Strict Implicit.

(** When compared with Ocaml Map, this signature has been split in
    several parts :

   - The first parts [WSfun] and [WS] propose signatures for weak
     maps, which are maps with no ordering on the key type nor the
     data type.  [WSfun] and [WS] are almost identical, apart from the
     fact that [WSfun] is expressed in a functorial way whereas [WS]
     is self-contained. For obtaining an instance of such signatures,
     a decidable equality on keys in enough (see for example
     [FMapWeakList]). These signatures contain the usual operators
     (add, find, ...). The only function that asks for more is
     [equal], whose first argument should be a comparison on data.

   - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the
     case where the key type is ordered. The main novelty is that
     [elements] is required to produce sorted lists.

   - Finally, [Sord] extends [S] with a complete comparison function. For
     that, the data type should have a decidable total ordering as well.

   If unsure, what you're looking for is probably [S]: apart from [Sord],
   all other signatures are subsets of [S].

   Some additional differences with Ocaml:

    - no [iter] function, useless since Coq is purely functional
    - [option] types are used instead of [Not_found] exceptions
    - more functions are provided: [elements] and [cardinal] and [map2]

*)

Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.

(** ** Weak signature for maps

    No requirements for an ordering on keys nor elements, only decidability
    of equality on keys. First, a functorial signature: *)

Module Type WSfun (E : DecidableType).

  Definition key := E.t.
  Hint Transparent key.

  Parameter t : Type -> Type.
  (** the abstract type of maps *)

  Section Types.

    Variable elt:Type.

    Parameter empty : t elt.
    (** The empty map. *)

    Parameter is_empty : t elt -> bool.
    (** Test whether a map is empty or not. *)

    Parameter add : key -> elt -> t elt -> t elt.
    (** [add x y m] returns a map containing the same bindings as [m],
	plus a binding of [x] to [y]. If [x] was already bound in [m],
	its previous binding disappears. *)

    Parameter find : key -> t elt -> option elt.
    (** [find x m] returns the current binding of [x] in [m],
	or [None] if no such binding exists. *)

    Parameter remove : key -> t elt -> t elt.
    (** [remove x m] returns a map containing the same bindings as [m],
	except for [x] which is unbound in the returned map. *)

    Parameter mem : key -> t elt -> bool.
    (** [mem x m] returns [true] if [m] contains a binding for [x],
	and [false] otherwise. *)

    Variable elt' elt'' : Type.

    Parameter map : (elt -> elt') -> t elt -> t elt'.
    (** [map f m] returns a map with same domain as [m], where the associated
	value a of all bindings of [m] has been replaced by the result of the
	application of [f] to [a]. Since Coq is purely functional, the order
        in which the bindings are passed to [f] is irrelevant. *)

    Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
    (** Same as [map], but the function receives as arguments both the
	key and the associated value for each binding of the map. *)

    Parameter map2 :
     (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
    (** [map2 f m m'] creates a new map whose bindings belong to the ones
        of either [m] or [m']. The presence and value for a key [k] is
        determined by [f e e'] where [e] and [e'] are the (optional) bindings
        of [k] in [m] and [m']. *)

    Parameter elements : t elt -> list (key*elt).
    (** [elements m] returns an assoc list corresponding to the bindings
        of [m], in any order. *)

    Parameter cardinal : t elt -> nat.
    (** [cardinal m] returns the number of bindings in [m]. *)

    Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A.
    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
	where [k1] ... [kN] are the keys of all bindings in [m]
	(in any order), and [d1] ... [dN] are the associated data. *)

    Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal,
      that is, contain equal keys and associate them with equal data.
      [cmp] is the equality predicate used to compare the data associated
      with the keys. *)

    Section Spec.

      Variable m m' m'' : t elt.
      Variable x y z : key.
      Variable e e' : elt.

      Parameter MapsTo : key -> elt -> t elt -> Prop.

      Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.

      Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.

      Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').

      Definition eq_key_elt (p p':key*elt) :=
          E.eq (fst p) (fst p') /\ (snd p) = (snd p').

    (** Specification of [MapsTo] *)
      Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.

    (** Specification of [mem] *)
      Parameter mem_1 : In x m -> mem x m = true.
      Parameter mem_2 : mem x m = true -> In x m.

    (** Specification of [empty] *)
      Parameter empty_1 : Empty empty.

    (** Specification of [is_empty] *)
      Parameter is_empty_1 : Empty m -> is_empty m = true.
      Parameter is_empty_2 : is_empty m = true -> Empty m.

    (** Specification of [add] *)
      Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
      Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
      Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.

    (** Specification of [remove] *)
      Parameter remove_1 : E.eq x y -> ~ In y (remove x m).
      Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
      Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.

    (** Specification of [find] *)
      Parameter find_1 : MapsTo x e m -> find x m = Some e.
      Parameter find_2 : find x m = Some e -> MapsTo x e m.

    (** Specification of [elements] *)
      Parameter elements_1 :
        MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
      Parameter elements_2 :
        InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
      (** When compared with ordered maps, here comes the only
         property that is really weaker: *)
      Parameter elements_3w : NoDupA eq_key (elements m).

    (** Specification of [cardinal] *)
      Parameter cardinal_1 : cardinal m = length (elements m).

    (** Specification of [fold] *)
      Parameter fold_1 :
	forall (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.

    (** Equality of maps *)

    (** Caveat: there are at least three distinct equality predicates on maps.
      - The simpliest (and maybe most natural) way is to consider keys up to
        their equivalence [E.eq], but elements up to Leibniz equality, in
        the spirit of [eq_key_elt] above. This leads to predicate [Equal].
      - Unfortunately, this [Equal] predicate can't be used to describe
        the [equal] function, since this function (for compatibility with
        ocaml) expects a boolean comparison [cmp] that may identify more
        elements than Leibniz. So logical specification of [equal] is done
        via another predicate [Equivb]
      - This predicate [Equivb] is quite ad-hoc with its boolean [cmp],
        it can be generalized in a [Equiv] expecting a more general
        (possibly non-decidable) equality predicate on elements *)

     Definition Equal m m' := forall y, find y m = find y m'.
     Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
         (forall k, In k m <-> In k m') /\
         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
     Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp).

     (** Specification of [equal] *)

     Variable cmp : elt -> elt -> bool.

     Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
     Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'.

    End Spec.
   End Types.

    (** Specification of [map] *)
      Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
        MapsTo x e m -> MapsTo x (f e) (map f m).
      Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
        In x (map f m) -> In x m.

    (** Specification of [mapi] *)
      Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
      Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
        (f:key->elt->elt'), In x (mapi f m) -> In x m.

    (** Specification of [map2] *)
      Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
	In x m \/ In x m' ->
        find x (map2 f m m') = f (find x m) (find x m').

     Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
        In x (map2 f m m') -> In x m \/ In x m'.

  Hint Immediate MapsTo_1 mem_2 is_empty_2
    map_2 mapi_2 add_3 remove_3 find_2
    : map.
  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1
    remove_2 find_1 fold_1 map_1 mapi_1 mapi_2
    : map.

End WSfun.

(** ** Static signature for Weak Maps

    Similar to [WSfun] but expressed in a self-contained way. *)

Module Type WS.
  Declare Module E : DecidableType.
  Include WSfun E.
End WS.

(** ** Maps on ordered keys, functorial signature *)

Module Type Sfun (E : OrderedType).
  Include WSfun E.
  Section elt.
  Variable elt:Type.
   Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').
   (* Additional specification of [elements] *)
   Parameter elements_3 : forall m, sort lt_key (elements m).
   (** Remark: since [fold] is specified via [elements], this stronger
   specification of [elements] has an indirect impact on [fold],
   which can now be proved to receive elements in increasing order. *)
  End elt.
End Sfun.

(** ** Maps on ordered keys, self-contained signature *)

Module Type S.
  Declare Module E : OrderedType.
  Include Sfun E.
End S.

(** ** Maps with ordering both on keys and datas *)

Module Type Sord.

  Declare Module Data : OrderedType.
  Declare Module MapS : S.
  Import MapS.

  Definition t := MapS.t Data.t.

  Parameter eq : t -> t -> Prop.
  Parameter lt : t -> t -> Prop.

  Axiom eq_refl : forall m : t, eq m m.
  Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
  Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
  Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
  Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.

  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.

  Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
  Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.

  Parameter compare : forall m1 m2, Compare lt eq m1 m2.
  (** Total ordering between maps. [Data.compare] is a total ordering
      used to compare data associated with equal keys in the two maps. *)

End Sord.


Require Export Completeness.
Require Import UniformTopology.
Require Import RTopology.

(*Local Unset Standard Proposition Elimination Names.*)

Arguments injective {_ _} _.

Lemma completion_exists: forall (X:Type) (d:X->X->R) (d_metric:metric d),
  exists Y:Type, exists i:X->Y, exists d':Y->Y->R,
  exists d'_metric:metric d',
  (injective i) /\
  dense (Im Full_set i) (X:=MetricTopology d' d'_metric) /\
  (forall x1 x2:X, d' (i x1) (i x2) = d x1 x2) /\ complete d' d'_metric.
Proof.
intros.
cut (exists Y:Type, exists i:X->Y, exists d':Y->Y->R,
  exists d'_metric:metric d', injective i /\
  (forall x1 x2:X, d' (i x1) (i x2) = d x1 x2) /\
  complete d' d'_metric).
intros.
destruct H as [Y [i [d' [d'_metric [? []]]]]].
pose (F := closure (Im Full_set i) (X:=MetricTopology d' d'_metric)).
exists {y:Y | In F y}.
assert (forall x:X, In F (i x)).
intros.
apply closure_inflationary.
exists x; trivial.
constructor.
exists (fun x:X => exist _ (i x) (H2 x)).
exists (fun y1 y2 => d' (proj1_sig y1) (proj1_sig y2)).
assert (d'_metric0 : metric (fun (y1 y2:{y:Y | In F y}) =>
                       d' (proj1_sig y1) (proj1_sig y2))).
constructor; try destruct x; try destruct y; try destruct z; simpl;
  try apply d'_metric.
intros.
Require Import Proj1SigInjective.
apply subset_eq_compatT.
apply d'_metric; trivial.
exists d'_metric0.
repeat split.
red; intros.
injection H3; intros.
apply H; trivial.
red.
apply Extensionality_Ensembles; split; red; intros.
constructor.
simpl in x.
destruct x.
clear H3.
generalize i0.
apply first_countable_sequence_closure in i0.
destruct i0.
destruct H3.
assert (forall n:nat, { x:X | x0 n = i x }).
intros.
Require Import Description.
apply constructive_definite_description.
apply -> unique_existence.
split.
destruct (H3 n).
exists x1; trivial.
red; intros.
apply H.
rewrite H5 in H6; trivial.
assert (forall n:nat, In F (i (proj1_sig (X0 n)))).
intros; apply H2.
intros.
apply (@net_limit_in_closure nat_DS
  (MetricTopology _ d'_metric0)
  _ (fun n:nat => exist _ (i (proj1_sig (X0 n))) (H5 n))).
red; intros.
exists i1.
split.
simpl; auto with arith.
exists (proj1_sig (X0 i1)).
constructor.
apply subset_eq_compatT.
reflexivity.
pose proof (metric_space_net_limit_converse (MetricTopology d' d'_metric) d'
  (MetricTopology_metrizable _ d' d'_metric) nat_DS x0 x H4).
apply metric_space_net_limit with (1:=MetricTopology_metrizable _ _ d'_metric0).
intros.
destruct (H6 eps H7).
exists x1.
intros.
simpl.
destruct (X0 j).
simpl.
rewrite <- e.
apply H8; trivial.
apply metrizable_impl_first_countable.
exists d'; trivial.
apply MetricTopology_metrizable.

intros.
simpl.
apply H0.
apply (closed_subset_of_complete_is_complete Y d' d'_metric F);
  trivial.
apply closure_closed.

destruct (classic (inhabited X)).
destruct H as [x0].

assert (forall x y z:X, R_metric (d x z) (d y z) <= d x y).
unfold R_metric.
assert (forall a b:R, -b <= a -> a <= b -> Rabs a <= b).
intros.
unfold Rabs.
Require Import Fourier.
destruct Rcase_abs; fourier.
intros.
apply H.
assert (d x z <= d x y + d y z) by apply d_metric.
fourier.
rewrite (metric_sym _ _ d_metric x y).
assert (d y z <= d y x + d x z) by apply d_metric.
fourier.

exists (uniform_space R_metric (d x0)).
unshelve refine (let H0:=_ in ex_intro _ (fun x:X => exist _ (d x) (H0 x)) _).
intros.
exists (d x0 x).
red; intros.
destruct H0.
rewrite H1; trivial.
exists (uniform_metric R_metric (d x0) R_metric_is_metric
  (inhabits x0)).
exists (uniform_metric_is_metric _ _ _ _ _ _).
repeat split.
red; intros.
injection H1; intros.
apply d_metric.
rewrite H2; apply d_metric.

intros.
unfold uniform_metric; destruct sup; simpl.
apply Rle_antisym.
apply i.
red; intros.
destruct H1.
rewrite H2; apply H.
apply i.
exists x1.
constructor.
rewrite metric_zero; trivial.
unfold R_metric.
rewrite (metric_sym _ _ d_metric x2 x1).
rewrite Rminus_0_r.
symmetry; apply Rabs_right; apply d_metric.

apply uniform_metric_complete.
exact R_metric_complete.

exists False.
exists (fun x:X => H (inhabits x)).
exists (False_rect _).
assert (metric (False_rect (False->R))).
constructor; intros; destruct x.
exists H0.
repeat split.
red; intros.
contradiction (H (inhabits x1)).
intros.
contradiction (H (inhabits x1)).
red; intros.
contradiction (x O).

Qed.


Require Import HoTT.
From GR Require Import path_over globe_over.

Definition path_fam (A : Type)
  := {x : A & {y : A & (x = y) * (x = y)}}.

Definition lpath {A : Type} (p : path_fam A)
  := fst (p.2.2).

Definition rpath {A : Type} (p : path_fam A)
  := snd (p.2.2).

Module Export path_coeq.
  Private Inductive pCoeq {A B : Type} (P : B -> path_fam A) :=
  | pcoeq : A -> pCoeq P.

  Axiom pcp : forall {A B : Type}
                     {P : B -> path_fam A}
                     (b : B),
      globe (ap (pcoeq P) (lpath (P b))) (ap (pcoeq P) (rpath (P b))).

  Section pcoeq_ind.
    Variable (A B : Type)
             (P : B -> path_fam A)
             (Y : pCoeq P -> Type)
             (pcoeqY : forall (a : A), Y(pcoeq P a))
             (pcpY : forall (b : B),
                 globe_over Y
                            (pcp b)
                            (path_over_compose (pcoeq P) (apd_po pcoeqY (lpath (P b))))
                            (path_over_compose (pcoeq P) (apd_po pcoeqY (rpath (P b))))).

    Fixpoint pCoeq_ind (x : pCoeq P) : Y x
      := (match x with
          | pcoeq a => fun _ => pcoeqY a
          end) pcpY.
  End pcoeq_ind.
End path_coeq.


Lemma demorgan_dn P :
  (forall X (p : X -> Prop), ~ (forall x, ~ p x) -> exists x, p x) -> ~ ~ P -> P.
Proof.
  intros DM HP. destruct (@DM P (fun _ => True)).
  - intros H. tauto.
  - exact x.
Qed.

Require Import nd models.
Require Import List Lia.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Program.Equality.

(** * Enumerable Strong Completeness *)

Definition stable (T : theory) :=
  forall phi, ~ ~ T phi -> T phi.

Lemma Lindenbaum_stable {d: DerivationType} T phi :
  ~ T ⊢T phi -> stable (max T phi).
Proof.
  intros HT psi HP. destruct (decode_surj psi) as [n <-].
  exists (S n). right. split; trivial. intros H.
  apply HP. intros [k Hk]. assert (k <= n \/ n <= k) as [Hn|Hn] by lia.
  - apply (does_not_derive_i HT (i:=n)). apply (ndtW H).
    intros psi [->|]; trivial. now apply (maxn_subset_ij Hn).
  - apply (does_not_derive_i HT (i:=k)). apply (ndtW H).
    intros psi [->|]; trivial. now apply (maxn_subset_ij Hn).
Qed.

Section Models.
  Context {d : DerivationType}.

  Definition evalK' {M: KripkeModel} (Γ: theory) :=
    fun w => forall s, (Γ s) -> @evalK M s w.

  (**
    Being an IEL or IEL^- model is a property of a given model.
   **)
  Definition isIEL (M: KripkeModel) := forall w, exists w', verif w w'.

  Definition model_constraint (d : DerivationType) m :=
      if d then True else isIEL m.

  Definition entails {d: DerivationType} (Γ: theory) (φ: form) :=
    forall (M : KripkeModel), model_constraint d M ->
      ((forall w,evalK' Γ w -> @evalK M φ w)).

  Notation "Γ ⊨ φ" := (entails Γ φ) (at level 30).

  (** Evaluation is monotone, that is if φ is true at world w
      and we can reach world v from w, φ true at v.  *)
  Variable M : KripkeModel.

End Models.
(** ** Canonical models *)
Section Canonical.
  (**
We define the *canonical models*, whose worlds are the maximally consistent theories.
We first define the relations.
   **)
  Context {d : DerivationType}.

  Record mcTheory := mkmcTheory {
                         T: theory;
                         Ttheory: forall φ, (@ndT d T φ) -> T φ;
                         Tconsistent:  ~(T ⊥);
                         Tprime: is_primeDN T;
                         Tstable : stable T;
                       }.

  Definition lindenBaumTheory (Γ: theory) (φ: form) (H: ~(ndT Γ φ)) :mcTheory.
    destruct (Lindenbaum H).  destruct H1. destruct H2.

    apply mkmcTheory with (T := (max Γ φ)).
    + tauto.
    + intro. apply H1. apply ndtE. apply ndtA. assumption.
    + apply H2.
    + now apply Lindenbaum_stable.
  Defined.

  Lemma lindenBaumTheorySubset Γ (φ: form) (H: ~(ndT Γ φ)) : exists Δ: mcTheory ,Γ ⊆ (T Δ).
  Proof.
    exists (lindenBaumTheory H).
    simpl T. assert ( (T (lindenBaumTheory H)) = (max Γ φ)). cbv. firstorder.  unfold lindenBaumTheory. apply max_subset.
  Qed.

  Definition subsetMKT (A B: mcTheory) := subset (T A) (T B).
  Definition valuationMKT (A: mcTheory) (a: nat) := (T A) (Var a).

  Definition subsetVerif (A B:mcTheory) :=
    forall a, ((T A) (K a)) -> (T B) a.
  Instance canonical: (KripkeModel).
  Proof.
    apply mkKripkeModel with (world := mcTheory) (cogn := subsetMKT) (val := valuationMKT) (verif := subsetVerif).
    all: try firstorder.
    intros A B c d' E. apply Ttheory with (φ := d'). destruct B. simpl. apply ndtA. apply c. apply ndtA in E. apply ndtKpos in E.
      apply Ttheory in E. exact E.
  Defined.

  Lemma deductionGamma (Gamma: mcTheory) (phi: form):  ndT (T Gamma) phi <-> (T Gamma) phi.
  Proof.
    split.
    - intro. apply Ttheory in H. exact H.
    - apply ndtA.
  Qed.
  Hint Resolve deductionGamma : core.

  Lemma world_canonical_disjunction (t: mcTheory) ψ φ :
    ((T t) (φ ∨ ψ)) <-> ~ ~ ((ndT (T t) φ) \/ ndT (T t) ψ).
  Proof.
    intros. split.
    - intro. intros H'.
      eapply Tprime. intros H''.
      apply H'. apply H''.
      apply deductionGamma.
      exact H.
    - intro. apply Tstable. intros H'. apply H. intros []; apply H'.
      + apply deductionGamma. apply ndtDIL. eauto.
      + apply deductionGamma. apply ndtDIR. eauto.
  Qed.

End Canonical.

Lemma canonicalIEL : isIEL (@canonical normal).
Proof.
  intros w.
  assert (~(@ndT normal (unbox (T w)) ⊥)).
  {
    intros H % modalShiftingLemma.
    destruct w. apply Tconsistent0.
    apply @Ttheory0.
    apply @ndtIE with (s := (K ⊥)).
    - apply @ndtW with (T := empty).
      + apply IELKBot.
      + firstorder.
    - simpl T in H.  exact H.
  }
  exists (lindenBaumTheory H).
  intros x H1. simpl lindenBaumTheory.
  simpl T.
  apply max_subset.
  apply unbox_rewrite.
  exact H1.
Qed.

(** ** Strong Completeness *)
Section Completeness.

  Lemma DNS' : forall X (P : X -> Prop), ~ ~ (forall x, P x) -> (forall x, ~ ~ P x).
  Proof.
    intros. intuition.
  Qed.

  Lemma DN_imp (P Q : Prop) :
    (P -> ~ ~ Q) -> ~ ~ (P -> Q).
  Proof.
    tauto.
  Qed.

  Hypothesis DNS : forall X (P : X -> Prop), (forall x, ~ ~ P x) -> ~ ~ (forall x, P x).

  (** *** Truth-Lemma *)
  Lemma truth_lemma {d: DerivationType} : forall  (X: form) (t: (@world  canonical)),
    ~ ~ (evalK X t) <-> ((T t) X).
  Proof.
    intro x.
    induction x.
    - split.
      + intro H0. apply Tstable. intro H'.
        assert (H: ~ unbox (T t) ⊢T x).
        * intros H. now apply H', deductionGamma, modalShiftingLemma.
        * assert (exists Δ: mcTheory , (unbox (T t)) ⊆ (T Δ)
                                  /\ ~((T Δ) x)).
          {
            exists (lindenBaumTheory H).
            split.
            - apply max_subset.
            - intro. apply ndtA in H1.
              apply does_not_derive in H1; auto.
          }
          destruct H1. destruct H1.  apply H2.  apply IHx. intuition.
      + intros H. cbn. apply DNS. intros t'. apply DN_imp. intros H' H''.
        apply (IHx t'); trivial. now apply H'.
    - split.
      +
        intro.
        apply deductionGamma. rewrite deductionGamma. apply Tstable.
        intro.
        enough (exists Δ: mcTheory, (T t) ⊆ (T Δ) /\ ((T Δ) x1) /\ ~((T Δ) x2)). destruct H1 as [Δ H2].
        apply H. cbn. intros H'. specialize (H' Δ). destruct H2. destruct H2. firstorder eauto.
        rewrite<- deductionGamma in H0. rewrite ImpAgree in H0.
        destruct (Lindenbaum H0).
        exists (lindenBaumTheory H0).
        split. intros x H3. apply H1. now right.

        split.
        * apply deductionGamma. apply ndtW with  (x1#(T t)). apply ndtA. left.
          reflexivity. unfold lindenBaumTheory. cbn. apply max_subset.
        * rewrite<- deductionGamma. destruct H2. auto.
      + intros. cbn. apply DNS. intros t'. apply DN_imp. intros Ht. apply DN_imp.
        intros H'. apply IHx2. apply deductionGamma. apply ndtIE with (s := x1). apply deductionGamma. apply Ht, H.
        apply deductionGamma. apply IHx1. tauto.
    - split.
      + intro H.
        apply deductionGamma.
        apply ndtCI; apply ndtA.
        * apply IHx1. intuition.
        * apply IHx2. intuition.
      + intros H1 % deductionGamma H2.
        assert (HL : T t x1) by now apply deductionGamma, (ndtCEL H1).
        assert (HR : T t x2) by now apply deductionGamma, (ndtCER H1).
        apply (IHx1 t); trivial. intros H. apply (IHx2 t); trivial. intros H'.
        apply H2. cbn. split; trivial.
    - intro. simpl evalK. rewrite world_canonical_disjunction.
      repeat rewrite deductionGamma. rewrite <- IHx1. rewrite <- IHx2. tauto.

    - split.
      + cbn. tauto.
      + intro.  exfalso. apply (Tconsistent H).
    - split; intros H.
      + apply Tstable. apply H.
      + intros H'. apply H', H.
  Qed.

  Lemma StrongQuasiModelExistence' {d: DerivationType} (Gamma: theory) (phi: form):
    ~ Gamma ⊢T phi -> exists w : @world canonical, ~ ~ evalK' Gamma w /\ ~ evalK phi w.
  Proof.
    intros H. exists (lindenBaumTheory H). split.
    - apply DNS. intros psi. apply DN_imp. intros H'.
      apply truth_lemma. cbn. now apply max_subset.
    - intros H'. apply (does_not_derive H). apply ndtA.
      change (T (lindenBaumTheory H) phi). now apply truth_lemma.
  Qed.

  Lemma StrongQuasiModelExistence {d: DerivationType} (Gamma: theory) (phi: form):
    ~ Gamma ⊢T phi -> exists M (w : @world M), ~ ~ evalK' Gamma w /\ ~ evalK phi w.
  Proof.
    intros H. exists canonical. now apply StrongQuasiModelExistence'.
  Qed.

  Lemma StrongQuasiCompleteness {d: DerivationType} (Γ: theory) (φ: form):
    (entails Γ φ) -> ~ ~ Γ ⊢T φ.
  Proof.
    intros H1 H2. destruct (StrongQuasiModelExistence' H2) as [w[Hw1 Hw2]].
    apply Hw1. intros Hw1'. apply Hw2. apply H1; try apply Hw1'.
    destruct d eqn:deq; cbn; trivial. apply canonicalIEL.
  Qed.

  Hypothesis WLEM : forall P, ~ P \/ ~ ~ P.

  Lemma WLEM_truth_lemma {d: DerivationType} : forall (X: form) (t: (@world  canonical)),
    (evalK X t) <-> (T t) X.
  Proof.
    intro x.
     induction x.
     - split.
       + intro H0. apply Tstable. intro H'.
         assert (H: ~ unbox (T t) ⊢T x).
         * intros H. now apply H', deductionGamma, modalShiftingLemma.
         * assert (exists Δ: mcTheory , (unbox (T t)) ⊆ (T Δ)
                                   /\ ~((T Δ) x)).
           {
             exists (lindenBaumTheory H).
             split.
             - apply max_subset.
             - intro. apply ndtA in H1.
               apply does_not_derive in H1; auto.
           }
           destruct H1. destruct H1.  apply H2.  apply IHx. auto.

       + intros A. simpl evalK. intros r V. apply IHx. auto.
     - split.
       +
         intro.
         apply deductionGamma. rewrite deductionGamma. apply Tstable.
         intro.
         enough (exists Δ: mcTheory, (T t) ⊆ (T Δ) /\ ((T Δ) x1) /\ ~((T Δ) x2)). destruct H1 as [Δ H2].
         specialize (H Δ). destruct H2. destruct H2. apply H3. apply IHx2. (*apply H0.*) firstorder eauto.
         (*    apply IHx1. exact H2.  *)
         rewrite<- deductionGamma in H0. rewrite ImpAgree in H0.
         destruct (Lindenbaum H0).
         exists (lindenBaumTheory H0).
         split. intros x H3. firstorder eauto. split.
         * apply deductionGamma. apply ndtW with  (x1#(T t)). apply ndtA. left. reflexivity. unfold lindenBaumTheory. cbn. apply max_subset.
         * rewrite<- deductionGamma. destruct H2. auto.
       + intros. intros w H1 H2. apply IHx2. apply deductionGamma. apply ndtIE with (s := x1). apply deductionGamma. apply H1. exact H. apply deductionGamma. apply IHx1. exact H2.
     - split.
       + intro H.
         destruct H.
         apply deductionGamma.
         apply ndtCI; apply ndtA.
         * apply IHx1. exact H.
         *  apply IHx2. exact H0.
       + intros H1.  split.
         * apply deductionGamma in H1.  apply ndtCEL in H1. apply IHx1.
           apply deductionGamma.  auto.
         * apply deductionGamma in H1.  apply ndtCER in H1. apply IHx2.
           apply deductionGamma.  auto.
     - intro.  simpl evalK. rewrite world_canonical_disjunction. rewrite IHx1. rewrite IHx2.
       repeat rewrite deductionGamma. split; try tauto.
       destruct (WLEM (T t x1)) as [H1|H1].
       + intros H'. right. apply Tstable. tauto.
       + left. apply Tstable. tauto.
     - split.
       +
         intro. exfalso. apply H.
       + intro.  exfalso. apply (Tconsistent H).
     - split; firstorder.
  Qed.

  Lemma WLEMStrongQuasiModelExistence' {d: DerivationType} (Gamma: theory) (phi: form):
    ~ Gamma ⊢T phi -> exists w : @world canonical, evalK' Gamma w /\ ~ evalK phi w.
  Proof.
    intros H. exists (lindenBaumTheory H). split.
    - intros psi H'. apply WLEM_truth_lemma. cbn. now apply max_subset.
    - intros H'. apply (does_not_derive H). apply ndtA.
      change (T (lindenBaumTheory H) phi). now apply truth_lemma.
  Qed.

  Lemma WLEMStrongQuasiModelExistence {d: DerivationType} (Gamma: theory) (phi: form):
    ~ Gamma ⊢T phi -> exists M (w : @world M), evalK' Gamma w /\ ~ evalK phi w.
  Proof.
    intros H. exists canonical. now apply WLEMStrongQuasiModelExistence'.
  Qed.

  Lemma WLEMStrongQuasiCompleteness {d: DerivationType} (Γ: theory) (φ: form):
    (entails Γ φ) -> ~ ~ Γ ⊢T φ.
  Proof.
    intros H1 H2. destruct (WLEMStrongQuasiModelExistence' H2) as [w[Hw1 Hw2]].
    apply Hw2. apply H1; try apply Hw1.
    destruct d eqn:deq; cbn; trivial. apply canonicalIEL.
  Qed.

End Completeness.

Definition Neg phi :=
    Imp phi Bot.

Section WLEM.

  Context {D : DerivationType}.

  Variable P : Prop.

  Let TP phi :=
    phi = Or (Var 0) (Neg (Var 0)) \/ P /\ phi = Var 0 \/ ~ P /\ phi = Neg (Var 0).

  Instance trivial_model :
    KripkeModel.
  Proof.
    unshelve eapply mkKripkeModel.
    - exact unit.
    - exact (fun _ _ => True).
    - exact (fun _ _ => True).
    - exact (fun _ _ => P).
    - split; auto.
    - cbn. trivial.
    - intuition.
    - cbn. trivial.
  Defined.

  Lemma trivial_model_constraint :
    model_constraint D trivial_model.
  Proof.
    destruct D; cbn; trivial. intros w. exists w. cbn. trivial.
  Qed.

  Lemma TP_consistent :
    ~ TP ⊢T ⊥.
  Proof.
    intros [A[H1 H2]]. assert (HP : ~ ~ (P \/ ~ P)) by tauto. apply HP. intros HP'.
    apply (@soundness _ _ _ H2 _ trivial_model_constraint tt).
    intros phi H % H1. destruct H as [->|[[H ->]|[H ->]]]; cbn; tauto.
  Qed.

  Hypothesis all_T_satis : forall (T : form -> Prop) (phi : form), ~ T ⊢T phi
                           -> exists (M : KripkeModel) w, evalK' T w /\ ~ evalK phi w.

  Theorem WLEM :
    ~ P \/ ~ ~ P.
  Proof.
    destruct (@all_T_satis TP Bot) as [M[w[HM _]]].
    - apply TP_consistent.
    - destruct (HM (Or (Var 0) (Neg (Var 0)))) as [H|H].
      + now left.
      + right. intros HP. assert (HTP : TP (Neg (Var 0))) by (unfold TP; tauto).
        apply (HM (Neg (Var 0)) HTP w); try apply preorderCogn. apply H.
      + left. intros HP. apply (H w); try apply preorderCogn.
        assert (HTP : TP (Var 0)) by (unfold TP; tauto). apply (HM (Var 0) HTP).
  Qed.

End WLEM.

Definition prime (T : form -> Prop) :=
  forall phi psi, T (Or phi psi) -> T phi \/ T psi.

Definition quasi_prime (T : form -> Prop) :=
  forall phi psi, T (Or phi psi) -> ~ ~ (T phi \/ T psi).

Lemma WLEM_prime {D : DerivationType} T :
  (forall P, ~ P \/ ~ ~ P) -> stable T -> quasi_prime T -> prime T.
Proof.
  intros wlem H1 H2 phi psi Hp. destruct (wlem (T phi)) as [H|H].
  - right. apply H1. intros H'. apply H2 in Hp. apply Hp. tauto.
  - left. apply H1, H.
Qed.

Lemma WLEM_prime_back {D : DerivationType} :
  (forall T, stable T -> quasi_prime T -> prime T) -> forall P, ~ P \/ ~ ~ P.
Proof.
  intros HT P. edestruct (HT (T (lindenBaumTheory (@TP_consistent _ P)))).
  - apply Lindenbaum_stable, TP_consistent.
  - intros phi psi H % ndtA H'. eapply Tprime. intros HT'. apply HT' in H as [H|H].
    all: apply H'. 1: left. 2: right. all: now apply Ttheory.
  - apply max_subset. left. reflexivity.
  - right. intros HP. eapply Tconsistent. apply Ttheory. eapply ndtIE; try apply ndtA, H.
    apply ndtA. eapply max_subset. right. right. tauto.
  - left. intros HP. eapply Tconsistent. apply Ttheory. eapply ndtIE; try apply ndtA, H.
    apply ndtA. eapply max_subset. right. left. tauto.
Qed.

Section WDNS.

  Context {D : DerivationType}.

  Variable p : nat -> Prop.

  Let TP phi :=
    exists n, phi = Or (Var n) (Neg (Var n)) \/ p n /\ phi = Var n \/ ~ p n /\ phi = Neg (Var n).

  Instance pointwise_model :
    KripkeModel.
  Proof.
    unshelve eapply mkKripkeModel.
    - exact unit.
    - exact (fun _ _ => True).
    - exact (fun _ _ => True).
    - exact (fun _ n => p n).
    - split; auto.
    - cbn. trivial.
    - intuition.
    - cbn. trivial.
  Defined.

  Lemma pointwise_model_constraint :
    model_constraint D pointwise_model.
  Proof.
    destruct D; cbn; trivial. intros w. exists w. cbn. trivial.
  Qed.

  Lemma pointwise_model_TP A :
    (forall phi, In phi A -> TP phi) -> ~ ~ models.evalK' A tt.
  Proof.
    intros HA. induction A; intros H.
    - apply H. intros phi [].
    - apply IHA; auto. intros H'. destruct (HA a) as [n Hn]; auto.
      assert (Hp : ~ ~ (p n \/ ~ p n)) by tauto. apply Hp. intros Hp'.
      apply H. intros phi [<-| HP]; try now apply H'.
      destruct Hn as [->|[[Ha ->]|[Ha ->]]]; cbn; tauto.
  Qed.

  Hypothesis all_T_satis : forall (T : form -> Prop) (phi : form), ~ T ⊢T phi
                           -> ~ ~ exists (M : KripkeModel) w, ~ ~ evalK' T w /\ ~ evalK phi w.

  Theorem WDNS :
    ~ ~ (forall n, ~ p n \/ ~ ~ p n).
  Proof.
    intros dns. apply (@all_T_satis TP Bot); try intros [M[w[HM _]]].
    - intros [A[H1 H2]]. apply (pointwise_model_TP H1). intros HA.
      now apply (@soundness _ _ _ H2 _ pointwise_model_constraint tt).
    - apply HM. intros HM'. apply dns. intros n.
      destruct (HM' (Or (Var n) (Neg (Var n)))) as [H|H].
      + exists n. now left.
      + right. intros HP. assert (HTP : TP (Neg (Var n))) by (exists n; tauto).
        apply (HM' (Neg (Var n)) HTP w); try apply preorderCogn. apply H.
      + left. intros HP. apply (H w); try apply preorderCogn.
        assert (HTP : TP (Var n)) by (exists n; tauto). apply (HM' (Var n) HTP).
  Qed.

  Hypothesis quasi_complete :
    forall (T : form -> Prop) (phi : form), (forall (M : KripkeModel) w, evalK' T w -> evalK phi w) -> ~ ~ T ⊢T phi.

  Theorem WDNS' :
    ~ ~ (forall n, ~ p n \/ ~ ~ p n).
  Proof.
    intros dns. apply (@quasi_complete TP Bot); try intros [M[w[HM _]]].
    - intros M w HM. apply dns. intros n.
      destruct (HM (Or (Var n) (Neg (Var n)))) as [H|H].
      + exists n. now left.
      + right. intros HP. assert (HTP : TP (Neg (Var n))) by (exists n; tauto).
        apply (HM (Neg (Var n)) HTP w); try apply preorderCogn. apply H.
      + left. intros HP. apply (H w); try apply preorderCogn.
        assert (HTP : TP (Var n)) by (exists n; tauto). apply (HM (Var n) HTP).
    - intros [A[H1 H2]]. apply (pointwise_model_TP H1). intros HA.
      now apply (@soundness _ _ _ H2 _ pointwise_model_constraint tt).
  Qed.

End WDNS.

Definition quasi_model_existence {D : DerivationType} :=
  forall (T : form -> Prop) (phi : form), ~ T ⊢T phi -> ~ ~ exists (M : KripkeModel) w, evalK' T w /\ ~ evalK phi w.

Definition quasi_completeness {D : DerivationType} :=
  forall (T : form -> Prop) (phi : form), (forall (M : KripkeModel) w, evalK' T w -> ~ ~ evalK phi w) -> ~ ~ T ⊢T phi.

Lemma model_existence_to_completeness {D : DerivationType} :
  quasi_model_existence <-> quasi_completeness.
Proof.
  split; intros H1 T phi H2 H3.
  - apply (H1 T phi H3). intros [M[w[H H']]]. firstorder.
  - apply (H1 T phi); try apply H2. firstorder.
Qed.

Definition quasi_model_existence' {D : DerivationType} :=
  forall (T : form -> Prop) (phi : form), ~ T ⊢T phi -> ~ ~ exists (M : KripkeModel) w, ~ ~ evalK' T w /\ ~ evalK phi w.

Definition quasi_completeness' {D : DerivationType} :=
  forall (T : form -> Prop) (phi : form), (forall (M : KripkeModel) w, evalK' T w -> evalK phi w) -> ~ ~ T ⊢T phi.

Lemma model_existence_to_completeness' {D : DerivationType} :
  quasi_model_existence' -> quasi_completeness'.
Proof.
  intros H1 T phi H2 H3. apply (H1 T phi H3). intros [M[w[H H']]]. firstorder.
Qed.

Lemma WDNS_equiv :
  (~ ~ (forall P, ~ P \/ ~ ~ P) -> (forall p : nat -> Prop, ~ ~ (forall n, ~ p n \/ ~ ~ p n))).
Proof.
  intros H1 H2 H. apply H1. intros H'. apply H. intros n. apply H'.
Qed.


(* code taken from the Iris tutorial… *)

From iris.program_logic Require Import adequacy.
From iris_time.heap_lang Require Import proofmode notation.
From iris_time Require Import TimeCredits Reduction.

(** A function that sums all elements of a list, defined as a heap-lang value: *)
Definition sum_list : val :=
  rec: "sum_list" "l" :=
    match: "l" with
      NONE => #0
    | SOME "p" =>
      let: "x" := Fst !"p" in
      let: "l" := Snd !"p" in
      "x" + "sum_list" "l"
    end.

(** Representation predicate in separation logic for a list of integers [l]: *)
Fixpoint is_list `{heapGS Σ} (l : list Z) (v : val) : iProp Σ :=
  match l with
  | [] => ⌜ v = NONEV ⌝
  | x :: l' => ∃ (p : loc), ⌜ v = SOMEV #p ⌝ ∗
                 ∃ (v' : val), p ↦ (#x, v') ∗ is_list l' v'
  end%I.
(* [is_list_tr l v] means that the translation of [v] represents [l]: *)
Fixpoint is_list_tr `{timeCreditHeapG Σ} (l : list Z) (v : val) : iProp Σ :=
  match l with
  | [] => ⌜ v = NONEV ⌝
  | x :: l' => ∃ (p : loc), ⌜ v = SOMEV #p ⌝ ∗
                 ∃ (v' : val), p ↦ (#x, «v'») ∗ is_list_tr l' v'
  end%I.
(* some proofs: *)
Lemma is_list_translation `{!timeCreditHeapG Σ} l v :
  is_list l v -∗ is_list l v ∗ ⌜v = «v»%V⌝.
Proof.
  iIntros "Hl".
  destruct l as [|x l] ; simpl.
  - by iDestruct "Hl" as %->.
  - iDestruct "Hl" as (p) "[-> ?]".
    iSplitL.
    + iExists p. by iFrame.
    + done.
Qed.
Lemma is_list_tr_translation `{!timeCreditHeapG Σ} l v :
  is_list_tr l v -∗ is_list_tr l v ∗ ⌜v = «v»%V⌝.
Proof.
  iIntros "Hl".
  destruct l as [|x l] ; simpl.
  - by iDestruct "Hl" as %->.
  - iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v') "[Hp Hl']".
    iSplitL.
    + iExists p. iSplit ; first done. eauto with iFrame.
    + done.
Qed.
Lemma is_list_tr_is_list_translation `{!timeCreditHeapG Σ} l v :
  is_list_tr l v ⊣⊢ is_list l «v»%V.
Proof.
  iSplit ; iIntros "Hl".
{
  iInduction l as [|x l] "IH" forall (v) ; simpl.
  - iDestruct "Hl" as %->.
    done.
  - iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
    iPoseProof ("IH" with "Hl") as "Hl". eauto with iFrame.
}
{
  iInduction l as [|x l] "IH" forall (v) ; simpl.
  - iDestruct "Hl" as %Eq. iPureIntro. by eapply translationV_injective.
  - iDestruct "Hl" as (p) "[Eq Hl]" ; iDestruct "Eq" as %Eq ; iDestruct "Hl" as (v') "[Hp Hl]".
    change (InjRV #p)%V with «InjRV #p»%V in Eq. apply translationV_injective in Eq as ->.
    iDestruct (is_list_translation with "Hl") as "[Hl ->]".
    iPoseProof ("IH" with "Hl") as "Hl". eauto with iFrame.
}
Qed.
Lemma is_list_is_list_tr `{!timeCreditHeapG Σ} l v :
  (is_list l v ⊣⊢ is_list_tr l v)%I.
Proof.
  iSplit ; iIntros "Hl".
{
  iInduction l as [|x l] "IH" forall (v) ; simpl.
  - done.
  - iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
    iExists p. iSplitR ; first done. iExists v.
    iDestruct (is_list_translation with "Hl") as "[Hl <-]".
    iFrame.
    iApply ("IH" with "Hl").
}
{
  iInduction l as [|x l] "IH" forall (v) ; simpl.
  - done.
  - iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
    iExists p. iSplitR ; first done. iExists v.
    iDestruct (is_list_tr_translation with "Hl") as "[Hl <-]".
    iFrame.
    iApply ("IH" with "Hl").
}
Qed.

Definition sum_list_coq (l : list Z) : Z :=
  fold_right Z.add 0 l.

(** The proof using induction over [l]: *)
Lemma sum_list_spec `{!heapGS Σ} (l : list Z) (v : val) :
  {{{ is_list l v }}} sum_list v {{{ RET #(sum_list_coq l) ; is_list l v }}}.
Proof.
  iIntros (Φ) "Hl Post".
  iInduction l as [|x l] "IH" forall (v Φ) ; simpl.
  - iDestruct "Hl" as %->.
    wp_rec.
    wp_match.
    by iApply "Post".
  - iDestruct "Hl" as (p) "[-> Hl]". iDestruct "Hl" as (v) "[Hp Hl]".
    wp_rec.
    wp_match.
    wp_load. wp_proj. wp_let.
    wp_load. wp_proj. wp_let.
    wp_apply ("IH" with "Hl"). iIntros "Hl".
    wp_op.
    iApply "Post". eauto with iFrame.
Qed.
Lemma sum_list_translation_spec `{!timeCreditHeapG Σ} (l : list Z) (v : val) :
  TC_invariant -∗
  {{{ is_list_tr l v ∗ TC (4 + 13 * length l) }}} « sum_list v » {{{ RET #(sum_list_coq l) ; is_list_tr l v }}}.
Proof.
  iIntros "#Htickinv !#" (Φ) "[Hl Htc] Post".
  iInduction l as [|x l] "IH" forall (v Φ).
  - simpl.
    iDestruct "Hl" as %->.
    wp_tick_rec. wp_tick_match.
    by iApply "Post".
  - replace (4 + 13 * length (x :: l))%nat with (17 + 13 * length l)%nat by (simpl ; lia).
    iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
    wp_tick_rec. wp_tick_match.
    wp_tick_load. wp_tick_proj. wp_tick_let.
    wp_tick_load. wp_tick_proj. wp_tick_let.
    iDestruct "Htc" as "[Htc1 Htc]".
    wp_apply ("IH" with "Hl Htc"). iIntros "Hl".
    wp_tick_op.
    iApply "Post". simpl. eauto with iFrame.
Qed.

Definition make_list : val :=
  rec: "make_list" "n" :=
    if: "n" = #0 then
      NONE
    else
      SOME (ref ("n", "make_list" ("n" - #1))).

Fixpoint make_list_coq (n : nat) : list Z :=
  match n with
  | 0%nat => []
  | S n'  => Z.of_nat n :: make_list_coq n'
  end.

(** The proof using induction over [l]: *)
Lemma make_list_spec `{!heapGS Σ} (n : nat) :
  {{{ True }}} make_list #n {{{ v, RET v ; is_list (make_list_coq n) v }}}.
Proof.
  iIntros (Φ) "_ Post".
  iInduction n as [|n'] "IH" forall (Φ) ; simpl.
  - wp_rec. wp_op. wp_if. wp_inj.
    by iApply "Post".
  - wp_rec. wp_op. wp_if.
    wp_op.
    assert (Z.of_nat n' = Z.of_nat (S n') - 1) as Eq by lia ; simpl in Eq ; destruct Eq.
    wp_apply "IH". iIntros (v') "Hl".
    change (Z.pos $ Pos.of_succ_nat n') with (Z.of_nat $ S n').
    wp_alloc p. wp_inj.
    iApply "Post". eauto with iFrame.
Qed.
Lemma make_list_translation_spec `{!timeCreditHeapG Σ} (n : nat) :
  TC_invariant -∗
  {{{ TC (4+7*n) }}} «make_list #n» {{{ v', RET v' ; is_list (make_list_coq n) v' }}}.
Proof.
  iIntros "#Htickinv !#" (Φ) "Htc Post".
  iInduction n as [|n'] "IH" forall (Φ).
  - wp_tick_rec. wp_tick_op. wp_tick_if. wp_tick_inj.
    by iApply "Post".
  - replace (4 + 7 * S n')%nat with (11 + 7 * n')%nat by lia.
    wp_tick_rec. wp_tick_op. wp_tick_if.
    wp_tick_op.
    assert (Z.of_nat n' = Z.of_nat (S n') - 1) as Eq by lia ; simpl in Eq ; destruct Eq.
    iDestruct "Htc" as "[? [? [? Htc]]]".
    wp_apply ("IH" with "Htc"). iIntros (v') "Hl".
    change (Z.pos $ Pos.of_succ_nat n') with (Z.of_nat $ S n').
    wp_tick_pair. wp_tick_alloc p. wp_tick_inj.
    iApply "Post". simpl. eauto with iFrame.
Qed.

Definition prgm (n : nat) : expr :=
  sum_list (make_list #n).

Lemma length_make_list_coq (n : nat) :
  length (make_list_coq n) = n.
Proof.
  induction n as [|n' IH].
  - done.
  - simpl. by f_equal.
Qed.

Lemma sum_list_coq_make_list_coq (n : nat) :
  sum_list_coq (make_list_coq n) = (Z.of_nat n * (Z.of_nat n + 1)) `div` 2.
Proof.
  rewrite - Z.div2_div.
  assert (2 * sum_list_coq (make_list_coq n) = (Z.of_nat n * (Z.of_nat n + 1))) as Eq.
  {
  induction n as [|n' IH].
  - done.
  - rewrite /= Z.mul_add_distr_l IH. lia.
  }
  assert (Zeven (Z.of_nat n * (Z.of_nat n + 1))) as Heven % Zeven_div2.
  {
    pose proof (Zeven_odd_dec n) as [ Heven | Hodd ].
    - by apply Zeven_mult_Zeven_l.
    - by apply Zeven_mult_Zeven_r, Zodd_plus_Zodd.
  }
  lia.
Qed.

Lemma prgm_spec `{!heapGS Σ} (n : nat) :
  {{{ True }}} prgm n {{{ v, RET v ; ⌜v = #(n*(n+1)/2)⌝ }}}.
Proof.
  iIntros (Φ) "_ Post".
  unfold prgm.
  wp_apply (make_list_spec with "[//]"). iIntros (v) "Hl".
  wp_apply (sum_list_spec with "Hl"). iIntros "Hl".
  iApply ("Post" with "[%]"). repeat f_equal. apply sum_list_coq_make_list_coq.
Qed.
Lemma prgm_translation_spec `{!timeCreditHeapG Σ} (n : nat) :
  TC_invariant -∗
  {{{ TC (8+20*n) }}} «prgm n» {{{ v, RET v ; ⌜v = #(n*(n+1)/2)⌝ }}}.
Proof.
  iIntros "#Htickinv !#" (Φ) "Htc Post".
  replace (8+20*n)%nat with ((4+7*n) + (4+13*n))%nat by lia ;
  rewrite TC_plus ; iDestruct "Htc" as "[Htc_make Htc_sum]".
  unfold prgm. simpl_trans.
  wp_apply (make_list_translation_spec with "Htickinv Htc_make"). iIntros (v) "Hl".
  iDestruct (is_list_translation with "Hl") as "[Hl ->]".
  wp_apply (sum_list_translation_spec with "Htickinv [Hl Htc_sum]"). {
    rewrite - is_list_tr_is_list_translation.
    erewrite length_make_list_coq. iFrame.
  } iIntros "Hl".
  iApply ("Post" with "[%]"). repeat f_equal. apply sum_list_coq_make_list_coq.
Qed.

Lemma prgm_timed_spec (n : nat) (σ : state) `{!timeCreditHeapPreG Σ} :
    adequate NotStuck (prgm n) σ (λ v _, v = #(n*(n+1)/2))
  ∧ bounded_time (prgm n) σ (8 + 20 * n)%nat.
Proof.
  apply (spec_tctranslation__adequate_and_bounded' (Σ:=Σ)).
  - by intros _ ->.
  - intros HtcHeapG. apply prgm_translation_spec.
  - assumption.
Qed.


Module Type LEARNING.
  Parameter Learnt: Prop -> Prop.
  Parameter markLearnt: forall {P: Prop} (p: P), Learnt P.
End LEARNING.

Module Import Learning: LEARNING.
  Definition Learnt(P: Prop) := P.
  Definition markLearnt{P: Prop}(p: P): Learnt P := p.
End Learning.

Ltac learn_tac p H :=
  let P := type of p in
  lazymatch goal with
  | H: Learnt P |- _ => fail
  | |- _ =>
    let L := fresh "L" in
    pose proof (markLearnt p) as L; (* will stay around *)
    pose proof p as H (* will likely be destructed *)
  end.

Tactic Notation "learn" constr(p) := let H := fresh in learn_tac p H.
Tactic Notation "learn" constr(p) "as" ident(H) := learn_tac p H.

Ltac cheap_saturate :=
  unshelve (repeat match goal with
    | H: _ /\ _ |- _ => let Hl := fresh H "l" in let Hr := fresh H "r" in destruct H as [Hl Hr]
    | E: exists y, _ |- _ => let yf := fresh y in destruct E as [yf E]
    | H: forall (x: ?T), _ |- _ =>
      match type of T with
      | Prop => fail 1
      | _ => let x' := fresh x in (evar (x': T)); specialize (H x'); subst x'
      end
    | H1: _, H2: _ -> _ |- _ => let H3 := fresh H1 "_" H2 in learn (H2 H1) as H3
  end);
  [(eauto || exact unit)..|].


(*LES FONCTIONS EN COQ*)

(* Check verifie les types des expressions*)
Check fun x => x + 2.
Check (fun x => x + 2) 3.
Check 3.

(*Compute teste les fonctions*)
Compute (fun x => x+2) 3.
Compute (fun x => x+2) 3.

Eval vm_compute in (fun x => x + 2) 4.

(*Definition permet de donner un nom a la fonction*)
Definition add2 := fun x => x+2.
Compute add2 4.
(*shortcut*)
Definition add3 x := x+2.
Compute add3 4.

(*JOUER AVEC LES FONCTIONS*)

(*fonctions avec deux arguments*)
Check fun x => fun y => y + (x+2).
Check fun x y => y + (x+2).

(*ORDRES SUPERIEURS*)

(**)


From UnivalentParametricity Require Import HoTT FP.
Require Import list perm.

Set Universe Polymorphism.

Notation permutes := Permutation.
Notation perm_sym := Permutation_sym.
Notation perm_app := Permutation_app.
Notation perm_app_comm := Permutation_app_comm.
Notation perm_cons_app := Permutation_cons_app.

Lemma add_Sn_m (n m : nat) : S n + m = S (n + m).
Proof. reflexivity. Defined.

Lemma add_n_Sm (n m : nat) : n + S m = S (n + m).
Proof.
  revert m. induction n; intro m; try reflexivity.
  rewrite add_Sn_m, add_Sn_m, IHn. reflexivity.
Defined.

Lemma add_n_O (n : nat) : n + O = n.
Proof.
  induction n; try reflexivity. rewrite add_Sn_m, IHn. reflexivity.
Defined.

Lemma add_comm (n m : nat) : n + m = m + n.
Proof.
  revert m. induction n; intro m.
  - rewrite add_n_O. reflexivity.
  - rewrite add_Sn_m, add_n_Sm, IHn. reflexivity.
Defined.

Lemma max_comm (n m : nat) : Nat.max n m = Nat.max m n.
Proof.
  revert m. induction n; destruct m; try reflexivity.
  simpl. rewrite IHn. reflexivity.
Defined.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import Overture PathGroupoids Contractible Equivalences Trunc.
Local Open Scope trunc_scope.
Local Open Scope path_scope.

(** * Decidability *)

(** ** Definitions *)

(* NB: This has to come after our definition of [not] (which is in [Overture]), so that it refers to our [not] rather than the one in [Coq.Logic]. *)
Class Decidable (A : Type) :=
  dec : A + (~ A).
Arguments dec A {_}.

(** The [decide_type] and [decide] tactic allow to automatically prove
decidable claims using previously written decision procedures that
compute. *)
Ltac decide_type A :=
  let K := (eval hnf in (dec A)) in
  match K with
  | inl ?Z => exact Z
  | inr ?Z => exact Z
  end.

Ltac decide :=
  match goal with
  | [|- ?A] => decide_type A
  end.

Class DecidablePaths (A : Type) :=
  dec_paths : forall (x y : A), Decidable (x = y).
Global Existing Instance dec_paths.

Class Stable P := stable : ~~P -> P.

Global Instance stable_decidable P `{!Decidable P} : Stable P.
Proof.
  intros dn;destruct (dec P) as [p|n].
  - assumption.
  - apply Empty_rect,dn,n.
Qed.

(**
  Because [vm_compute] evaluates terms in [PROP] eagerly
  and does not remove dead code we
  need the decide_rel hack. Suppose we have [(x = y) =def  (f x = f y)], now:
     bool_decide (x = y) -> bool_decide (f x = f y) -> ...
  As we see, the dead code [f x] and [f y] is actually evaluated,
  which is of course an utter waste.
  Therefore we introduce decide_rel and bool_decide_rel.
     bool_decide_rel (=) x y -> bool_decide_rel (fun a b => f a = f b) x y -> ...
  Now the definition of equality remains under a lambda and
  our problem does not occur anymore!
*)
Definition decide_rel {A B} (R : A -> B -> Type)
  {dec : forall x y, Decidable (R x y)} (x : A) (y : B)
  : Decidable (R x y)
  := dec x y.

(** ** Decidable hprops *)

(** Contractible types are decidable. *)

Global Instance decidable_contr X `{Contr X} : Decidable X
  := inl (center X).

(** Thus, hprops have decidable equality. *)

Global Instance decidablepaths_hprop X `{IsHProp X} : DecidablePaths X
  := fun x y => dec (x = y).

(** Empty types are trivial. *)

Global Instance decidable_empty : Decidable Empty
  := inr idmap.

(** ** Transfer along equivalences *)

Definition decidable_equiv (A : Type) {B : Type} (f : A -> B) `{IsEquiv A B f}
: Decidable A -> Decidable B.
Proof.
  intros [a|na].
  - exact (inl (f a)).
  - exact (inr (fun b => na (f^-1 b))).
Defined.

Definition decidable_equiv' (A : Type) {B : Type} (f : A <~> B)
: Decidable A -> Decidable B
  := decidable_equiv A f.

Definition decidablepaths_equiv
           (A : Type) {B : Type} (f : A -> B) `{IsEquiv A B f}
: DecidablePaths A -> DecidablePaths B.
Proof.
  intros d x y.
  destruct (d (f^-1 x) (f^-1 y)) as [e|ne].
  - apply inl. exact ((eisretr f x)^ @ ap f e @ eisretr f y).
  - apply inr; intros p. apply ne, ap, p.
Defined.

Definition decidablepaths_equiv' (A : Type) {B : Type} (f : A <~> B)
: DecidablePaths A -> DecidablePaths B
  := decidablepaths_equiv A f.

(** ** Hedberg's theorem: any type with decidable equality is a set. *)

(** A weakly constant function is one all of whose values are equal (in a specified way). *)
Class WeaklyConstant {A B} (f : A -> B) :=
  wconst : forall x y, f x = f y.

(** Any map that factors through an hprop is weakly constant. *)
Definition wconst_through_hprop {A B P} `{IsHProp P}
           (f : A -> P) (g : P -> B)
: WeaklyConstant (g o f).
Proof.
  intros x y; apply (ap g), path_ishprop.
Defined.

(** A type is collapsible if it admits a weakly constant endomap. *)
Class Collapsible (A : Type) :=
  { collapse : A -> A ;
    wconst_collapse : WeaklyConstant collapse
  }.
Global Existing Instance wconst_collapse.

Class PathCollapsible (A : Type) :=
  path_coll : forall (x y : A), Collapsible (x = y).
Global Existing Instance path_coll.

Global Instance collapsible_decidable (A : Type) `{Decidable A}
: Collapsible A.
Proof.
  destruct (dec A) as [a | na].
  - exists (const a).
    intros x y; reflexivity.
  - exists idmap.
    intros x y; destruct (na x).
Defined.

Global Instance pathcoll_decpaths (A : Type) `{DecidablePaths A}
: PathCollapsible A.
Proof.
  intros x y; exact _.
Defined.

(** We give this a relatively high-numbered priority so that in deducing [IsHProp -> IsHSet] Coq doesn't detour via [DecidablePaths]. *)
Global Instance hset_pathcoll (A : Type) `{PathCollapsible A}
: IsHSet A | 1000.
Proof.
  intros x y.
  assert (h : forall p:x=y, p = (collapse (idpath x))^ @ collapse p).
  { intros []; symmetry; by apply concat_Vp. }
  apply hprop_allpath; intros p q.
  refine (h p @ _ @ (h q)^).
  apply whiskerL.
  apply wconst.
Defined.

Definition collapsible_hprop (A : Type) `{IsHProp A}
: Collapsible A.
Proof.
  exists idmap.
  intros x y; apply path_ishprop.
Defined.

Definition pathcoll_hset (A : Type) `{IsHSet A}
: PathCollapsible A.
Proof.
  intros x y; apply collapsible_hprop; exact _.
Defined.

Corollary hset_decpaths (A : Type) `{DecidablePaths A}
: IsHSet A.
Proof.
  exact _.
Defined.

(** ** Truncation *)

(** Having decidable equality (which implies being an hset, by Hedberg's theorem above) is itself an hprop. *)

Global Instance ishprop_decpaths `{Funext} (A : Type)
: IsHProp (DecidablePaths A).
Proof.
  apply hprop_inhabited_contr; intros d.
  assert (IsHSet A) by exact _.
  exists d; intros d'.
  apply path_forall; intros x; apply path_forall; intros y.
  generalize (d x y); clear d; intros d.
  generalize (d' x y); clear d'; intros d'.
  destruct d as [d|nd]; destruct d' as [d'|nd'].
  - apply ap, path_ishprop.
  - elim (nd' d).
  - elim (nd d').
  - apply ap, path_forall; intros p; elim (nd p).
Defined.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rmult.
Require Export XR_Rmult_comm.
Require Export XR_Rmult_0_r.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_0_l : forall r, R0 * r = R0.
Proof.
  intro x.
  rewrite Rmult_comm.
  rewrite Rmult_0_r.
  reflexivity.
Qed.


(*|
#################################################################################################################
How does one define dependent type with named arguments in Coq without issues in unification in the constructors?
#################################################################################################################

:Link: https://stackoverflow.com/q/71518005
|*)

(*|
Question
********

I want to defined a lenghted list but I like arguments with names at
the top of the inductive definition. Whenever I try that I get
unification errors with things I hoped worked and was forced to do a
definition that obviously has bugs e.g. allows a list where everything
is length ``0`` but has ``1`` element. How do I fix this?
|*)

Inductive Vector {A : Type} (n : nat) : Type :=
| vnil (* not quite right... *)
| vcons (hd : A) (tail : Vector (n - 1)).

Check vnil 0.
Check vcons 1 true (vnil 0).

Inductive Vector' {A: Type} : nat -> Type :=
| vnil' : Vector' 0
| vcons' : forall n : nat, A -> Vector' n -> Vector' (S n).

Check vnil'.
Check vcons' 0 true (vnil').

Inductive Vector'' {A : Type} (n : nat) : Type :=
| vnil'' : Vector'' n (* seems weird, wants to unify with n, argh! *)
| vcons'' : A -> Vector'' (n - 1) -> Vector'' n.

Check vnil'' 0.
Check vcons'' 1 true (vnil'' 0).
(* Check vcons'' 0 true (vnil'' 0). *)
(* it also worked! nooooo! hope the -1 did the trick but not *)

(*|
Answer
******

Named arguments to the left of ``:`` (they are called parameters) are
implicitly ``forall``'d in each constructor and must appear as the
same variable in the return type of each constructor. Arguments to the
right (they are called indices) are not implicitly ``forall``'d and
may appear as anything. Part of the issue with your definitions is
that ``n`` is already introduced by the time you're writing the type
of each constructor, so you can't quite restrict it to be ``Z`` or ``S
m`` at that point.

The idea is that parameters are supposed to be parameters to the whole
inductive definition. ``Vector A n`` and ``Vector B m`` do not depend
on each other; it would make sense to consider ``Vector A`` and
``Vector B`` to be different inductive definitions, and ``Vector`` as
a family of inductives parameterized by a ``Type``. On the other hand,
``Vector A (S n)`` refers to ``Vector A n``; you cannot construct the
type ``Vector A (S n)`` without first constructing ``Vector A n``, so
they should be considered parts of one inductive construction ``Vector
A : nat -> Type``.

This interpretation is not strictly enforced---you can poke a hole in
it with ``Inductive E (n : nat) : Set := | mk_E : E (S n) -> E
n.``---but the rule about parameters vs. indices in constructor return
types is enforced. It is the *intent of the design* of Coq that the
"most natural" way to define ``Vector`` is
|*)

Reset Initial. (* .none *)
(* making A an implicit argument to Vector seems a bad idea... *)
Inductive Vector (A : Type) : nat -> Type :=
| vnil  : Vector A O
| vcons : forall n, A -> Vector A n -> Vector A (S n).
(* if you want to clean up vnil and vcons afterwards you can issue
   something like *)
Arguments vnil {A}.
Arguments vcons {A n}.
(* it would also work to define Vector with A implicit and then just
   use Arguments on Vector to make A explicit (it would leave n
   explicit in vcons), but that's just weird *)

(*|
If you want to clarify what the ``nat`` is doing, you could just leave
a comment like

.. code-block:: coq

    (* A [Vector A n] is a list of [n] elements of type [A]. *)

or

.. code-block:: coq

    Inductive Vector (A : Type) : (* n *) nat -> Type :=

If you *really* want ``Inductive Vector (A : Type) (n : nat) : Type``,
then you have to resort to something like
|*)

Reset Initial. (* .none *)
Inductive Vector (A : Type) (n : nat) : Type :=
| vnil  (prf : n = O)
| vcons (m : nat) (prf : n = S m) (x : A) (xs : Vector A m).

(*| Which makes everything messy. |*)


From Tealeaves Require Export
  Applicative.

Import Applicative.Notations.

#[local] Generalizable Variables F.

(** * The <<Backwards>> idiom *)
(******************************************************************************)
Section Backwards.

  Record Backwards (F : Type -> Type) A :=
    { forwards : F A }.

  Context
    `{Applicative F}.

  #[export] Instance Fmap_Backwards : Fmap (Backwards F) :=
    fun A B f '(Build_Backwards _ _ x) => {| forwards := fmap F f x |}.

  #[export] Instance Pure_Backwards : Pure (Backwards F) :=
    fun A a => Build_Backwards _ _ (pure F a).

  Definition swap {A B} : B * A -> A * B :=
    fun '(b, a) => (a, b).

  Definition mult_Backwards {A B} : Backwards F A -> Backwards F B -> Backwards F (A * B) :=
    fun ba bb => Build_Backwards F _ (fmap F swap (forwards _ _ bb ⊗ forwards _ _ ba)).

  #[export] Instance Mult_Backwards : Mult (Backwards F) :=
    fun A B '(x, y) => mult_Backwards x y.

  (* TODO Finish proving <<Backwards>> is an applicative.
     We do not need this right now. *)
  (*
  #[export, program] Instance Applicative_Backwards : Applicative (Backwards F).
   *)

End Backwards.


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

Require Import Arith Omega List Permutation.

Require Import utils ill_form phase_sem.

Local Infix "~p" := (@perm_t _) (at level 70).

Set Implicit Arguments.

Section Rules.

  Variable (P : list ill_form -> ill_form -> Type).

  Notation "Γ ⊨ A" := (P Γ A) (at level 70, no associativity).

  Implicit Types (X Y : list ill_form -> Type).

  Definition cl_ctx X Δ := forall Γ A, (forall ϴ, X ϴ -> ϴ++Γ ⊨ A)
                                     ->                  Δ++Γ ⊨ A.

  Definition comp_ctx (Γ Δ ϴ : list ill_form) := Γ++Δ ~p ϴ.

  Notation cl := cl_ctx.
  Notation comp := comp_ctx.

  Infix "∘" := (Composes comp_ctx) (at level 50, no associativity).

  Notation J := (fun Γ => cl (sg ∅) Γ * cl (sg Γ ∘ sg Γ) Γ)%type.
  Notation K := (fun Γ => { Δ | Γ = ‼Δ }).

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

  Fact cl_ctx_increase X : X ⊆ cl X.
  Proof. intros ? ? ? ?; auto. Qed.

  Fact cl_ctx_mono X Y : X ⊆ Y -> cl X ⊆ cl Y.
  Proof.
    intros H1 de Hde ga x HY.
    apply Hde.
    intros; apply HY, H1; auto.
  Qed.

  Fact cl_ctx_idem X : cl (cl X) ⊆ cl X.
  Proof.
    intros de Hde ga x HX.
    apply Hde.
    intros th Hth.
    apply Hth, HX.
  Qed.

  Hint Resolve cl_ctx_increase cl_ctx_mono cl_ctx_idem.

  Hypothesis P_perm : forall Γ Δ A, Γ ~p Δ -> Γ ⊨ A -> Δ ⊨ A.

  Hint Resolve perm_t_refl perm_t_app_comm.

  Local Fact cl_comm Γ Δ : sg Γ ∘ sg Δ ⊆ cl (sg Δ ∘ sg Γ).
  Proof.
    intros _ [ ga de th ? ? Hth ]; subst Γ Δ.
    intros rho x H; apply H.
    constructor 1 with de ga; auto.
    revert Hth; unfold comp.
    apply perm_t_trans; auto.
  Qed.

  Local Fact cl_neutral_1 : forall Γ, cl (sg ∅ ∘ sg Γ) Γ.
  Proof.
    intros ga th x H.
    apply H.
    constructor 1 with nil ga; auto.
    red; simpl; auto.
  Qed.

  Local Fact cl_neutral_2 : forall Γ, sg ∅ ∘ sg Γ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho x G; subst th de.
    cbv in H1.
    generalize (G _ eq_refl).
    apply P_perm, perm_t_app; auto.
  Qed.

  Fact cl_ctx_stable_l : forall X Y, cl X ∘ Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho x HXY.
    red in H1; red in H3.
    apply P_perm with (ga++(de++rho)).
    1: { rewrite <- app_ass; apply perm_t_app; auto. }
    apply H1.
    intros ka Hka.
    rewrite <- app_ass.
    apply HXY.
    constructor 1 with ka de; auto.
    red; auto.
  Qed.

  Local Fact cl_assoc : forall Γ Δ ϴ, sg Γ ∘ (sg Δ ∘ sg ϴ) ⊆ cl ((sg Γ ∘ sg Δ) ∘ sg ϴ).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H3 as [ de' th' to ]; subst ga' de' th'.
    intros u x Hu.
    specialize (Hu ((ga++de)++th)).
    spec all in Hu.
    constructor 1 with (ga++de) th; auto.
    constructor 1 with ga de; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, perm_t_app; auto.
    rewrite app_ass.
    apply perm_t_trans with (2 := H4).
    apply perm_t_app; auto.
  Qed.

  Local Fact sub_monoid_1 : cl K ∅.
  Proof.
    intros ga A H.
    apply H; exists ∅; auto.
  Qed.

  Local Fact sub_monoid_2 : K ∘ K ⊆ K.
  Proof.
    intros _ [ a b c [ga Ha] [de Hb] H ]; subst a b.
    red in H; simpl in H.
    unfold ill_lbang in H.
    rewrite <- map_app in H.
    apply perm_t_map_inv_t in H.
    destruct H as (th & H1 & H2); subst c.
    exists th; auto.
  Qed.

  Section sub_J_cs.

    Hypothesis P_weak : ∀ Γ Δ A, Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Hypothesis P_cntr : ∀ Γ Δ A, ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A.

    Local Fact sub_J_1 : K ⊆ J.
    Proof.
      intros x (de & Hde); subst x.
      constructor; red.
      + intros ga A H.
        specialize (H _ eq_refl); simpl in H.
        apply P_weak; auto.
      + intros ga A H.
        specialize (H (‼de++‼de)).
        spec all in H.
        { constructor 1 with (‼de) (‼de); auto; red; auto. }
        rewrite app_ass in H.
        apply P_cntr; auto.
    Qed.

    Check ill_Form_sem_sound.

    Definition rules_sound := ill_Form_sem_sound _ cl_ctx_increase
                                                   cl_ctx_mono
                                                   cl_ctx_idem
                                                   cl_comm
                                                   cl_ctx_stable_l
                                                   cl_neutral_1
                                                   cl_neutral_2
                                                   cl_assoc
                                                   sub_monoid_1
                                                   sub_monoid_2
                                                   sub_J_1.

  End sub_J_cs.

  Section sub_J_cn.

    Hypothesis K_inc_J : K ⊆ J.

    Let J_banged Γ : J (‼Γ).
    Proof. apply K_inc_J; exists Γ; auto. Qed.

    Let weak Γ : cl (sg nil) (‼Γ).
    Proof. apply J_banged. Qed.

    Let cntr Γ : cl (sg (‼Γ) ∘ sg (‼Γ)) (‼Γ).
    Proof. apply J_banged. Qed.

    Local Fact sub_J_2 Γ Δ A : Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H; apply weak; intros _ []; apply H.
    Qed.

    Local Fact sub_J_3 Γ Δ A : ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H; apply cntr.
      intros _ [ x y th [] [] H1 ].
      revert H; apply P_perm.
      rewrite <- app_ass; apply perm_t_app; auto.
    Qed.

  End sub_J_cn.

  Fact sub_J_eq : K ⊆ J ≡ (∀ Γ Δ A, Δ ⊨ A -> ‼Γ++Δ ⊨ A)
                         * (∀ Γ Δ A, ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A).
  Proof.
    split.
    + split.
      * apply sub_J_2; auto.
      * apply sub_J_3; auto.
    + intros; apply sub_J_1; tauto.
  Qed.

  Notation "↓" := (fun A Γ => Γ ⊨ A).

  Fact dc_closed A : cl (↓A) ⊆ ↓A.
  Proof.
    intros ga Hga; red in Hga.
    rewrite (app_nil_end ga); apply Hga.
    intro; rewrite <- app_nil_end; auto.
  Qed.

  Notation sg := (@eq _).
  Infix "⊸" := (Magicwand comp) (at level 51, right associativity).

  Section equivalences.

    (* We show that each rule has an algebraic counterpart *)

    (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

    Fact rule_ax_eq A : ↓A (A::∅)
                    ≡ A::∅ ⊨ A.
    Proof. split; auto. Qed.

    Fact rule_limp_l_eq A B : (↓A ⊸ cl (sg (B::∅))) (A -o B::∅)
                          ≡ ∀ Γ Δ C, Γ ⊨ A -> B::Δ ⊨ C -> A -o B::Γ++Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De C H1 H2.
        specialize (H (A -o B::Ga)).
        spec all in H.
        constructor 1 with (A -o B :: nil) Ga; auto; red; simpl; auto.
        change (A -o B :: Ga ++ De) with ((A -o B :: Ga) ++ De).
        apply H; intros _ []; auto.
      + intros H0 th Hth de C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst rho; red in H3; simpl in H3.
        apply P_perm with (A -o B::ga++de).
        { apply perm_t_app with (1 := H3); auto. }
        apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_limp_r_eq A B : sg (A::∅) ⊸ ↓B ⊆ ↓(A -o B)
                          ≡ ∀ Γ, A::Γ ⊨ B -> Γ ⊨ A -o B.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1).
        apply perm_t_app_comm with (a := _::nil).
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with th (A :: nil); auto.
        apply perm_t_app_comm.
    Qed.

    Fact rule_times_l_eq A B : cl (sg (A::B::nil)) (A⊗B::nil)
                           ≡ ∀ Γ C, A::B::Γ ⊨ C -> A ⊗ B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_times_r_eq A B : ↓A ∘ ↓B ⊆ ↓(A⊗B)
                           ≡ ∀ Γ Δ, Γ ⊨ A -> Δ ⊨ B -> Γ++Δ ⊨ A ⊗ B.
    Proof.
      split.
      + intros H Ga De H1 H2.
        apply H.
        constructor 1 with Ga De; auto; red; auto.
      + intros H _ [ Ga Gb Gc HGa HGb HGc ].
        apply P_perm with (1 := HGc).
        apply H; auto.
    Qed.

    Fact rule_with_l1_eq A B : cl (sg (A::∅)) (A&B::∅)
                           ≡ ∀ Γ C, A::Γ ⊨ C -> A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_l2_eq A B : cl (sg (B::∅)) (A&B::∅)
                           ≡ ∀ Γ C, B::Γ ⊨ C -> A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_r_eq A B : ↓A ∩ ↓B ⊆ ↓(A & B)
                          ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ B -> Γ ⊨ A﹠B.
    Proof.
      split.
      + intros H Ga H1 H2.
        apply H; auto.
      + intros H ? []; apply H; auto.
    Qed.

    Fact rule_plus_l_eq A B : cl (sg (A::∅) ∪ sg (B::∅)) (A⊕B::∅)
                          ≡ ∀ Γ C, A::Γ ⊨ C -> B::Γ ⊨ C -> A⊕B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1 H2.
        apply H; intros _ [ [] | [] ]; auto.
      + intros H0 ? ? H; apply H0; apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_plus_r1_eq A B : ↓A ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_plus_r2_eq A B : ↓B ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ B -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_bang_l_eq A : cl (sg (A::∅)) (!A::∅)
                        ≡ ∀ Γ B, A::Γ ⊨ B -> !A::Γ ⊨ B.
    Proof.
      split.
      + intros H Ga B H1; apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_bang_r_eq A : K ∩ ↓A ⊆ ↓(!A)
                        ≡   ∀ Γ, ‼ Γ ⊨ A -> ‼ Γ ⊨ !A.
    Proof.
      split.
      + intros H Ga H1.
        apply H; split; auto.
        exists Ga; auto.
      + intros H0 Ga [ (De & H1) H2 ]; subst.
        apply H0; auto.
    Qed.

    Fact rule_unit_l_eq : cl (sg ∅) (𝝐::nil)
                      ≡ ∀ Γ A, Γ ⊨ A -> 𝝐 :: Γ ⊨ A.
    Proof.
      split.
      + intros H Ga A H1; apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_unit_r_eq : sg ∅ ⊆ ↓𝝐  ≡ ∅ ⊨ 𝝐.
    Proof.
      split.
      + intros H; apply H; auto.
      + intros H x []; apply H.
    Qed.

    Fact rule_bot_l_eq : cl (fun _ => False) (⟘::∅)
                     ≡ ∀ Γ A, ⟘ :: Γ ⊨ A.
    Proof.
      split.
      + intros H Ga A; apply H; tauto.
      + intros H0 ? ? _; apply H0.
    Qed.

    Fact rule_top_r_eq : (fun _ => True) ⊆ ↓⟙ ≡ ∀ Γ, Γ ⊨ ⟙.
    Proof.
      split.
      + intros H Ga; apply H; auto.
      + intros H ? _; apply H.
    Qed.

  End equivalences.

End Rules.


Welcome to Coq 8.4pl4 (August 2014)

Coq < Section Math016.

Coq < Require Import Arith.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]

Coq < Load CpdtTactics.

Coq < Goal forall x, (4 * x) * 25 = (100 * x).
1 subgoal

  ============================
   forall x : nat, 4 * x * 25 = 100 * x

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined

Coq <


Require Import list_examples.

Definition rev_app_body :=
  (If (Var 0)
    (Let (Deref (Var 0)) (Lam
      (Seq (Assign (Var 1) (Cons (Car (Var 0)) (Var 2)))
           ((Var 3) (Var 1) (Cdr (Var 0))))))
    (Var 1)).
Definition list_rev_app :=
  strict_fix (Lam (Lam (Lam rev_app_body))).
Definition list_rev_body := list_rev_app Nil (Var 0).
Definition list_rev := Lam list_rev_body.

Inductive reverse_spec : Spec cfg :=
  rev_claim : forall l pl env, exp_val reverse_spec
  list_rev_body (pl::env)
    (rep_list l pl)
    (rep_list (rev l))
 |rev_app_claim : forall k l pk pl env, exp_val reverse_spec
  rev_app_body (pl::pk::fix_env (Lam (Lam rev_app_body)) env)
    (rep_list k pk :* rep_list l pl)
    (rep_list (rev_append l k)).

Lemma reverse_proof : sound lam_step reverse_spec.
Proof. list_solver;
rewrite <- rev_alt in * |- ;
list_run. Qed.


(* Snake lemma *)

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

Require Import AbGroup.

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

Theorem KK_mem_compat {A B A' B'} : ∀ (a : HomGr A A') (b : HomGr B B') f f',
  diagram_commutes f a b f'
  → ∀ x : gr_set (Ker a), x ∈ Ker a → Happ f x ∈ Ker b.
intros * Hc * (Hx & Hax).
split; [ now apply f | ].
rewrite Hc, <- (Hzero _ _ f').
apply f'; [ apply a, Hx | easy ].
Qed.

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

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

Definition HomGr_Ker_Ker {A B A' B'}
    {f : HomGr A B} {f' : HomGr A' B'} (a : HomGr A A') (b : HomGr B B')
    (Hc : diagram_commutes f a b f') :=
  {| Happ (x : gr_set (Ker a)) := Happ f x : gr_set (Ker b);
     Hmem_compat := KK_mem_compat a b f f' Hc;
     Happ_compat := KK_app_compat f a;
     Hadditive := KK_additive f a |}.

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

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

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

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

Definition HomGr_Coker_Coker {A B A' B'}
    {f : HomGr A B} {f' : HomGr A' B'} (a : HomGr A A') (b : HomGr B B')
    (Hc : diagram_commutes f a b f') :=
  {| Happ (x : gr_set (Coker a)) := Happ f' x : gr_set (Coker b);
     Hmem_compat := CC_mem_compat f' a b;
     Happ_compat := CC_app_compat f f' a b Hc;
     Hadditive := CC_additive f' a b |}.

(* Morphism g in snake lemma is surjective *)

Theorem g_is_surj {B C C' g} (c : HomGr C C') {cz : HomGr C Gr1} :
   Decidable_Membership
   → Im g == Ker cz
   → ∀ x : gr_set (Ker c), ∃ y, x ∈ C → y ∈ B ∧ (Happ g y = x)%G.
Proof.
intros * mem_dec sg x.
destruct (mem_dec C x) as [H2| H2]; [ | now exists 0%G ].
enough (H : x ∈ Im g). {
  simpl in H.
  destruct H as (y & Hy & Hyx).
  now exists y.
}
apply sg.
split; [ easy | ].
now destruct (Happ cz x).
Qed.

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

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

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

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

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

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

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

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

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

(* *)

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

(* Connecting homomorphism: d *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Check snake.

(*
Print Assumptions snake.
*)