(** *************************************************

Contents:

- Definition of limits
- Proof that limits form a property in a (saturated/univalent) category ([isaprop_Lims])
- Pointwise construction of limits in functor precategories [LimsFunctorCategory]
- Alternative definition of limits via colimits

Written by: Benedikt Ahrens and Anders Mörtberg, 2015-2016

*****************************************************)

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

Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.MoreFoundations.Propositions.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.

Local Open Scope cat.

(** * Definition of limits *)
Section lim_def.

Definition forms_cone {C : precategory} {g : graph} (d : diagram g C)
    {c : C} (f : ∏ (v : vertex g), C⟦c, dob d v⟧) : UU
  := ∏ (u v : vertex g) (e : edge u v), f u · dmor d e = f v.

(** better not the following: [Coercion coneOut : cone >-> Funclass.] *)

Definition cone {C : precategory} {g : graph} (d : diagram g C) (c : C) : UU :=
  ∑ (f : ∏ (v : vertex g), C⟦c,dob d v⟧), forms_cone d f.

Definition make_cone {C : precategory} {g : graph} {d : diagram g C} {c : C}
  (f : ∏ v, C⟦c, dob d v⟧) (Hf : forms_cone d f) : cone d c
  := tpair _ f Hf.

(** The injections to c in the cocone *)
Definition coneOut {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cone d c) :
  ∏ v, C⟦c, dob d v⟧ := pr1 cc.

Lemma coneOutCommutes {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cone d c) :
  forms_cone d (coneOut cc).
Proof.
apply (pr2 cc).
Qed.

Definition is_cone_mor {C : precategory} {g : graph} {d : diagram g C} {c1 : C}
           (cc1 : cone d c1) {c2 : C} (cc2 : cone d c2) (x : c1 --> c2) : UU :=
  ∏ (v : vertex g), x · coneOut cc2 v = coneOut cc1 v.

Definition isLimCone {C : precategory} {g : graph} (d : diagram g C) (c0 : C)
  (cc0 : cone d c0) : UU := ∏ (c : C) (cc : cone d c),
    iscontr (∑ x : C⟦c,c0⟧, is_cone_mor cc cc0 x).

Definition LimCone {C : precategory} {g : graph} (d : diagram g C) : UU :=
   ∑ (A : (∑ l, cone d l)), isLimCone d (pr1 A) (pr2 A).

Definition make_LimCone {C : precategory} {g : graph} (d : diagram g C)
  (c : C) (cc : cone d c) (isCC : isLimCone d c cc) : LimCone d
  := tpair _ (tpair _ c cc) isCC.

(** [lim] is the tip of the [LimCone] *)
Definition lim {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) : C
  := pr1 (pr1 CC).

Definition limCone {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) :
  cone d (lim CC) := pr2 (pr1 CC).

Definition limOut {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) :
  ∏ (v : vertex g), C⟦lim CC, dob d v⟧ := coneOut (limCone CC).

Lemma limOutCommutes {C : precategory} {g : graph} {d : diagram g C}
  (CC : LimCone d) : forms_cone d (limOut CC).
Proof.
exact (coneOutCommutes (limCone CC)).
Qed.

Lemma limUnivProp {C : precategory} {g : graph} {d : diagram g C}
  (CC : LimCone d) : ∏ (c : C) (cc : cone d c),
  iscontr (∑ x : C⟦c, lim CC⟧, ∏ (v : vertex g), x · limOut CC v = coneOut cc v).
Proof.
apply (pr2 CC).
Qed.

Lemma isaprop_isLimCone {C : precategory} {g : graph} {d : diagram g C} (c0 : C)
  (cc0 : cone d c0) : isaprop (isLimCone d c0 cc0).
Proof.
repeat (apply impred; intro).
apply isapropiscontr.
Qed.

Definition isLimCone_LimCone {C : precategory} {g : graph} {d : diagram g C}
    (CC : LimCone d)
  : isLimCone d (lim CC) (tpair _ (limOut CC) (limOutCommutes CC))
  := pr2 CC.

Definition limArrow {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d)
  (c : C) (cc : cone d c) : C⟦c, lim CC⟧ :=
  pr1 (pr1 (isLimCone_LimCone CC c cc)).

Lemma limArrowCommutes {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d)
  (c : C) (cc : cone d c) (u : vertex g) :
   limArrow CC c cc · limOut CC u = coneOut cc u.
Proof.
exact ((pr2 (pr1 (isLimCone_LimCone CC _ cc))) u).
Qed.

Lemma limArrowUnique {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d)
  (c : C) (cc : cone d c) (k : C⟦c, lim CC⟧)
  (Hk : ∏ (u : vertex g), k · limOut CC u = coneOut cc u) :
  k = limArrow CC c cc.
Proof.
apply path_to_ctr. red. apply Hk.
Qed.

Lemma Cone_precompose {C : precategory} {g : graph} {d : diagram g C}
  {c : C} (cc : cone d c) (x : C) (f : C⟦x,c⟧) :
    ∏ u v (e : edge u v), (f · coneOut cc u) · dmor d e = f · coneOut cc v.
Proof.
now intros u v e; rewrite <- assoc, coneOutCommutes.
Qed.

Lemma limArrowEta {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d)
  (c : C) (f : C⟦c, lim CC⟧) :
  f = limArrow CC c (tpair _ (λ u, f · limOut CC u)
                 (Cone_precompose (limCone CC) c f)).
Proof.
now apply limArrowUnique.
Qed.

Definition limOfArrows {C : precategory} {g : graph} {d1 d2 : diagram g C}
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v) :
  C⟦lim CC1 , lim CC2⟧.
Proof.
apply limArrow; use make_cone.
- now intro u; apply (limOut CC1 u · f u).
- abstract (intros u v e; simpl;
            now rewrite <- assoc, fNat, assoc, limOutCommutes).
Defined.

Lemma limOfArrowsOut {C : precategory} {g : graph} (d1 d2 : diagram g C)
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v) :
    ∏ u, limOfArrows CC1 CC2 f fNat · limOut CC2 u =
          limOut CC1 u · f u.
Proof.
now unfold limOfArrows; intro u; rewrite limArrowCommutes.
Qed.

Lemma postCompWithLimOfArrows_subproof {C : precategory} {g : graph} {d1 d2 : diagram g C}
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v)
  (x : C) (cc : cone d1 x) u v (e : edge u v) :
    (coneOut cc u · f u) · dmor d2 e = coneOut cc v · f v.
Proof.
now rewrite <- (coneOutCommutes cc u v e), <- assoc, fNat, assoc.
Defined.

Lemma postCompWithLimOfArrows {C : precategory} {g : graph} (d1 d2 : diagram g C)
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v)
  (x : C) (cc : cone d1 x) :
     limArrow CC1 x cc · limOfArrows CC1 CC2 f fNat =
       limArrow CC2 x (make_cone (λ u, coneOut cc u · f u)
         (postCompWithLimOfArrows_subproof CC1 CC2 f fNat x cc)).
Proof.
apply limArrowUnique; intro u.
now rewrite <- assoc, limOfArrowsOut, assoc, limArrowCommutes.
Qed.

Lemma postCompWithLimArrow {C : precategory} {g : graph} (D : diagram g C)
 (CC : LimCone D) (c : C) (cc : cone D c) (d : C) (k : C⟦d,c⟧) :
   k · limArrow CC c cc  =
   limArrow CC d (make_cone (λ u, k · coneOut cc u)
              (Cone_precompose cc d k)).
Proof.
  apply limArrowUnique.
  now intro u; rewrite <- assoc, limArrowCommutes.
Qed.

Lemma lim_endo_is_identity {C : precategory} {g : graph} (D : diagram g C)
  (CC : LimCone D) (k : lim CC --> lim CC)
  (H : ∏ u, k · limOut CC u = limOut CC u) :
  identity _ = k.
Proof.
use (uniqueExists (limUnivProp CC _ _)).
- now apply (limCone CC).
- intros v; simpl.
  unfold compose. simpl.
  now apply id_left.
- simpl; now apply H.
Qed.

Lemma isLim_is_z_iso {C : precategory} {g : graph} (D : diagram g C) (CC : LimCone D) (d : C) (cd : cone D d) :
  isLimCone D d cd -> is_z_isomorphism (limArrow CC d cd).
Proof.
intro H.
set (CD := make_LimCone D d cd H).
apply (tpair _ (limArrow (make_LimCone D d cd H) (lim CC) (limCone CC))).
split.
    apply pathsinv0.
    change d with (lim CD).
    apply lim_endo_is_identity. simpl; intro u;
      rewrite <- assoc.
      eapply pathscomp0; [eapply maponpaths; apply limArrowCommutes|].
      apply (limArrowCommutes CC).
      apply pathsinv0, (lim_endo_is_identity _ CC); simpl; intro u;
      rewrite <- assoc.
      eapply pathscomp0; [eapply maponpaths; apply (limArrowCommutes CC)|].
      apply (limArrowCommutes CD).
Defined.

Lemma inv_isLim_is_z_iso {C : precategory} {g : graph} (D : diagram g C) (CC : LimCone D) (d : C)
  (cd : cone D d) (H : isLimCone D d cd) :
  inv_from_z_iso (_,,isLim_is_z_iso D CC d cd H) =
  limArrow (make_LimCone D d cd H) _ (limCone CC).
Proof.
  apply idpath.
Qed.

Lemma is_z_iso_isLim {C : category} {g : graph} (D : diagram g C) (CC : LimCone D) (d : C) (cd : cone D d) :
  is_z_isomorphism (limArrow CC d cd) -> isLimCone D d cd.
Proof.
intro H.
set (iinv := z_iso_inv_from_is_z_iso _ H).
intros x cx.
use tpair.
- use tpair.
  + exact (limArrow CC x cx·iinv).
  + simpl; intro u.
    assert (XR:=limArrowCommutes CC x cx u).
    eapply pathscomp0; [| apply XR].
    eapply pathscomp0; [ apply (!assoc _ _ _ ) |].
    apply maponpaths.
    apply z_iso_inv_on_right.
    apply pathsinv0, limArrowCommutes.
- intros p; destruct p as [f Hf].
  apply subtypePath.
  + intro a; apply impred; intro u; apply C.
  + simpl; apply  z_iso_inv_on_left; simpl.
    apply pathsinv0, limArrowUnique; intro u.
    cbn in *.
    eapply pathscomp0; [| apply Hf].
    eapply pathscomp0. apply (!assoc _ _ _ ).
    apply maponpaths.
    apply limArrowCommutes.
Defined.

(*
Definition Cocone_by_postcompose {g : graph} (D : diagram g C)
 (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : cocone D d.
Proof.
now exists (λ u, coconeIn cc u · k); apply Cocone_postcompose.
Defined.

Lemma isColim_weq_subproof1 {g : graph} (D : diagram g C)
  (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) :
  ∏ u, coconeIn cc u · k = pr1 (Cocone_by_postcompose D c cc d k) u.
Proof.
now intro u.
Qed.

Lemma isColim_weq_subproof2 (g : graph) (D : diagram g C)
  (c : C) (cc : cocone D c) (H : ∏ d, isweq (Cocone_by_postcompose D c cc d))
  (d : C) (cd : cocone D d) (u : vertex g) :
    coconeIn cc u · invmap (make_weq _ (H d)) cd = coconeIn cd u.
Proof.
rewrite (isColim_weq_subproof1 D c cc d (invmap (make_weq _ (H d)) _) u).
set (p := homotweqinvweq (make_weq _ (H d)) cd); simpl in p.
now rewrite p.
Qed.

Lemma isColim_weq {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) :
  isColimCocone D c cc <-> ∏ d, isweq (Cocone_by_postcompose D c cc d).
Proof.
split.
- intros H d.
  refine (isweq_iso _ _ _ _).
  + intros k.
    exact (colimArrow (make_ColimCocone D c cc H) _ k).
  + abstract (intro k; simpl;
              now apply pathsinv0, (colimArrowEta (make_ColimCocone D c cc H))).
  + abstract (simpl; intro k;
              apply total2_paths_second_isaprop;
                [ now repeat (apply impred; intro); apply hsC
                | destruct k as [k Hk]; simpl; apply funextsec; intro u;
                  now apply (colimArrowCommutes (make_ColimCocone D c cc H))]).
- intros H d cd.
  refine (tpair _ _ _).
  + exists (invmap (make_weq _ (H d)) cd).
    abstract (intro u; now apply isColim_weq_subproof2).
  + abstract (intro t; apply total2_paths_second_isaprop;
                [ now apply impred; intro; apply hsC
                | destruct t as [t Ht]; simpl;
                  apply (invmaponpathsweq (make_weq _ (H d))); simpl;
                  apply total2_paths_second_isaprop;
                    [ now repeat (apply impred; intro); apply hsC
                    | simpl; apply pathsinv0, funextsec; intro u; rewrite Ht;
                      now apply isColim_weq_subproof2]]).
Defined.
*)

Definition z_iso_from_lim_to_lim {C : precategory} {g : graph} {d : diagram g C}
  (CC CC' : LimCone d) : z_iso (lim CC) (lim CC').
Proof.
use make_z_iso.
- apply limArrow, limCone.
- apply limArrow, limCone.
- abstract (now split; apply pathsinv0, lim_endo_is_identity; intro u;
              rewrite <- assoc, limArrowCommutes; eapply pathscomp0; try apply limArrowCommutes).
Defined.

End lim_def.

Arguments LimCone [_] {_} _.

Section Lims.

Definition Lims (C : precategory) : UU := ∏ (g : graph) (d : diagram g C), LimCone d.
Definition hasLims (C : precategory) : UU  :=
  ∏ (g : graph) (d : diagram g C), ishinh (LimCone d).

(** Limits of a specific shape *)
Definition Lims_of_shape (g : graph) (C : precategory) : UU :=
  ∏ (d : diagram g C), LimCone d.

Section Universal_Unique.

Variable (C : univalent_category).

Let H : is_univalent C := pr2 C.

Lemma isaprop_Lims : isaprop (Lims C).
Proof.
apply impred; intro g; apply impred; intro cc.
apply invproofirrelevance; intros Hccx Hccy.
apply subtypePath.
- intro; apply isaprop_isLimCone.
- apply (total2_paths_f (isotoid _ H (z_iso_from_lim_to_lim Hccx Hccy))).
  set (B c := ∏ v, C⟦c,dob cc v⟧).
  set (C' (c : C) f := forms_cone(c:=c) cc f).
  rewrite (@transportf_total2 _ B C').
  apply subtypePath.
  + intro; repeat (apply impred; intro); apply univalent_category_has_homsets.
  + abstract (now simpl; eapply pathscomp0; [apply transportf_isotoid_dep'|];
              apply funextsec; intro v; rewrite inv_isotoid, idtoiso_isotoid;
              cbn; apply limArrowCommutes).
Qed.

End Universal_Unique.
End Lims.

(** * Limits in functor categories *)
Section LimFunctor.

Context {A C : category} {g : graph} (D : diagram g [A, C]).

Variable (HCg : ∏ (a : A), LimCone (diagram_pointwise D a)).

Definition LimFunctor_ob (a : A) : C := lim (HCg a).

Definition LimFunctor_mor (a a' : A) (f : A⟦a, a'⟧) :
  C⟦LimFunctor_ob a,LimFunctor_ob a'⟧.
Proof.
use limOfArrows.
- now intro u; apply (# (pr1 (dob D u)) f).
- abstract (now intros u v e; simpl; apply (nat_trans_ax (# D e))).
Defined.

Definition LimFunctor_data : functor_data A C := tpair _ _ LimFunctor_mor.

Lemma is_functor_LimFunctor_data : is_functor LimFunctor_data.
Proof.
split.
- intro a; simpl.
  apply pathsinv0, lim_endo_is_identity; intro u.
  unfold LimFunctor_mor; rewrite limOfArrowsOut.
  assert (H : # (pr1 (dob D u)) (identity a) = identity (pr1 (dob D u) a)).
    apply (functor_id (dob D u) a).
  now rewrite H, id_right.
- intros a b c fab fbc; simpl; unfold LimFunctor_mor.
  apply pathsinv0.
  eapply pathscomp0; [now apply postCompWithLimOfArrows|].
  apply pathsinv0, limArrowUnique; intro u.
  rewrite limOfArrowsOut, (functor_comp (dob D u)); simpl.
  now rewrite <- assoc.
Qed.

Definition LimFunctor : functor A C := tpair _ _ is_functor_LimFunctor_data.

Definition lim_nat_trans_in_data v : [A, C] ⟦ LimFunctor, dob D v ⟧.
Proof.
use tpair.
- intro a; exact (limOut (HCg a) v).
- abstract (intros a a' f; apply (limOfArrowsOut _ _ (HCg a) (HCg a'))).
Defined.

Definition cone_pointwise (F : [A,C]) (cc : cone D F) a :
  cone (diagram_pointwise D a) (pr1 F a).
Proof.
use make_cone.
- now intro v; apply (pr1 (coneOut cc v) a).
- abstract (intros u v e;
    now apply (nat_trans_eq_pointwise (coneOutCommutes cc u v e))).
Defined.

Lemma LimFunctor_unique (F : [A, C]) (cc : cone D F) :
  iscontr (∑ x : [A, C] ⟦ F, LimFunctor ⟧,
            ∏ v, x · lim_nat_trans_in_data v = coneOut cc v).
Proof.
use tpair.
- use tpair.
  + apply (tpair _ (λ a, limArrow (HCg a) _ (cone_pointwise F cc a))).
    abstract (intros a a' f; simpl; apply pathsinv0; eapply pathscomp0;
    [ apply (postCompWithLimOfArrows _ _ (HCg a))
    | apply pathsinv0; eapply pathscomp0;
      [ apply postCompWithLimArrow
      | apply limArrowUnique; intro u; eapply pathscomp0;
      [ now apply limArrowCommutes | now use nat_trans_ax]]]).
  + abstract (intro u; apply (nat_trans_eq C); simpl; intro a;
              now apply (limArrowCommutes (HCg a))).
- abstract (intro t; destruct t as [t1 t2];
            apply subtypePath; simpl;
              [ intro; apply impred; intro u; apply functor_category_has_homsets
              | apply (nat_trans_eq C); simpl; intro a;
                apply limArrowUnique; intro u;
                now apply (nat_trans_eq_pointwise (t2 u))]).
Defined.

Lemma LimFunctorCone : LimCone D.
Proof.
use make_LimCone.
- exact LimFunctor.
- use make_cone.
  + now apply lim_nat_trans_in_data.
  + abstract (now intros u v e; apply (nat_trans_eq C);
                  intro a; apply (limOutCommutes (HCg a))).
- now intros F cc; simpl; apply (LimFunctor_unique _ cc).
Defined.

Definition isLimFunctor_is_pointwise_Lim
  (X : [A,C]) (R : cone D X) (H : isLimCone D X R)
  : ∏ a, isLimCone (diagram_pointwise D a) _ (cone_pointwise X R a).
Proof.
  intro a.
  apply (is_z_iso_isLim _ (HCg a)).
  set (XR := isLim_is_z_iso D LimFunctorCone X R H).
  apply  (nat_trafo_pointwise_z_iso_if_z_iso _ _ XR).
Defined.

End LimFunctor.

Lemma LimsFunctorCategory (A C : category)
  (HC : Lims C) : Lims [A,C].
Proof.
now intros g d; apply LimFunctorCone.
Defined.

Lemma LimsFunctorCategory_of_shape (g : graph) (A C : category)
  (HC : Lims_of_shape g C) : Lims_of_shape g [A,C].
Proof.
now intros d; apply LimFunctorCone.
Defined.

Lemma pointwise_Lim_is_isLimFunctor
  {A C : category} {g : graph}
  (d : diagram g [A,C]) (G : [A,C]) (cG : cone d G)
  (H : ∏ a, isLimCone _ _ (cone_pointwise d G cG a)) :
  isLimCone d G cG.
Proof.
 set (CC a := make_LimCone _ _ _ (H a)).
 set (D' := LimFunctorCone _ CC).
 use is_z_iso_isLim.
 - apply D'.
 - use tpair.
   + use make_nat_trans.
     * intros a; apply identity.
     * abstract (
           intros a b f; rewrite id_left, id_right;
           apply pathsinv0 ;
           apply (limArrowUnique (CC b) (lim (CC a))) ; intro u ; cbn ;
           now rewrite <- (nat_trans_ax (coneOut cG u))
         ).
   + abstract (split;
               [ apply (nat_trans_eq C); intros x; simpl; rewrite id_right;
                 apply pathsinv0, (limArrowUnique (CC x)); intros v;
                 now rewrite id_left
               | apply (nat_trans_eq C); intros x; simpl; rewrite id_left;
                 apply pathsinv0, (limArrowUnique (CC x)); intro u;
                 now rewrite id_left]).
Defined.

Section map.

Context {C D : category} (F : functor C D).

Definition mapcone {g : graph} (d : diagram g C) {x : C}
  (dx : cone d x) : cone (mapdiagram F d) (F x).
Proof.
use make_cone.
- simpl; intro n.
  exact (#F (coneOut dx n)).
- abstract (intros u v e; simpl; rewrite <- functor_comp;
            apply maponpaths, (coneOutCommutes dx _ _ e)).
Defined.

Definition preserves_limit {g : graph} (d : diagram g C) (L : C)
  (cc : cone d L) : UU :=
  isLimCone d L cc -> isLimCone (mapdiagram F d) (F L) (mapcone d cc).

(** ** Right adjoints preserve limits *)
Lemma right_adjoint_preserves_limit (HF : is_right_adjoint F)
      {g : graph} (d : diagram g C) (L : C) (ccL : cone d L) : preserves_limit d L ccL.
Proof.
intros HccL M ccM.
set (G := left_adjoint HF).
set (H := pr2 HF : are_adjoints G F).
apply (@iscontrweqb _ (∑ y : C ⟦ G M, L ⟧,
    ∏ i, y · coneOut ccL i = φ_adj_inv H (coneOut ccM i))).
- eapply (weqcomp (Y := ∑ y : C ⟦ G M, L ⟧,
    ∏ i, φ_adj H y · # F (coneOut ccL i) = coneOut ccM i)).
  + apply invweq, (weqbandf (adjunction_hom_weq H M L)); simpl; intro f.
    abstract (now apply weqiff; try (apply impred; intro; apply D)).
  + eapply (weqcomp (Y := ∑ y : C ⟦ G M, L ⟧,
      ∏ i, φ_adj H (y · coneOut ccL i) = coneOut ccM i)).
    * apply weqfibtototal; simpl; intro f.
      abstract (apply weqiff; try (apply impred; intro; apply D); split; intros HH i;
               [ now rewrite φ_adj_natural_postcomp; apply HH
               | now rewrite <- φ_adj_natural_postcomp; apply HH ]).
    * apply weqfibtototal; simpl; intro f.
      abstract (apply weqiff; [ | apply impred; intro; apply D | apply impred; intro; apply C ];
      split; intros HH i;
        [ now rewrite <- (HH i), φ_adj_inv_after_φ_adj
        | now rewrite (HH i),  φ_adj_after_φ_adj_inv ]).
- transparent assert (X : (cone d (G M))).
  { use make_cone.
    + intro v; apply (φ_adj_inv H (coneOut ccM v)).
    + intros m n e; simpl.
      rewrite <- (coneOutCommutes ccM m n e); simpl.
      now rewrite φ_adj_inv_natural_postcomp.
  }
  apply (HccL (G M) X).
Defined.

End map.

Section Reflects.
  Context {C D : category} (F : functor C D).

  Definition reflects_limits_of_shape (g : graph) : UU :=
    ∏ (d : diagram g C) (L : ob C) cc,
      isLimCone (mapdiagram F d) (F L) (mapcone F d cc) ->
        isLimCone d L cc.

  Definition reflects_all_limits : UU :=
    ∏ (g : graph), reflects_limits_of_shape g.

  (** Fully faithful functors reflect limits of any given shape. *)
  Lemma fully_faithful_reflects_all_limits (fff : fully_faithful F) :
    reflects_all_limits.
  Proof.
    intros g d L cc isLimConeImL.
    unfold isLimCone in *.
    intros L' cc'.
    unfold fully_faithful in fff.
    apply (@iscontrweqf
             (∑ x : D ⟦ F L', F L ⟧,
              ∏ v : vertex g,
                x · coneOut (mapcone F d cc) v = coneOut (mapcone F d cc') v)).
    - apply (@weqcomp _ (∑ x : C ⟦ L', L ⟧, ∏ v : vertex g, # F x · coneOut (mapcone F d cc) v = coneOut (mapcone F d cc') v)).
      + apply invweq.
        apply (weqfp (weq_from_fully_faithful fff _ _)
                     (λ f, ∏ v, f · coneOut (mapcone F d cc) v = coneOut (mapcone F d cc') v)).
      + apply weqfibtototal; intro f.
        apply weqonsecfibers; intro v.
        unfold mapcone; cbn.
        apply invweq.
        apply fully_faithful_commutative_triangle_weq.
        assumption.
    - apply isLimConeImL.
  Qed.
End Reflects.

(** * Definition of limits via colimits *)

(** Put in a module for namespace reasons *)

Require UniMath.CategoryTheory.opp_precat.

Module co.

Import UniMath.CategoryTheory.opp_precat.

Section lim_def.

Context (C : category).

(* A cone with tip c over a diagram d *)
(*
Definition cocone {g : graph} (d : diagram g C) (c : C) : UU :=
  ∑ (f : ∏ (v : vertex g), C⟦dob d v,c⟧),
    ∏ (u v : vertex g) (e : edge u v), dmor d e · f v = f u.
*)

Definition opp_diagram g C := diagram g C^op.

Definition cone {g : graph} (d : diagram g C^op) (c : C) : UU :=
  @cocone C^op g d c.

(*
Definition make_cocone {g : graph} {d : diagram g C} {c : C}
  (f : ∏ v, C⟦dob d v,c⟧) (Hf : ∏ u v e, dmor d e · f v = f u) :
  cocone d c := tpair _ f Hf.
*)

Definition make_cone {g : graph} {d : diagram g C^op} {c : C}
           (f : ∏ v, C⟦c, dob d v⟧) (Hf : ∏ u v (e : edge u v) , f v · dmor d e  = f u) :
  cone d c
  := tpair _ f Hf.

(* The injections to c in the cocone *)
Definition coneOut {g : graph} {d : diagram g C^op} {c : C} (cc : cone d c) :
  ∏ v, C⟦c, dob d v⟧ := coconeIn cc.

Lemma coneOutCommutes {g : graph} {d : diagram g C^op} {c : C} (cc : cone d c) :
  ∏ u v (e : edge u v), coneOut cc v · dmor d e = coneOut cc u.
Proof.
  apply (coconeInCommutes cc).
Qed.

(* cc0 is a colimit cocone if for any other cocone cc over the same
   diagram there is a unique morphism from the tip of cc0 to the tip
   of cc *)
Definition isLimCone {g : graph} (d : diagram g C^op) (c0 : C)
  (cc0 : cone d c0) : UU :=
   isColimCocone _ _ cc0.
(*
∏ (c : C) (cc : cone d c),
      isColimCocone
    iscontr (∑ x : C⟦c0,c⟧, ∏ v, coconeIn cc0 v · x = coconeIn cc v).
*)

Definition LimCone {g : graph} (d : diagram g C^op) : UU :=
  ColimCocone d.

Definition make_LimCone {g : graph} (d : diagram g C^op)
  (c : C) (cc : cone d c) (isCC : isLimCone d c cc) : LimCone d.
Proof.
use make_ColimCocone.
- apply c.
- apply cc.
- apply isCC.
Defined.

Definition Lims : UU := ∏ (g : graph) (d : diagram g C^op), LimCone d.
Definition hasLims : UU  :=
  ∏ (g : graph) (d : diagram g C^op), ishinh (LimCone d).

(* lim is the tip of the lim cone *)
Definition lim {g : graph} {d : diagram g C^op} (CC : LimCone d) : C
  := colim CC.

Definition limCone {g : graph} {d : diagram g C^op} (CC : LimCone d) :
  cone d (lim CC) := colimCocone CC.

Definition limOut {g : graph} {d : diagram g C^op} (CC : LimCone d) :
  ∏ (v : vertex g), C⟦lim CC, dob d v⟧ := coneOut (limCone CC).

Lemma limOutCommutes {g : graph} {d : diagram g C^op}
  (CC : LimCone d) : ∏ (u v : vertex g) (e : edge u v),
   limOut CC v · dmor d e = limOut CC u.
Proof.
exact (coneOutCommutes (limCone CC)).
Qed.

Lemma limUnivProp {g : graph} {d : diagram g C^op}
  (CC : LimCone d) : ∏ (c : C) (cc : cone d c),
  iscontr (∑ x : C⟦c, lim CC⟧, ∏ (v : vertex g), x · limOut CC v = coneOut cc v).
Proof.
apply (colimUnivProp CC).
Qed.

Definition isLimCone_LimCone {g : graph} {d : diagram g C^op}
    (CC : LimCone d)
  : isLimCone d (lim CC) (tpair _ (limOut CC) (limOutCommutes CC))
  := isColimCocone_from_ColimCocone CC.

Definition limArrow {g : graph} {d : diagram g C^op} (CC : LimCone d)
  (c : C) (cc : cone d c) : C⟦c, lim CC⟧.
Proof.
 exact (colimArrow CC _ cc).
Defined.

Lemma limArrowCommutes {g : graph} {d : diagram g C^op} (CC : LimCone d)
  (c : C) (cc : cone d c) (u : vertex g) :
   limArrow CC c cc · limOut CC u = coneOut cc u.
Proof.
  exact (colimArrowCommutes CC _ cc _ ).
Qed.

Lemma limArrowUnique {g : graph} {d : diagram g C^op} (CC : LimCone d)
  (c : C) (cc : cone d c) (k : C⟦c, lim CC⟧)
  (Hk : ∏ (u : vertex g), k · limOut CC u = coneOut cc u) :
  k = limArrow CC c cc.
Proof.
  apply (colimArrowUnique CC c cc k Hk).
Qed.

Lemma Cone_precompose {g : graph} {d : diagram g C^op}
  {c : C} (cc : cone d c) (x : C) (f : C⟦x,c⟧) :
    ∏ u v (e : edge u v), (f · coneOut cc v) · dmor d e = f · coneOut cc u.
Proof.
  apply (Cocone_postcompose cc x f).
Qed.

Lemma limArrowEta {g : graph} {d : diagram g C^op} (CC : LimCone d)
  (c : C) (f : C⟦c, lim CC⟧) :
  f = limArrow CC c (tpair _ (λ u, f · limOut CC u)
                 (Cone_precompose (limCone CC) c f)).
Proof.
now apply limArrowUnique.
Qed.

Definition limOfArrows {g : graph} {d1 d2 : diagram g C^op}
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f v · (dmor d2 e : C⟦dob d2 v, dob d2 u⟧)
                              =
                                (dmor d1 e : C⟦dob d1 v, dob d1 u⟧)· f u) :
  C⟦lim CC1 , lim CC2⟧.
Proof.
  use (colimOfArrows CC2 CC1).
  - apply f.
  - apply fNat.
Defined.

Lemma limOfArrowsOut {g : graph} (d1 d2 : diagram g C^op)
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f v · dmor d2 e = (dmor d1 e : C ⟦ _ , _ ⟧)  · f u) :
    ∏ u, limOfArrows CC1 CC2 f fNat · limOut CC2 u =
          limOut CC1 u · f u.
Proof.
  apply (colimOfArrowsIn _ _ CC2 CC1 f fNat).
Qed.

Lemma postCompWithLimOfArrows_subproof {g : graph} {d1 d2 : diagram g C^op}
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f v · dmor d2 e = (dmor d1 e : C ⟦ _ , _ ⟧)  · f u)
  (x : C) (cc : cone d1 x) u v (e : edge u v) :
    (coneOut cc v · f v) · dmor d2 e = coneOut cc u · f u.
Proof.
  apply (preCompWithColimOfArrows_subproof CC2 CC1 f fNat x cc _ _ e).
Defined.

Lemma postcompWithColimOfArrows {g : graph} (d1 d2 : diagram g C^op)
  (CC1 : LimCone d1) (CC2 : LimCone d2)
  (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧)
  (fNat : ∏ u v (e : edge u v), f v · dmor d2 e = (dmor d1 e : C ⟦ _ , _ ⟧)  · f u)
  (x : C) (cc : cone d1 x) :
     limArrow CC1 x cc · limOfArrows CC1 CC2 f fNat =
       limArrow CC2 x (make_cone (λ u, coneOut cc u · f u)
         (postCompWithLimOfArrows_subproof CC1 CC2 f fNat x cc)).
Proof.
  apply limArrowUnique.
  intro.
  rewrite <- assoc.
  rewrite limOfArrowsOut.
  rewrite assoc.
  rewrite limArrowCommutes.
  apply idpath.
Qed.

Lemma precompWithLimArrow {g : graph} (D : diagram g C^op)
 (CC : LimCone D) (c : C) (cc : cone D c) (d : C) (k : C⟦d,c⟧) :
   k · limArrow CC c cc  =
   limArrow CC d (make_cone (λ u, k · coneOut cc u)
              (Cone_precompose cc d k)).
Proof.
  apply limArrowUnique.
  now intro u; rewrite <- assoc, limArrowCommutes.
Qed.

Lemma lim_endo_is_identity {g : graph} (D : diagram g C^op)
  (CC : LimCone D) (k : lim CC --> lim CC)
  (H : ∏ u, k · limOut CC u = limOut CC u) :
  identity _ = k.
Proof.
use (uniqueExists (limUnivProp CC _ _)).
- now apply (limCone CC).
- intros v; simpl.
  unfold compose. simpl.
  now apply id_left.
- simpl; now apply H.
Qed.

(*
Definition Cocone_by_postcompose {g : graph} (D : diagram g C)
 (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : cocone D d.
Proof.
now exists (λ u, coconeIn cc u · k); apply Cocone_postcompose.
Defined.

Lemma isColim_weq_subproof1 {g : graph} (D : diagram g C)
  (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) :
  ∏ u, coconeIn cc u · k = pr1 (Cocone_by_postcompose D c cc d k) u.
Proof.
now intro u.
Qed.

Lemma isColim_weq_subproof2 (g : graph) (D : diagram g C)
  (c : C) (cc : cocone D c) (H : ∏ d, isweq (Cocone_by_postcompose D c cc d))
  (d : C) (cd : cocone D d) (u : vertex g) :
    coconeIn cc u · invmap (make_weq _ (H d)) cd = coconeIn cd u.
Proof.
rewrite (isColim_weq_subproof1 D c cc d (invmap (make_weq _ (H d)) _) u).
set (p := homotweqinvweq (make_weq _ (H d)) cd); simpl in p.
now rewrite p.
Qed.

Lemma isColim_weq {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) :
  isColimCocone D c cc <-> ∏ d, isweq (Cocone_by_postcompose D c cc d).
Proof.
split.
- intros H d.
  refine (isweq_iso _ _ _ _).
  + intros k.
    exact (colimArrow (make_ColimCocone D c cc H) _ k).
  + abstract (intro k; simpl;
              now apply pathsinv0, (colimArrowEta (make_ColimCocone D c cc H))).
  + abstract (simpl; intro k;
              apply total2_paths_second_isaprop;
                [ now repeat (apply impred; intro); apply hsC
                | destruct k as [k Hk]; simpl; apply funextsec; intro u;
                  now apply (colimArrowCommutes (make_ColimCocone D c cc H))]).
- intros H d cd.
  refine (tpair _ _ _).
  + exists (invmap (make_weq _ (H d)) cd).
    abstract (intro u; now apply isColim_weq_subproof2).
  + abstract (intro t; apply total2_paths_second_isaprop;
                [ now apply impred; intro; apply hsC
                | destruct t as [t Ht]; simpl;
                  apply (invmaponpathsweq (make_weq _ (H d))); simpl;
                  apply total2_paths_second_isaprop;
                    [ now repeat (apply impred; intro); apply hsC
                    | simpl; apply pathsinv0, funextsec; intro u; rewrite Ht;
                      now apply isColim_weq_subproof2]]).
Defined.
*)

Lemma isLim_is_z_iso {g : graph} (D : diagram g C^op) (CC : LimCone D) (d : C) (cd : cone D d) :
  isLimCone D d cd -> is_z_isomorphism (limArrow CC d cd).
Proof.
intro H.
set (CD := make_LimCone D d cd H).
apply (tpair _ (limArrow (make_LimCone D d cd H) (lim CC) (limCone CC))).
split.
    apply pathsinv0.
    change d with (lim CD).
    apply lim_endo_is_identity. simpl; intro u;
      rewrite <- assoc.
      eapply pathscomp0; [eapply maponpaths; apply limArrowCommutes|].
      apply (limArrowCommutes CC).
      apply pathsinv0, (lim_endo_is_identity _ CC); simpl; intro u;
      rewrite <- assoc.
      eapply pathscomp0; [eapply maponpaths; apply (limArrowCommutes CC)|].
      apply (limArrowCommutes CD).
Defined.

Lemma inv_isLim_is_iso {g : graph} (D : diagram g C^op) (CC : LimCone D) (d : C)
  (cd : cone D d) (H : isLimCone D d cd) :
  inv_from_z_iso (_,,isLim_is_z_iso D CC d cd H) =
  limArrow (make_LimCone D d cd H) _ (limCone CC).
Proof.
  apply idpath.
Qed.

Lemma is_z_iso_isLim {g : graph} (D : diagram g C^op) (CC : LimCone D) (d : C) (cd : cone D d) :
  is_z_isomorphism (limArrow CC d cd) -> isLimCone D d cd.
Proof.
intro H.
set (iinv := z_iso_inv_from_is_z_iso _ H).
intros x cx.
use tpair.
- use tpair.
  + exact (limArrow CC x cx · iinv).
  + simpl; intro u.
    assert (XR := limArrowCommutes CC x cx u).
    eapply pathscomp0; [| apply XR].
    etrans. { use assoc. }
    apply (maponpaths (fun f => compose(C:=C^op) f (limArrow CC x cx))).
    apply (z_iso_inv_on_right(C:=C)).
    apply pathsinv0, limArrowCommutes.
- intros p; destruct p as [f Hf].
  apply subtypePath.
  + intro a; apply impred; intro u; apply C.
  + simpl; apply  z_iso_inv_on_left; simpl.
    apply pathsinv0, limArrowUnique; intro u.
    cbn in *.
    eapply pathscomp0; [| apply Hf].
    eapply pathscomp0. apply (!assoc _ _ _ ).
    apply (maponpaths (fun f' => compose(C:=C^op) f' f)).
    apply limArrowCommutes.
Defined.

End lim_def.

Arguments Lims : clear implicits.

Section LimFunctor.

Definition get_diagram (A C : category)
  (g : graph) (D : diagram g [A, C]^op) :
    diagram g [A^op, C^op].
Proof.
apply (tpair _ (λ u, from_opp_to_opp_opp _ _ _ (pr1 D u))).
intros u v e; simpl.
use tpair; simpl.
  + apply (pr2 D _ _ e).
  + abstract (intros a b f; apply pathsinv0, (pr2 (pr2 D u v e) b a f)).
Defined.

Definition get_cocone  (A C : category)
  (g : graph) (D : diagram g [A, C]^op) (F : functor A C) (ccF : cocone D F) :
  cocone (get_diagram A C  g D) (functor_opp F).
Proof.
destruct ccF as [t p]. (* If I remove this destruct the Qed for LimsFunctorCategory
                 takes twice as long *)
use make_cocone.
- intro u; apply (tpair _ (pr1 (t u))).
  abstract (intros a b f; apply pathsinv0, (pr2 (t u) b a f)).
- abstract (intros u v e; apply (nat_trans_eq C^op );
            now intro a; simpl; rewrite <- (p u v e)).
Defined.

Lemma LimFunctorCone (A C : category)
  (g : graph)
  (D : diagram g [A, C]^op)
  (HC : ∏ a : A^op,
            LimCone _
              (diagram_pointwise (get_diagram A C g D) a))
  : LimCone _ D.
Proof.
set (HColim := ColimFunctorCocone (get_diagram _ _ _ D) HC).
destruct HColim as [pr1x pr2x].
destruct pr1x as [pr1pr1x pr2pr1x].
destruct pr2pr1x as [pr1pr2pr1x pr2pr2pr1x].
simpl in *.
use (make_ColimCocone _ (from_op_op_to_op  _ _ pr1pr1x)).
- use make_cocone.
  + simpl; intros.
    use tpair.
    * intro a; apply (pr1pr2pr1x v a).
    * abstract (intros a b f; apply pathsinv0, (nat_trans_ax (pr1pr2pr1x v) (*b a f*))).
  + abstract (intros u v e; apply (nat_trans_eq C); simpl; intro a;
              now rewrite <- (pr2pr2pr1x u v e)).
- intros F ccF.
  set (H := pr2x (from_opp_to_opp_opp _ _ _ F) (get_cocone  _ _ _ _ _ ccF)).
  destruct H as [H1 H2].
  destruct H1 as [α Hα].
  simpl in *.
  use tpair.
  + use tpair.
    * exists α.
      abstract (intros a b f; simpl; now apply pathsinv0, (nat_trans_ax α b a f)).
    * abstract (intro u; apply (nat_trans_eq C); intro a;
        destruct ccF as [t p]; apply (toforallpaths _ _ _ (maponpaths pr1 (Hα u)) a)).
  + intro H; destruct H as [f Hf]; apply subtypePath.
    * abstract (intro β; repeat (apply impred; intro);
        now apply (has_homsets_opp (functor_category_has_homsets A C C))).
    * match goal with |[ H2 : ∏ _ : ?TT ,  _ = _ ,,_   |- _ ] =>
                       transparent assert (T : TT) end.
      (*
      refine (let T : ∑ x : nat_trans pr1pr1x (functor_opp F),
                         ∏ v, nat_trans_comp (functor_opp (pr1 D v)) _ _
                                (pr1pr2pr1x v) x =
                               coconeIn (get_cocone A C hsC g D F ccF) v :=
                  _ in _).
      *)
      { use (tpair _ (tpair _ (pr1 f) _)); simpl.
        - abstract (intros x y fxy; apply pathsinv0, (pr2 f y x fxy)).
        - abstract (intro u; apply (nat_trans_eq (has_homsets_opp C)); intro x;
            destruct ccF as [t p]; apply (toforallpaths _ _ _ (maponpaths pr1 (Hf u)) x)).
      }
      set (T' := maponpaths pr1 (H2 T)); simpl in T'.
      apply (nat_trans_eq C); intro a; simpl.
      now rewrite <- T'.
Defined.

End LimFunctor.

(*

(* Defines colimits in functor categories when the target has colimits *)
Section ColimFunctor.

Variable A C : precategory.
Variable HC : Colims C.
Variable hsC : has_homsets C.
Variable g : graph.
Variable D : diagram g [A, C, hsC].

Definition diagram_pointwise (a : A) : diagram g C.
Proof.
exists (λ v, pr1 (dob D v) a); intros u v e.
now apply (pr1 (dmor D e) a).
Defined.

Let HCg a := HC g (diagram_pointwise a).

Definition ColimFunctor_ob (a : A) : C := colim (HCg a).

Definition ColimFunctor_mor (a a' : A) (f : A⟦a, a'⟧) :
  C⟦ColimFunctor_ob a,ColimFunctor_ob a'⟧.
Proof.
refine (colimOfArrows _ _ _ _).
- now intro u; apply (# (pr1 (dob D u)) f).
- abstract (now intros u v e; simpl; apply pathsinv0, (nat_trans_ax (dmor D e))).
Defined.

Definition ColimFunctor_data : functor_data A C := tpair _ _ ColimFunctor_mor.

Lemma is_functor_ColimFunctor_data : is_functor ColimFunctor_data.
Proof.
split.
- intro a; simpl.
  apply pathsinv0, colim_endo_is_identity; intro u.
  unfold ColimFunctor_mor.
  now rewrite colimOfArrowsIn, (functor_id (dob D u)), id_left.
- intros a b c fab fbc; simpl; unfold ColimFunctor_mor.
  apply pathsinv0.
  eapply pathscomp0; [now apply precompWithColimOfArrows|].
  apply pathsinv0, colimArrowUnique; intro u.
  rewrite colimOfArrowsIn.
  rewrite (functor_comp (dob D u)).
  now apply pathsinv0, assoc.
Qed.

Definition ColimFunctor : functor A C := tpair _ _ is_functor_ColimFunctor_data.

Definition colim_nat_trans_in_data v : [A, C, hsC] ⟦ dob D v, ColimFunctor ⟧.
Proof.
refine (tpair _ _ _).
- intro a; exact (colimIn (HCg a) v).
- abstract (intros a a' f;
            now apply pathsinv0, (colimOfArrowsIn _ _ (HCg a) (HCg a'))).
Defined.

Definition cocone_pointwise (F : [A,C,hsC]) (cc : cocone D F) a :
  cocone (diagram_pointwise a) (pr1 F a).
Proof.
refine (make_cocone _ _).
- now intro v; apply (pr1 (coconeIn cc v) a).
- abstract (intros u v e;
    now apply (nat_trans_eq_pointwise  (coconeInCommutes cc u v e))).
Defined.

Lemma ColimFunctor_unique (F : [A, C, hsC]) (cc : cocone D F) :
  iscontr (∑ x : [A, C, hsC] ⟦ ColimFunctor, F ⟧,
            ∏ v : vertex g, colim_nat_trans_in_data v · x = coconeIn cc v).
Proof.
refine (tpair _ _ _).
- refine (tpair _ _ _).
  + apply (tpair _ (λ a, colimArrow (HCg a) _ (cocone_pointwise F cc a))).
    abstract (intros a a' f; simpl;
              eapply pathscomp0;
                [ now apply precompWithColimOfArrows
                | apply pathsinv0; eapply pathscomp0;
                  [ now apply postcompWithColimArrow
                  | apply colimArrowUnique; intro u;
                    eapply pathscomp0;
                      [ now apply colimArrowCommutes
                      | now apply pathsinv0, nat_trans_ax ]]]).
  + abstract (intro u; apply (nat_trans_eq hsC); simpl; intro a;
              now apply (colimArrowCommutes (HCg a))).
- abstract (intro t; destruct t as [t1 t2];
            apply (total2_paths_second_isaprop); simpl;
              [ apply impred; intro u; apply functor_category_has_homsets
              | apply (nat_trans_eq hsC); simpl; intro a;
                apply colimArrowUnique; intro u;
                now apply (nat_trans_eq_pointwise (t2 u))]).
Defined.

Lemma ColimFunctorCocone : ColimCocone D.
Proof.
refine (make_ColimCocone _ _ _ _).
- exact ColimFunctor.
- refine (make_cocone _ _).
  + now apply colim_nat_trans_in_data.
  + abstract (now intros u v e; apply (nat_trans_eq hsC);
                  intro a; apply (colimInCommutes (HCg a))).
- now intros F cc; simpl; apply (ColimFunctor_unique _ cc).
Defined.

End ColimFunctor.

Lemma ColimsFunctorCategory (A C : precategory) (hsC : has_homsets C)
  (HC : Colims C) : Colims [A,C,hsC].
Proof.
now intros g d; apply ColimFunctorCocone.
Defined.
*)

End co.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   natZ.
   Some lemmas about inject_nat, absolu and the relation between
   Z and nat in general.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision: 788 $
*)

Require Import ZArith.
Require Import EqNat.

Require Import lemmas.

Lemma abs_opp : forall x : Z, Zabs_nat x = Zabs_nat (- x).
Proof.
   simple induction x.
   simpl in |- *. reflexivity.
   simpl in |- *. reflexivity.
   simpl in |- *. reflexivity.
Qed.

Lemma inj_abs_pos : forall x : Z, (x >= 0)%Z -> Z_of_nat (Zabs_nat x) = x.
Proof.
   simple induction x.
   reflexivity.
   intros. simpl in |- *.
   induction  p as [p Hrecp| p Hrecp| ].
   rewrite BinInt.Zpos_xI.
   rewrite <- Hrecp.
   replace (nat_of_P (xI p)) with (S (2 * nat_of_P p)).
   rewrite Znat.inj_S.
   rewrite Znat.inj_mult.
   rewrite Hrecp.
   simpl in |- *.
   reflexivity.
   apply Zle_ge. apply Zorder.Zle_0_pos.
   replace 2 with (nat_of_P 2).
   rewrite <- nat_of_P_mult_morphism.
   simpl in |- *.
   rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ.
   rewrite P_of_succ_nat_o_nat_of_P_eq_succ.
   simpl in |- *.
   reflexivity.
   simpl in |- *.
   reflexivity.
   apply Zle_ge. apply Zorder.Zle_0_pos.
   rewrite BinInt.Zpos_xO.
   rewrite <- Hrecp.
   replace (nat_of_P (xO p)) with (2 * nat_of_P p).
   rewrite Znat.inj_mult.
   rewrite Hrecp.
   simpl in |- *.
   reflexivity.
   apply Zle_ge. apply Zorder.Zle_0_pos.
   replace 2 with (nat_of_P 2).
   rewrite <- nat_of_P_mult_morphism.
   simpl in |- *.
   reflexivity.
   simpl in |- *.
   reflexivity.
   apply Zle_ge.
   apply Zorder.Zle_0_pos.
   reflexivity.
   intros.
   elim H.
   simpl in |- *.
   reflexivity.
Qed.

Lemma inj_abs_neg :
 forall x : Z, (x < 0)%Z -> Z_of_nat (Zabs_nat x) = (- x)%Z.
Proof.
   intros.
   rewrite abs_opp.
   apply inj_abs_pos.
   apply Zle_ge.
   apply Zplus_le_reg_l with x.
   rewrite <- Zplus_0_r_reverse.
   rewrite Zplus_opp_r.
   apply Zlt_le_weak.
   assumption.
Qed.

Lemma abs_inj : forall n : nat, Zabs_nat (Z_of_nat n) = n.
Proof.
   simple induction n.
   simpl in |- *. reflexivity.
   intros m IH.
   rewrite <- IH. simpl in |- *.
   rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
   reflexivity.
Qed.

Lemma abs_mult : forall x y : Z, Zabs_nat (x * y) = Zabs_nat x * Zabs_nat y.
Proof.
   simple induction x.
   simpl in |- *. intro. reflexivity.
   intro.
   simple induction y.
   simpl in |- *.
   rewrite <- mult_n_O.
   reflexivity.
   intro.
   simpl in |- *.
   rewrite <- nat_of_P_mult_morphism.
   reflexivity.
   simpl in |- *.
   intro.
   rewrite <- nat_of_P_mult_morphism.
   reflexivity.
   intro.
   simple induction y.
   simpl in |- *.
   rewrite <- mult_n_O.
   reflexivity.
   intro.
   unfold Zabs_nat in |- *.
   simpl in |- *.
   rewrite <- nat_of_P_mult_morphism.
   reflexivity.
   intro.
   unfold Zabs_nat in |- *.
   simpl in |- *.
   rewrite <- nat_of_P_mult_morphism.
   reflexivity.
Qed.

Lemma isnat_inj_abs :
 forall (x : Z) (n : nat), x = Z_of_nat n -> n = Zabs_nat x.
Proof.
   intros.
   rewrite H.
   rewrite abs_inj.
   reflexivity.
Qed.

Lemma isnat_abs_inj :
 forall (x : Z) (n : nat), (0 <= x)%Z -> n = Zabs_nat x -> x = Z_of_nat n.
Proof.
   intros.
   rewrite H0.
   rewrite inj_abs_pos.
   reflexivity.
   apply Zle_ge.
   assumption.
Qed.

Lemma isnat_plus : forall x y : Z, (0 <= x)%Z -> (0 <= y)%Z -> (0 <= x + y)%Z.
Proof.
   simple induction x. simpl in |- *. intros. assumption.
   intro. simple induction y. simpl in |- *. intros. assumption.
   simpl in |- *. intros. unfold Zle in |- *. simpl in |- *. discriminate.
   intros. unfold Zle in H0. elim H0. simpl in |- *. reflexivity.
   intros. unfold Zle in H. elim H. simpl in |- *. reflexivity.
Qed.

Lemma isnat_mult : forall x y : Z, (0 <= x)%Z -> (0 <= y)%Z -> (0 <= x * y)%Z.
Proof.
   simple induction x.
   simpl in |- *. intros. unfold Zle in |- *. simpl in |- *. discriminate.
   intro. simple induction y. simpl in |- *. intros. unfold Zle in |- *. simpl in |- *. discriminate.
   simpl in |- *. intros. unfold Zle in |- *. simpl in |- *. discriminate.
   intros. unfold Zle in H0. elim H0. simpl in |- *. reflexivity.
   intros. unfold Zle in H. elim H. simpl in |- *. reflexivity.
Qed.

Lemma lezle :
 forall x y : Z,
 (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Zabs_nat x <= Zabs_nat y.
Proof.
   intros.
   elim (le_or_lt (Zabs_nat x) (Zabs_nat y)).
   intros. assumption.
   intros. elim (Zlt_not_le y x).
   rewrite <- (inj_abs_pos x).
   rewrite <- (inj_abs_pos y).
   apply Znat.inj_lt. assumption.
   apply Zle_ge. assumption.
   apply Zle_ge. assumption.
   assumption.
Qed.

Lemma gtzgt :
 forall x y : Z,
 (0 <= x)%Z -> (0 <= y)%Z -> (x > y)%Z -> Zabs_nat x > Zabs_nat y.
Proof.
   intros.
   elim (le_or_lt (Zabs_nat x) (Zabs_nat y)).
   intros.
   elim (Zle_not_lt x y).
   rewrite <- (inj_abs_pos x).
   rewrite <- (inj_abs_pos y).
   apply Znat.inj_le. assumption.
   apply Zle_ge. assumption.
   apply Zle_ge. assumption.
   apply Zgt_lt. assumption.
   unfold gt in |- *. intro. assumption.
Qed.

Lemma ltzlt :
 forall x y : Z,
 (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Zabs_nat x < Zabs_nat y.
Proof.
   intros.
   change (Zabs_nat y > Zabs_nat x) in |- *.
   apply gtzgt. assumption. assumption.
   apply Zlt_gt. assumption.
Qed.

Lemma abs_plus_pos :
 forall x y : Z,
 (0 <= x)%Z -> (0 <= y)%Z -> Zabs_nat (x + y) = Zabs_nat x + Zabs_nat y.
Proof.
   simple induction x.
   simpl in |- *.
   intros.
   reflexivity.
   intro.
   simple induction y.
   simpl in |- *.
   rewrite <- plus_n_O.
   intros.
   reflexivity.
   simpl in |- *.
   intros.
   apply nat_of_P_plus_morphism.
   intros.
   unfold Zle in H0.
   simpl in H0.
   elim H0.
   reflexivity.
   intros.
   unfold Zle in H.
   simpl in H.
   elim H.
   reflexivity.
Qed.

Lemma abs_minus_pos :
 forall x y : Z,
 (0 <= x)%Z ->
 (0 <= y)%Z -> (x >= y)%Z -> Zabs_nat (x - y) = Zabs_nat x - Zabs_nat y.
Proof.
   intros.
   elim (Z_of_nat_complete x).
   intros nx Hx.
   elim (Z_of_nat_complete y).
   intros ny Hy.
   elim (Z_of_nat_complete (x - y)).
   intros d Hd.
   rewrite Hx.
   rewrite Hy.
   rewrite <- Znat.inj_minus1.
   rewrite abs_inj.
   rewrite abs_inj.
   rewrite abs_inj.
   reflexivity.
   rewrite (isnat_inj_abs x nx).
   rewrite (isnat_inj_abs y ny).
   apply lezle.
   assumption.
   assumption.
   apply Zge_le.
   assumption.
   assumption.
   assumption.
   unfold Zminus in |- *.
   apply Zle_left.
   apply Zge_le.
   assumption.
   assumption.
   assumption.
Qed.

Lemma abs_pred_pos :
 forall x : Z, (0 < x)%Z -> pred (Zabs_nat x) = Zabs_nat (x - 1).
Proof.
   intros.
   rewrite abs_minus_pos.
   replace (Zabs_nat 1) with 1.
   rewrite predminus1.
   reflexivity.
   reflexivity.
   apply Zlt_le_weak.
   assumption.
   unfold Zle in |- *.
   simpl in |- *.
   discriminate.
   apply Zle_ge.
   change (Zsucc 0 <= x)%Z in |- *.
   apply Zlt_le_succ.
   assumption.
Qed.

Lemma abs_neq_lt : forall x : Z, x <> 0%Z -> 0 < Zabs_nat x.
Proof.
   simple induction x.
   intro. elim H. reflexivity.
   intros. change (Zabs_nat 0 < Zabs_nat (Zpos p)) in |- *. apply ltzlt.
   unfold Zle in |- *. simpl in |- *. discriminate.
   unfold Zle in |- *. simpl in |- *. discriminate.
   unfold Zlt in |- *. simpl in |- *. reflexivity.
   intros. change (Zabs_nat 0 < Zabs_nat (Zpos p)) in |- *. apply ltzlt.
   unfold Zle in |- *. simpl in |- *. discriminate.
   unfold Zle in |- *. simpl in |- *. discriminate.
   unfold Zlt in |- *. simpl in |- *. reflexivity.
Qed.

Lemma nat_ge_0 : forall n : nat, (Z_of_nat n >= 0)%Z.
Proof.
   simple induction n.
   simpl in |- *. unfold Zge in |- *. simpl in |- *. discriminate.
   intros m IHm.
   change (Z_of_nat (S m) >= Z_of_nat 0)%Z in |- *.
   apply Znat.inj_ge. unfold ge in |- *.
   apply le_O_n.
Qed.


Require Import Bool Arith Omega List Coq.Program.Equality.
Require Import MSets.
Require Import Maps Imp.
Require Import Sequences Semantics.

(** In this chapter: liveness analysis and its use for an optimization
  called dead code elimination. *)

(** * 1. Sets of variables *)

(** The static analysis we need -- liveness analysis -- operates over
  sets of variables.  Coq's standard library provides a rich, efficient
  implementation of finite sets.  Before being able to use it, however,
  we must provide it with a Coq module equipping the type of identifiers
  with a decidable equality.  The implementation of this module follows. *)

Module Id_Decidable <: DecidableType with Definition t := id.
  Definition t := id.
  Definition eq (x y: t) := x = y.
  Lemma eq_equiv: Equivalence eq.
  Proof.
    constructor; red; unfold eq; intros; congruence.
  Qed.
  Definition eq_dec: forall (x y: t), {eq x y} + {~eq x y}.
  Proof.
    intros. destruct  (beq_id x y) eqn:BEQ.
  - left; apply beq_id_true_iff; auto.
  - right; apply beq_id_false_iff; auto.
  Defined.
End Id_Decidable.

(** We then instantiate the finite sets modules from Coq's standard library
  with this ordered type of integers. *)

Module VS := MSetWeakList.Make(Id_Decidable).
Module VSP := MSetProperties.WProperties(VS).
Module VSdecide := MSetDecide.Decide(VS).
Import VSdecide.

(** * 2. Liveness analysis *)

(** ** Free variables *)

(** Computation of the set of variables appearing in an expression or command. *)

Fixpoint fv_aexp (a: aexp) : VS.t :=
  match a with
  | ANum n => VS.empty
  | AId v => VS.singleton v
  | APlus a1 a2 => VS.union (fv_aexp a1) (fv_aexp a2)
  | AMinus a1 a2 => VS.union (fv_aexp a1) (fv_aexp a2)
  | AMult a1 a2 => VS.union (fv_aexp a1) (fv_aexp a2)
  end.

Fixpoint fv_bexp (b: bexp) : VS.t :=
  match b with
  | BTrue => VS.empty
  | BFalse => VS.empty
  | BEq a1 a2 => VS.union (fv_aexp a1) (fv_aexp a2)
  | BLe a1 a2 => VS.union (fv_aexp a1) (fv_aexp a2)
  | BNot b1 => fv_bexp b1
  | BAnd b1 b2 => VS.union (fv_bexp b1) (fv_bexp b2)
  end.

Fixpoint fv_com (c: com) : VS.t :=
  match c with
  | SKIP => VS.empty
  | x ::= a => fv_aexp a
  | (c1 ;; c2) => VS.union (fv_com c1) (fv_com c2)
  | IFB b THEN c1 ELSE c2 FI => VS.union (fv_bexp b) (VS.union (fv_com c1) (fv_com c2))
  | WHILE b DO c END => VS.union (fv_bexp b) (fv_com c)
  end.

(** ** Computing post-fixpoints. *)

Section FIXPOINT.

Variable F: VS.t -> VS.t.
Variable default: VS.t.

(** Our goal is to find a set of variables [x] such that [F x] is a subset of [x]
  (a post-fixpoint of F).  We use a naive algorithm: iterate [F] at most [n] times,
  stopping as soon as a post-fixpoint is encountered.  If not,
  we return a safe default result. *)

Fixpoint iter (n: nat) (x: VS.t) : VS.t :=
  match n with
  | O => default
  | S n' =>
      let x' := F x in
      if VS.subset x' x then x else iter n' x'
  end.

Definition niter := 10%nat.

Definition fixpoint : VS.t := iter niter VS.empty.

Lemma fixpoint_charact:
  VS.Subset (F fixpoint) fixpoint \/ fixpoint = default.
Proof.
  unfold fixpoint. generalize niter, VS.empty. induction n; intros; simpl.
- auto.
- destruct (VS.subset (F t) t) eqn:SUBSET.
+ left. apply VS.subset_spec; auto.
+ apply IHn.
Qed.

Hypothesis F_stable:
  forall x, VS.Subset x default -> VS.Subset (F x) default.

Lemma fixpoint_upper_bound:
  VS.Subset fixpoint default.
Proof.
  assert (forall n x, VS.Subset x default -> VS.Subset (iter n x) default).
  { induction n; intros; simpl.
  - red; auto.
  - destruct (VS.subset (F x) x) eqn:SUBSET.
    + auto.
    + apply IHn; auto.
  }
  unfold fixpoint. apply H. apply VSP.subset_empty.
Qed.

End FIXPOINT.

(** ** Liveness analysis. *)

(** [L] is the set of variables live "after" command [c].
  The result of [live c L] is the set of variables live "before" [c]. *)

Fixpoint live (c: com) (L: VS.t) : VS.t :=
  match c with
  | SKIP => L
  | x ::= a =>
      if VS.mem x L
      then VS.union (VS.remove x L) (fv_aexp a)
      else L
  | (c1 ;; c2) =>
      live c1 (live c2 L)
  | IFB b THEN c1 ELSE c2 FI =>
      VS.union (fv_bexp b) (VS.union (live c1 L) (live c2 L))
  | WHILE b DO c END =>
      let L' := VS.union (fv_bexp b) L in
      let default := VS.union (fv_com (CWhile b c)) L in
      fixpoint (fun x => VS.union L' (live c x)) default
  end.

Lemma live_upper_bound:
  forall c L,
  VS.Subset (live c L) (VS.union (fv_com c) L).
Proof.
  induction c; intros; simpl.
- fsetdec.
- destruct (VS.mem i L) eqn:MEM. fsetdec. fsetdec.
- specialize (IHc1 (live c2 L)). specialize (IHc2 L). fsetdec.
- specialize (IHc1 L). specialize (IHc2 L). fsetdec.
- apply fixpoint_upper_bound. intro x. specialize (IHc x). fsetdec.
Qed.

Lemma live_while_charact:
  forall b c L,
  let L' := live (WHILE b DO c END) L in
  VS.Subset (fv_bexp b) L' /\ VS.Subset L L' /\ VS.Subset (live c L') L'.
Proof.
  intros.
  specialize (fixpoint_charact
    (fun x : VS.t => VS.union (VS.union (fv_bexp b) L) (live c x))
          (VS.union (VS.union (fv_bexp b) (fv_com c)) L)).
  simpl in L'. fold L'. intros [A|A].
- split. fsetdec. split; fsetdec.
- split. rewrite A. fsetdec.
  split. rewrite A. fsetdec.
  eapply VSP.subset_trans. apply live_upper_bound. rewrite A. fsetdec.
Qed.

(** * 3. Dead code elimination *)

(** ** Code transformation *)

(** The code transformation turns assignments [x ::= a] to dead variables [x]
  into [SKIP] statements. *)

Fixpoint dce (c: com) (L: VS.t): com :=
  match c with
  | SKIP => SKIP
  | x ::= a => if VS.mem x L then x ::= a else SKIP
  | (c1 ;; c2) => (dce c1 (live c2 L) ;; dce c2 L)
  | IFB b THEN c1 ELSE c2 FI => IFB b THEN dce c1 L ELSE dce c2 L FI
  | WHILE b DO c END => WHILE b DO dce c (live (WHILE b DO c END) L) END
  end.

(** Example of optimization. *)

Notation va := (Id "a").
Notation vb := (Id "b").
Notation vq := (Id "q").
Notation vr := (Id "r").

Definition prog :=
  ( vr ::= AId va ;;
    vq ::= ANum 0 ;;
    WHILE BLe (AId vb) (AId vr) DO
      vr ::= AMinus (AId vr) (AId vb) ;;
      vq ::= APlus (AId vq) (ANum 1)
    END ).

Compute (dce prog (VS.singleton vr)).

(** Result is:
<<
   r := a;                 ===>   r := a;
   q := 0;                        skip;
   while b <= r do                while b <= r do
     r := r - b;                    r := r - b;
     q := q + 1;                    skip;
   done                           done
>>
*)

Compute (dce prog (VS.singleton vq)).

(** Program is unchanged. *)

(** ** Semantic correctness *)

(** Two states agree on a set [L] of live variables if they assign
  the same values to each live variable. *)

Definition agree (L: VS.t) (s1 s2: state) : Prop :=
  forall x, VS.In x L -> s1 x = s2 x.

(** Monotonicity property. *)

Lemma agree_mon:
  forall L L' s1 s2,
  agree L' s1 s2 -> VS.Subset L L' -> agree L s1 s2.
Proof.
  unfold VS.Subset, agree; intros. auto.
Qed.

(** Agreement on the free variables of an expression implies that this
    expression evaluates identically in both states. *)

Lemma aeval_agree:
  forall L s1 s2, agree L s1 s2 ->
  forall a, VS.Subset (fv_aexp a) L -> aeval s1 a = aeval s2 a.
Proof.
  induction a; simpl; intros.
- auto.
- apply H. fsetdec.
- f_equal. apply IHa1. fsetdec. apply IHa2. fsetdec.
- f_equal. apply IHa1. fsetdec. apply IHa2. fsetdec.
- f_equal. apply IHa1. fsetdec. apply IHa2. fsetdec.
Qed.

Lemma beval_agree:
  forall L s1 s2, agree L s1 s2 ->
  forall b, VS.Subset (fv_bexp b) L -> beval s1 b = beval s2 b.
Proof.
  induction b; simpl; intros.
- auto.
- auto.
- repeat rewrite (aeval_agree L s1 s2); auto; fsetdec.
- repeat rewrite (aeval_agree L s1 s2); auto; fsetdec.
- f_equal; apply IHb; auto.
- f_equal. apply IHb1; fsetdec. apply IHb2; fsetdec.
Qed.

(** Agreement is preserved by simultaneous assignment to a live variable. *)

Lemma agree_update_live:
  forall s1 s2 L x v,
  agree (VS.remove x L) s1 s2 ->
  agree L (t_update s1 x v) (t_update s2 x v).
Proof.
  intros; red; intros. unfold t_update. destruct (beq_id x x0) eqn:BEQ.
- auto.
- apply H. apply VS.remove_spec. split; auto. apply sym_not_equal. apply beq_id_false_iff. auto.
Qed.

(** Agreement is also preserved by unilateral assignment to a dead variable. *)

Lemma agree_update_dead:
  forall s1 s2 L x v,
  agree L s1 s2 -> ~VS.In x L ->
  agree L (t_update s1 x v) s2.
Proof.
  intros; red; intros. unfold t_update. destruct (beq_id x x0) eqn:BEQ.
- apply beq_id_true_iff in BEQ. subst x0. contradiction.
- apply H; auto.
Qed.

(** We now show that dead code elimination preserves semantics for terminating
  source program.  We use big-step semantics to show the following diagram:
<<
                agree (live c L) st st1
     c / st ----------------------------- dce C L / st1
       |                                          |
       |                                          |
       |                                          |
       v                                          v
      st' -------------------------------------- st1'
                    agree L st' st1'
>>
  The proof is a simple induction on the big-step evaluation derivation on the left. *)

Theorem dce_correct_terminating:
  forall st c st', c / st \\ st' ->
  forall L st1,
  agree (live c L) st st1 ->
  exists st1', dce c L / st1 \\ st1' /\ agree L st' st1'.
Proof.
  induction 1; intros; simpl.

- (* skip *)
  exists st1; split. constructor. auto.

- (* := *)
  simpl in H0. destruct (VS.mem x L) eqn:LIVE_AFTER.
  + (* x is live after *)
    assert (aeval st1 a1 = n).
    { rewrite <- H. symmetry. eapply aeval_agree. eauto. fsetdec. }
    exists (t_update st1 x n); split.
    apply E_Ass. auto.
    apply agree_update_live. eapply agree_mon. eauto. fsetdec.
  + (* x is dead after *)
    exists st1; split.
    apply E_Skip.
    apply agree_update_dead. auto.
    rewrite <- VS.mem_spec. congruence.

- (* seq *)
  simpl in H1.
  destruct (IHceval1 _ _ H1) as [st1' [E1 A1]].
  destruct (IHceval2 _ _ A1) as [st2' [E2 A2]].
  exists st2'; split.
  apply E_Seq with st1'; auto.
  auto.

- (* if true *)
  simpl in H1.
  assert (beval st1 b = true).
  { rewrite <- H. symmetry. eapply beval_agree; eauto. fsetdec. }
  destruct (IHceval L st1) as [st1' [E A]].
    eapply agree_mon; eauto. fsetdec.
  exists st1'; split.
  apply E_IfTrue; auto.
  auto.

- (* if false *)
  simpl in H1.
  assert (beval st1 b = false).
  { rewrite <- H. symmetry. eapply beval_agree; eauto. fsetdec. }
  destruct (IHceval L st1) as [st1' [E A]].
    eapply agree_mon; eauto. fsetdec.
  exists st1'; split.
  apply E_IfFalse; auto.
  auto.

- (* while end *)
  destruct (live_while_charact b c L) as [P [Q R]].
  assert (beval st1 b = false).
  { rewrite <- H. symmetry. eapply beval_agree; eauto. }
  exists st1; split.
  apply E_WhileFalse. auto.
  eapply agree_mon; eauto.

- (* while loop *)
  destruct (live_while_charact b c L) as [P [Q R]].
  assert (beval st1 b = true).
  { rewrite <- H. symmetry. eapply beval_agree; eauto. }
  destruct (IHceval1 (live (WHILE b DO c END) L) st1) as [st2 [E1 A1]].
    eapply agree_mon; eauto.
  destruct (IHceval2 L st2) as [st3 [E2 A2]].
    auto.
  exists st3; split.
  apply E_WhileTrue with st2; auto.
  auto.
Qed.

(** *** Exercise (3 stars, optional) *)

(** To prove semantic preservation both for terminating and diverging programs.
  complete the following simulation proof, which uses the small-step semantics
  of Imp, without continuations. *)

Fixpoint measure (c: com) : nat :=
  match c with
  | (x ::= a) => 1
  | (c1 ;; c2) => measure c1
  | _ => 0
  end.

Theorem dce_simulation:
  forall c st c' st',
  c / st ==> c' / st' ->
  forall L st1,
  agree (live c L) st st1 ->
  (exists st1',
   dce c L / st1 ==> dce c' L / st1' /\
   agree (live c' L) st' st1')
  \/
  (measure c' < measure c /\ dce c L = dce c' L /\ agree (live c' L) st' st1).
Proof.
   intros until st'. intro STEP. dependent induction STEP; simpl; intros.
  (* FILL IN HERE *)
Admitted.


(* Copyright (c) 2013, Louis Parlant and Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Import prelude.

Inductive R2 : relation (Stream Z) :=
  | R2_base12 : R2 (Σ@{1,2} #1) nats
  | R2_base02 : R2 (Σ@{0,2} #1) nats
  | R2_base2132 : R2 (Σ@{1,2} Σ@{2,3} #1) (nats ^^ 2)
  | R2_base2031 : R2 (Σ@{0,2} Σ@{1,3} #1) (nats ⊙ (#1 ⊕ nats))
  | R2_refl s : R2 s s
  | R2_plus s1 s2 t1 t2 : R2 s1 t1 → R2 s2 t2 → R2 (s1 ⊕ s2) (t1 ⊕ t2)
  | R2_eq s1 s2 t1 t2 : s1 ≡ s2 → t1 ≡ t2 → R2 s1 t1 → R2 s2 t2.

Instance: Proper (equal ==> equal ==> iff) R2.
Proof. now split; apply R2_eq. Qed.

Lemma nats_pow_tail : (nats ^^ 2)` ≡ #1 ⊕ nats ⊕ nats ⊙ (#1 ⊕ nats).
Proof. rewrite Spow_tail, Sfrom_tail, Spow_S, Spow_1; ring. Qed.
Lemma nats_nats_pow_tail :
  (nats ⊙ (#1 ⊕ nats))` ≡ #1 ⊕ #1  ⊕ nats ⊕ nats ⊕ (nats ⊙ (#1 ⊕ nats)).
Proof. rewrite !zip_with_tail, Sfrom_tail, repeat_tail; ring. Qed.
Lemma Ssigma2132_tail :
  (Σ@{1,2} Σ@{2,3} #1)` ≡ #1 ⊕ Σ@{0,2} #1 ⊕ Σ@{0,2} Σ@{1,3} #1.
Proof.
  rewrite !Ssigma_tail_S, Ssigma_head_S, Ssigma_plus,
    repeat_tail, repeat_head. ring.
Qed.
Lemma Ssigma2031_tail :
  (Σ@{0,2} Σ@{1,3}#1)` ≡ #1 ⊕ #1 ⊕ Σ@{0,2} #1 ⊕ Σ@{0,2} #1 ⊕ Σ@{0,2} Σ@{1,3} #1.
Proof.
  rewrite Ssigma_tail_0, Ssigma_tail_S, zip_with_tail, zip_with_head; simpl.
  rewrite !repeat_head, repeat_tail, Ssigma_tail_0.
  rewrite !repeat_tail, repeat_head, !Ssigma_plus, repeat_2; simpl. ring.
Qed.

Lemma bisimulation_R2 : bisimulation R2.
Proof.
  intros s t Hst. split.
  { induction Hst.
    * now rewrite Ssigma_head_S.
    * now rewrite Ssigma_head_0.
    * now rewrite !Ssigma_head_S.
    * now rewrite Ssigma_head_0, Ssigma_tail_S, zip_with_head, Ssigma_head_0.
    * easy.
    * rewrite !zip_with_head; congruence.
    * now rewrite <-H, <-H0. }
  induction Hst.
  * rewrite Ssigma_tail_S, Sfrom_tail. repeat constructor.
  * rewrite Ssigma_tail_0, Sfrom_tail. repeat constructor.
  * rewrite Ssigma2132_tail, nats_pow_tail. repeat constructor.
  * rewrite Ssigma2031_tail, nats_nats_pow_tail. repeat constructor.
  * constructor.
  * simpl. now repeat constructor.
  * now rewrite <-H, <-H0.
Qed.
Theorem Moessner_case2 : Σ@{1,2} Σ@{2,3} #1 ≡ nats ^^ 2.
Proof. apply (bisimulation_equal _ _ _ bisimulation_R2). constructor. Qed.


Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

Require Import ListUtility.
Require Import InvTactics.
Require Import HttpRequest.
Require Import HttpResponse.
Require Import State.

(** What it means for an HTTP request and an HTTP response to be matched.
    Right now we only ask them both to be well formed. **)

Inductive request_response_matched (req: HttpRequest) (res: HttpResponse) : Prop :=
| wf_match: complete_request req ->
            well_formed_response res ->
            request_response_matched req res.

(** `has_state req1 req2 state res1 res2`
     means that it can happen that a connection at state `state`
     has processed `req2`, and has requests `req1` pending for processing,
     and it has sent `res2`, and has responses `res1` waiting to be sent.
     Right now, the part related to handling chunked data has not been
     modeled here yet.
 **)
Inductive has_state : HttpRequest -> HttpRequest ->
                      State -> HttpResponse -> HttpResponse -> Prop :=
| S_Init: forall req,
    complete_request req ->
    has_state req nil Init nil nil
| S_InitClose: forall req,
    (* This is not exactly what happened in the web server,
     but this makes the proof easier. *)
    ~(complete_request (rev req)) ->
    has_state nil req Closed nil nil
| S_UrlReceived: forall s req,
    has_state (Req_InitialMessage s :: req) nil Init nil nil ->
    has_state req (Req_InitialMessage s :: nil) UrlReceived nil nil
| S_HeaderPartReceived1: forall req1 req2 req3 s,
    req1 = (Req_HeaderLine s) :: req2 ->
    has_state req1 req3 UrlReceived nil nil ->
    has_state req2 (Req_HeaderLine s :: req3) HeaderPartReceived nil nil
| S_HeaderPartReceived2: forall req1 req2 req3 line,
    req1 = line :: req2 ->
    has_state req1 req3 HeaderPartReceived nil nil ->
    has_state req2 (line :: req3) HeaderPartReceived nil nil
| S_HeadersReceived1: forall req,
    has_state nil (req :: nil) UrlReceived nil nil ->
    has_state nil (req :: nil) HeadersReceived nil nil
| S_HeadersReceived2: forall req,
    has_state nil req HeaderPartReceived nil nil ->
    has_state nil req HeadersReceived nil nil
| S_HeadersProcessed: forall req,
    has_state nil req HeadersReceived nil nil ->
    has_state nil req HeadersProcessed nil nil
| S_FootersReceived: forall req,
    has_state nil req HeadersProcessed nil nil ->
    has_state nil req FootersReceived nil nil
| S_HeadersSending1: forall req res,
    request_response_matched (rev req) res ->
    has_state nil req FootersReceived nil nil ->
    has_state nil req HeadersSending res nil
| S_HeaderSending2: forall req res1 res2 s,
    has_state nil req HeadersSending (Res_HeaderPart s :: res1) res2 ->
    has_state nil req HeadersSending res1 (Res_HeaderPart s :: res2)
| S_HeadersSent1: forall req res1 res2 s,
    has_state nil req HeadersSending (Res_BodyPart s :: res1) res2 ->
    has_state nil req HeadersSent (Res_BodyPart s :: res1) res2
| S_HeadersSent2: forall req res,
    has_state nil req HeadersSending nil res ->
    has_state nil req HeadersSent nil res
| S_NormalBodyUnready: forall req res1 res2,
    has_state nil req HeadersSent res1 res2 ->
    has_state nil req NormalBodyUnready res1 res2
| S_NormalBodyReady1: forall req res1 res2,
    has_state nil req NormalBodyUnready res1 res2 ->
    has_state nil req NormalBodyReady res1 res2
| S_NormalBodyReady2: forall req res1 res2 s,
    has_state nil req NormalBodyReady (Res_BodyPart s :: res1) res2 ->
    has_state nil req NormalBodyReady res1 (Res_BodyPart s :: res2)
| S_FootersSent: forall req res,
    has_state nil req NormalBodyReady nil res ->
    has_state nil req FootersSent nil res
| S_Closed: forall req res,
    has_state nil req FootersSent nil res ->
    has_state nil req Closed nil res.

(** Some theorems about the connection.
    The most import theorem (the last one), says that if a complete request
    was received, it would be answered with a matched response.
 **)

Hint Resolve well_formed_request_inverse.
Hint Resolve complete_request_not_empty.
Hint Resolve complete_request_inverse.
Hint Resolve completet_request_starts_with_initial.
Hint Resolve complete_request_has_initial_and_header_line.
Hint Resolve well_formed_response_not_empty.

Hint Constructors has_state.

Lemma progress_req: forall r req1 req2 state res1 res2,
    has_state (r :: req1) req2 state res1 res2 ->
    exists state', has_state req1 (r :: req2) state' res1 res2.
Proof with eauto.
  intros. remember (r :: req1) as req0.
  assert (Hhs: has_state req0 req2 state res1 res2); auto.
  induction H; subst; try inversion Heqreq0...
  - apply completet_request_starts_with_initial in H.
    destruct H. subst. exists UrlReceived...
  - inversion H.
    apply complete_request_has_initial_and_header_line in H0. subst.
    destruct H0. destruct H0. inversion H0. subst.
    exists HeaderPartReceived. eapply S_HeaderPartReceived1.
    reflexivity. assumption.
    intro. inversion H2.
Qed.

Lemma req_relation: forall req1 req2 req3 state res1 res2,
    has_state (req1 ++ req2) req3 state res1 res2 ->
    exists state', has_state req2 (rev req1 ++ req3) state' res1 res2.
Proof.
  intros.
  generalize dependent state.
  generalize dependent req3.
  induction req1; intros.
  - simpl in *. exists state. assumption.
  - assert (exists state', has_state (req1 ++ req2) (a::req3) state' res1 res2).
    { eapply progress_req. apply H. }
    destruct H0. apply IHreq1 in H0.
    simpl. rewrite <- app_assoc. simpl. assumption.
Qed.

Lemma progress_req_to_nil: forall req res1 res2,
    has_state req nil Init res1 res2 ->
    exists state, has_state nil (rev req) state res1 res2.
Proof.
  intros.
  assert (rev req ++ nil = rev req).
  { apply app_nil_r. }
  rewrite <- H0. eapply req_relation.
  rewrite app_nil_r. apply H.
Qed.

Lemma res_always_empty_or_well_formed : forall req1 req2 state res1 res2,
    has_state req1 req2 state res1 res2 ->
    well_formed_response (rev res2 ++ res1) \/ (rev res2 ++ res1 = nil).
Proof with auto.
  intros. induction H; simpl...
  - inversion H...
  - rewrite <- app_assoc. simpl...
  - rewrite <- app_assoc. simpl...
Qed.

Lemma progress_res : forall r req1 req2 state res1 res2,
    has_state req1 req2 state (r :: res1) res2 ->
    exists state', has_state req1 req2 state' res1 (r :: res2).
Proof with auto.
  intros. remember (r :: res1) as res0.
  assert (Hhs: has_state req1 req2 state res0 res2)...
         induction H; try inversion Heqres0; auto; subst.
  - destruct r.
    + exists HeadersSending...
    + exists NormalBodyReady...
  - destruct r.
    + exists HeadersSending...
    + exists NormalBodyReady...
  - exists NormalBodyReady...
  - destruct r.
    + apply res_always_empty_or_well_formed in Hhs.
      destruct Hhs.
      * exfalso. simpl in H1. rewrite <- app_assoc in H1. simpl in H1.
        eapply body_before_header_response_not_well_formed. apply H1.
      * simpl in H1. remember (rev res2 ++ Res_BodyPart s :: nil) as res'.
        exfalso. eapply nil_neq_app_cons. symmetry. apply H1.
    + exists NormalBodyReady...
Qed.

Lemma res_relation : forall req1 req2 state res1 res2 res3,
    has_state req1 req2 state (res1 ++ res2) res3 ->
    exists state', has_state req1 req2 state' res2 (rev res1 ++ res3).
Proof.
  intros.
  generalize dependent state.
  generalize dependent res3.
  induction res1; intros.
  - simpl in *. exists state. assumption.
  - assert (exists state', has_state req1 req2 state' (res1 ++ res2) (a::res3)).
    { eapply progress_res. apply H. }
    destruct H0. apply IHres1 in H0.
    simpl. rewrite <- app_assoc. simpl. apply H0.
Qed.

Lemma progress_res_to_nil : forall req res state,
    has_state nil req state res nil ->
    exists state', has_state nil req state' nil (rev res).
Proof.
  intros.
  assert (rev res = rev res ++ nil).
  { symmetry. apply app_nil_r. }
  rewrite H0. eapply res_relation.
  rewrite app_nil_r. apply H.
Qed.

Lemma close_after_finish : forall req res state,
    request_response_matched (rev req) (rev res) ->
    has_state nil req state nil res ->
    has_state nil req Closed nil res.
Proof.
  intros. remember nil as reqn. remember (@nil HttpResponsePart) as resn.
  assert (Hhs: has_state reqn req state resn res); auto.
  induction H0; subst; eauto; inversion H;
    try (repeat constructor; assumption);
    try (exfalso; eapply well_formed_response_not_empty; eauto).
Qed.

Lemma good_req_will_be_received : forall req,
    complete_request req ->
    has_state nil (rev req) FootersReceived nil nil.
Proof.
  intros. assert (Hcr: complete_request req); auto.
  apply S_Init in H.
  apply progress_req_to_nil in H. destruct H.
  induction x; inversion H; subst; eauto;
    try (rewrite rev_involutive in H0; contradiction);
    try (repeat constructor);
    solve [exfalso; eapply complete_request_not_empty; eauto
          | try solve by inversion 7].
Qed.

Theorem good_req_will_be_answered : forall req res,
    complete_request req ->
    request_response_matched req res ->
    has_state nil (rev req) Closed nil (rev res).
Proof.
  intros. apply good_req_will_be_received in H.
  apply S_HeadersSending1 with (res:=res) in H.
  apply progress_res_to_nil in H. destruct H.
  apply close_after_finish with (state:=x).
  rewrite rev_involutive. rewrite rev_involutive. assumption.
  assumption. rewrite rev_involutive. assumption.
Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo116:
  prime  37680100350880616627817671311->
  prime  4955950558850274991939631318283193.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      4955950558850274991939631318283193
      131527
      ((37680100350880616627817671311,1)::nil)
      0
      1015808
      32
      1024)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.Classes.theory.premetric
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe
               TruncType Types.Sigma
               HIT.quotient.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Export Rlow Opens Functions
               Valuations LowerIntegrals
               D_op OpenFun Riesz1.

Set Implicit Arguments.

(** * Giry monad on sets *)

(** unit operator *)
Definition unit (A : hSet) (x : A) : IntPos A.
Proof.
exists (fun f : mf A => f x).
+ reflexivity.
+ intros f g; reflexivity.
+ unfold Mprob; unfold Rlle; auto.
+ intros f g Hfg; apply Hfg.
+ intros f; unfold Rlle; auto.
Defined.

(** bind operator *)
Definition bind (A B : hSet) : IntPos A -> (A -> IntPos B) -> IntPos B.
Proof.
intros I M.
split with (fun f => I (fun x => (M x) f)).
+ red; assert (H : (fun x : A => (M x) ∅) = (fun x : A => RlP_0)).
  apply path_forall; intros x.
  rewrite (I_def (M x)); reflexivity.
  rewrite H.
  apply I_def.
+ red; intros f g.
  rewrite <- I_add.
  assert (Hc : fplus (fun x : A => (M x) f) (fun x : A => (M x) g)=
               fun x : A => (M x) (fplus f g)).
  apply path_forall.
  intros x.
  rewrite I_add.
  reflexivity.
  rewrite Hc; reflexivity.
+ red.
  assert (Rlle (I (fun x : A => (M x) (fone B)))
                (I (fun x : A => RlP_1))).
  apply I_mon.
  intros x; apply I_prob.
  assert (Rlle (I (fun _ : A => RlP_1)) RlP_1).
  apply I_prob.
  unfold Rlle; auto.
+ red; intros f g Hfg.
  apply I_mon. intros x; apply I_mon; trivial.
+ intros f.
  pose (ff := fun n : nat =>
            (fun x : A => ((M x) (f n)))).
  assert (Hff : forall n, fle (ff n) (ff (S n))).
  intros n; unfold ff. intros x.
  apply (M x), f.
  pose (F := Build_IncreasingSequence ff Hff).
  generalize (I_cont I F);
  unfold Mcont; intros HI.
  unfold F in *; simpl in *.
  unfold ff in *.
  assert (H : Rlle (I (fun x : A => (M x) (fun x0 : B =>
             RllubPos (fun n : nat => f n x0))))
               (I (fun x : A => RllubPos
                      (fun n : nat => (M x) (f n))))).
  apply I_mon; intros x.
  apply (M x).
  assert (X : Rlle (I (fun x : A => RllubPos
                      (fun n : nat => (M x) (f n))))
        (Rllub (toRlseq (fun n : nat => I (fun x : A => (M x) (f n)))))).
  trivial.
  unfold Rlle in *; auto.
Defined.

(** Monadic properties *)
Lemma monad1 {A B : hSet} : forall (x : A) (F : A -> IntPos B),
              bind (unit A x) F = F x.
Proof.
intros x F.
unfold bind; simpl;
apply IntPos_eq0;trivial.
Qed.

Lemma monad2 {A : hSet} : forall (X : IntPos A),
                 bind X (unit A) = X.
Proof.
intros X; simpl; apply IntPos_eq0;
reflexivity.
Qed.

Lemma monad3 {A B C: hSet} : forall (X : IntPos A)
                   (F : A -> IntPos B) (G : B -> IntPos C),
     bind (bind X F) G = bind X (fun x:A => bind (F x) G).
Proof.
intros X F G; apply IntPos_eq0;
simpl; reflexivity.
Qed.

Lemma unit_mon {A :hSet} : forall (x:A) (f g : mf A),
    fle f g -> Rlle ((unit A x) f) ((unit A x) g).
Proof.
intros x U V HUV.
simpl; trivial.
Qed.

Lemma bind_mon {A B :hSet} : forall (x:A) (X: IntPos A)
                       (F : A -> IntPos B) (f g : mf B),
       fle f g -> Rlle ((bind X F) f) ((bind X F) g).
Proof.
intros x X F f g Hfg.
unfold bind;
simpl in *.
apply I_mon.
intros s; apply I_mon;
trivial.
Qed.


Require Import Prelude.
Require Import RLE.

Require Import Proofs.GHC.Base.

(* This example uses the following lemma from the Base library theory:

     map_map

*)

Lemma group_by_not_nil:
  forall f (xs : list E),
    ~ In nil (groupBy f xs).
Proof.
  induction xs.
  * simpl. auto.
  * simpl.
    destruct (groupBy f xs) eqn:?.
    - simpl in *.
      intuition congruence.
    - destruct l eqn:?.
      + intuition.
      + destruct (f a e).
        ** contradict IHxs.
           destruct IHxs; try congruence.
           intuition.
        ** contradict IHxs.
           destruct IHxs; try congruence.
Qed.

Lemma concat_groupBy:
  forall f (xs : list E),
    concat (groupBy f xs) = xs.
Proof.
  intros.
  induction xs.
  * reflexivity.
  * simpl.
    destruct (groupBy f xs) eqn:?.
    - simpl in IHxs.  unfold concat in *. simpl in *. congruence.
    - destruct l eqn:?.
      + exfalso.
        apply (group_by_not_nil f xs).
        rewrite Heql.
        intuition.
      + destruct (f a e); unfold concat in *; simpl in *; congruence.
Qed.

(*
Lemma map_map:
  forall a b c (f : a -> b) (g : b -> c) (x : list a),
  map g (map f x) = map (g ∘ f) x.
Proof.
  intros.
  induction x.
  * auto.
  * simpl. rewrite IHx. auto.
Qed.

*)

Lemma in_map_hd_in_concat:
  forall (x : E) xs,
  ~ In nil xs ->
  In x (map hd xs) ->
  In x (concat xs).
Proof.
  intros.
  induction xs.
  * inversion H0.
  * simpl.
    unfold concat. simpl.
    rewrite in_app_iff.
    destruct H0.
    - left.
      subst.
      destruct a.
      + contradict H. intuition.
      + intuition.
    - right.
      apply IHxs.
      + contradict H. right. assumption.
      + assumption.
Qed.

(* For the good rle, we can prove
   properties about it, simply because we
   never look at the axiom. *)
Lemma rle_dom:
  forall `{Eq_ E} (x : E) xs,
    In x (map fst (rle xs)) -> In x xs.
Proof.
  intros.
  unfold rle in H0.
  rewrite map_map in H0.
  apply in_map_hd_in_concat in H0.
  unfold group in H0.
  rewrite concat_groupBy in H0.
  assumption.
  apply group_by_not_nil.
Qed.

(* For the bad rle, at some point we
   would have to prove that [hd nil] is in [xs].
   We would not be able to prove that in general. *)
Lemma int_suc_absurd: forall x : Int,  (#1 + x <> x).
Proof.
  intros.
  change ((1 + x)%Z <> (0 + x)%Z).
  rewrite Z.add_cancel_r.
  destruct (Z.eq_dec 1 0); intuition congruence.
Qed.

Lemma bad_rle_dom:
  exists (x : Int) xs,
    In x (map fst (bad_rle xs)) /\ ~ (In x xs).
Proof.
  remember (hd nil : Int) as x.
  exists x.
  exists (cons (#1 + x) nil).
  split.
  * left. subst. reflexivity.
  * intro.
    destruct H.
    - apply (int_suc_absurd _ H).
    - destruct H.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem len_append: forall (l1 l2: lst), len (append l1 l2) = plus (len l1) (len l2).
Proof.
  induction l1; induction l2; simpl.
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { reflexivity. }
  { reflexivity. }
Qed.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem len_rev: forall (l: lst), len (rev l) = len l.
Proof.
  induction l; simpl.
  +
    rewrite len_append.
    lfind. Admitted.


Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import Coq.Unicode.Utf8 CoRN.model.metric2.Qmetric CoRN.model.metric2.CRmetric CoRN.metric2.UniformContinuity.

Section const_fun_uc.
 Variable X : MetricSpace.
 Variable c : X.

 (** The uniformly continuous constant function *)
 Definition const_raw : X → Complete X := λ _, Cunit c.

 (* Any modulus bigger than 0 will do, so we pick \infty *)
 Definition const_mu (ε:Qpos) : QposInf := QposInfinity.

 Lemma const_uc_prf : is_UniformlyContinuousFunction const_raw const_mu.
 Proof.
  unfold is_UniformlyContinuousFunction; now intuition.
 Qed.

 (** [const_uc c] defines the uniformly continuous function [λ _, c] *)
 Open Scope uc_scope.
 Definition const_uc : X --> Complete X :=
   Build_UniformlyContinuousFunction (const_uc_prf).
End const_fun_uc.

Arguments const_uc {X}.


Require expr cem cesm im db assembly.
Require curien_cem_name.
Require Import cem_cesm cesm_im.
Require Import Unicode.Utf8.
Require Import util db_assembly relations.

(* This file has the high level structure of the compiler and the corresponding
main theorems of correctness *)

Definition compile t := assemble t 0.

Theorem compile_correct (t : db.tm) v : cem.step (cem.I t) v →
  sigT (λ v', refl_trans_clos im.step (im.I (compile t)) v' *
              state_rel (cesm.st (cem.conf_h v) nil (cem.conf_c v)) v').
intros. unfold cem.I in X. destruct v. eapply cem_cesm with (s := []) in
X. assert (csi := eq_refl (cesm.I t)). unfold cesm.I in csi at 1. rewrite csi
in X. simpl. apply cesm_im_assemble. assumption. Qed.


Require Export semantics.

Definition getStamp (x : location * term * stamp) :=
  match x with
      |(_,_,s) => s
  end.

Theorem lookupExtension : forall H' l v S H C,
                            lookup H l = Some(v, S) ->
                            Forall (fun x : location * term * stamp => getStamp x = C) H' ->
                            lookup (H'++H) l = Some(v, S) \/
                            exists S' v', lookup (H'++H) l = Some(v', S') /\
                                          S' = C.
Proof.
  induction H'; intros.
  {simpl. auto. }
  {simpl in *. destruct a. destruct p. destruct (eq_nat_dec l l0).
   {right. subst. repeat econstructor. inv H1. auto. }
   {inv H1. eapply IHH' in H5; eauto. }
  }
Qed.

Theorem replayHeapExtension : forall H H' S e0 L e L' e' C,
                                replay H (Some(S,e0),L,e) (Some(S,e0),L',e') -> S < C ->
                                Forall (fun x : location * term * stamp => getStamp x = C) H' ->
                                replay (H'++H) (Some(S,e0),L,e) (Some(S,e0),L',e').
Proof.
  intros. dependent induction H0.
  {constructor. }
  {inv H0.
   {copy H8. eapply lookupExtension with (H':=H') in H0; eauto. inv H0.
    {econstructor. eapply r_readStepValid; eauto. eauto. }
    {invertHyp. econstructor. eapply r_readStepInvalid; eauto. omega. eauto. }
   }
   {copy H8. eapply lookupExtension with (H':=H') in H0; eauto. inv H0.
    {econstructor. eapply r_readStepInvalid; eauto. eauto. }
    {invertHyp. econstructor. eapply r_readStepInvalid; eauto. omega. eauto. }
   }
   {econstructor. eapply r_readInDomainStep; eauto. eauto. }
   {econstructor. eapply r_writeStep; eauto. eauto. }
   {econstructor. eapply r_atomicIdemStep; eauto. eauto. }
   {econstructor. eapply r_betaStep; eauto. eauto. }
  }
Qed.

Theorem abortRewind : forall S L H S' e' L' e0 e,
                        validate S L H S' (abort e' L') ->
                        rewind H (Some (S, e0), [], e0) (Some (S, e0), L, e) ->
                        rewind H (Some (S, e0), [], e0) (Some (S, e0), L', e').
Proof.
  intros. dependent induction H1.
  {inv H0. }
  {inv H2; eauto.
   {inv H0; eauto. apply decomposeEq in H10. subst. auto. }
   {inv H0; eauto. eapply decomposeEq in H10. subst. auto. }
   {inv H0. eauto. }
  }
Qed.

Ltac lookupSame :=
  match goal with
      |H:logLookup ?L ?l = ?v, H':logLookup ?L ?l = ?v' |- _ =>
       rewrite H in H'; inv H'
      |A:lookup ?H ?l = ?v, B:lookup ?H ?l = ?v' |- _ =>
       rewrite A in B; inv B
  end.

Theorem rewindDiffStamp : forall S C H e0 L e L' e' H' S',
                            rewind H (Some(S,e0), L, e) (Some(S,e0), L', e') -> C > S ->
                            validate S L' H S' (commit H') ->
                            rewind H (Some(C,e0), L, e) (Some(C,e0), L', e').
Proof.
  intros. generalize dependent H'. dependent induction H0; intros. constructor. inv H0.
  {econstructor. eapply r_readStepValid; eauto. omega. inv H3.
   eapply IHrewind; eauto. }
  {inv H3. lookupSame. omega. }
  {econstructor. eapply r_readInDomainStep; eauto. eauto. }
  {inv H3. econstructor. eapply r_writeStep; eauto. intros c. inv c.
   eapply IHrewind; eauto. }
  {econstructor. eapply r_atomicIdemStep; eauto. intros c. inv c. eauto. }
  {econstructor. eapply r_betaStep; eauto. intros c. inv c. eauto. }
Qed.

Theorem poolRewindWeakening : forall C C' H T,
                                poolRewind C H T -> C' >= C ->
                                poolRewind C' H T.
Proof.
  intros. induction H0.
  {constructor. }
  {constructor; auto. omega. }
  {constructor; auto. }
Qed.

Theorem poolRewindHeapExtension : forall H H' T C C',
                                    C' >= C -> poolRewind C H T ->
                                    Forall (fun x : location * term * stamp => getStamp x = C) H' ->
                                    poolRewind C' (H'++H) T.
Proof.
  intros. induction H1.
  {constructor. }
  {constructor. rewrite rewindIFFReplay. eapply replayHeapExtension; eauto.
   rewrite <- rewindIFFReplay. auto. omega. }
  {constructor; auto. }
Qed.

Theorem validateHeapExtension : forall S H C H' L,
                                    validate S L H C (commit H')  ->
                                    exists H'', H' = H'' ++ H .
Proof.
  intros. dependent induction H0; eauto; try solve[exists nil; eauto].
  {invertHyp. exists ((l,v,S')::x). simpl. reflexivity. }
Qed.

Theorem validateStampGE : forall H' S L H C,
                            validate S L H C (commit (H'++H)) ->
                            Forall (fun x => getStamp x = C) H'.
Proof.
  intros. dependent induction H0; auto.
  {destruct H'. constructor. apply lengthsEq in x. simpl in *.
   rewrite app_length in x. omega. }
  {copy H0. eapply validateHeapExtension in H0. invertHyp. destruct H'.
   simpl in x. apply lengthsEq in x. simpl in x. rewrite app_length in x. omega.
   constructor. inv x. auto. eapply IHvalidate; eauto. inversion x. auto. }
Qed.

(*--------------------partial rollback step---------------------*)
Theorem p_stampHeapMonotonic : forall C H T C' H' T',
                               p_step C H T C' H' T' ->
                               C' >= C /\ (exists H'', H' = H'' ++ H /\ Forall (fun x => getStamp x = C) H'').
Proof.
  intros. induction H0; try invertHyp; split; eauto; try solve[exists nil; auto].
  {exists [(l,v,C)]. simpl. split; auto.  }
  {copy H0. apply validateHeapExtension in H0. invertHyp. exists x. split; auto.
   eapply validateStampGE in H2. auto. }
Qed.

Theorem p_stepRewind : forall C H T C' H' T',
                       p_step C H T C' H' T' -> poolRewind C H T ->
                       poolRewind C' H' T'.
Proof.
  intros. induction H0; try solve[repeat econstructor].
  {inv H1. inv H0; exfalso; apply H6; auto. inv H0.
   {destruct(lt_dec S' S).
    {constructor; auto. econstructor; eauto. eapply r_readStepValid; eauto. }
    {constructor; auto. econstructor; eauto. eapply r_readStepInvalid; eauto. omega. }
   }
   {constructor. econstructor; eauto. eapply r_readInDomainStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_writeStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_atomicIdemStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_betaStep; eauto. auto. }
  }
  {inv H1. constructor; auto. eapply p_stampHeapMonotonic in H0. invertHyp.
   eapply poolRewindHeapExtension; eauto. }
  {inv H1. constructor; auto.  eapply p_stampHeapMonotonic in H0. invertHyp.
   eapply poolRewindHeapExtension; eauto. }
  {inv H1. constructor. copy H0. eapply abortRewind in H0; eauto.
   apply validateValidate in H1. invertHyp.
   eapply rewindDiffStamp; eauto. omega. }
Qed.

(*--------------------full rollback step---------------------*)
Theorem f_stampHeapMonotonic : forall C H T C' H' T',
                               f_step C H T C' H' T' ->
                               C' >= C /\ (exists H'', H' = H'' ++ H /\ Forall (fun x => getStamp x = C) H'').
Proof.
  intros. induction H0; try invertHyp; split; eauto; try solve[exists nil; auto].
  {exists [(l,v,C)]. simpl. split; auto.  }
  {copy H0. apply validateHeapExtension in H0. invertHyp. exists x. split; auto.
   eapply validateStampGE in H2. auto. }
Qed.

Theorem f_stepRewind : forall C H T C' H' T',
                       f_step C H T C' H' T' -> poolRewind C H T ->
                       poolRewind C' H' T'.
Proof.
  intros. induction H0; try solve[repeat econstructor].
  {inv H1. inv H0; exfalso; apply H6; auto. inv H0.
   {destruct(lt_dec S' S).
    {constructor; auto. econstructor; eauto. eapply r_readStepValid; eauto. }
    {constructor; auto. econstructor; eauto. eapply r_readStepInvalid; eauto. omega. }
   }
   {constructor. econstructor; eauto. eapply r_readInDomainStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_writeStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_atomicIdemStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_betaStep; eauto. auto. }
  }
  {inv H1. constructor; auto. eapply f_stampHeapMonotonic in H0.
   invertHyp. eapply poolRewindHeapExtension; eauto. }
  {inv H1. constructor; auto. eapply f_stampHeapMonotonic in H0.
   invertHyp. eapply poolRewindHeapExtension; eauto. }
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i $Id: Rdefinitions.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(*********************************************************)
(**          Definitions for the axiomatization          *)
(*********************************************************)

Declare ML Module "r_syntax_plugin".
Require Export ZArith_base.

Parameter R : Set.

(* Declare Scope positive_scope with Key R *)
Delimit Scope R_scope with R.

(* Automatically open scope R_scope for arguments of type R *)
Bind Scope R_scope with R.

Open Local Scope R_scope.

Parameter R0 : R.
Parameter R1 : R.
Parameter Rplus : R -> R -> R.
Parameter Rmult : R -> R -> R.
Parameter Ropp : R -> R.
Parameter Rinv : R -> R.
Parameter Rlt : R -> R -> Prop.
Parameter up : R -> Z.

Infix "+" := Rplus : R_scope.
Infix "*" := Rmult : R_scope.
Notation "- x" := (Ropp x) : R_scope.
Notation "/ x" := (Rinv x) : R_scope.

Infix "<" := Rlt : R_scope.

(***********************************************************)

(**********)
Definition Rgt (r1 r2:R) : Prop := r2 < r1.

(**********)
Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2.

(**********)
Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2.

(**********)
Definition Rminus (r1 r2:R) : R := r1 + - r2.

(**********)
Definition Rdiv (r1 r2:R) : R := r1 * / r2.

(**********)

Infix "-" := Rminus : R_scope.
Infix "/" := Rdiv   : R_scope.

Infix "<=" := Rle : R_scope.
Infix ">=" := Rge : R_scope.
Infix ">"  := Rgt : R_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope.
Notation "x <= y < z"  := (x <= y /\ y <  z) : R_scope.
Notation "x < y < z"   := (x <  y /\ y <  z) : R_scope.
Notation "x < y <= z"  := (x <  y /\ y <= z) : R_scope.


(**********************************************************************************

 Discrete two-sided displayed categories

 Discreteness for two-sided displayed categories is defined in much the same way
 as for categories and displayed categories. We require univalence, and that all
 morphisms are equal and invertible. Note that from this, one can conclude that the
 displayed objects actually form a set.

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Profunctors.Core.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.

Local Open Scope cat.

Definition isaprop_disp_twosided_mor
           {C₁ C₂ : category}
           (D : twosided_disp_cat C₁ C₂)
  : UU
  := ∏ (x₁ x₂ : C₁)
       (y₁ y₂ : C₂)
       (xy₁ : D x₁ y₁)
       (xy₂ : D x₂ y₂)
       (f : x₁ --> x₂)
       (g : y₁ --> y₂)
       (fg fg' : xy₁ -->[ f ][ g ] xy₂),
    fg = fg'.

Definition all_disp_mor_iso
           {C₁ C₂ : category}
           (D : twosided_disp_cat C₁ C₂)
  : UU
  := ∏ (x₁ x₂ : C₁)
       (y₁ y₂ : C₂)
       (xy₁ : D x₁ y₁)
       (xy₂ : D x₂ y₂)
       (f : x₁ --> x₂)
       (g : y₁ --> y₂)
       (Hf : is_z_isomorphism f)
       (Hg : is_z_isomorphism g)
       (fg : xy₁ -->[ f ][ g ] xy₂),
     is_iso_twosided_disp Hf Hg fg.

Definition sym_mor_twosided_disp_cat
           {C₁ C₂ : category}
           (D : twosided_disp_cat C₁ C₂)
  : UU
  := ∏ (x₁ x₂ : C₁)
       (y₁ y₂ : C₂)
       (xy₁ : D x₁ y₁)
       (xy₂ : D x₂ y₂)
       (f : x₁ --> x₂)
       (g : y₁ --> y₂)
       (Hf : is_z_isomorphism f)
       (Hg : is_z_isomorphism g)
       (fg : xy₁ -->[ f ][ g ] xy₂),
     xy₂
     -->[ inv_from_z_iso (f ,, Hf) ][ inv_from_z_iso (g ,, Hg) ]
     xy₁.

Definition all_disp_mor_iso_from_prop
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD₁ : isaprop_disp_twosided_mor D)
           (HD₂ : sym_mor_twosided_disp_cat D)
  : all_disp_mor_iso D.
Proof.
  intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g Hf Hg fg.
  simple refine (_ ,, _ ,, _).
  - apply HD₂.
    exact fg.
  - apply HD₁.
  - apply HD₁.
Defined.

Definition discrete_twosided_disp_cat
           {C₁ C₂ : category}
           (D : twosided_disp_cat C₁ C₂)
  : UU
  := isaprop_disp_twosided_mor D
     ×
     all_disp_mor_iso D
     ×
     is_univalent_twosided_disp_cat D.

Definition make_discrete_twosided_disp_cat
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD₁ : isaprop_disp_twosided_mor D)
           (HD₂ : sym_mor_twosided_disp_cat D)
           (HD₃ : is_univalent_twosided_disp_cat D)
  : discrete_twosided_disp_cat D.
Proof.
  simple refine (_ ,, _ ,, _).
  - exact HD₁.
  - apply all_disp_mor_iso_from_prop.
    + exact HD₁.
    + exact HD₂.
  - exact HD₃.
Defined.

Definition isaset_discrete_twosided_cat_ob
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD : discrete_twosided_disp_cat D)
           (x : C₁)
           (y : C₂)
  : isaset (D x y).
Proof.
  pose (HD₁ := pr1 HD).
  pose (HD₂ := pr22 HD).
  intros xy₁ xy₂.
  use (isofhlevelweqb
         _
         (_ ,, HD₂ x x y y (idpath x) (idpath y) xy₁ xy₂)).
  use isaproptotal2.
  - intro.
    apply isaprop_is_iso_twosided_disp.
  - intros.
    apply HD₁.
Qed.

Definition mortoid_discrete_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD : discrete_twosided_disp_cat D)
           {x : C₁}
           {y : C₂}
           (xy₁ xy₂ : D x y)
           (r : xy₁ -->[ identity x ][ identity y ] xy₂)
  : xy₁ = xy₂.
Proof.
  use (isotoid_twosided_disp (pr22 HD) (idpath _) (idpath _) xy₁ xy₂).
  simple refine (r ,, _).
  apply HD.
Defined.