Require Export Instances.Comma.Cone.
Require Export Finite.

Definition is_limit {D C: Category} (F: Functor D C) (L: Cone F) :=
  forall N: Cone F, exists f: N ~> L, forall f', f = f'.

Definition is_colimit {D C: Category} (F: Functor D C) (L: Cocone F) :=
  forall N: Cocone F, exists f: L ~> N, forall f', f = f'.

Lemma is_limit_co {D C: Category} (F: Functor D C) (L: Cone F): is_limit F L <-> is_colimit (cof F) (to (cocone F) L).
Proof.
  split.
  + intros HL N'.
    destruct (fiso_surj (cocone F) N') as [N].
    subst N'.
    specialize (HL N).
    destruct HL as [f Hf].
    exists (fmap (to (cocone F)) f).
    intros g'.
    destruct (iso_full (cocone F) _ _ g') as [g].
    subst g'.
    now f_equal.
  + intros HL N'.
    specialize (HL (to (cocone F) N')).
    destruct HL as [f' Hf].
    destruct (iso_full (cocone F) _ _ f') as [f].
    subst f'.
    exists f.
    intros g.
    specialize (Hf (fmap (to (cocone F)) g)).
    apply iso_faithful in Hf.
    exact Hf.
Qed.

Instance is_limit_iso {D C: Category} (F: Functor D C): Proper (isomorphic _ ==> iff) (is_limit F).
Proof.
  enough (Proper (isomorphic _ ==> impl) (is_limit F)).
  now split; apply H.
  intros X Y [i].
  intros Hx N.
  specialize (Hx N).
  destruct Hx as [f Hf].
  exists (i ∘ f).
  intros g.
  rewrite (Hf (i⁻¹ ∘ g)).
  rewrite comp_assoc, inv_r.
  apply comp_id_l.
Qed.

Instance is_colimit_iso {D C: Category} (F: Functor D C): Proper (isomorphic _ ==> iff) (is_colimit F).
Proof.
  assert (exists D', co D' = D).
    exists (co D).
    apply co_invol.
  destruct H as [D'].
  subst D; rename D' into D.
  assert (exists C', co C' = C).
    exists (co C).
    apply co_invol.
  destruct H as [C'].
  subst C; rename C' into C.
  destruct (fiso_surj (CoFun D C) F) as [F'].
  subst F; rename F' into F.
  change (D ~> C) in F.
  simpl.
  intros X' Y' H.
  destruct (fiso_surj (cocone F) X') as [X].
  subst X'.
  destruct (fiso_surj (cocone F) Y') as [Y].
  subst Y'.
  rewrite <- !is_limit_co.
  apply is_limit_iso.
  apply ((fobj_iso _ _ (to (cocone F)⁻¹) _ (reflexivity _))) in H.
  change (((cocone F)⁻¹ ∘ cocone F) X ≃ ((cocone F)⁻¹ ∘ cocone F) Y) in H.
  rewrite inv_l in H.
  simpl in H.
  rewrite iso_co in H.
  exact H.
Qed.

Definition is_limit' {D C: Category} (F: Functor D C) (l: C) (η: Δ l ~> F) :=
  forall n (ϵ: Δ n ~> F), exists! f: n ~> l, η ∘ ∇ f = ϵ.

Definition is_colimit' {D C: Category} (F: Functor D C) (l: C) (η: F ~> Δ l) :=
  forall (n: C) (ϵ: F ~> Δ n), exists! f: l ~> n, ∇ f ∘ η = ϵ.

Lemma is_limit'_co {D C: Category} (F: Functor D C) (l: C) (η: Δ l ~> F): is_limit' F l η <-> is_colimit' (cof F) l (eq_iso (cof_diag_c l) ∘ fmap (to (CoFun D C)) η).
Proof.
  enough (forall (n: C) (ϵ: Δ n ~> F) (f: n ~> l), η ∘ ∇ f = ϵ <->
    ∇ (f: @hom (co C) l n) ∘ (eq_iso (cof_diag_c l) ∘ fmap (to (CoFun D C)) η) =
    eq_iso (cof_diag_c n) ∘ fmap (to (CoFun D C)) ϵ
  ).
  split.
  + intros Hl n ϵ.
    simpl in n.
    assert (exists ϵ', eq_iso (cof_diag_c n) ∘ ϵ' = ϵ).
      exists ((eq_iso (cof_diag_c n))⁻¹ ∘ ϵ).
      rewrite comp_assoc.
      rewrite inv_r.
      apply comp_id_l.
    destruct H0 as [ϵ'].
    subst ϵ.
    destruct (iso_full (CoFun D C) _ _ ϵ') as [ϵ].
    subst ϵ'.
    specialize (Hl n ϵ).
    revert Hl.
    change (?P -> ?Q) with (impl P Q).
    f_equiv; intros f.
    f_equiv; clear f.
    extensionality f.
    apply propositional_extensionality.
    apply H.
  + intros Hl n ϵ.
    specialize (Hl n (eq_iso (cof_diag_c n) ∘ fmap (to (CoFun D C)) ϵ)).
    revert Hl.
    change (?P -> ?Q) with (impl P Q).
    f_equiv; intros f.
    f_equiv; clear f.
    extensionality f.
    apply propositional_extensionality.
    symmetry.
    apply H.
  + intros n ϵ f.
    split.
    all: intros H.
    all: generalize (proj1 (natural_eq _ _) H).
    all: clear H; intros H.
    all: simpl in H.
    all: natural_eq x.
    all: specialize (H x).
    etransitivity.
    etransitivity.
    apply (f_equal (fun f => _ ∘ (f ∘ _))).
    3: apply (f_equal (fun f => f ∘ _)).
    3: symmetry.
    1, 3: apply is_eq_refl.
    1: apply (transform_is_eq (eq_iso (cof_diag_c l))).
    2: apply (transform_is_eq (eq_iso (cof_diag_c n))).
    1, 2: apply eq_iso_is_eq.
    rewrite !comp_id_l.
    exact H.
    repeat change (@comp (co ?C) _ _ _ ?f ?g) with (@comp C _ _ _ g f) in H.
    etransitivity.
    etransitivity.
    2: exact H.
    f_equal.
    symmetry.
    1: change (to (eq_iso (cof_diag_c l)) x ∘ η x = η x).
    2: change (to (eq_iso (cof_diag_c n)) x ∘ ϵ x = ϵ x).
    all: rewrite <- comp_id_l.
    all: f_equal.
    all: apply is_eq_refl.
    1: apply (transform_is_eq (eq_iso (cof_diag_c l))).
    2: apply (transform_is_eq (eq_iso (cof_diag_c n))).
    1, 2: apply eq_iso_is_eq.
Qed.

Lemma is_limit'_move {D C: Category} (F G: Functor D C) (l: C) (η: Δ l ~> F) (e: F = G): is_limit' F l η <-> is_limit' G l (eq_iso e ∘ η).
Proof.
  destruct e.
  f_equiv.
  symmetry.
  apply comp_id_l.
Qed.

Lemma is_colimit'_move {D C: Category} (F G: Functor D C) (l: C) (η: F ~> Δ l) (e: G = F): is_colimit' F l η <-> is_colimit' G l (η ∘ eq_iso e).
Proof.
  destruct e.
  f_equiv.
  symmetry.
  apply comp_id_r.
Qed.

Lemma is_limit'_co' {D C: Category} (F: Functor D C) (l: C) (η: F ~> Δ l): is_colimit' F l η <-> is_limit' (cof F) l (fmap (to (CoFun D C)) η ∘ (eq_iso (cof_diag_c l))⁻¹).
Proof.
  enough (forall (n: C) (ϵ: F ~> Δ n) (f: l ~> n), ∇ f ∘ η = ϵ <->
    @comp (Fun (co D) (co C)) _ _ _ (fmap (to (CoFun D C)) η) (eq_iso (cof_diag_c l))⁻¹ ∘ ∇ (f: @hom (co C) n l) =
    fmap (to (CoFun D C)) ϵ ∘ (eq_iso (cof_diag_c n))⁻¹
  ).
  split.
  + intros Hl n ϵ.
    simpl in n.
    assert (exists ϵ', ϵ' ∘ (eq_iso (cof_diag_c n))⁻¹ = ϵ).
      exists (ϵ ∘ eq_iso (cof_diag_c n)).
      rewrite <- comp_assoc.
      rewrite inv_r.
      apply comp_id_r.
    destruct H0 as [ϵ'].
    subst ϵ.
    destruct (iso_full (CoFun D C) _ _ ϵ') as [ϵ].
    subst ϵ'.
    specialize (Hl n ϵ).
    revert Hl.
    change (?P -> ?Q) with (impl P Q).
    f_equiv; intros f.
    f_equiv; clear f.
    extensionality f.
    apply propositional_extensionality.
    apply H.
  + intros Hl n ϵ.
    specialize (Hl n (fmap (to (CoFun D C)) ϵ ∘ (eq_iso (cof_diag_c n))⁻¹)).
    revert Hl.
    change (?P -> ?Q) with (impl P Q).
    f_equiv; intros f.
    f_equiv; clear f.
    extensionality f.
    apply propositional_extensionality.
    symmetry.
    apply H.
  + intros n ϵ f.
    split.
    all: intros H.
    all: generalize (proj1 (natural_eq _ _) H).
    all: clear H; intros H.
    all: simpl in H.
    all: natural_eq x.
    all: specialize (H x).
    etransitivity.
    etransitivity.
    apply (f_equal (fun f => _ ∘ f ∘ _)).
    3: apply (f_equal (fun f => _ ∘ f)).
    3: symmetry.
    1, 3: apply is_eq_refl.
    1: apply (transform_is_eq (eq_iso (cof_diag_c l))⁻¹).
    2: apply (transform_is_eq (eq_iso (cof_diag_c n))⁻¹).
    1, 2: apply is_eq_inv, eq_iso_is_eq.
    rewrite !comp_id_r.
    exact H.
    repeat change (@comp (co ?C) _ _ _ ?f ?g) with (@comp C _ _ _ g f) in H.
    etransitivity.
    etransitivity.
    2: exact H.
    f_equal.
    symmetry.
    all: rewrite <- comp_id_l.
    1: change (@comp (co C) _ _ _ (η x) (to (eq_iso (cof_diag_c l))⁻¹ x) = @comp (co C) _ _ _ (η x) (@id (co C) l)).
    2: change (@comp (co C) _ _ _ (ϵ x) (to (eq_iso (cof_diag_c n))⁻¹ x) = @comp (co C) _ _ _ (ϵ x) (@id (co C) n)).
    all: f_equal.
    all: apply is_eq_refl.
    1: apply (transform_is_eq (eq_iso (cof_diag_c l))⁻¹).
    2: apply (transform_is_eq (eq_iso (cof_diag_c n))⁻¹).
    1, 2: apply is_eq_inv, eq_iso_is_eq.
Qed.

Lemma is_limit_alt {D C: Category} (F: Functor D C) (L: Cone F): is_limit F L <-> is_limit' F (Cone.vertex L) (nat_cone L).
Proof.
  split.
  + intros H n ϵ.
    specialize (H (cone_nat n ϵ)).
    destruct H as [u Hu].
    exists u.
    split.
    natural_eq x.
    apply (Cone.mediator_comm u).
    intros u' H.
    generalize (fun u' H => proj1 (Cone.hom_eq _ _ _) (Hu {| Cone.mediator := u'; Cone.mediator_comm := H |})).
    clear Hu; intros Hu.
    simpl in Hu.
    apply Hu; clear Hu.
    exact (proj1 (natural_eq (nat_cone L ∘ ∇ u') ϵ) H).
  + intros H N.
    specialize (H (Cone.vertex N) (nat_cone N)).
    destruct H as [u Hu].
    unshelve eexists.
    exists u.
    2: intros u'.
    2: Cone.hom_eq.
    exact (proj1 (natural_eq (nat_cone L ∘ ∇ u) (nat_cone N)) (proj1 Hu)).
    apply Hu.
    natural_eq x.
    apply Cone.mediator_comm.
Qed.

Lemma is_colimit_alt {D C: Category} (F: Functor D C) (L: Cocone F): is_colimit F L <-> is_colimit' F (Cocone.vertex L) (nat_cocone L).
Proof.
  assert (exists D', co D' = D).
    exists (co D).
    apply co_invol.
  destruct H as [D'].
  subst D; rename D' into D.
  assert (exists C', co C' = C).
    exists (co C).
    apply co_invol.
  destruct H as [C'].
  subst C; rename C' into C.
  destruct (fiso_surj (CoFun D C) F) as [F'].
  subst F; rename F' into F.
  change (D ~> C) in F.
  destruct (fiso_surj (cocone F) L) as [L'].
  subst L; rename L' into L.
  simpl fobj at 1 3.
  rewrite <- is_limit_co.
  rewrite is_limit_alt.
  rewrite is_limit'_co.
  f_equiv.
  natural_eq x.
  etransitivity.
  apply (f_equal (fun f => f ∘ _)).
  apply is_eq_refl.
  apply (transform_is_eq (eq_iso (cof_diag_c (Cone.vertex L)))).
  apply eq_iso_is_eq.
  apply comp_id_l.
Qed.

Lemma is_limit_alt' {D C: Category} (F: Functor D C) (l: C) (η: Δ l ~> F): is_limit' F l η <-> is_limit F (cone_nat l η).
Proof.
  split.
  + intros H N.
    specialize (H (Cone.vertex N) (nat_cone N)).
    destruct H as [u Hu].
    unshelve eexists.
    exists u.
    2: intros u'.
    2: Cone.hom_eq.
    simpl.
    exact (proj1 (natural_eq (η ∘ ∇ u) (nat_cone N)) (proj1 Hu)).
    apply Hu.
    natural_eq x.
    apply (Cone.mediator_comm u').
  + intros H n ϵ.
    specialize (H (cone_nat n ϵ)).
    destruct H as [u Hu].
    exists u.
    split.
    natural_eq x.
    apply (Cone.mediator_comm u).
    intros u' H.
    generalize (fun u' H => proj1 (Cone.hom_eq _ _ _) (Hu {| Cone.mediator := u'; Cone.mediator_comm := H |})).
    clear Hu; intros Hu.
    simpl in Hu.
    apply Hu; clear Hu.
    exact (proj1 (natural_eq (η ∘ ∇ u') ϵ) H).
Qed.

Lemma is_colimit_alt' {D C: Category} (F: Functor D C) (l: C) (η: F ~> Δ l): is_colimit' F l η <-> is_colimit F (cocone_nat l η).
Proof.
  split.
  + intros H N.
    specialize (H (Cocone.vertex N) (nat_cocone N)).
    destruct H as [u Hu].
    unshelve eexists.
    exists u.
    2: intros u'.
    2: Cocone.hom_eq.
    simpl.
    exact (proj1 (natural_eq (∇ u ∘ η) (nat_cocone N)) (proj1 Hu)).
    apply Hu.
    natural_eq x.
    apply (Cocone.mediator_comm u').
  + intros H n ϵ.
    specialize (H (cocone_nat n ϵ)).
    destruct H as [u Hu].
    exists u.
    split.
    natural_eq x.
    apply (Cocone.mediator_comm u).
    intros u' H.
    generalize (fun u' H => proj1 (Cocone.hom_eq _ _ _) (Hu {| Cocone.mediator := u'; Cocone.mediator_comm := H |})).
    clear Hu; intros Hu.
    simpl in Hu.
    apply Hu; clear Hu.
    exact (proj1 (natural_eq (∇ u' ∘ η) ϵ) H).
Qed.

Definition is_limit_obj {D C: Category} (F: Functor D C) (l: C) :=
  exists L, Cone.vertex L = l /\ is_limit F L.

Definition is_colimit_obj {D C: Category} (F: Functor D C) (l: C) :=
  exists L, Cocone.vertex L = l /\ is_colimit F L.

Definition ex_limit {D C: Category} (F: Functor D C) :=
  exists L, is_limit F L.

Definition ex_colimit {D C: Category} (F: Functor D C) :=
  exists L, is_colimit F L.

Lemma limit_obj_ex {D C: Category} (F: Functor D C) (l: C): is_limit_obj F l -> ex_limit F.
Proof.
  intros [L [_ H]].
  now exists L.
Qed.

Lemma colimit_obj_ex {D C: Category} (F: Functor D C) (l: C): is_colimit_obj F l -> ex_colimit F.
Proof.
  intros [L [_ H]].
  now exists L.
Qed.

Lemma is_limit_obj_alt {D C: Category} (F: Functor D C) (l: C): is_limit_obj F l <-> exists η: Δ l ~> F, is_limit' F l η.
Proof.
  split.
  + intros [L [Hl H]].
    subst l.
    exists (nat_cone L).
    apply is_limit_alt, H.
  + intros [η H].
    exists (cone_nat l η).
    split.
    reflexivity.
    apply is_limit_alt', H.
Qed.

Lemma is_colimit_obj_alt {D C: Category} (F: Functor D C) (l: C): is_colimit_obj F l <-> exists η: F ~> Δ l, is_colimit' F l η.
Proof.
  split.
  + intros [L [Hl H]].
    subst l.
    exists (nat_cocone L).
    apply is_colimit_alt, H.
  + intros [η H].
    exists (cocone_nat l η).
    split.
    reflexivity.
    apply is_colimit_alt', H.
Qed.

Lemma ex_limit_alt {D C: Category} (F: Functor D C): ex_limit F <-> exists l (η: Δ l ~> F), is_limit' F l η.
Proof.
  split.
  + intros [L H].
    exists (Cone.vertex L), (nat_cone L).
    apply is_limit_alt, H.
  + intros [l [η H]].
    exists (cone_nat l η).
    apply is_limit_alt', H.
Qed.

Lemma ex_colimit_alt {D C: Category} (F: Functor D C): ex_colimit F <-> exists l (η: F ~> Δ l), is_colimit' F l η.
Proof.
  split.
  + intros [L H].
    exists (Cocone.vertex L), (nat_cocone L).
    apply is_colimit_alt, H.
  + intros [l [η H]].
    exists (cocone_nat l η).
    apply is_colimit_alt', H.
Qed.

Lemma is_limit_obj_co {D C: Category} (F: Functor D C) (l: C): is_limit_obj F l <-> is_colimit_obj (cof F) l.
Proof.
  split.
  + intros [L [Hl H]].
    subst l.
    exists (to (cocone F) L).
    split.
    reflexivity.
    apply is_limit_co, H.
  + intros [L' [Hl H]].
    subst l.
    destruct (fiso_surj (cocone F) L') as [L].
    subst L'.
    exists L.
    split.
    reflexivity.
    apply is_limit_co, H.
Qed.

Lemma is_limit_obj_co' {D C: Category} (F: Functor D C) (l: C): is_limit_obj (cof F) l <-> is_colimit_obj F l.
Proof.
  rewrite is_limit_obj_alt, is_colimit_obj_alt.
  split.
  + intros [η H].
    assert (exists η': cof (Δ l) ~> cof F, η' ∘ (eq_iso (cof_diag_c l))⁻¹ = η).
      exists (η ∘ eq_iso (cof_diag_c l)).
      rewrite <- comp_assoc, inv_r.
      apply comp_id_r.
    destruct H0 as [η'].
    subst η.
    destruct (iso_full (CoFun _ _) _ _ η') as [η].
    subst η'.
    rewrite <- is_limit'_co' in H.
    now exists η.
  + intros [η H].
    set (fmap (to (CoFun _ _)) η).
    rewrite is_limit'_co' in H.
    eexists.
    exact H.
Qed.

Lemma ex_limit_co {D C: Category} (F: Functor D C): ex_limit F <-> ex_colimit (cof F).
Proof.
  split.
  + intros [L H].
    exists (to (cocone F) L).
    apply is_limit_co, H.
  + intros [L' H].
    destruct (fiso_surj (cocone F) L') as [L].
    subst L'.
    exists L.
    apply is_limit_co, H.
Qed.

Instance ex_limit_iso {D C: Category}: Proper (isomorphic (Fun D C) ==> iff) ex_limit.
Proof.
  enough (Proper (isomorphic (Fun D C) ==> impl) ex_limit).
  now split; apply H.
  intros F G [I].
  rewrite !ex_limit_alt.
  intros [l [η H]].
  exists l, (I ∘ η).
  intros n ϵ.
  specialize (H n (I⁻¹ ∘ ϵ)).
  destruct H as [f [Hf H]].
  exists f.
  split; simpl.
  + rewrite <- comp_assoc.
    etransitivity.
    apply f_equal.
    exact Hf.
    rewrite comp_assoc.
    rewrite inv_r.
    apply comp_id_l.
  + intros f' Hf'.
    apply H.
    rewrite <- Hf'.
    rewrite <- comp_assoc.
    rewrite comp_assoc.
    rewrite inv_l.
    symmetry.
    apply comp_id_l.
Qed.

Instance ex_colimit_iso {D C: Category}: Proper (isomorphic (Fun D C) ==> iff) ex_colimit.
Proof.
  assert (exists D', co D' = D).
    exists (co D).
    apply co_invol.
  destruct H as [D'].
  subst D; rename D' into D.
  assert (exists C', co C' = C).
    exists (co C).
    apply co_invol.
  destruct H as [C'].
  subst C; rename C' into C.
  intros F' G' H.
  destruct (fiso_surj (CoFun D C) F') as [F].
  subst F'.
  destruct (fiso_surj (CoFun D C) G') as [G].
  subst G'.
  apply (fobj_iso _ _ (to (CoFun D C)⁻¹) _ (reflexivity _)) in H.
  simpl in *.
  rewrite !cof_inv_l, iso_co in H.
  rewrite <- !ex_limit_co.
  apply ex_limit_iso, H.
Qed.

Instance limit_obj_iso {D C: Category}: Proper (isomorphic (Fun D C) ==> isomorphic C ==> iff) is_limit_obj.
Proof.
  enough (Proper (isomorphic (Fun D C) ==> isomorphic C ==> impl) is_limit_obj).
  now split; apply H.
  intros F G H l1 l2 H0.
  transitivity (is_limit_obj F l2).
  1: clear G H; rename H0 into H.
  2: clear l1 H0; rename l2 into l.
  + intros [L [Hl HL]].
    subst l1.
    destruct (cone_iso_ex L l2 H) as [L2 [Hl H0]].
    clear H; rename H0 into H.
    exists L2.
    split.
    assumption.
    now rewrite <- H.
  + intros [L [Hl HL]].
    destruct H as [I].
    subst l.
    exists (cone_lift F G (to I) L).
    split.
    reflexivity.
    intros N'.
    assert (exists N, cone_lift F G I N = N').
    exists (cone_lift G F (to I⁻¹) N').
    apply Cone.obj_eq; simpl; split.
    reflexivity.
    intros x e.
    rewrite eq_iso_refl; clear e.
    simpl.
    rewrite comp_id_r.
    rewrite comp_assoc.
    change (to I x ∘ from I x) with ((I ∘ I⁻¹) x).
    rewrite inv_r.
    apply comp_id_l.
    destruct H as [N].
    subst N'.
    specialize (HL N).
    destruct HL as [f Hf].
    exists (fmap (cone_lift F G I) f).
    intros g'.
    assert (exists g, fmap (cone_lift F G I) g = g').
    destruct g' as [g Hg].
    simpl in g, Hg.
    unshelve eexists.
    exists g.
    2: Cone.hom_eq.
    intros x.
    apply (is_iso_monic (to I x)).
    apply is_iso_transform, iso_is_iso.
    rewrite comp_assoc.
    apply Hg.
    reflexivity.
    destruct H as [g].
    subst g'.
    f_equal.
    apply Hf.
Qed.

Instance colimit_obj_iso {D C: Category}: Proper (isomorphic (Fun D C) ==> isomorphic C ==> iff) is_colimit_obj.
Proof.
  assert (exists D', co D' = D).
    exists (co D).
    apply co_invol.
  destruct H as [D'].
  subst D; rename D' into D.
  assert (exists C', co C' = C).
    exists (co C).
    apply co_invol.
  destruct H as [C'].
  subst C; rename C' into C.
  intros F' G' H x y xy.
  destruct (fiso_surj (CoFun D C) F') as [F].
  subst F'.
  destruct (fiso_surj (CoFun D C) G') as [G].
  subst G'.
  apply (fobj_iso _ _ (to (CoFun D C)⁻¹) _ (reflexivity _)) in H.
  simpl in *.
  rewrite !cof_inv_l, iso_co in H.
  rewrite iso_co in xy.
  rewrite <- !is_limit_obj_co.
  now apply limit_obj_iso.
Qed.

Lemma iso_limit {D C: Category} (F: Functor D C) (L1 L2: Cone F): is_limit F L1 -> is_limit F L2 -> L1 ≃ L2.
Proof.
  intros H1 H2.
  destruct (H2 L1) as [f _].
  destruct (H1 L2) as [g _].
  specialize (H1 L1).
  destruct H1 as [i1 H1].
  specialize (H2 L2).
  destruct H2 as [i2 H2].
  constructor.
  exists f, g.
  1: transitivity i1.
  3: transitivity i2.
  all: easy.
Qed.

Lemma iso_colimit {D C: Category} (F: Functor D C) (L1 L2: Cocone F): is_colimit F L1 -> is_colimit F L2 -> L1 ≃ L2.
Proof.
  intros H1 H2.
  destruct (H2 L1) as [f _].
  destruct (H1 L2) as [g _].
  specialize (H1 L1).
  destruct H1 as [i1 H1].
  specialize (H2 L2).
  destruct H2 as [i2 H2].
  constructor.
  exists g, f.
  1: transitivity i1.
  3: transitivity i2.
  all: easy.
Qed.

Definition has_limit (D C: Category) :=
  forall F: Functor D C, ex_limit F.

Definition has_colimit (D C: Category) :=
  forall F: Functor D C, ex_colimit F.

Lemma has_limit_co@{d1 d2 c1 c2 i} (D: Category@{d1 d2}) (C: Category@{c1 c2}): has_limit@{d1 d2 c1 c2 i} D C <-> has_colimit (co D) (co C).
Proof.
  split.
  + intros H F'.
    destruct (fiso_surj (CoFun D C) F') as [F].
    subst F'.
    simpl.
    apply ex_limit_co, H.
  + intros H F.
    apply ex_limit_co, H.
Qed.

Definition is_lim {D C: Category} (F: Functor (Fun D C) C) := Δ' -| F.
Definition ex_lim (D C: Category) := exists F: Functor (Fun D C) C, is_lim F.

Definition is_colim {D C: Category} (F: Functor (Fun D C) C) := F -| Δ'.
Definition ex_colim (D C: Category) := exists F: Functor (Fun D C) C, is_colim F.

Definition Colim {D C: Category}: co (Fun (Fun D C) C) <~> Fun (Fun (co D) (co C)) (co C) := Comp_r_iso (CoFun D C)⁻¹ · CoFun (Fun D C) C.

Lemma is_lim_co {D C: Category} (F: Functor (Fun D C) C): is_lim (to Colim F) <-> is_colim F.
Proof.
  change (Δ' -| to (CoFun (Fun D C) C) F ∘ (CoFun D C)⁻¹ <-> F -| Δ').
  replace (@Δ' (co C) (co D)) with (to (CoFun D C) ∘ to (CoFun C (Fun D C)) (@Δ' C D)).
  rewrite (adjoint_co F Δ').
  apply (adjoint_comp_iso_r _ _ ((CoFun D C) ⁻¹)).
  clear.
  fun_eq x y f.
  unfold cof.
  simpl.
  fun_eq a b f.
  now rewrite !eq_iso_refl.
  natural_eq a.
  rewrite (is_eq_refl (to (eq_iso H) a)).
  rewrite (is_eq_refl (to (eq_iso H0) a)).
  simpl.
  rewrite comp_id_r.
  apply comp_id_l.
  1: apply (transform_is_eq (eq_iso H0)).
  2: apply (transform_is_eq (eq_iso H)).
  all: apply eq_iso_is_eq.
Qed.

Lemma ex_lim_co {D C: Category}: ex_lim (co D) (co C) <-> ex_colim D C.
Proof.
  split.
  + intros [F' H].
    assert (exists F: Fun D C ~> C, to Colim F = F').
    exists (to Colim⁻¹ F').
    change ((Colim ∘ Colim⁻¹) F' = F').
    now rewrite inv_r.
    destruct H0 as [F HF].
    subst F'.
    exists F.
    apply is_lim_co, H.
  + intros [F H].
    exists (to Colim F).
    apply is_lim_co, H.
Qed.

Lemma ex_lim_correct (D C: Category): ex_lim D C <-> has_limit D C.
Proof.
  split.
  + intros [L [η [ɛ adj]]] F.
    apply adjoint_by_alt in adj.
    destruct adj as [adj1 adj2].
    apply ex_limit_alt.
    exists (L F), (ɛ F).
    intros n ϵ.
    exists (fmap L ϵ ∘ η n).
    split.
    - rewrite fmap_comp, comp_assoc.
      change (ɛ F ∘ fmap (Δ' ∘ L) ϵ ∘ ∇ (η n) = ϵ).
      rewrite naturality.
      simpl fmap at 1.
      rewrite <- comp_assoc.
      simpl in adj1.
      rewrite adj1.
      apply comp_id_r.
    - intros f Hf.
      subst ϵ.
      rewrite fmap_comp.
      change (fmap L (ɛ F) ∘ fmap (L ∘ Δ') f ∘ η n = f).
      rewrite <- comp_assoc.
      setoid_rewrite <- (naturality η f).
      rewrite comp_assoc.
      rewrite adj2.
      apply comp_id_l.
  + intros H.
    red in H.
    setoid_rewrite ex_limit_alt in H.
    apply ex_forall in H.
    destruct H as [L H].
    apply ex_forall in H.
    destruct H as [l H].
    generalize (fun F x => proj1 (ex_forall _) (H F x)).
    clear H; intros H.
    generalize (fun F => proj1 (ex_forall _) (H F)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [λ H].
    assert ((forall F x η, l F ∘ ∇ (λ F x η) = η) /\ (forall F x η g, l F ∘ ∇ g = η -> λ F x η = g)).
      split; apply H.
    clear H; destruct H0 as [H Hu].
    assert (exists Lim: Fun D C ~> C, fobj Lim = L /\ forall F G η (eF: Lim F = L F) (eG: Lim G = L G), eq_iso eG ∘ fmap Lim η = λ G (L F) (η ∘ l F) ∘ eq_iso eF).
    1: {
      unshelve eexists.
      exists L (fun F G η => λ G (L F) (η ∘ l F)).
      3: simpl; split.
      + intros F.
        apply Hu.
        rewrite fmap_id.
        rewrite comp_id_l.
        apply comp_id_r.
      + intros X Y Z η ϵ.
        apply Hu.
        rewrite fmap_comp.
        rewrite comp_assoc.
        simpl.
        rewrite H.
        rewrite <- comp_assoc.
        rewrite H.
        apply comp_assoc.
      + reflexivity.
      + intros F G η eF eG.
        rewrite !eq_iso_refl; clear eF eG.
        simpl.
        rewrite comp_id_r.
        apply comp_id_l.
    }
    destruct H0 as [Lim []].
    subst L.
    assert (forall F G η, fmap Lim η = λ G (Lim F) (η ∘ l F)).
      intros F G η.
      specialize (H1 F G η eq_refl eq_refl).
      simpl in H1.
      rewrite comp_id_l, comp_id_r in H1.
      exact H1.
    clear H1.
    exists Lim.
    assert (exists ɛ: Δ' ∘ Lim ~> id (Fun D C), transform ɛ = l).
    1: {
      unshelve eexists.
      exists l.
      2: reflexivity.
      intros F G η.
      change (l G ∘ ∇ (fmap Lim η) = η ∘ l F).
      rewrite H0.
      apply H.
    }
    destruct H1 as [ɛ].
    subst l.
    assert (exists η: id C ~> Lim ∘ Δ', forall x, η x = λ (Δ x) x (id (Δ x))).
    1: {
      unshelve eexists.
      exists (fun x => λ (Δ x) x (id (Δ x))).
      2: reflexivity.
      intros x y f.
      change (λ (Δ y) y (id (Δ y)) ∘ f = fmap Lim (∇ f) ∘ λ (Δ x) x (id (Δ x))).
      rewrite H0.
      transitivity (λ (Δ y) x (∇ f)).
      symmetry.
      all: apply Hu.
      all: rewrite fmap_comp, comp_assoc.
      all: simpl.
      all: rewrite H.
      apply comp_id_l.
      rewrite <- comp_assoc.
      rewrite H.
      apply comp_id_r.
    }
    destruct H1 as [η].
    exists η, ɛ.
    apply adjoint_by_alt.
    split.
    - intros x.
      rewrite H1.
      apply H.
    - intros x.
      rewrite <- fmap_id.
      rewrite !H0, H1.
      symmetry.
      apply Hu.
      rewrite fmap_comp.
      rewrite comp_assoc.
      simpl.
      rewrite H.
      rewrite <- comp_assoc.
      rewrite H.
      rewrite comp_id_l.
      apply comp_id_r.
Qed.

Lemma ex_colim_correct (D C: Category): ex_colim D C <-> has_colimit D C.
Proof.
  rewrite <- (co_invol D) at 2.
  rewrite <- (co_invol C) at 2.
  rewrite <- ex_lim_co, <- has_limit_co.
  apply ex_lim_correct.
Qed.

Instance has_limit_iso2: Proper (cequiv ==> cequiv ==> iff) has_limit.
Proof.
  enough (Proper (cequiv ==> cequiv ==> impl) has_limit).
  now split; apply H.
  intros A B H1 C D H2.
  rewrite cequiv_ex in H1, H2.
  transitivity (has_limit B C).
  1: clear D H2; destruct H1 as [I].
  2: clear A H1; destruct H2 as [I].
  + intros H F.
    specialize (H (F ∘ I)).
    apply ex_limit_alt in H.
    apply ex_limit_alt.
    destruct H as [l [ι H]].
    assert (exists ι': Δ l ∘ I ~> F ∘ I, ι' ∘ (eq_iso (diag_comp l I))⁻¹ = ι).
      exists (ι ∘ (eq_iso (diag_comp l I))).
      rewrite <- comp_assoc, inv_r.
      apply comp_id_r.
    destruct H0 as [ι'].
    subst ι.
    assert (exists ι: Δ l ~> F, ι |> I = ι').
      exists (ρ F ∘ (F <| iunit I⁻) ∘ (α F I I⁻)⁻¹ ∘ (ι' |> I⁻) ∘ α (Δ l) I I⁻ ∘ (Δ l <| (iunit I⁻)⁻¹) ∘ (ρ (Δ l))⁻¹).
      natural_eq x.
      rewrite comp_id_l, !comp_id_r.
      rewrite <- iunit_to.
      change (fmap (F ∘ I) (to (iunit I) x) ∘ ι' (I⁻ (I x)) = ι' x).
      rewrite <- naturality.
      apply comp_id_r.
    destruct H0 as [ι].
    subst ι'.
    exists l, ι.
    intros n δ.
    specialize (H n (δ |> I ∘ (eq_iso (diag_comp n I))⁻¹)).
    destruct H as [f Hf].
    exists f.
    split; [apply proj1 in Hf | apply proj2 in Hf].
    generalize (proj1 (natural_eq _ _) Hf).
    clear Hf; intros Hf.
    simpl in Hf.
    natural_eq y.
    specialize (Hf (I⁻ y)).
    setoid_rewrite (is_eq_refl (from (eq_iso (diag_comp l I)) (I ⁻ y))) in Hf.
    setoid_rewrite (is_eq_refl (from (eq_iso (diag_comp n I)) (I ⁻ y))) in Hf.
    simpl in Hf.
    rewrite !comp_id_r in Hf.
    setoid_rewrite <- (comp_id_r (ι y)).
    setoid_rewrite <- (comp_id_r (δ y)).
    simpl.
    change (id l) with (fmap (Δ l) (to (iunit I⁻) y)).
    change (id n) with (fmap (Δ n) (to (iunit I⁻) y)).
    setoid_rewrite (@naturality _ _ _ _ ι).
    setoid_rewrite (@naturality _ _ _ _ δ).
    rewrite <- comp_assoc.
    now f_equal.
    1: apply (transform_is_eq (eq_iso (diag_comp n I))⁻¹).
    2: apply (transform_is_eq (eq_iso (diag_comp l I))⁻¹).
    1, 2: apply is_eq_inv, eq_iso_is_eq.
    intros g Hg.
    apply Hf; clear Hf.
    generalize (proj1 (natural_eq _ _) Hg).
    clear Hg; intros Hg.
    natural_eq y.
    setoid_rewrite (is_eq_refl (from (eq_iso (diag_comp l I)) y)).
    setoid_rewrite (is_eq_refl (from (eq_iso (diag_comp n I)) y)).
    rewrite !comp_id_r.
    apply Hg.
    1: apply (transform_is_eq (eq_iso (diag_comp n I))⁻¹).
    2: apply (transform_is_eq (eq_iso (diag_comp l I))⁻¹).
    all: apply is_eq_inv, eq_iso_is_eq.
  + intros H F'.
    assert (exists F, I ∘ F ≃ F').
      exists (I⁻ ∘ F').
      rewrite comp_assoc.
      rewrite (inv2_r I).
      rewrite comp_id_l.
      reflexivity.
    destruct H0 as [F].
    rewrite <- H0; clear H0.
    specialize (H F).
    apply ex_limit_alt in H.
    apply ex_limit_alt.
    destruct H as [l [ι H]].
    exists (I l).
    exists (I <| ι ∘ (eq_iso (comp_diag I l))⁻¹).
    intros n δ.
    assert (exists δ', δ' ∘ ∇ (to (icounit I)⁻¹ n) = δ).
      exists (δ ∘ ∇ (to (icounit I) n)).
      rewrite <- comp_assoc, <- fmap_comp.
      change (to (icounit I) n ∘ _) with ((icounit I ∘ (icounit I)⁻¹) n).
      rewrite inv_r.
      simpl transform.
      rewrite fmap_id.
      apply comp_id_r.
    destruct H0 as [δ'].
    subst δ.
    assert (exists δ, δ ∘ (eq_iso (comp_diag I (I⁻ n))) ⁻¹ = δ').
      exists (δ' ∘ eq_iso (comp_diag I (I⁻ n))).
      rewrite <- comp_assoc, inv_r.
      apply comp_id_r.
    destruct H0 as [δ''].
    subst δ'.
    assert (exists δ, I <| δ = δ'').
      exists (λ F ∘ (iunit I |> F) ∘ α I⁻ I F ∘ (I⁻ <| δ'') ∘ (α I⁻ I (Δ (I⁻ n)))⁻¹ ∘ ((iunit I)⁻¹ |> Δ (I⁻ n)) ∘ (λ (Δ (I⁻ n)))⁻¹).
      natural_eq x.
      rewrite !comp_id_l, !comp_id_r.
      rewrite !fmap_comp.
      setoid_rewrite (iunit_to I (F x)).
      setoid_rewrite (@naturality _ _ _ _ (to (icounit I))).
      rewrite <- iunit_to.
      rewrite <- comp_assoc, <- comp_id_r.
      apply f_equal.
      etransitivity.
      symmetry.
      apply (@fmap_comp _ _ I).
      rewrite <- fmap_id.
      f_equal.
      change ((iunit I ∘ (iunit I)⁻¹) (I⁻ n) = id (id C) (I⁻ n)).
      f_equal.
      apply inv_r.
    destruct H0 as [δ].
    subst δ''.
    specialize (H (I⁻ n) δ).
    destruct H as [f Hf].
    exists (fmap I f ∘ to (icounit I)⁻¹ n).
    split; [apply proj1 in Hf | apply proj2 in Hf].
    rewrite fmap_comp, comp_assoc.
    f_equal.
    generalize (proj1 (natural_eq _ _) Hf).
    clear Hf; intros Hf.
    simpl in Hf.
    natural_eq y.
    setoid_rewrite (is_eq_refl (from (eq_iso (comp_diag I l)) y)).
    setoid_rewrite (is_eq_refl (from (eq_iso (comp_diag I (I⁻ n))) y)).
    rewrite !comp_id_r.
    setoid_rewrite <- (@fmap_comp _ _ I).
    f_equal.
    apply Hf.
    1: apply (transform_is_eq (eq_iso (comp_diag I (I⁻ n)))⁻¹).
    2: apply (transform_is_eq (eq_iso (comp_diag I l))⁻¹).
    1, 2: apply is_eq_inv, eq_iso_is_eq.
    intros g Hg.
    apply (iso2_faithful I⁻).
    rewrite fmap_comp.
    apply (is_iso_monic (to (iunit I) l)).
    apply is_iso_transform, iso_is_iso.
    rewrite comp_assoc.
    etransitivity.
    apply (f_equal (fun f => f ∘ _)).
    apply (@naturality _ _ _ _ (to (iunit I))).
    setoid_rewrite <- (iunit_co' I n).
    rewrite <- comp_assoc.
    etransitivity.
    apply f_equal.
    symmetry.
    apply (@fmap_comp _ _ I⁻).
    change (to (iunit I⁻) n ∘ _) with ((iunit I⁻ ∘ (iunit I⁻)⁻¹) n).
    rewrite inv_r.
    simpl.
    rewrite fmap_id, comp_id_r.
    change (from2 I) with (to2 I⁻).
    apply Hf; clear f Hf.
    generalize (proj1 (natural_eq _ _) Hg).
    clear Hg; intros Hg.
    simpl in Hg.
    natural_eq y.
    specialize (Hg y).
    setoid_rewrite (is_eq_refl (from (eq_iso (comp_diag I l)) y)) in Hg.
    setoid_rewrite (is_eq_refl (from (eq_iso (comp_diag I (I⁻ n))) y)) in Hg.
    setoid_rewrite comp_id_r in Hg.
    destruct (iso2_full I _ _ (g ∘ to (icounit I) n)) as [f H].
    apply (f_equal (fun f => f ∘ to (icounit I)⁻¹ n)) in H.
    rewrite <- comp_assoc in H.
    change (to (icounit I) n ∘ to (icounit I)⁻¹ n) with (((icounit I) ∘ (icounit I)⁻¹) n) in H.
    rewrite inv_r in H.
    simpl transform in H at 2.
    rewrite comp_id_r in H.
    subst g.
    rewrite comp_assoc in Hg.
    apply is_iso_epic in Hg.
    setoid_rewrite <- (@fmap_comp _ _ I) in Hg.
    apply iso2_faithful in Hg.
    rewrite <- Hg.
    f_equal.
    clear ι δ Hg.
    rewrite fmap_comp, comp_assoc.
    etransitivity.
    apply (f_equal (fun f => f ∘ _)).
    apply (@naturality _ _ _ _ (to (iunit I))).
    rewrite <- comp_assoc, <- comp_id_r.
    f_equal.
    rewrite <- iunit_from, <- fmap_id.
    etransitivity.
    symmetry.
    apply (@fmap_comp _ _ I⁻).
    f_equal.
    change ((icounit I ∘ (icounit I)⁻¹) n = id (id D) n).
    f_equal.
    apply inv_r.
    apply (is_iso_transform (icounit I)⁻¹), iso_is_iso.
    1: apply (transform_is_eq (eq_iso (comp_diag I (I⁻ n)))⁻¹).
    2: apply (transform_is_eq (eq_iso (comp_diag I l))⁻¹).
    all: apply is_eq_inv, eq_iso_is_eq.
Qed.

Instance has_colimit_iso2: Proper (cequiv ==> cequiv ==> iff) has_colimit.
Proof.
  intros D1 D2 HD C1 C2 HC.
  rewrite <- (co_invol D1).
  rewrite <- (co_invol C1).
  rewrite <- (co_invol D2).
  rewrite <- (co_invol C2).
  rewrite <- !has_limit_co.
  now do 2 f_equiv.
Qed.

Instance ex_lim_iso2: Proper (cequiv ==> cequiv ==> iff) ex_lim.
Proof.
  intros D1 D2 HD C1 C2 HC.
  rewrite !ex_lim_correct.
  now f_equiv.
Qed.

Instance ex_colim_iso2: Proper (cequiv ==> cequiv ==> iff) ex_colim.
Proof.
  intros D1 D2 HD C1 C2 HC.
  rewrite !ex_colim_correct.
  now f_equiv.
Qed.

Instance has_limit_iso: Proper (isomorphic Cat ==> isomorphic Cat ==> iff) has_limit | 10.
Proof.
  intros C D I S T J.
  f_equiv.
  all: now apply iso_cequiv.
Qed.

Instance has_colimit_iso: Proper (isomorphic Cat ==> isomorphic Cat ==> iff) has_colimit | 10.
Proof.
  intros C D I S T J.
  f_equiv.
  all: now apply iso_cequiv.
Qed.

Instance ex_lim_iso: Proper (isomorphic Cat ==> isomorphic Cat ==> iff) ex_lim | 10.
Proof.
  intros C D I S T J.
  f_equiv.
  all: now apply iso_cequiv.
Qed.

Instance ex_colim_iso: Proper (isomorphic Cat ==> isomorphic Cat ==> iff) ex_colim | 10.
Proof.
  intros C D I S T J.
  f_equiv.
  all: now apply iso_cequiv.
Qed.

Section preservation.
Context {S T: Category} (F: S ~> T) (D: Category).

Definition preserve :=
  forall (G: D ~> S) L, is_limit G L -> is_limit (F ∘ G) (cone_whisk_l F G L).

Lemma preserve_alt: preserve <-> forall (G: D ~> S) (l: S) (η: Δ l ~> G), is_limit' G l η -> is_limit' (F ∘ G) (F l) ((F <| η) ∘ (eq_iso (comp_diag F l))⁻¹).
Proof.
  split.
  + intros HF G l η HL.
    apply is_limit_alt' in HL.
    apply is_limit_alt'.
    apply HF in HL.
    revert HL.
    change (?P -> ?Q) with (impl P Q).
    f_equiv.
    apply Cone.obj_eq; simpl.
    repeat split.
    intros x e.
    rewrite eq_iso_refl; clear e.
    simpl.
    rewrite comp_id_r.
    rewrite <- (comp_id_r (fmap _ _)) at 1.
    f_equal.
    symmetry.
    apply is_eq_refl.
    apply (transform_is_eq (eq_iso (comp_diag F l))⁻¹).
    apply is_eq_inv, eq_iso_is_eq.
  + intros HF G L HL.
    apply is_limit_alt in HL.
    apply is_limit_alt.
    apply HF in HL.
    revert HL.
    change (?P -> ?Q) with (impl P Q).
    f_equiv.
    natural_eq x.
    rewrite <- comp_id_r.
    f_equal.
    apply is_eq_refl.
    apply (transform_is_eq (eq_iso (comp_diag F (Cone.vertex L)))⁻¹).
    apply is_eq_inv, eq_iso_is_eq.
Qed.

Definition create :=
  forall (G: D ~> S) L, is_limit (F ∘ G) L -> exists L', unique (fun L' => cone_whisk_l F G L' = L) L' /\ is_limit G L'.

Definition copreserve :=
  forall (G: D ~> S) L, is_colimit G L -> is_colimit (F ∘ G) (cocone_whisk_l F G L).

Lemma copreserve_alt: copreserve <-> forall (G: D ~> S) (l: S) (η: G ~> Δ l), is_colimit' G l η -> is_colimit' (F ∘ G) (F l) (eq_iso (comp_diag F l) ∘ (F <| η)).
Proof.
  split.
  + intros HF G l η HL.
    apply is_colimit_alt' in HL.
    apply is_colimit_alt'.
    apply HF in HL.
    revert HL.
    change (?P -> ?Q) with (impl P Q).
    f_equiv.
    apply Cocone.obj_eq; simpl.
    repeat split.
    intros x e.
    rewrite eq_iso_refl; clear e.
    simpl.
    f_equiv.
    symmetry.
    apply is_eq_refl.
    apply (transform_is_eq (eq_iso (comp_diag F l))).
    apply eq_iso_is_eq.
  + intros HF G L HL.
    apply is_colimit_alt in HL.
    apply is_colimit_alt.
    apply HF in HL.
    revert HL.
    change (?P -> ?Q) with (impl P Q).
    f_equiv.
    natural_eq x.
    rewrite <- comp_id_l.
    f_equal.
    apply is_eq_refl.
    apply (transform_is_eq (eq_iso (comp_diag F (Cocone.vertex L)))).
    apply eq_iso_is_eq.
Qed.

End preservation.

Lemma preserve_co {S T: Category} (F: S ~> T) (D: Category): preserve F D <-> copreserve (cof F) (co D).
Proof.
  enough (forall (l: S) (G: D ~> S) (η: Δ l ~> G),
    eq_iso (cof_diag_c (F l))
  ∘ fmap (to (CoFun D T)) (F <| η ∘ (eq_iso (comp_diag F l)) ⁻¹)
  ∘ eq_iso (@fmap_comp _ _ Co' _ _ _ F G) =
    eq_iso (comp_diag (cof F) l)
  ∘ (cof F <| (eq_iso (cof_diag_c l) ∘ fmap (to (CoFun D S)) η))).
  rewrite preserve_alt, copreserve_alt.
  split.
  + intros HF G' l η Hl.
    destruct (fiso_surj (CoFun D S) G') as [G].
    subst G'.
    simpl in l, Hl.
    change (D ~> S) in G.
    assert (exists η': cof G ~> cof (Δ l), eq_iso (cof_diag_c l) ∘ η' = η).
      exists ((eq_iso (cof_diag_c l))⁻¹ ∘ η).
      rewrite comp_assoc.
      rewrite inv_r.
      apply comp_id_l.
    destruct H0 as [η'].
    subst η.
    destruct (iso_full (CoFun D S) _ _ η') as [η].
    subst η'.
    rewrite <- is_limit'_co in Hl.
    apply HF in Hl; clear HF.
    rewrite is_limit'_co in Hl.
    rewrite (is_colimit'_move _ (cof F ∘ cof G) _ _ (@fmap_comp _ _ Co' _ _ _ F G)) in Hl.
    revert Hl.
    change (?P -> ?Q) with (impl P Q).
    f_equiv.
    apply H.
  + intros HF G l η Hl.
    rewrite is_limit'_co in Hl.
    rewrite is_limit'_co.
    rewrite (is_colimit'_move _ (cof F ∘ cof G) _ _ (@fmap_comp _ _ Co' _ _ _ F G)).
    apply HF in Hl; clear HF.
    revert Hl.
    change (?P -> ?Q) with (impl P Q).
    f_equiv.
    symmetry.
    apply H.
  + intros l G η.
    natural_eq x.
    rewrite comp_id_r.
    repeat change (@comp (co T) _ _ _ ?f ?g) with (@comp T _ _ _ g f).
    repeat change (@comp (co S) _ _ _ ?f ?g) with (@comp S _ _ _ g f).
    rewrite fmap_comp.
    rewrite <- !comp_assoc.
    f_equal.
    apply is_eq_unique.
    all: apply is_eq_comp.
    4: apply fmap_is_eq.
    1, 3, 4: rewrite is_eq_co.
    1: apply (transform_is_eq (eq_iso (cof_diag_c (F l)))).
    2: apply (@transform_is_eq (co D) _ _ _ (eq_iso (comp_diag (cof F) l))).
    3: apply (transform_is_eq (eq_iso (cof_diag_c l))).
    4: apply (transform_is_eq (eq_iso (comp_diag F l))⁻¹).
    4: apply is_eq_inv.
    all: apply eq_iso_is_eq.
Qed.

Definition fin_complete (C: Category) :=
  forall D, fin D -> has_limit D C.
Definition fin_cocomplete (C: Category) :=
  forall D, fin D -> has_colimit D C.

Definition fin_continue {S T: Category} (F: S ~> T) :=
  forall D, fin D -> preserve F D.
Definition fin_cocontinue {S T: Category} (F: S ~> T) :=
  forall D, fin D -> copreserve F D.

Definition complete (C: Category) :=
  forall D, has_limit D C.
Definition cocomplete (C: Category) :=
  forall D, has_colimit D C.

Definition continue {S T: Category} (F: S ~> T) :=
  forall D, preserve F D.
Definition cocontinue {S T: Category} (F: S ~> T) :=
  forall D, copreserve F D.


From Coq Require Import ZArith List.
From Crypt Require Import choice_type Package.
Import PackageNotation.
From Crypt Require Import pkg_interpreter.
From extructures Require Import ord fset fmap.
Require Import Hacspec_Lib_Comparable.

Require Import Coq.Logic.FunctionalExtensionality.

(*****************************************************)
(*   This file defines a utility functions to reason *)
(* about equivalence of Locations and Signatures     *)
(*****************************************************)

(*** Location *)

Definition loc_eqType :=
  (@eqtype.tag_eqType choice_type_eqType (fun _ : choice_type => ssrnat.nat_eqType)).

Definition location_eqb (ℓ ℓ' : Location) :=
  andb (@eqtype.eq_op ssrnat.nat_eqType (projT2 ℓ) (projT2 ℓ'))
       (@eqtype.eq_op _ (projT1 ℓ) (projT1 ℓ')).

Definition location_eqbP : forall (l1 l2 : Location),
    @location_eqb (l1) (l2)
    = (@eqtype.eq_op
         (@eqtype.tag_eqType choice_type_eqType
                             (fun _ : choice_type => ssrnat.nat_eqType)) l1 l2).
Proof.
  intros.

  unfold location_eqb.
  unfold eqtype.eq_op.

  cbn.
  rewrite ssrnat.eqnE.
  unfold eqtype.tag_eq.
  unfold eqtype.tagged_as.
  unfold ssrfun.tag.
  unfold ssrfun.tagged.

  rewrite Bool.andb_comm.

  unfold eq_rect_r, eq_rect.

  set (eqtype.eq_op _ _) at 2.
  replace (choice_type_eq _ _) with b by reflexivity.

  destruct b eqn:b_eq ; subst b.
  - f_equal.
    case eqtype.eqP ; intros.
    + rewrite e in *.
      unfold eq_sym.
      reflexivity.
    + exfalso.
      apply (ssrbool.elimT eqtype.eqP) in b_eq.
      apply n.
      eapply b_eq.
  - reflexivity.
Qed.

Theorem is_true_split_or : forall a b, is_true (a || b) = (is_true a \/ is_true b).
Proof.
  intros.
  rewrite boolp.propeqE.
  symmetry.
  apply (ssrbool.rwP ssrbool.orP).
Qed.
Theorem is_true_split_and : forall a b, is_true (a && b) = (is_true a /\ is_true b).
Proof.
  intros.
  rewrite boolp.propeqE.
  symmetry.
  apply (ssrbool.rwP ssrbool.andP).
Qed.

Theorem LocsSubset : (forall {A} (L1 L2 : list A) (a : A),
                         List.incl L1 L2 ->
                         List.In a L1 ->
                         List.In a L2).
  intros.
  induction L1 as [ | a0 L ] ; cbn in *.
  - contradiction.
  - destruct (List.incl_cons_inv H).
    destruct H0.
    + subst.
      assumption.
    + apply IHL ; assumption.
Qed.

Lemma location_eqb_sound : forall ℓ ℓ' : Location, is_true (location_eqb ℓ ℓ') <-> ℓ = ℓ'.
Proof.
  intros.
  rewrite location_eqbP.
  pose (@eqtype.eqP loc_eqType).
  unfold eqtype.Equality.axiom in a.
  pose (ssrbool.elimT).
  pose (@eqtype.tag_eqP ).

  split.

  apply (Couplings.reflection_nonsense (@eqtype.tag_eqType choice_type_eqType (fun _ : choice_type => ssrnat.nat_eqType)) ℓ ℓ').
  intros. subst.
  apply eqtype.eq_refl.
Qed.

Global Program Instance location_eqdec: EqDec (Location) := {
    eqb := location_eqb;
    eqb_leibniz := location_eqb_sound;
  }.

Definition location_ltb : Location -> Location -> bool :=
  (tag_leq (I:=choice_type_ordType) (T_:=fun _ : choice_type => nat_ordType)).

Definition location_ltb_simple : Location -> Location -> bool :=
  fun x y => ltb (projT2 x) (projT2 y).

Global Instance location_comparable : Comparable (Location) :=
  eq_dec_lt_Comparable location_ltb.

Definition le_is_ord_leq : forall s s0 : nat_ordType,
    eqtype.eq_op s s0 = false -> ltb s s0 = (s <= s0)%ord.
Proof.
  intros s s0.
  unfold ltb , nat_comparable , Nat.ltb.
  intros e.

  generalize dependent s.
  induction s0 ; intros.
  * destruct s ; easy.
  * destruct s. reflexivity.
    cbn.
    cbn in IHs0.
    rewrite IHs0.
    reflexivity.
    assumption.
Qed.

Definition opsig_eqb (ℓ ℓ' : opsig) : bool :=
  andb (@eqtype.eq_op ssrnat.nat_eqType (fst ℓ) (fst ℓ'))
       (andb (@eqtype.eq_op _ (fst (snd ℓ)) (fst (snd ℓ')))
             (@eqtype.eq_op _ (snd (snd ℓ)) (snd (snd ℓ')))).

Lemma opsig_eqb_sound : forall ℓ ℓ' : opsig, is_true (opsig_eqb ℓ ℓ') <-> ℓ = ℓ'.
Proof.
  intros.

  destruct ℓ as [? []] , ℓ' as [? []].
  setoid_rewrite is_true_split_and.
  rewrite is_true_split_and.
  unfold fst, snd in *.

  transitivity (i = i0 /\ c = c1 /\ c0 = c2).
  {
    apply ZifyClasses.and_morph.
    symmetry.
    apply (ssrbool.rwP (@eqtype.eqP ssrnat.nat_eqType i i0)).
    apply ZifyClasses.and_morph.
    symmetry.
    apply (ssrbool.rwP (@eqtype.eqP _ c c1)).
    symmetry.
    apply (ssrbool.rwP (@eqtype.eqP _ c0 c2)).
  }

  split ; [ intros [? []] | intros H ; inversion H ] ; subst ; easy.
Qed.

Global Program Instance opsig_eqdec: EqDec (opsig) := {
    eqb := opsig_eqb;
    eqb_leibniz := opsig_eqb_sound;
  }.

Theorem fset_compute : forall {T : ordType}, forall l : T, forall n : list T, List.In l n <-> is_true (ssrbool.in_mem l (@ssrbool.mem _ (seq.seq_predType (Ord.eqType T)) n)).
  intros.
  apply (ssrbool.rwP (xseq.InP _ _)).
Qed.

Definition opsig_ordType := (prod_ordType nat_ordType (prod_ordType choice_type_ordType choice_type_ordType)).

Definition loc_ordType := (@tag_ordType choice_type_ordType (fun _ : choice_type => nat_ordType)).

Fixpoint incl_expand A `{EqDec A} (l1 l2 : list A) : Prop :=
  match l1 with
  | nil => True
  | (x :: xs) => In x l2 /\ incl_expand A xs l2
  end.

Theorem in_remove_fset : forall {T : ordType} a (l : list T), List.In a l <-> List.In a (fset l).
Proof.
  intros.
  do 2 rewrite fset_compute.
  now rewrite <- in_fset.
Qed.

Theorem in_split_cat : forall a (l0 l1 : list Location), List.In a (seq.cat l0 l1) <-> List.In a l0 \/ List.In a l1.
Proof.
  split ; intros.
  - induction l0.
    + right. apply H.
    + destruct H.
      * left. left. assumption.
      * destruct (IHl0 H).
        -- left. right. assumption.
        -- right. assumption.
  - destruct H.
    + induction l0.
      * contradiction.
      * destruct H.
        -- left. assumption.
        -- right.
           apply IHl0.
           assumption.
    + induction l0.
      * assumption.
      * right.
        assumption.
Qed.

Theorem in_split_fset_cat : forall a (l0 l1 : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)}), List.In a (l0 :|: l1) <-> List.In a l0 \/ List.In a l1.
Proof.
  intros.
  transitivity (In a (seq.cat (eqtype.val l0) (eqtype.val l1))).
  symmetry.
  apply in_remove_fset.
  apply in_split_cat.
Qed.

Theorem loc_list_incl_fsubset : forall (l0 l1 : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)}), is_true (fsubset l0 l1) <-> List.incl l0 l1.
Proof.
  intros.
  rewrite <- (ssrbool.rwP (@fsubsetP _ l0 l1)).

  unfold ssrbool.sub_mem.
  unfold incl.

  assert (forall {A} (P Q : A -> Prop), (forall x, P x <-> Q x) -> (forall x, P x) <-> (forall x, Q x)).
  { split ; intros ; apply H ; apply H0. }
  apply H. clear H.
  intros x. cbn in *.

  rewrite fset_compute.
  rewrite fset_compute.

  reflexivity.
Qed.

Theorem opsig_list_incl_fsubset : forall (l0 l1 : _), is_true (fsubset (T:=opsig_ordType) l0 l1) <-> List.incl l0 l1.
Proof.
  intros.
  rewrite <- (ssrbool.rwP (@fsubsetP _ l0 l1)).

  unfold ssrbool.sub_mem.
  unfold incl.

  assert (forall {A} (P Q : A -> Prop), (forall x, P x <-> Q x) -> (forall x, P x) <-> (forall x, Q x)).
  { split ; intros ; apply H ; apply H0. }
  apply H. clear H.
  intros x. cbn in *.

  rewrite fset_compute.
  rewrite fset_compute.

  reflexivity.
Qed.

Lemma valid_injectLocations_b :
  forall (import : Interface) (A : choice.Choice.type)
         (L1 L2 : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)})
         (v : raw_code A),
    List.incl L1 L2 -> ValidCode L1 import v -> ValidCode L2 import v.
Proof.
  intros I A L1 L2 v incl.
  apply valid_injectLocations.
  apply loc_list_incl_fsubset.
  apply incl.
Qed.

Lemma valid_injectOpsig_b :
  forall (I1 I2 : Interface) (A : choice.Choice.type)
         (L : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)})
         (v : raw_code A),
    List.incl I1 I2 -> ValidCode L I1 v -> ValidCode L I2 v.
Proof.
  intros I1 I2 A L v incl.
  apply valid_injectMap.
  apply opsig_list_incl_fsubset.
  apply incl.
Qed.

Theorem loc_list_incl_remove_fset {A} `{EqDec A} : forall (l1 l2 : list Location), List.incl l1 l2 <-> List.incl (fset l1) (fset l2).
Proof.
  intros.

  cbn in *.

  induction l1.
  - rewrite <- fset0E. easy.
  - cbn.
    unfold incl.
    cbn.
    split.
    + intros.
      rewrite <- in_remove_fset.
      rewrite <- in_remove_fset in H1.
      apply H0.
      apply H1.
    + intros.
      pose (@in_remove_fset).
      rewrite -> (in_remove_fset (T:=loc_ordType)).
      apply H0.
      rewrite <- (in_remove_fset (T:=loc_ordType)).
      apply H1.
Qed.

Theorem opsig_list_incl_remove_fset {A} `{EqDec A} : forall (l1 l2 : list opsig), List.incl l1 l2 <-> List.incl (fset l1) (fset l2).
Proof.
  intros.

  cbn in *.

  induction l1.
  - rewrite <- fset0E. easy.
  - cbn.
    unfold incl.
    cbn.
    split.
    + intros.
      rewrite <- in_remove_fset in H1 |- *.
      apply H0.
      apply H1.
    + intros.
      rewrite -> (in_remove_fset (T:=opsig_ordType)).
      apply H0.
      rewrite <- (in_remove_fset (T:=opsig_ordType)).
      apply H1.
Qed.

Theorem list_incl_cons_iff : (forall A (a : A) l1 l2, List.incl (a :: l1) l2 <-> (List.In a l2 /\ List.incl l1 l2)).
Proof.
  split.
  - pose List.incl_cons_inv.
    apply List.incl_cons_inv.
  - intros [].
    apply List.incl_cons ; assumption.
Qed.

Theorem loc_list_incl_expand {A} `{EqDec A} : forall (l1 l2 : list Location),
    List.incl l1 l2 <-> incl_expand _ l1 l2.
Proof.
  induction l1.
  - split ; intros.
    reflexivity.
    apply incl_nil_l.
  - intros.
    rewrite list_incl_cons_iff.
    cbn.
    apply and_iff_compat_l.
    apply IHl1.
Qed.

Theorem opsig_list_incl_expand {A} `{EqDec A} : forall (l1 l2 : list opsig),
    List.incl l1 l2 <-> incl_expand _ l1 l2.
Proof.
  induction l1.
  - split ; intros.
    reflexivity.
    apply incl_nil_l.
  - intros.
    rewrite list_incl_cons_iff.
    cbn.
    apply and_iff_compat_l.
    apply IHl1.
Qed.

Definition location_lebP : (tag_leq (I:=choice_type_ordType) (T_:=fun _ : choice_type => nat_ordType)) = leb.
Proof.
  intros.
  do 2 (apply (@functional_extensionality Location) ; intros []).
  cbn.

  unfold tag_leq.
  unfold eqtype.tag_eq.

  unfold location_ltb.
  unfold tag_leq.

  unfold location_eqb.

  unfold ssrfun.tag , ssrfun.tagged , projT1 , projT2 in *.

  rewrite (Bool.andb_comm _ (eqtype.eq_op _ _)).

  destruct (eqtype.eq_op x _) eqn:x_eq_x0.
  2: reflexivity.
  apply Couplings.reflection_nonsense in x_eq_x0.
  subst.
  rewrite eqtype.eq_refl.
  rewrite Bool.andb_true_l.
  rewrite Bool.andb_true_l.
  rewrite Ord.ltxx.
  rewrite Bool.orb_false_l.

  destruct (eqtype.eq_op _ _) eqn:n_eq_n0.
  2: reflexivity.

  unfold eqtype.tagged_as in *.
  unfold ssrfun.tagged ,  projT2 in *.
  unfold eq_rect_r , eq_rect in *.

  destruct eqtype.eqP in *.
  2: contradiction.
  cbn in n_eq_n0.
  destruct eq_sym in *.
  rewrite ssrnat.eqnE in n_eq_n0.
  apply Couplings.reflection_nonsense in n_eq_n0.
  apply Ord.eq_leq. assumption.
Qed.

Lemma iff_extensionality : forall {A} (P Q : A -> Prop), (forall a, P a <-> Q a) -> ((forall a, P a) <-> (forall a, Q a)).
Proof.
  intros. split ; intuition.
Qed.

Lemma iff_eq_sym : forall {A} (x y : A), (x = y) <-> (y = x).
Proof.
  intros. split ; intuition.
Qed.

Definition loc_seq_has (a : Location) := seq.has (ssrbool.fun_of_rel (@eqtype.eq_op loc_eqType) a).

Theorem loc_seq_has_remove_sort {A} `{EqDec A} : forall (l : list Location) (a : Location) leb,
    is_true (loc_seq_has a l) <->
    is_true (loc_seq_has a (path.sort leb l)).
Proof.
  intros.
  rewrite <- (Bool.negb_involutive (loc_seq_has a (path.sort leb l))).

  unfold loc_seq_has.

  rewrite <- seq.all_predC.
  rewrite path.all_sort.
  rewrite seq.all_predC.

  rewrite Bool.negb_involutive.

  reflexivity.
Qed.

Theorem list_in_iff_seq_has {A} `{EqDec A} : forall (l : list Location) (a : Location),
    is_true (loc_seq_has a l) <-> List.In a l.
Proof.
  induction l ; intros.
  - split ; intros ; easy.
  - cbn.
    rewrite is_true_split_or.
    apply ZifyClasses.or_morph.
    + rewrite <- (ssrbool.rwP (@eqtype.eqP loc_eqType a0 a)).
      apply iff_eq_sym.
    + apply IHl.
Qed.

Theorem list_in_iff_list_in_sort {A} `{EqDec A} : forall (l : list Location) (a : Location) leb,
    List.In a l <-> List.In a (path.sort leb l).
Proof.
  intros.
  rewrite <- (list_in_iff_seq_has (path.sort leb l)).
  rewrite <- loc_seq_has_remove_sort.
  rewrite list_in_iff_seq_has.
  reflexivity.
Qed.

Theorem list_in_sort_order_ignorant_compute {A} `{EqDec A} : forall (l : list Location) leb1 leb2 a,
    (List.In a (path.sort leb1 l)) <-> List.In a (path.sort leb2 l).
Proof.
  intros.
  rewrite <- list_in_iff_list_in_sort.
  rewrite <- list_in_iff_list_in_sort.
  reflexivity.
Qed.

Theorem list_incl_sort_order_ignorant_compute {A} `{EqDec A} : forall (l1 l2 : list Location) leb1 leb2,
    List.incl (path.sort leb1 l1) (path.sort leb1 l2) <-> List.incl (path.sort leb2 l1) (path.sort leb2 l2).
Proof.
  intros.
  apply iff_extensionality.
  intros a.

  rewrite list_in_sort_order_ignorant_compute with (leb1 := leb1) (leb2 := leb2).
  rewrite list_in_sort_order_ignorant_compute with (leb1 := leb1) (leb2 := leb2).
  reflexivity.
Qed.

Theorem list_incl_sort {A} `{EqDec A} : forall (l1 l2 : list Location) leb,
    List.incl l1 l2 <-> List.incl (path.sort leb l1) (path.sort leb l2).
Proof.
  intros.
  apply iff_extensionality.
  intros a.
  rewrite <- list_in_iff_list_in_sort.
  rewrite <- list_in_iff_list_in_sort.
  reflexivity.
Qed.

Theorem choice_type_test_refl : forall x , is_true (choice_type_test x x).
Proof.
  intros.
  replace (choice_type_test _ _) with (eqtype.eq_op x x) by reflexivity.
  apply eqtype.eq_refl.
Qed.

Theorem fset_eqEincl: forall a b : list Location, fset a = fset b <-> List.incl a b /\ List.incl b a.
Proof.
  intros.
  rewrite (ssrbool.rwP (@eqtype.eqP _ (fset a) (fset b))).
  rewrite (@eqEfsubset _ (fset a) (fset b)).
  rewrite is_true_split_and.

  apply ZifyClasses.and_morph ; rewrite loc_list_incl_fsubset ; rewrite <- loc_list_incl_remove_fset ; reflexivity.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype tuple finfun bigop prime binomial.
From mathcomp Require Import ssralg finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext.

(** * Additional lemmas about bigops *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section bigop_no_law.

Variables (R : Type) (idx : R) (op : R -> R -> R).

Lemma big_tcast n m (n_m : m = n) (A : finType) F (P : pred {: n.-tuple A}) :
  \big[op/idx]_(p in {: n.-tuple A} | P p) (F p) =
  \big[op/idx]_(p in {: m.-tuple A} | P (tcast n_m p)) (F (tcast n_m p)).
Proof. subst m; apply eq_bigr => ta => /andP[_ H]; by rewrite tcast_id. Qed.

End bigop_no_law.

Section bigop_law.

Variables (R : eqType) (idx : R) (op : Monoid.law idx) .
Variable (A : finType).

Lemma big_neq0 (X : {set A}) (f : A -> R) :
  \big[op/idx]_(t | t \in X) f t != idx -> [exists t, (t \in X) && (f t != idx)].
Proof.
move=> H.
apply negbNE.
rewrite negb_exists.
apply/negP => /forallP abs.
move/negP : H; apply.
rewrite big_mkcond /=.
apply/eqP.
transitivity (\big[op/idx]_(a : A) idx); last by rewrite big1_eq.
apply eq_bigr => a _.
case: ifP => // Hcond.
move: (abs a); by rewrite Hcond /= negbK => /eqP.
Qed.

End bigop_law.

Section removeme.

Variable op : Monoid.com_law 1.

Local Notation "'*%M'" := op (at level 0).
Local Notation "x * y" := (op x y).

Lemma mybig_index_uniq (I : eqType) (i : R) (r : seq I) (E : 'I_(size r) -> R) :
  uniq r ->
  \big[*%M/1]_i E i = \big[*%M/1]_(x <- r) oapp E i (insub (seq.index x r)).
Proof.
move=> Ur.
apply/esym.
rewrite big_tnth.
apply: eq_bigr => j _.
by rewrite index_uniq // valK.
Qed.

End removeme.

Section bigop_add_law.

Variables (R : Type) (idx : R) (op : R -> R -> R) (M : Monoid.add_law idx op).
Variable A : finType.

Lemma Set2sumE (f : A -> R) (card_A : #|A| = 2%nat) :
 \big[M/idx]_(i in A) (f i) = M (f (Set2.a card_A)) (f (Set2.b card_A)).
Proof.
by rewrite /index_enum -enumT Set2.enumE !big_cons big_nil (Monoid.addm0 M) !enum_valP.
Qed.

Lemma big_rV_0 f (P : pred _) : \big[M/idx]_(v in 'rV[A]_0 | P v) f v =
  if P (row_of_tuple [tuple]) then f (row_of_tuple [tuple]) else idx.
Proof.
rewrite -big_map /= /index_enum -enumT /=.
set e := enum _.
rewrite (_ : e = [:: row_of_tuple [tuple]]).
  by rewrite /= big_cons big_nil Monoid.addm0.
rewrite /e.
apply (@eq_from_nth _ (row_of_tuple [tuple])).
  by rewrite -cardE card_matrix muln0 expn0.
move=> i.
rewrite -cardE card_matrix muln0 expn0 ltnS leqn0 => /eqP ->{i}.
rewrite -/e.
destruct e => //.
apply val_inj => /=.
by apply/ffunP => /= -[? []].
Qed.

End bigop_add_law.

Section bigop_add_law_eqtype.

Variable A : finType.

(** Switching from a sum on the domain to a sum on the image of function *)

Definition fin_img (B : eqType) (f : A -> B) : seq B :=
  undup (map f (enum A)).

Variables (R : eqType) (idx : R) (op : R -> R -> R) (M : Monoid.add_law idx op).

Lemma sum_parti (p : seq A) (f : A -> R) : forall g, uniq p ->
  \big[M/idx]_(i <- p) (g i) =
  \big[M/idx]_(r <- undup (map f p)) \big[M/idx]_(i <- p | f i == r) (g i).
Proof.
move Hn : (undup (map f (p))) => n.
move: n p f Hn.
elim => [p f HA F Hp | h t IH p f H F Hp].
- rewrite big_nil.
  suff : p = [::] by move=> ->; rewrite big_nil.
  move/undup_nil : HA => /(congr1 size) /=; rewrite size_map.
  by move/eqP; rewrite size_eq0 => /eqP.
- rewrite big_cons.
  have [preh [pret [H1 [H2 H3]]]] : exists preh pret,
    perm_eq p (preh ++ pret) /\ undup (map f preh) = [:: h] /\ undup (map f pret) = t.
    by apply undup_perm.
  apply (@trans_eq _ _ (\big[M/idx]_(i <- preh ++ pret) F i)); first exact: eq_big_perm.
  apply trans_eq with
   (M (\big[M/idx]_(i <- preh ++ pret | f i == h) F i)
   (\big[M/idx]_(j <- t) \big[M/idx]_(i <- preh ++ pret | f i == j) F i)); last first.
    congr (M _ _).
      apply: eq_big_perm; by rewrite perm_eq_sym.
    apply eq_bigr => i _ /=; apply: eq_big_perm; by rewrite perm_eq_sym.
  have -> :
    \big[M/idx]_(j <- t) \big[M/idx]_(i <- (preh ++ pret) | f i == j) F i =
    \big[M/idx]_(j <- t) \big[M/idx]_(i <- pret | f i == j) F i.
    rewrite [in LHS]big_seq_cond [in RHS]big_seq_cond /=.
    apply/esym/eq_bigr => i Hi.
    rewrite big_cat /=.
    rewrite (_ : \big[M/idx]_(i0 <- preh | f i0 == i) F i0 = idx) ?Monoid.add0m //.
    transitivity (\big[M/idx]_(i0 <- preh | false) F i0); last by rewrite big_pred0.
    rewrite big_seq_cond.
    apply eq_bigl => /= j.
    apply/negP.
    case/andP; move=> Xj_i; move/eqP=> j_preh.
    subst i.
    have Xj_h : f j \in [:: h].
      have H4 : f j \in map f preh by apply/mapP; exists j.
      have : f j \in undup (map f preh) by rewrite mem_undup.
      by rewrite H2.
    have : uniq (h :: t).
      rewrite -H.
      by apply undup_uniq.
    rewrite /= in_cons in_nil orbC /= in Xj_h.
    move/eqP : Xj_h => Xj_h.
    subst h.
    rewrite andbC /= in Hi.
    by rewrite /= Hi.
  rewrite -IH //; last first.
    have : uniq (preh ++ pret) by rewrite -(@perm_eq_uniq _ _ _ H1).
    rewrite cat_uniq.
    case/andP => _; by case/andP.
  have -> : \big[M/idx]_(i <- (preh ++ pret) | f i == h) F i =
    \big[M/idx]_(i <- preh) F i.
    rewrite big_cat /=.
    have -> : \big[M/idx]_(i <- pret | f i == h) F i = idx.
      transitivity (\big[M/idx]_(i0 <- pret | false) F i0); last by rewrite big_pred0.
      rewrite big_seq_cond.
      apply eq_bigl => /= j.
      apply/negP.
      case/andP; move => j_pret; move/eqP => Xj_h.
      subst h.
      have Xj_t : f j \in t.
        have H4 : f j \in map f pret.
        apply/mapP; by exists j.
        have H5 : f j \in undup (map f pret).
        by rewrite mem_undup.
        by rewrite H3 in H5.
      have : uniq (f j :: t) by rewrite -H undup_uniq.
      by rewrite /= Xj_t.
    rewrite Monoid.addm0 big_seq_cond /=.
    symmetry.
    rewrite big_seq_cond /=.
    apply congr_big => //= x.
    case/boolP : (x \in preh) => Y //=.
    symmetry.
    have : f x \in [:: h].
      rewrite -H2 mem_undup.
      apply/mapP; by exists x.
    by rewrite in_cons /= in_nil orbC.
  by rewrite big_cat.
Qed.

(* NB: use finset.partition_big_imset? *)
Lemma sum_parti_finType (f : A -> R) g :
   \big[M/idx]_(i in A) (g i) =
   \big[M/idx]_(r <- fin_img f) \big[M/idx]_(i in A | f i == r) (g i).
Proof.
move: (@sum_parti (enum A) f g) => /=.
rewrite enum_uniq.
move/(_ (refl_equal _)) => IH.
transitivity (\big[M/idx]_(i <- enum A) g i).
  apply congr_big => //.
  by rewrite enumT.
rewrite IH.
apply eq_bigr => i _.
apply congr_big => //; by rewrite enumT.
Qed.

End bigop_add_law_eqtype.

Section bigop_com_law.

Variables (R : Type) (idx : R) (M : Monoid.com_law idx).
Variable A : finType.

Lemma big_union (X1 X2 : {set A}) f :
  [disjoint X2 & X1] ->
  \big[M/idx]_(a | a \in X1 :|: X2) f a =
  M (\big[M/idx]_(a | a \in X1) f a) (\big[M/idx]_(a | a \in X2) f a).
Proof.
move=> Hdisj.
rewrite (@big_setID _ _ _ _ _ X1) /= setUK setDUl setDv set0U.
suff : X2 :\: X1 = X2 by move=> ->.
by apply/setDidPl.
Qed.

Variable B : finType.

(** Big sums lemmas for cartesian products *)

Lemma pair_big_fst (F : {: A * B} -> R) P Q :
  P =1 Q \o fst ->
  \big[M/idx]_(i in A | Q i) \big[M/idx]_(j in B) F (i, j) =
  \big[M/idx]_(i in {: A * B} | P i) F i.
Proof.
move=> /= PQ; rewrite pair_big /=.
apply eq_big.
- case=> /= i1 i2; by rewrite inE andbC PQ.
- by case.
Qed.

Lemma pair_big_snd (F : {: A * B} -> R) P Q :
  P =1 Q \o snd ->
  \big[M/idx]_(i in A) \big[M/idx]_(j in B | Q j) F (i, j) =
  \big[M/idx]_(i in {: A * B} | P i) F i.
Proof.
move=> /= PQ; rewrite pair_big /=.
apply eq_big.
- case=> /= i1 i2; by rewrite PQ.
- by case.
Qed.

Lemma big_rV_prod n f (X : {set 'rV[A * B]_n}) :
  \big[M/idx]_(a in 'rV[A * B]_n | a \in X) f a =
  \big[M/idx]_(a in {: 'rV[A]_n * 'rV[B]_n} | (prod_rV a) \in X) f (prod_rV a).
Proof.
rewrite (reindex_onto (@rV_prod _ _ _) (@prod_rV _ _ _)) //=; last first.
  move=> ? _; by rewrite prod_rVK.
apply eq_big => [?|? _]; by rewrite rV_prodK // eqxx andbC.
Qed.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma big_rV_1 f g (P : pred _) (Q : pred _):
  (forall i : 'rV[A]_1, f i = g (i ``_ ord0)) ->
  (forall i : 'rV[A]_1, P i = Q (i ``_ ord0)) ->
  \big[M/idx]_(i in 'rV[A]_1 | P i) f i = \big[M/idx]_(i in A | Q i) g i.
Proof.
move=> FG PQ.
rewrite (reindex_onto (fun i => \row_(j < 1) i) (fun p => p ``_ ord0)) /=; last first.
  move=> m Pm.
  apply/matrixP => a b; rewrite {a}(ord1 a) {b}(ord1 b); by rewrite mxE.
apply eq_big => a.
  by rewrite PQ mxE eqxx andbT.
by rewrite FG !mxE.
Qed.

Lemma big_singl_rV (f : A -> R) k :
  \big[M/idx]_(i in A) f i = k -> \big[M/idx]_(i in 'rV[A]_1) f (i ``_ ord0) = k.
Proof.
move=> <-.
rewrite (reindex_onto (fun j => \row_(i < 1) j) (fun p => p ``_ ord0)) /=.
- apply eq_big => a; first by rewrite mxE eqxx inE.
  move=> _; by rewrite mxE.
- move=> t _; apply/matrixP => a b; by rewrite (ord1 a) (ord1 b) mxE.
Qed.

Lemma big_1_tuple F G P Q :
  (forall i : 1.-tuple A, F i = G (thead i)) ->
  (forall i : 1.-tuple A, P i = Q (thead i)) ->
  \big[M/idx]_(i in {: 1.-tuple A} | P i) F i = \big[M/idx]_(i in A | Q i) G i.
Proof.
move=> FG PQ.
rewrite (reindex_onto (fun i => [tuple of [:: i]]) (fun p => thead p)) /=; last first.
  case/tupleP => h t X; by rewrite theadE (tuple0 t).
apply eq_big => x //.
by rewrite (PQ [tuple x]) /= theadE eqxx andbC.
move=> X; by rewrite FG.
Qed.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma big_rV_cons n (F : 'rV[A]_n.+1 -> R) (a : A) :
  \big[M/idx]_(v in 'rV[A]_n) (F (row_mx (\row_(k < 1) a) v)) =
  \big[M/idx]_(v in 'rV[A]_n.+1 | v ``_ ord0 == a) (F v).
Proof.
symmetry.
rewrite (reindex_onto (fun j : 'rV[A]_n => row_mx (\row_(k < 1) a) j)
  (fun p : 'rV[A]_n.+1 => rbehead p)) /=; last first.
  move=> m Hm.
  apply/matrixP => i j; rewrite {i}(ord1 i).
  rewrite row_mx_rbehead //.
  by apply/eqP.
apply eq_bigl => /= x.
by rewrite rbehead_row_mx eqxx andbT row_mx_row_ord0 eqxx.
Qed.

Lemma big_rV_behead n (F : 'rV[A]_n.+1 -> R) (w : 'rV[A]_n) :
  \big[M/idx]_(a in A) (F (row_mx (\row_(k < 1) a) w)) =
  \big[M/idx]_(v in 'rV[A]_n.+1 | rbehead v == w) (F v).
Proof.
apply/esym.
rewrite (reindex_onto (fun p => row_mx (\row_(k < 1) p) w) (fun p => p ``_ ord0) ) /=; last first.
  move=> i /eqP <-.
  apply/matrixP => a b; rewrite {a}(ord1 a).
  by rewrite row_mx_rbehead.
apply eq_bigl => /= a.
by rewrite rbehead_row_mx eqxx /= row_mx_row_ord0 eqxx.
Qed.

Lemma big_rV_cons_behead_support n (F : 'rV[A]_n.+1 -> R) (X1 : {set A}) (X2 : {set {: 'rV[A]_n}}) :
  \big[M/idx]_(a in X1) \big[M/idx]_(v in X2) (F (row_mx (\row_(k < 1) a) v))
  =
  \big[M/idx]_(w in 'rV[A]_n.+1 | (w ``_ ord0 \in X1) && (rbehead w \in X2)) (F w).
Proof.
apply/esym.
rewrite (@partition_big _ _ _ _ _ _ (fun x : 'rV[A]_n.+1 => x ``_ ord0) (mem X1)) //=.
- apply eq_bigr => i Hi.
  rewrite (reindex_onto (fun j : 'rV[A]_n => row_mx (\row_(k < 1) i) j) rbehead) /=; last first.
    move=> j Hj.
    case/andP : Hj => Hj1 /eqP => <-.
    apply/matrixP => a b; rewrite {a}(ord1 a).
    by rewrite row_mx_rbehead.
  apply congr_big => // x /=.
  by rewrite rbehead_row_mx eqxx andbT row_mx_row_ord0 eqxx Hi andbT.
move=> i; by case/andP.
Qed.

Lemma big_rV_cons_behead n (F : 'rV[A]_n.+1 -> R) (P1 : pred A) (P2 : pred 'rV[A]_n) :
  \big[M/idx]_(i in A | P1 i) \big[M/idx]_(j in 'rV[A]_n | P2 j) (F (row_mx (\row_(k < 1) i) j))
  =
  \big[M/idx]_(p in 'rV[A]_n.+1 | (P1 (p ``_ ord0)) && (P2 (rbehead p)) ) (F p).
Proof.
symmetry.
rewrite (@partition_big _ _ _ _ _ _ (fun x : 'rV[A]_n.+1 => x ``_ ord0)
  (fun x : A => P1 x)) //=.
- apply eq_bigr => i Hi.
  rewrite (reindex_onto (fun j : 'rV[A]_n => row_mx (\row_(k < 1) i) j) rbehead) /=; last first.
    move=> j Hj.
    case/andP : Hj => Hj1 /eqP => <-.
    apply/matrixP => a b; rewrite {a}(ord1 a).
    by rewrite row_mx_rbehead.
  apply congr_big => // x /=.
  by rewrite row_mx_row_ord0 rbehead_row_mx 2!eqxx Hi !andbT.
move=> i; by case/andP.
Qed.

End bigop_com_law.

Section MyPartitions.

Variables (R : Type) (idx : R) (op : Monoid.com_law idx).

Variables T I : finType.

Lemma big_bigcup_partition (F : I -> {set T}) E (V : {set I}):
  (forall i j, i != j -> [disjoint F i & F j]) ->
  \big[op/idx]_(x in \bigcup_(i in V) F i) E x =
    \big[op/idx]_(i in V) \big[op/idx]_(x in F i) E x.
Proof.
move=> disjF; pose Q := [set F i | i in V & F i != set0].
have trivP: trivIset Q.
  apply/trivIsetP=> _ _ /imsetP[i _ ->] /imsetP[j _ ->] neqFij.
  by apply: disjF; apply: contraNneq neqFij => ->.
have ->: \bigcup_(i in V) F i = cover Q.
  apply/esym.
  rewrite cover_imset big_mkcond /=.
  apply/esym.
  rewrite big_mkcond /=.
  apply: eq_bigr => i _.
  case: ifP.
    rewrite inE => -> /=.
    by case: ifP => // /eqP.
  by rewrite inE => ->.
rewrite big_trivIset // big_imset => [|i j _ /setIdP[_ notFj0] eqFij].
  rewrite big_mkcond [in X in _ = X]big_mkcond.
  apply: eq_bigr => i _.
  rewrite inE.
  case: ifP.
    by case/andP=> ->.
  move/negbT.
  rewrite negb_and.
  case/orP.
    by move/negbTE => ->.
  rewrite negbK => /eqP Fi.
  case: ifP => //.
  by rewrite Fi big_set0.
by apply: contraNeq (disjF _ _) _; rewrite -setI_eq0 eqFij setIid.
Qed.

End MyPartitions.

Section big_tuple_ffun.

Import Monoid.Theory.

Variable R : Type.
Variable times : Monoid.mul_law 0.
Local Notation "*%M" := times (at level 0).
Variable plus : Monoid.add_law 0 *%M.
Local Notation "+%M" := plus (at level 0).

Lemma big_tuple_ffun (I J : finType) (F : {ffun I -> J} -> R)
  (G : _ -> _ -> _) (jdef : J) (idef : I) :
  \big[+%M/0]_(j : #|I|.-tuple J) G (F [ffun x => tnth j (enum_rank x)]) (nth jdef j 0)
    = \big[+%M/0]_(f : {ffun I -> J}) G (F f) (f (nth idef (enum I) 0)).
Proof.
rewrite (reindex_onto (fun y => fgraph y) (fun p => [ffun x => tnth p (enum_rank x)])); last first.
  move=> t _; by apply/eq_from_tnth => i; rewrite tnth_fgraph ffunE enum_valK.
apply eq_big.
  move=> f /=; apply/eqP/ffunP => i; by rewrite ffunE tnth_fgraph enum_rankK.
move=> f _.
congr (G (F _) _).
  apply/ffunP => i; by rewrite ffunE tnth_fgraph enum_rankK.
have @zero : 'I_#|I| by exists O; apply/card_gt0P; exists idef.
transitivity (tnth (fgraph f) zero).
  apply set_nth_default; by rewrite size_tuple ltn_ord.
rewrite tnth_fgraph; congr (f _).
by apply enum_val_nth.
Qed.

End big_tuple_ffun.

Lemma bigcup_set0 n i (T T' : finType) (D : 'I_n -> {set T'}) (A : T' -> 'I_n -> {set T}) :
  (exists t', (t' \in D i) && (A t' i != set0)) ->
  \bigcup_(t' in D i) A t' i == set0 -> D i == set0.
Proof.
move=> abs.
move/set0Pn => Hset0.
apply/set0Pn.
move=> abs'; apply Hset0 => {Hset0}.
case: abs' => t' t'i.
case: abs => t'' /andP[t''i].
case/set0Pn => t tA.
exists t; apply/bigcupP; by exists t''.
Qed.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : word 8 }.
Definition format :=
  format_string ◦ const "<data>" ++
  format_word ◦ data ++
  format_string ◦ const "</data>".
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
  (* More of a limitation than error: need to fix [solve_side_condition], add
  a decides instance, disallow simplifying the decoder function, and add a
  [DecodeMEquivAlignedDecodeM] instance. *)
Defined.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.

Set Implicit Arguments.
Set Strict Implicit.

Theorem pull_ex_and_left
: forall T P Q, Basics.flip Basics.impl ((@ex T P) /\ Q) (exists n, P n /\ Q).
Proof.
  do 2 red. intros.
  firstorder.
Qed.

Theorem pull_ex_and_right
: forall T P Q, Basics.flip Basics.impl (Q /\ (@ex T P)) (exists n, Q /\ P n).
Proof.
  do 2 red; firstorder.
Qed.

Hint Rewrite pull_ex_and_left : pulling.
Hint Rewrite pull_ex_and_right : pulling.

Fixpoint goal2 mx n (acc : nat) : Prop :=
  match n with
  | 0 =>
    if PeanoNat.Nat.ltb acc mx then
      exists x : nat, 0 = 0
    else
      0 = 0
  | S n =>
    goal2 mx n (acc * 2) /\ goal2 mx n (acc * 2 + 1)
  end.

Set Printing Depth 5. (* To avoid printing large terms *)
Goal goal2 10 8 0.
simpl.
Time rewrite_strat (bottomup (hints pulling ; eval cbv beta)).
(*
Time repeat progress (repeat setoid_rewrite pull_ex_and_left in H;
                      repeat setoid_rewrite pull_ex_and_right in H).
*)
(*
Time repeat first [ setoid_rewrite pull_ex_and_left in H
                  | setoid_rewrite pull_ex_and_right in H ].
*)
repeat exists 0; tauto.
Qed.