(** * Verif_append1: List segments *)

(** Here is a little C program, [append.c]

    #include <stddef.h>

    struct list {int head; struct list *tail;};

    struct list *append (struct list *x, struct list *y) {
      struct list *t, *u;
      if (x==NULL)
        return y;
      else {
        t = x;
        u = t->tail;
        while (u!=NULL) {
          t = u;
          u = t->tail;
        }
        t->tail = y;
        return x;
      }
    }

In this chapter, we will learn to verify this in-place linked-list-append
operation. That is, two original lists will be destructed and a new list,
the concatenation of them, will be constructed in this program.
As we did in previous chapters, we import VST and the C program's AST. *)

Require VC.Preface. (* Check for the right version of VST *)

Require Import VST.floyd.proofauto.
Require Import VC.append.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* ================================================================= *)
(** ** Specification of the [append] function. *)

(** Here we just copy what we have defined in [Verif_reverse] *)

Definition t_list := Tstruct _list noattr.

Fixpoint listrep (sigma: list val) (p: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_list (h,y) p  *  listrep hs y
 | nil =>
    !! (p = nullval) && emp
 end.

Arguments listrep sigma p : simpl never.

(** Then we can easily describe the functionality of this [append]. *)

Definition append_spec :=
 DECLARE _append
  WITH x: val, y: val, s1: list val, s2: list val
  PRE [ tptr t_list , tptr t_list]
     PROP()
     PARAMS (x; y)
     SEP (listrep s1 x; listrep s2 y)
  POST [ tptr t_list ]
    EX r: val,
     PROP()
     RETURN(r)
     SEP (listrep (s1++s2) r).

Definition Gprog : funspecs := [ append_spec ].

(* ================================================================= *)
(** ** List segments. *)

(** When verifying this program, a critical step is to figure out
a correct loop invariant. If we try to simulate this program,
especially the loop in it, we may want a loop invariant which
can be illustrated by the following diagram.
(The following diagram is best demonstrated with a monospaced font. )

        +---+---+            +---+---+   +---+---+   +---+---+
  x ==> |   |  ===> ... ===> |   | t ==> | b | u ==> |   |  ===> ...
        +---+---+            +---+---+   +---+---+   +---+---+

      | <========= s1a =========> |       (b)       | <==== s1c ====> |
      | <============================= s1 ==========================> |

        +---+---+   +---+---+   +---+---+
  y ==> |   |  ===> |   |   ==> |   |  ===> ...
        +---+---+   +---+---+   +---+---+

      | <================ s2 =================> |
*)

(** To describe this loop invariant, we need a separation logic predicate to
describe the partial linked list from address [x] to address [t] with contents
[s1a]. This must a new predicate different from [listrep] because [listrep]
describes linked lists ending with [NULL] which is not the case here. We call
this new predicate [lseg], pronounced "list-segment". *)

Fixpoint lseg (contents: list val) (x z: val) : mpred :=
  match contents with
  | nil => !! (x = z) && emp
  | h::hs => EX y:val, data_at Tsh t_list (h, y) x * lseg hs y z
  end.

Arguments lseg contents x z : simpl never.

(** Now, we can prove some useful properties about [lseg]. *)

(** **** Exercise: 1 star, standard (singleton_lseg) *)
Lemma singleton_lseg: forall (a: val) (x y: val),
  data_at Tsh t_list (a, y) x |-- lseg [a] x y.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** It is critical to observe that a partial linked list defined by
 [lseg s x y] may have a loop. For example, the following diagram does
 satisfy [lseg [a; b] x y].
(The following diagram is best demonstrated with a monospaced font. )

        +---+---+   +---+---+
  x ==> | a | y ==> | b | y ====+
        +---+---+   +- -+---+   |
                      ^         |
                      |         |
                      +=========+

We can prove this formally. *)

Lemma lseg_maybe_loop: forall (a b x y: val),
  data_at Tsh t_list (a, y) x * data_at Tsh t_list (b, y) y
  |-- lseg [a; b] x y.
Proof.
  intros.
  unfold lseg.
  Exists y.
  Exists y.
  entailer!.
Qed.

(** Is our definition of [lseg] wrong? The answer is no because a loopy [lseg]
cannot connect to a nonempty linked list. For instance, we can prove that

  data_at Tsh t_list (a, y) x * data_at Tsh t_list (b, y) y * listrep [c] y

will lead to a contradication. Here, the first two separating conjuncts build
a loopy [lseg] and the third separating conjunct is a nonempty [listrep]. *)

Lemma loopy_lseg_not_bad: forall (a b c x y: val),
  data_at Tsh t_list (a, y) x * data_at Tsh t_list (b, y) y * listrep [c] y
    |-- FF.
Proof.
  intros.
  unfold listrep.
  Intros u.
  subst.
Check (data_at_conflict Tsh t_list (c, nullval)).
  sep_apply (data_at_conflict Tsh t_list (c, nullval)).
  + auto.
  + entailer!.
Qed.

(** Important note!  The proof above demonstrates the use of the [sep_apply]
 tactic.  Step through that part of the proof to see what [sep_apply] does. *)

(** Now we can prove the following theorems about partial linked
 lists and complete linked lists. *)

(** **** Exercise: 1 star, standard (lseg_lseg) *)
Lemma lseg_lseg: forall (s1 s2: list val) (x y z: val),
  lseg s1 x y * lseg s2 y z |-- lseg (s1 ++ s2) x z.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard (lseg_list) *)
Lemma lseg_list: forall (s1 s2: list val) (x y: val),
  lseg s1 x y * listrep s2 y |-- listrep (s1 ++ s2) x.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** Is it possible to define [lseg] in a different way so that loopy
   situations can be banned?  Yes.  We discuss this near the end of
   the chapter. *)

(* ================================================================= *)
(** ** Proof of the [append] function *)

(** Before verifying the functional correctness of [append], we still need
to add lemmas to hint databases for separation logic predicates. Readers
may copy proofs from [Verif_reverse] or just skip down to "End of the
material". *)

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
(* FILL IN HERE *) Admitted.
#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
(* FILL IN HERE *) Admitted.
#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

(** (End of the material repeated from Verif_reverse.v) *)

(** In C programs, we test whether the head pointer of a linked list is null
 to determine whether that list is empty or not. Thus, from a separating
 conjunct [listrep contents x], it is useful to prove [contents = nil] (or
 [contents <> nil]) when knowing that [x = nullval] (or [x <> nullval]). The
 following two lemmas state such correlation. They will be used several
 times in the C function [append]'s correctness proof. *)

(** **** Exercise: 1 star, standard (listrep_null) *)
Lemma listrep_null: forall contents x,
  x = nullval ->
  listrep contents x = !! (contents=nil) && emp.
Proof.
(** Hint: One way to prove [P=Q], where P and Q are [mpred]s,
  is to apply [pred_ext] and then prove [P|--Q] and [Q|--P]. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard (listrep_nonnull) *)
Lemma listrep_nonnull: forall contents x,
  x <> nullval ->
  listrep contents x =
    EX h: val, EX hs: list val, EX y:val,
      !! (contents = h :: hs) && data_at Tsh t_list (h, y) x * listrep hs y.
Proof.
(** Again, [pred_ext] will be useful here. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** Now, let's prove this [append] function correct. *)

(** **** Exercise: 3 stars, standard (body_append) *)
Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if. (* if (x == NULL) *)
- (* If-then *)
  (** This if-then branch handles the cases in which [x] is null. In other
   words, [s1] should be [nil]. We can easily derive this by [listrep_null].
   The rest of the proof in this branch is left as an exercise. *)
  rewrite (listrep_null _ x) by auto.
  (* FILL IN HERE *) admit.
- (* If-else *)
  (** This time, we know that [x] is not null; thus [s1] should
    be nonempty. *)
  rewrite (listrep_nonnull _ x) by auto.
  Intros h r u.
  forward. (* t = x; *)
  forward. (* u = t -> tail; *)

  (** After symbolically executing two assignment commands, we arrive
     at the while loop. As mentioned above, we can verify it using
     the following loop invariant. *)
  forward_while
      ( EX s1a: list val, EX b: val, EX s1c: list val, EX t: val, EX u: val,
        PROP (s1 = s1a ++ b :: s1c)
        LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
        SEP (lseg s1a x t;
             data_at Tsh t_list (b, u) t;
             listrep s1c u;
             listrep s2 y))%assert.
 + (* current assertion implies loop invariant *)
      Exists (@nil val) h r x u.
      subst s1. entailer!. unfold lseg; entailer!.
 + (* loop test is safe to execute *)
      entailer!.
 +  (* loop body preserves invariant *)
    (** We know [u] is not null from the fact that the loop condition
       is true. Thus we can represent [s1c] in the form of [(c :: s1d)]. *)
    clear h r u H0; rename u0 into u.
    rewrite (listrep_nonnull _ u) by auto.
    Intros c s1d z.
    forward. (* t = u; *)
    forward. (* u = t -> tail; *)

    (** In the end of the loop body, we need to re-establish the
      loop invariant. At this point, the memory layout can be
      illustrated by the following diagram.

      (The following diagram is best demonstrated with a monospaced font. )

                                 new t       new u
                                   |           |
                                   |           |
                 +---+---+   +---+---+   +---+---+   +---+---+
  x ==> ... ===> |   | t ==> | b | u ==> | c | z ==> |   |  ===> ...
                 +---+---+   +---+---+   +---+---+   +---+---+

      | <===== s1a =====> |   (b)         (c)      | <==== s1d ====> |
      | <========== new s1a ========> |  (new b)   | <== new s1c ==> |

        +---+---+   +---+---+   +---+---+
  y ==> |   |  ===> |   |   ==> |   |  ===> ...
        +---+---+   +---+---+   +---+---+
      | <================ s2 =================> |

 Clearly, [s1a ++ b :: nil] should be the new value of [s1a];  [c] should be
 the new value of [b]; [s1d] should be the new value of [s1c]; [u] should be
 the new value of [t]; and [z] should be the new value of [u]. The next
 command instantiates the existentially quantified variables in our loop
 invariant accordingly. *)

   Exists ((s1a ++ b :: nil),c,s1d,u,z). unfold fst, snd.

  (** As usual, we try [entailer!] to solve this proof goal. This time,
 [entailer!] does not solve it directly. Instead, two simplified proof goals
 are left. Their proofs are left for the reader, using [app_assoc],
 [singleton_lseg] and [lseg_lseg]. *)
    entailer!.
    * (* FILL IN HERE *) admit.
    * (* FILL IN HERE *) admit.
 + (* after the loop *)
   (** After exiting the loop, the loop condition must be false, i.e.
    [u] is the null pointer. Thus [s1c = nil] and [s1 = s1a ++ [b]]. *)
  clear h r u H0; rename u0 into u.
  rewrite (listrep_null s1c) by auto.
  Intros.
  subst s1c.

  (** The rest of the proof is standard. Hint, [singleton_lseg],
    [lseg_lseg] and/or [lseg_list] may be useful. *)
  (* FILL IN HERE *) admit.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Additional exercises: more proofs about list segments *)

(** For verifying the C function [append], it is enough to have only three
 separation logic proof rules about [lseg]: [singleton_lseg], [lseg_lseg]
 and [lseg_list]. The following exercises are other important properties
 of [lseg]. *)

(** **** Exercise: 1 star, standard: (lseg2listrep) *)
Lemma lseg2listrep: forall s x,
  lseg s x nullval |-- listrep s x.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard: (listrep2lseg) *)
Lemma listrep2lseg: forall s x,
  listrep s x |-- lseg s x nullval.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

Corollary lseg_listrep_equiv: forall s x,
  lseg s x nullval = listrep s x.
Proof.
  intros.
  apply pred_ext.
  + apply lseg2listrep.
  + apply listrep2lseg.
Qed.

(** **** Exercise: 2 stars, standard: (lseg_lseg_inv) *)
Lemma lseg_lseg_inv: forall s1 s2 x z,
  lseg (s1 ++ s2) x z |-- EX y: val, lseg s1 x y * lseg s2 y z.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard: (loopy_lseg_no_connection) *)
Lemma loopy_lseg_no_connection: forall s1 s2 x y z,
  s1 <> nil ->
  s2 <> nil ->
  x = y ->
  lseg s1 x y * lseg s2 y z |-- FF.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Additional exercises: loop-free list segments *)

(** In the following exercise, try to redo the proof above
  using a different partial-linked-list predicate.

 We have mentioned that the [lseg] predicate allows a loopy structure,
 which is quite counterintuitive. Here is an alternate definition that
 prohibits loops: *)

Fixpoint nt_lseg (contents: list val) (x z: val) : mpred :=
  match contents with
  | nil => !! (x = z) && emp
  | h::hs => EX y:val, !! (x <> z)
                   && data_at Tsh t_list (h, y) x * nt_lseg hs y z
  end.

Arguments nt_lseg contents x z : simpl never.

(** Here, "nt" means no-touch. *)

(** The difference between [nt_lseg] and [lseg] is the extra proposition
  [x <> z] in the nonempty situation. This extra clause in [nt_lseg]
  prevents loop structures.

  The proof theories of [nt_lseg] and [lseg] are a bit different as
  well. The following diagram shows that the counterpart of [lseg_lseg]
  is not valid!

        +---+---+   +---+---+   +---+---+   +---+---+
  x ==> | a | u ==> | b | y ==> | c | v ==> | d | u ===+
        +---+---+   +- -+---+   +---+---+   +---+---+  |
                      ^                                |
                      |                                |
                      +================================+

  In this example, both [ [a; b] ] and [ [c; d] ] are stored in loop-free
  partial linked lists but it is not true for their concatenation. In
  general, if [(nt_lseg s1 x y)] and [(nt_lseg s2 y z)] describe two
  loop-free partial linked lists, the assertion

    (nt_lseg s1 x y * nt_lseg s2 y z)

  cannot ensure that the structure is loop free. Specifically, the address
  [z] may be used in [(nt_lseg s1 x y)]. In other words,

   nt_lseg s1 x y * nt_lseg s2 y z |-/- nt_lseg (s1 ++ s2) x z
*)

(** For [nt_lseg], the following proof rules are useful. *)

(** **** Exercise: 2 stars, standard, optional (nt_lseg) *)
Lemma singleton_nt_lseg: forall (contents: list val) (a x y: val),
  data_at Tsh t_list (a, y) x * listrep contents y |--
  nt_lseg [a] x y * listrep contents y.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (singleton_nt_lseg') *)
Lemma singleton_nt_lseg': forall (a b x y z: val),
  data_at Tsh t_list (a, y) x * data_at Tsh t_list (b, z) y |--
  nt_lseg [a] x y * data_at Tsh t_list (b, z) y.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (nt_lseg_nt_lseg) *)
Lemma nt_lseg_nt_lseg: forall (s1 s2: list val) (a x y z u: val),
  nt_lseg s1 x y * nt_lseg s2 y z * data_at Tsh t_list (a, u) z |--
  nt_lseg (s1 ++ s2) x z * data_at Tsh t_list (a, u) z.
Proof.
(** Hint:  This lemma illustrates the most classic case where aggressive
 [cancel] can turn a provable goal into an unprovable goal.  For that reason,
  you may need to use [entailer] rather than [entailer!] at one point. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (nt_lseg_list) *)
Lemma nt_lseg_list: forall (s1 s2: list val) (x y: val),
  nt_lseg s1 x y * listrep s2 y |-- listrep (s1 ++ s2) x.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** Now, we will use [nt_lseg] instead of [lseg] in the loop invariant to
prove [body_append]. *)

(** **** Exercise: 3 stars, standard, optional (body_append_alter1) *)
Lemma body_append_alter1: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if. (* if (x == NULL) *)
- (* If-then *)
 rewrite (listrep_null _ x) by auto.
 (* FILL IN HERE *) admit.
- (* If-else *)
 rewrite (listrep_nonnull _ x) by auto.
 Intros h r u.
 forward. (* t = x; *)
 forward. (* u = t -> tail; *)
 (** Now use [forward_while] to verify this while loop.  Remember,
  [forward_while] will generate four proof goals: current precondition
  implies loop invariant; loop test is safe to execute; loop body preserves
  invariant; and the correctness of after-loop commands. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(* 2022-09-05 15:05 *)


Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Positive.
Require Import ExtLib.Tactics.Cases.

Set Implicit Arguments.
Set Strict Implicit.

Section pmap.
  Variable T : Type.
  Inductive pmap : Type :=
  | Empty
  | Branch : option T -> pmap -> pmap -> pmap.

  Definition pmap_here (m : pmap) : option T :=
    match m with
      | Empty => None
      | Branch d _ _ => d
    end.

  Definition pmap_left (m : pmap) : pmap :=
    match m with
      | Empty => Empty
      | Branch _ l _ => l
    end.

  Definition pmap_right (m : pmap) : pmap :=
    match m with
      | Empty => Empty
      | Branch _ _ r => r
    end.

  Fixpoint pmap_lookup (p : positive) (m : pmap) : option T :=
    match m with
      | Empty => None
      | Branch d l r =>
        match p with
          | xH => d
          | xO p => pmap_lookup p l
          | xI p => pmap_lookup p r
        end
    end.

  Fixpoint pmap_insert (p : positive) (v : T) (m : pmap) : pmap :=
    match p with
      | xH => Branch (Some v) (pmap_left m) (pmap_right m)
      | xO p =>
        Branch (pmap_here m) (pmap_insert p v (pmap_left m)) (pmap_right m)
      | xI p =>
        Branch (pmap_here m) (pmap_left m) (pmap_insert p v (pmap_right m))
    end.

  Definition branch (o : option T) (l r : pmap) : pmap :=
    match o , l , r with
      | None , Empty , Empty => Empty
      | _ , _ , _ => Branch o l r
    end.

  Fixpoint pmap_remove (p : positive) (m : pmap) : pmap :=
    match m with
      | Empty => Empty
      | Branch d l r =>
        match p with
          | xH => branch None l r
          | xO p => branch d (pmap_remove p l) r
          | xI p => branch d l (pmap_remove p r)
        end
    end.

  Definition pmap_empty : pmap := Empty.

  Fixpoint pmap_union (f m : pmap) : pmap :=
    match f with
      | Empty => m
      | Branch d l r =>
        Branch (match d with
                  | Some x => Some x
                  | None => pmap_here m
                end) (pmap_union l (pmap_left m)) (pmap_union r (pmap_right m))
    end.

  Global Instance Map_pmap : Map positive T pmap :=
  { empty := pmap_empty
  ; add := pmap_insert
  ; remove := pmap_remove
  ; lookup := pmap_lookup
  ; union := pmap_union
  }.

  Lemma tilde_1_inj_neg : forall k k',
    (k~1)%positive <> (k'~1)%positive -> k <> k'.
  Proof.
    induction k; destruct k'; intuition;
    try match goal with
          | H : _ = _ |- _ => inversion H; clear H; subst
        end; intuition eauto.
  Qed.

  Lemma tilde_0_inj_neg : forall k k',
    (k~0)%positive <> (k'~0)%positive -> k <> k'.
  Proof.
    induction k; destruct k'; intuition;
    try match goal with
          | H : _ = _ |- _ => inversion H; clear H; subst
        end; intuition eauto.
  Qed.

  Lemma pmap_lookup_insert_empty : forall k k' v,
    k <> k' ->
    pmap_lookup k' (pmap_insert k v Empty) = None.
  Proof.
    induction k; destruct k'; simpl; intros;
    eauto using tilde_0_inj_neg, tilde_1_inj_neg.
    destruct k'; simpl; auto.
    destruct k'; simpl; auto.
    destruct k'; simpl; auto.
    destruct k'; simpl; auto.
    congruence.
  Qed.

  Lemma lookup_empty : forall k, pmap_lookup k Empty = None.
  Proof.
    destruct k; reflexivity.
  Qed.

  Hint Rewrite lookup_empty pmap_lookup_insert_empty
       using (eauto using tilde_1_inj_neg, tilde_1_inj_neg) : pmap_rw.

  Lemma pmap_lookup_insert_eq
  : forall (m : pmap) (k : positive) (v : T),
      pmap_lookup k (pmap_insert k v m) = Some v.
  Proof.
    intros m k; revert m.
    induction k; simpl; intros; forward; Cases.rewrite_all_goal; eauto.
  Qed.

  Lemma pmap_lookup_insert_Some_neq
  : forall (m : pmap) (k : positive) (v : T) (k' : positive),
      k <> k' ->
      forall v' : T,
        pmap_lookup k' m = Some v' <-> pmap_lookup k' (pmap_insert k v m) = Some v'.
  Proof.
    intros m k; revert m.
    induction k; simpl; intros; forward; Cases.rewrite_all_goal;
    autorewrite with pmap_rw; eauto.
    { destruct k'; simpl; destruct m; simpl;
      autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity.
      erewrite IHk; eauto using tilde_1_inj_neg. reflexivity. }
    { destruct k'; simpl; destruct m; simpl;
      autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence.
      erewrite IHk. reflexivity. eauto using tilde_0_inj_neg. }
    { destruct k'; simpl; destruct m; simpl;
      autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence. }
  Qed.

  Lemma pmap_lookup_insert_None_neq
  : forall (m : pmap) (k : positive) (v : T) (k' : positive),
      k <> k' ->
        pmap_lookup k' m = None <-> pmap_lookup k' (pmap_insert k v m) = None.
  Proof.
    intros m k; revert m.
    induction k; simpl; intros; forward; Cases.rewrite_all_goal;
    autorewrite with pmap_rw; eauto.
    { destruct k'; simpl; destruct m; simpl;
      autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity.
      erewrite IHk; eauto using tilde_1_inj_neg. reflexivity. }
    { destruct k'; simpl; destruct m; simpl;
      autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence.
      erewrite IHk. reflexivity. eauto using tilde_0_inj_neg. }
    { destruct k'; simpl; destruct m; simpl;
      autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence. }
  Qed.

  Lemma pmap_lookup_insert_neq
  : forall (m : pmap) (k : positive) (v : T) (k' : positive),
      k <> k' ->
      forall v' : T,
        pmap_lookup k' (pmap_insert k v m) = pmap_lookup k' m.
  Proof.
    intros.
    remember (pmap_lookup k' m).
    destruct o; [
      apply pmap_lookup_insert_Some_neq; intuition |
      apply pmap_lookup_insert_None_neq; intuition].
  Qed.

  Global Instance MapOk_pmap : MapOk (@eq _) Map_pmap.
  Proof.
  refine {| mapsto := fun k v m => pmap_lookup k m = Some v |}.
    { abstract (induction k; simpl; congruence). }
    { abstract (induction k; simpl; intros; forward). }
    { eauto using pmap_lookup_insert_eq. }
    { eauto using pmap_lookup_insert_Some_neq. }
  Defined.

  Definition from_list : list T -> pmap :=
    (fix from_list acc i ls {struct ls} :=
       match ls with
         | nil => acc
         | List.cons l ls =>
           from_list (pmap_insert i l acc) (Pos.succ i) ls
       end) Empty 1%positive.

End pmap.

Arguments Empty {_}.
Arguments Branch {_} _ _ _.

Section fmap.
  Variables T U : Type.
  Variable f : T -> U.

  Fixpoint fmap_pmap (m : pmap T) : pmap U :=
    match m with
      | Empty => Empty
      | Branch h l r => Branch (fmap f h) (fmap_pmap l) (fmap_pmap r)
    end.

  Theorem fmap_lookup : forall a b m,
    mapsto a b m ->
    mapsto a (f b) (fmap_pmap m).
  Proof.
    induction a; destruct m; simpl; intros; try congruence.
    { eapply IHa. eapply H. }
    { eapply IHa; eapply H. }
    { subst. auto. }
  Qed.

  Theorem fmap_lookup_bk : forall a b m,
    mapsto a b (fmap_pmap m) ->
    exists b', mapsto a b' m /\ f b' = b.
  Proof.
    induction a; destruct m; simpl; intros; try congruence.
    { eapply IHa. eapply H. }
    { eapply IHa. eapply H. }
    { destruct o; try congruence. eexists; split; eauto. inversion H; auto. }
  Qed.

End fmap.

Require Import ExtLib.Core.Type.

Section type.
  Variable T : Type.
  Variable tT : type T.

  Instance type_pmap : type (pmap T) :=
    type_from_equal
      (fun l r =>
            (forall k v,
               mapsto k v l -> exists v', mapsto k v' r /\ equal v v')
         /\ (forall k v,
               mapsto k v r -> exists v', mapsto k v' l /\ equal v v')).

End type.

Global Instance Functor_pmap : Functor pmap :=
{ fmap := fmap_pmap }.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_congruencesymmetric_1 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_lessthancongruence_2 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).
Variable deflessthan_3 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_4 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).

Theorem proposition_03_5 : (forall A B C D E F : Universe, (exists X : Universe, ((lt_ C D A B /\ cong_ E F A B) -> (betS_ E X F /\ cong_ E X C D)))).
Proof.
  time tac.
Qed.

End FOFProblem.


From S5 Require Export proof.
From S5 Require Export prop.

Theorem soundness (G : form_set) (f : form) :
  ax_s5 G f ->
  forall m w, (forall g, G g -> interpret g m w) -> interpret f m w.
Proof.
  intros H m. induction H; intros w Hw.
  - apply Hw, H.
  - intros H _. assumption.
  - intros H1 H2 H3. simpl in H1, H2. apply (H1 H3 (H2 H3)).
  - simpl. intros H1 H2.
    destruct (excluded_middle (interpret f m w)) as [H3 | H3].
    + assumption.
    + exfalso. apply H1; assumption.
  - intros H1 H2 v R. simpl in H1, H2. specialize (H1 v).
    specialize (H2 v). apply (H1 R (H2 R)).
  - intros H. simpl in H. specialize (H w). apply H, reflex.
  - intros H v R1 u R2. apply H. eapply trans; eassumption.
  - intros H1 v R H2. simpl. simpl in H2. specialize (H2 w). apply H2.
    + apply sym, R.
    + assumption.
  - simpl in IHax_s5_1. apply IHax_s5_1.
    + apply Hw.
    + apply IHax_s5_2, Hw.
  - intros v R. specialize (IHax_s5 v). apply IHax_s5.
    intros g E. unfold empty_set in E. contradiction.
Qed.


Require Export Iron.DiscipleKernel.Ki.
Require Export Iron.DiscipleKernel.TyCon.

(********************************************************************)
(* Type Expressions. *)
Inductive ty  : Type :=
  | TVar      : nat   -> ty
  | TCon      : tycon -> ty
  | TForall   : ki    -> ty -> ty
  | TApp      : ty    -> ty -> ty
  | TSum      : ty    -> ty -> ty
  | TBot      : ki    -> ty.
Hint Constructors ty.

(* Baked-in Witness Types *)
Definition tImpl  t1 t2         := TApp (TApp (TCon TyConImpl) t1) t2.
Definition tPure    e1          := TApp (TCon TyConPure)    e1.
Definition tEmpty   c1          := TApp (TCon TyConEmpty)   c1.
Definition tConst   r1          := TApp (TCon TyConConst)   r1.
Definition tMutable r1          := TApp (TCon TyConMutable) r1.

(* Baked-in Effect Types *)
Definition tRead    r1          := TApp (TCon TyConRead)  r1.
Definition tWrite   r1          := TApp (TCon TyConWrite) r1.
Definition tAlloc   r1          := TApp (TCon TyConAlloc) r1.

(* Baked-in Closure Types *)
Definition tUse     r1          := TApp (TCon TyConUse) r1.

(* Baked-in Value Types *)
Definition tFun   t1 eff clo t2 := TApp (TApp (TApp (TApp (TCon TyConFun) t1) eff) clo) t2.
Definition tBool                := TCon TyConBool.
Definition tNat                 := TCon TyConNat.
Definition tArray r1            := TApp (TCon TyConArray) r1.

(* Type Environments *)
Definition tyenv := list ty.


Section ml.
Variables A B C:Prop.
Theorem Andasr: and A (and B C) -> and (and A B) C.
Proof.
    intro H0.
    elim H0; intros Ha Hbc.
    elim Hbc; intros Hb Hc.
    split.
    split; assumption.
    assumption.
Qed.
End ml.

Check Andasr.


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.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import prelude.basics.
Require Import prelude.cubical_methods.
Require Import groupoid_quotient.gquot.
Require Import groupoid_quotient.gquot_principles.

Local Open Scope cat.

(** * Encode-decode method for characterizing the path space of [gquot G]. *)
Section encode_decode.
  Variable (G : groupoid).

  (** First, we shall lift the hom set of [G] to a set relation of [gquot G].
      For that, we need an equivalence between [hom G a₁ b] and [hom G a₂ b] (given a morphism [hom G a₁ a₂]),
      and another one between [hom G a b₁] and [hom G a b₂] (given a morphism [hom G b₁ b₂]).
      Those are the [left_action] and the [right_action], resp.
   *)
  Definition right_action
        {a₁ a₂ : G} (b : G)
        (g : a₁ --> a₂)
    : a₁ --> b → a₂ --> b
    := λ h, inv_from_z_iso (g ,, pr2 G _ _ g) · h.

  Definition right_action_inv
             {a₁ a₂ : G} (b : G)
             (g : a₁ --> a₂)
    : a₂ --> b → a₁ --> b
    := λ h, g · h.

  Definition right_action_isweq
             (a : G) {b₁ b₂ : G}
             (g : b₁ --> b₂)
    : isweq (right_action a g).
  Proof.
    use gradth.
    - exact (right_action_inv a g).
    - abstract
        (intros h ; cbn ;
         unfold right_action, right_action_inv ; cbn ;
         rewrite !assoc ;
         rewrite (z_iso_inv_after_z_iso (g ,, _)) ;
         apply id_left).
    - abstract
        (intros h ; cbn ;
         unfold right_action, right_action_inv ; cbn ;
         rewrite !assoc ;
         rewrite (z_iso_after_z_iso_inv (g ,, _)) ;
         apply id_left).
  Defined.

  Definition left_action
        (a : G) {b₁ b₂ : G}
        (g : b₁ --> b₂)
    : a --> b₁ → a --> b₂
    := λ h, h · g.

  Definition left_action_inv
             (a : G) {b₁ b₂ : G}
             (g : b₁ --> b₂)
    : a --> b₂ → a --> b₁
    := λ h, h · (inv_from_z_iso (g ,, pr2 G _ _ g)).

  Definition left_action_isweq
             (a : G) {b₁ b₂ : G}
             (g : b₁ --> b₂)
    : isweq (left_action a g).
  Proof.
    use gradth.
    - exact (left_action_inv a g).
    - abstract
        (intros h ; cbn ;
         unfold left_action, left_action_inv ; cbn ;
         rewrite <- assoc ;
         rewrite (z_iso_inv_after_z_iso (g ,, _)) ;
         apply id_right).
    - abstract
        (intros h ; cbn ;
         unfold left_action, left_action_inv ; cbn ;
         rewrite <- assoc ;
         rewrite (z_iso_after_z_iso_inv (g ,, _)) ;
         apply id_right).
  Defined.

  (** The action of the unit element is the identity. *)
  Definition left_action_e (a b : G) (g : a --> b)
    : left_action a (identity b) g = g.
  Proof.
    apply id_right.
  Defined.

  Definition right_action_e (a b : G) (g : a --> b)
    : right_action b (identity a) g = g.
  Proof.
    unfold right_action.
    refine (_ @ id_left g).
    apply maponpaths_2.
    refine (!_).
    use inv_z_iso_unique'.
    unfold precomp_with ; cbn.
    apply id_left.
  Qed.

  Definition right_action_comp
             (a₁ a₂ a₃ b : G)
             (g₁ : a₁ --> a₂)
             (g₂ : a₂ --> a₃)
             (h : a₁ --> b)
    : right_action b (g₁ · g₂) h = right_action b g₂ (right_action b g₁ h).
  Proof.
    unfold right_action.
    rewrite assoc.
    apply maponpaths_2.
    refine (!_).
    use inv_z_iso_unique'.
    unfold precomp_with ; cbn.
    etrans.
    {
      rewrite !assoc.
      apply maponpaths_2.
      rewrite <- !assoc.
      rewrite (z_iso_inv_after_z_iso (g₂ ,, _)).
      apply id_right.
    }
    rewrite (z_iso_inv_after_z_iso (g₁ ,, _)).
    apply idpath.
  Qed.

  (** The lift of [hom G] to [gquot G]. *)
  Definition g_fam : gquot G → gquot G → hSet.
  Proof.
    simple refine (gquot_relation G G
                          (λ (z₁ z₂ : G), make_hSet (z₁ --> z₂) _)
                          (λ _ _ b g, right_action b g)
                          (λ a _ _ g, left_action a g)
                          _ _ _ _ _ _ _
                  ).
    - apply homset_property.
    - intros.
      apply right_action_isweq.
    - intros.
      apply left_action_isweq.
    - intros ? ? ? ; simpl.
      apply right_action_e.
    - intros ; intro ; cbn.
      apply right_action_comp.
    - intros a b g.
      apply left_action_e.
    - intros a b₁ b₂ b₃ g₁ g₂ h ; simpl.
      apply assoc.
    - intros a₁ a₂ b₁ b₂ g₁ g₂ h ; simpl.
      apply assoc.
  Defined.

  (** The computation rules of [g_fam] for the paths. *)
  Definition gquot_fam_l_gcleq
             {a₁ a₂ : G} (b : G) (g : a₁ --> a₂)
    : maponpaths (λ z, g_fam z (gcl G b)) (gcleq G g)
      =
      _
    := gquot_relation_beta_l_gcleq
         G G
         (λ (z₁ z₂ : G), make_hSet (z₁ --> z₂) _)
         _ _ _ _ _ _ _ _ _ _ g.

  Definition gquot_fam_r_gcleq
             (a : G) {b₁ b₂ : G} (g : b₁ --> b₂)
    : maponpaths (g_fam (gcl G a)) (gcleq G g)
      =
      _
    := gquot_relation_beta_r_gcleq
         G G
         (λ (z₁ z₂ : G), make_hSet (z₁ --> z₂) _)
         _ _ _ _ _ _ _ _ _ _ g.

  Opaque g_fam.

  (** The relation [g_fam] is reflexive. *)
  Definition g_fam_refl : ∏ (x : gquot G), g_fam x x.
  Proof.
    simple refine (gquot_ind_set (λ x, g_fam x x) _ _ _).
    - exact (λ a, identity a).
    - intros a₁ a₂ g.
      apply path_to_PathOver.
      refine ((transport_idmap_ap_set (λ x, g_fam x x) (gcleq G g) (identity a₁))
                @ _).
      refine (maponpaths (λ z, transportf _ z _) (_ @ _ @ _) @ _).
      + exact (ap_diag2 g_fam (gcleq G g)).
      + refine (maponpaths (λ z, z @ _) (gquot_fam_r_gcleq a₁ g) @ _).
        exact (maponpaths (λ z, _ @ z) (gquot_fam_l_gcleq a₂ g)).
      + exact (!(@path_HLevel_comp 2 _ _ _ _ _)).
      + refine (transport_path_hset _ _ @ _) ; simpl.
        unfold right_action, left_action ; simpl.
        refine (maponpaths (λ z, _ · z) (id_left _) @ _).
        exact (z_iso_after_z_iso_inv (g ,, _)).
    - intro.
      apply g_fam.
  Defined.

  (** Now we can define the encode function. *)
  Definition encode_gquot (x y : gquot G)
    : x = y → g_fam x y
    := λ p, transportf (g_fam x) p (g_fam_refl x).

  (** We can also define the decode function.
      For this we use double induction over a family of sets.
   *)
  Definition decode_gquot (x y : gquot G) : g_fam x y → x = y.
  Proof.
    simple refine (gquot_double_ind_set (λ x y, g_fam x y → x = y) _ _ x y).
    - intros a b.
      use funspace_isaset.
      exact (gtrunc G a b).
    - exact (λ _ _ g, gcleq G g).
    - intros ; simpl.
      simple refine (PathOver_arrow _ _ _ _ _ _) ; simpl.
      intro z.
      apply map_PathOver.
      refine (whisker_square
                (idpath _)
                (!(maponpaths_for_constant_function _ _))
                (!(maponpathsidfun _))
                _
                (maponpaths
                   (gcleq G)
                   ((!(id_right _))
                      @ maponpaths
                      (λ p, z · p)
                      (!(z_iso_after_z_iso_inv (g ,, pr2 G _ _ g)))
                      @ assoc _ _ _)
                   @ gconcat _ _ _)
             ).
      apply maponpaths.
      refine (_ @ !(transport_idmap_ap_set (g_fam (gcl G a)) (!(gcleq G g)) z)).
      refine (!(@transport_path_hset
                  (make_hSet (a --> b₂) _)
                  (make_hSet (a --> b₁) _)
                  (invweq (make_weq (left_action a g) (left_action_isweq a g))) z)
               @ _).
      refine (maponpaths (λ p, transportf _ p z) _).
      rewrite maponpathsinv0.
      refine (_ @ maponpaths (λ z, ! z) (!(gquot_fam_r_gcleq _ _))).
      apply (@path_HLevel_inv 2).
    - intros ; simpl.
      simple refine (PathOver_arrow _ _ _ _ _ _).
      intro z ; simpl.
      apply map_PathOver.
      refine (whisker_square
                (idpath _)
                (!(maponpathsidfun _))
                (!(maponpaths_for_constant_function _ _))
                _
                (!(gconcat _ _ _) @ !(pathscomp0rid _))
             ).
      apply maponpaths.
      refine (_ @ !(transport_idmap_ap_set (λ z, g_fam z (gcl G b)) (!(gcleq G g)) z)).
      refine (!(@transport_path_hset
                  (make_hSet (a₂ --> b) _)
                  (make_hSet (a₁ --> b) _)
                  (invweq (make_weq (right_action b g) (right_action_isweq b g))) z)
               @ _).
      refine (maponpaths (λ p, transportf pr1hSet p z) _).
      rewrite maponpathsinv0.
      refine (_ @ maponpaths (λ z, !z) (!(gquot_fam_l_gcleq b g))).
      apply (@path_HLevel_inv 2).
  Defined.

  (** The encode and decode maps are inverses of each other. *)
  Definition decode_gquot_encode_gquot
             {x y : gquot G}
             (p : x = y)
    : decode_gquot x y (encode_gquot x y p) = p.
  Proof.
    induction p.
    revert x.
    simple refine (gquot_ind_prop _ _ _).
    - intros a ; simpl.
      exact (ge _ _).
    - intro.
      exact (gtrunc G _ _ _ _).
  Defined.

  Definition encode_gquot_decode_gquot
    : ∏ {x y : gquot G} (p : g_fam x y), encode_gquot x y (decode_gquot x y p) = p.
  Proof.
    simple refine (gquot_double_ind_prop _ _ _).
    - simpl.
      intros a b.
      use impred ; intro.
      exact (setproperty (g_fam _ _) _ _).
    - intros a b g.
      unfold encode_gquot, g_fam_refl.
      simpl.
      refine (transport_idmap_ap_set
                (λ x : gquot G, g_fam (gcl G a) x)
                (gcleq G g)
                (identity a) @ _).
      refine (_ @ id_left g).
      rewrite gquot_fam_r_gcleq.
      rewrite transport_path_hset.
      apply idpath.
  Defined.

  Definition encode_gquot_isweq
    : ∏ {x y : gquot G}, isweq (encode_gquot x y).
  Proof.
    intros x y.
    use gradth.
    - exact (decode_gquot x y).
    - intros z.
      apply decode_gquot_encode_gquot.
    - intros z.
      apply encode_gquot_decode_gquot.
  Defined.
End encode_decode.


Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.SetoidClass.
Require Import Coq.Classes.Equivalence.

From Quotient.Construction Require Import function_util equalizer coequalizer construction_of_equalizer power co_equalizer_in_power.

Open Scope equiv_scope.

Section CoequalizerExists.

  Context {instance_proof_irrelevance : axiom_proof_irrelevance}.
  Context {instance_power_exists : axiom_power_exists}.
  Context {instance_preserve_reflexive_equalizer : axiom_preserve_reflexive_equalizer}.
  Context {instance_power_reflects_iso : axiom_power_reflects_iso}.
  Context {instance_power_f_faithful : axiom_power_f_faithful}.

  Context {B : Type}.
  Context {A : Type}.
  Variable f g : B -> A.

  Definition Vtau_equalizer : equalizer (power_f f) (power_f g)
    := construct_equalizer _ _.
  Definition V : Type :=
    equalizer_set _ _ Vtau_equalizer.
  Definition tau : V -> power A :=
    equalizer_fun _ _ Vtau_equalizer.
  Definition isEqualizer_PfPg : isEqualizer (power_f f) (power_f g) tau :=
    equalizer_isequalizer _ _ Vtau_equalizer.
  Definition Pftau_eq_Pgtau : f_comp (power_f f) tau === f_comp (power_f g) tau :=
    equalizer_equal _ _ _ isEqualizer_PfPg.
  Definition Vtau_equalizer_univ := @equalizer_univ _ _ _ _ _ _ isEqualizer_PfPg.
  Lemma mono_tau : mono tau.
  Proof.
    apply (equalizer_mono _ _ _ isEqualizer_PfPg).
  Qed.

  Lemma P3fP2tau_eq_P3gP2tau : f_comp (power_f (power_f (power_f f))) (power_f (power_f tau)) === f_comp (power_f (power_f (power_f g))) (power_f (power_f tau)).
  Proof.
    rewrite <- power_f_comp_comm.
    rewrite <- power_f_comp_comm.
    rewrite <- power_f_comp_comm.
    rewrite <- power_f_comp_comm.
    rewrite Pftau_eq_Pgtau.
    reflexivity.
  Qed.

  Lemma PfPepsilonAP2tau_eq_PgPepsilonAP2tau : f_comp (power_f f) (f_comp (power_f (power_epsilon A)) (power_f (power_f tau))) === f_comp (power_f g) (f_comp (power_f (power_epsilon A)) (power_f (power_f tau))).
  Proof.
    rewrite <- f_comp_assoc.
    rewrite <- f_comp_assoc.
    rewrite (triangle_power_f _ _ _ _ (power2_epsilon_natural f)).
    rewrite (triangle_power_f _ _ _ _ (power2_epsilon_natural g)).
    rewrite f_comp_assoc.
    rewrite f_comp_assoc.
    rewrite P3fP2tau_eq_P3gP2tau.
    reflexivity.
  Qed.

  Definition h_equalizer_univ := Vtau_equalizer_univ _ _ PfPepsilonAP2tau_eq_PgPepsilonAP2tau.
  Definition h : (power (power V)) -> V := proj1_sig h_equalizer_univ.
  Lemma PepsilonAP2tau_eq_tauh : f_comp (power_f (power_epsilon A)) (power_f (power_f tau)) === f_comp tau h.
  Proof.
    generalize (proj2_sig h_equalizer_univ); intro HH.
    destruct HH as [HH _].
    unfold h.
    apply HH.
  Qed.

  Definition Cv_equalizer : equalizer (power_epsilon (power V)) (power_f h)
    := construct_equalizer _ _.
  Definition C : Type :=
    equalizer_set _ _ Cv_equalizer.
  Definition v : C -> power V :=
    equalizer_fun _ _ Cv_equalizer.
  Definition isEqualizer_Cv : isEqualizer (power_epsilon (power V)) (power_f h) v :=
    equalizer_isequalizer _ _ Cv_equalizer.
  Definition epsilonPVv_eq_Phv : f_comp (power_epsilon (power V)) v === f_comp (power_f h) v :=
    equalizer_equal _ _ _ isEqualizer_Cv.
  Definition Cv_equalizer_univ := @equalizer_univ _ _ _ _ _ _ isEqualizer_Cv.
  Lemma mono_v : mono v.
  Proof.
    apply (equalizer_mono _ _ _ isEqualizer_Cv).
  Qed.

  Lemma epsilonPVPtauepsilonA_eq_PhPtauepsilonA : f_comp (power_epsilon (power V)) (f_comp (power_f tau) (power_epsilon A)) === f_comp (power_f h) (f_comp (power_f tau) (power_epsilon A)).
  Proof.
    rewrite <- f_comp_assoc.
    rewrite <- f_comp_assoc.
    rewrite power2_epsilon_natural.
    rewrite <- (triangle_power_f _ _ _ _ PepsilonAP2tau_eq_tauh).
    rewrite f_comp_assoc.
    rewrite f_comp_assoc.
    rewrite principle_equalizer_eq.
    reflexivity.
  Qed.

  Definition sigma_equalizer_univ := Cv_equalizer_univ _ _ epsilonPVPtauepsilonA_eq_PhPtauepsilonA.
  Definition sigma : A -> C := proj1_sig sigma_equalizer_univ.
  Lemma PtauepsilonA_eq_vsigma : f_comp (power_f tau) (power_epsilon A) === f_comp v sigma.
  Proof.
    generalize (proj2_sig sigma_equalizer_univ); intro HH.
    destruct HH as [HH _].
    unfold h.
    apply HH.
  Qed.

  Lemma sigmaf_eq_sigmag : f_comp sigma f === f_comp sigma g.
  Proof.
    apply mono_v.
    rewrite <- f_comp_assoc.
    rewrite <- f_comp_assoc.
    rewrite <- PtauepsilonA_eq_vsigma.
    rewrite f_comp_assoc.
    rewrite f_comp_assoc.
    rewrite power2_epsilon_natural.
    rewrite power2_epsilon_natural.
    rewrite <- f_comp_assoc.
    rewrite <- f_comp_assoc.
    rewrite <- power_f_comp_comm.
    rewrite <- power_f_comp_comm.
    rewrite Pftau_eq_Pgtau.
    reflexivity.
  Qed.

  (* Uniqueness *)
  Section Exists_Arrow.

    Variable D : Type.
    Variable r : A -> D.
    Variable rf_eq_rg : f_comp r f === f_comp r g.

    Lemma PfPr_eq_PgPr : f_comp (power_f f) (power_f r) === f_comp (power_f g) (power_f r).
    Proof.
      repeat rewrite <- power_f_comp_comm.
      rewrite rf_eq_rg.
      reflexivity.
    Qed.

    Definition s_univ := (Vtau_equalizer_univ _ _ PfPr_eq_PgPr).
    Definition s : (power D) -> V := proj1_sig s_univ.
    Lemma Pr_eq_taus : (power_f r) === f_comp tau s.
    Proof.
      generalize (proj2_sig s_univ); intro HH.
      destruct HH as [eqH _].
      unfold s.
      rewrite eqH.
      reflexivity.
    Qed.

    Lemma uniq_s : forall s', (power_f r) === f_comp tau s' -> s' === s.
      generalize (proj2_sig s_univ); intro HH.
      destruct HH as [_ unqH].
      unfold s.
      apply unqH.
    Qed.

    Lemma sPEd_eq_hPPs : f_comp s (power_f (power_epsilon D)) === f_comp h (power_f (power_f s)).
    Proof.
      apply mono_tau.
      rewrite <- (f_comp_assoc tau s _).
      rewrite <- Pr_eq_taus.
      rewrite <- power_f_comp_comm.
      rewrite <- (f_comp_assoc tau h _).
      rewrite <- PepsilonAP2tau_eq_tauh.
      rewrite (f_comp_assoc (power_f (power_epsilon A))).
      rewrite <- power_f_comp_comm.
      rewrite <- power_f_comp_comm.
      rewrite <- power_f_comp_comm.
      rewrite <- Pr_eq_taus.
      apply power_f_Proper.
      rewrite power2_epsilon_natural.
      reflexivity.
    Qed.

    Lemma PPEdPs_eq_PPPsPh : f_comp (power_f (power_f (power_epsilon D))) (power_f s) === f_comp (power_f (power_f (power_f s))) (power_f h).
    Proof.
      repeat rewrite <- power_f_comp_comm.
      rewrite sPEd_eq_hPPs.
      reflexivity.
    Qed.

    Lemma EPPDPsv_eq_PPEdPsv : f_comp (power_epsilon (power (power D))) (f_comp (power_f s) v) === f_comp (power_f (power_f (power_epsilon D))) (f_comp (power_f s) v).
    Proof.
      rewrite <- (f_comp_assoc (power_epsilon _) (power_f s) v).
      rewrite power2_epsilon_natural.
      rewrite (f_comp_assoc (power_f _) (power_epsilon _) v).
      rewrite epsilonPVv_eq_Phv.
      rewrite <- (f_comp_assoc _ (power_f h) v).
      rewrite <- PPEdPs_eq_PPPsPh.
      rewrite (f_comp_assoc _ (power_f s) v).
      reflexivity.
    Qed.

    Definition isEqualizer_power_epsilon_D := isEqualizer_power_epsilon D.
    Definition u_univ := @equalizer_univ _ _ _ _ _ _ (isEqualizer_power_epsilon_D) _ _ EPPDPsv_eq_PPEdPsv.
    Definition u : C -> D := proj1_sig u_univ.
    Lemma Psv_eq_Edu : f_comp (power_f s) v === f_comp (power_epsilon D) u.
    Proof.
      generalize (proj2_sig u_univ); intro HH.
      destruct HH as [eqH _].
      unfold v.
      rewrite eqH.
      reflexivity.
    Qed.

    Lemma r_eq_usigma : r === f_comp u sigma.
    Proof.
      apply (mono_power_epsilon D).
      rewrite power2_epsilon_natural.
      rewrite Pr_eq_taus.
      rewrite power_f_comp_comm.
      rewrite f_comp_assoc.
      rewrite PtauepsilonA_eq_vsigma.
      rewrite <- (f_comp_assoc _ v sigma).
      rewrite Psv_eq_Edu.
      rewrite (f_comp_assoc _ u sigma).
      reflexivity.
    Qed.

    Section Uniqueness.

      Variable u1 u2 : C -> D.
      Variable u1sigma_eq_r : f_comp u1 sigma === r.
      Variable u2sigma_eq_r : f_comp u2 sigma === r.

      Lemma hEv_eq_id : f_comp h (power_epsilon V) === id.
      Proof.
        apply mono_tau.
        rewrite f_comp_id_R.
        rewrite <- f_comp_assoc.
        rewrite <- PepsilonAP2tau_eq_tauh.
        rewrite f_comp_assoc.
        rewrite <- power2_epsilon_natural.
        rewrite <- f_comp_assoc.
        rewrite power_epsilon_unit_counit.
        rewrite f_comp_id_L.
        reflexivity.
      Qed.

      Lemma hPPh_eq_hPEPv : f_comp h (power_f (power_f h)) === f_comp h (power_f (power_epsilon (power V))).
      Proof.
        apply mono_tau.
        transitivity (f_comp (f_comp (power_f (power_epsilon A)) (power_f (power_f tau))) (power_f (power_f h))).
        {
          rewrite <- f_comp_assoc at 1.
          rewrite <- PepsilonAP2tau_eq_tauh.
          reflexivity.
        }
        transitivity (f_comp (power_f (power_epsilon A)) (f_comp (power_f (power_f (power_f (power_epsilon A)))) (power_f (power_f (power_f (power_f tau)))))).
        {
          rewrite f_comp_assoc at 1.
          rewrite <- (power_f_comp_comm (power_f h) (power_f tau)).
          rewrite <- (power_f_comp_comm tau h).
          rewrite <- PepsilonAP2tau_eq_tauh.
          rewrite (power_f_comp_comm (power_f (power_epsilon A)) (power_f _)).
          rewrite power_f_comp_comm.
          reflexivity.
        }
        transitivity (f_comp (power_f (power_epsilon A)) (f_comp (power_f (power_epsilon (power (power A)))) (power_f (power_f (power_f (power_f tau)))))).
        {
          repeat rewrite <- f_comp_assoc.
          rewrite <- power_f_comp_comm.
          rewrite <- principle_equalizer_eq.
          rewrite power_f_comp_comm.
          reflexivity.
        }
        transitivity (f_comp (power_f (power_epsilon A)) (f_comp (power_f (power_f tau)) (power_f (power_epsilon (power V))))).
        {
          rewrite <- power_f_comp_comm at 1.
          rewrite <- power2_epsilon_natural.
          rewrite power_f_comp_comm at 1.
          reflexivity.
        }
        rewrite <- f_comp_assoc.
        rewrite PepsilonAP2tau_eq_tauh.
        rewrite f_comp_assoc.
        reflexivity.
      Qed.

      Lemma isCoequalizerPV : isCoequalizer (power_f (power_f h)) (power_f (power_epsilon (power V))) h.
      Proof.
        apply isCoequalizer_symmetry.
        apply splitcoequalizer_coequalizer.
        apply (Build_isSplitCoequalizer _ _ _ _ _ _ (power_epsilon (power (power V))) (power_epsilon V)).
        {
          rewrite power_epsilon_unit_counit.
          reflexivity.
        } {
          rewrite power2_epsilon_natural.
          reflexivity.
        } {
          rewrite hEv_eq_id.
          reflexivity.
        } {
          rewrite hPPh_eq_hPEPv.
          reflexivity.
        }
      Qed.

      Lemma isCoequalizerPVC : isCoequalizer (power_f (power_f h)) (power_f (power_epsilon (power V))) (power_f v).
      Proof.
        apply isCoequalizer_symmetry.
        apply (proof_preserve_reflexive_equalizer _ _ _ _ _ _ (power_f (power_epsilon V)) isEqualizer_Cv).
        split.
        {
          rewrite power_epsilon_unit_counit.
          reflexivity.
        } {
          rewrite <- power_f_comp_comm.
          rewrite hEv_eq_id.
          rewrite power_f_id.
          reflexivity.
        }
      Qed.

      Lemma epi_h : epi h.
      Proof.
        apply (coequalizer_epi _ _ _ isCoequalizerPV).
      Qed.

      Lemma epi_Pv : epi (power_f v).
        apply (coequalizer_epi _ _ _ isCoequalizerPVC).
      Qed.

      Lemma PvPEPV_eq_PvPPh : f_comp (power_f v) (power_f (power_f h)) === f_comp (power_f v) (power_f (power_epsilon (power V))).
      Proof.
        repeat rewrite <- power_f_comp_comm.
        rewrite epsilonPVv_eq_Phv.
        reflexivity.
      Qed.

      Definition q_univ := @coequalizer_univ _ _ _ _ _ _ isCoequalizerPVC _ _ hPPh_eq_hPEPv.
      Definition qinv_univ := @coequalizer_univ _ _ _ _ _ _ isCoequalizerPV _ _ PvPEPV_eq_PvPPh.

      Definition q : power C -> V := proj1_sig q_univ.
      Lemma h_eq_qPv : h === f_comp q (power_f v).
        generalize (proj2_sig q_univ); intro HH.
        destruct HH as [HH _].
        unfold q.
        apply HH.
      Qed.

      Definition qinv : V -> power C := proj1_sig qinv_univ.
      Lemma Pv_eq_qinvh : power_f v === f_comp qinv h.
        generalize (proj2_sig qinv_univ); intro HH.
        destruct HH as [HH _].
        unfold qinv.
        apply HH.
      Qed.

      Lemma qqinv_eq_id : f_comp q qinv === id.
      Proof.
        apply epi_h.
        rewrite f_comp_id_L.
        rewrite f_comp_assoc.
        rewrite <- Pv_eq_qinvh.
        rewrite <- h_eq_qPv.
        reflexivity.
      Qed.

      Lemma qinvq_eq_id : f_comp qinv q === id.
      Proof.
        apply epi_Pv.
        rewrite f_comp_id_L.
        rewrite f_comp_assoc.
        rewrite <- h_eq_qPv.
        rewrite <- Pv_eq_qinvh.
        reflexivity.
      Qed.

      Lemma tauq_eq_Psigma : f_comp tau q === power_f sigma.
      Proof.
        apply epi_Pv.
        rewrite (f_comp_assoc tau q).
        rewrite <- h_eq_qPv.
        rewrite <- PepsilonAP2tau_eq_tauh.
        rewrite <- power_f_comp_comm.
        rewrite PtauepsilonA_eq_vsigma.
        rewrite power_f_comp_comm.
        reflexivity.
      Qed.

      Lemma tau_eq_Psigmaqinv : tau === f_comp (power_f sigma) qinv.
      Proof.
        transitivity (f_comp (f_comp tau q) qinv).
        {
          rewrite f_comp_assoc.
          rewrite qqinv_eq_id.
          rewrite f_comp_id_R.
          reflexivity.
        }
        rewrite tauq_eq_Psigma.
        reflexivity.
      Qed.

      Lemma qPu1_eq_s : f_comp q (power_f u1) === s.
      Proof.
        apply uniq_s.
        rewrite <- f_comp_assoc.
        rewrite tauq_eq_Psigma.
        rewrite <- power_f_comp_comm.
        rewrite u1sigma_eq_r.
        reflexivity.
      Qed.

      Lemma qPu2_eq_s : f_comp q (power_f u2) === s.
      Proof.
        apply uniq_s.
        rewrite <- f_comp_assoc.
        rewrite tauq_eq_Psigma.
        rewrite <- power_f_comp_comm.
        rewrite u2sigma_eq_r.
        reflexivity.
      Qed.

      Lemma Pu1_eq_Pu2 : power_f u1 === power_f u2.
      Proof.
        transitivity (f_comp qinv (f_comp q (power_f u1))).
        {
          rewrite <- f_comp_assoc.
          rewrite qinvq_eq_id.
          rewrite f_comp_id_L.
          reflexivity.
        }
        rewrite qPu1_eq_s.
        rewrite <- qPu2_eq_s.
        rewrite <- f_comp_assoc.
        rewrite qinvq_eq_id.
        rewrite f_comp_id_L.
        reflexivity.
      Qed.

      Lemma u1_eq_u2 : u1 === u2.
        apply proof_power_f_faithful.
        exact Pu1_eq_Pu2.
      Qed.

    End Uniqueness.

  End Exists_Arrow.

  Theorem isCoequalizerC : isCoequalizer f g sigma.
  Proof.
    split.
    exact sigmaf_eq_sigmag.
    intros D r eq_rf_rg.
    set (u D r eq_rf_rg) as u1.
    set (r_eq_usigma D r eq_rf_rg : r === f_comp u1 sigma) as eq_r_u1sigma.
    exists u1.
    split.
    exact (r_eq_usigma D r eq_rf_rg).
    intros u2 eq_r_u2sigma.
    apply (u1_eq_u2 D r eq_rf_rg).
    rewrite eq_r_u2sigma.
    reflexivity.
    rewrite eq_r_u1sigma.
    reflexivity.
  Qed.

  Definition construct_coequalizer : coequalizer f g :=
    {|
      coequalizer_set := C;
      coequalizer_fun := sigma;
      coequalizer_iscoequalizer := isCoequalizerC
    |}.

End CoequalizerExists.

Theorem XX__coequalizer_exists :
  axiom_proof_irrelevance ->
  forall instance_power_exists : axiom_power_exists,
    axiom_preserve_reflexive_equalizer ->
    axiom_power_reflects_iso ->
    axiom_power_f_faithful ->
    coequalizer_exists.
Proof.
  intros PEM APE APRE APRI APF.
  intros B A f1 f2.
  apply construct_coequalizer.
Qed.


Require Import Arith.
Require Import List.

Inductive proposition : Set :=
    Pimp  : proposition -> proposition -> proposition
  | Patom : nat -> proposition.

Notation "A *-> B" := (Pimp A B) (at level 20, right associativity).

Definition assump : Set := list proposition.

Inductive hilbert : assump -> proposition -> Prop :=
    Hmp       : forall {a : assump} {p1 p2 : proposition},
                hilbert a (p1 *-> p2) -> hilbert a p1 -> hilbert a p2
  | Hasp      : forall {a : assump} {p : proposition}, In p a -> hilbert a p
  | Hstarling : forall {a : assump} {p1 p2 p3 : proposition},
                hilbert a ((p1 *-> p2 *-> p3) *-> (p1 *-> p2) *-> p1 *-> p3)
  | Hkestrel  : forall {a : assump} {p1 p2 : proposition}, hilbert a (p1 *-> p2 *-> p1).

Inductive nd : assump -> proposition -> Prop :=
    NDmp   : forall {a : assump} {p1 p2 : proposition}, nd a (p1 *-> p2) -> nd a p1 -> nd a p2
  | NDasp  : forall {a : assump} {p : proposition}, In p a -> nd a p
  | NDimpi : forall {a : assump} {p1 p2 : proposition}, nd (p1 :: a) p2 -> nd a (p1 *-> p2).

Lemma NDstarling : forall {a : assump} {p1 p2 p3 : proposition},
                   nd a ((p1 *-> p2 *-> p3) *-> (p1 *-> p2) *-> p1 *-> p3).
  intros.
  repeat apply NDimpi.
  apply (@NDmp _ p2).
  apply (@NDmp _ p1) ; apply NDasp ; unfold In ; auto.
  apply (@NDmp _ p1) ; apply NDasp ; unfold In ; auto.
Defined.

Lemma NDkestrel : forall {a : assump} {p1 p2 : proposition}, nd a (p1 *-> p2 *-> p1).
  intros.
  repeat apply NDimpi.
  apply NDasp ; unfold In ; auto.
Defined.

Lemma Hidiot : forall {a : assump} {p : proposition}, hilbert a (p *-> p).
  intros.
  exact (Hmp (Hmp (@Hstarling a p (p *-> p) p) Hkestrel) Hkestrel).
Defined.

Theorem hilbert_nd_homomorphism : forall {a : assump} {p : proposition}, hilbert a p -> nd a p.
  intros.
  induction H.
  exact (NDmp IHhilbert1 IHhilbert2).
  exact (NDasp H).
  exact NDstarling.
  exact NDkestrel.
Defined.

Lemma Himpi : forall {a : assump} {p1 p2 : proposition}, hilbert (p1 :: a) p2 -> hilbert a (p1 *-> p2).
  intros.
  refine (hilbert_ind (fun a p1 =>
    match a with nil => True | p2 :: a => hilbert a (p2 *-> p1) end) _ _ _ _ (p1 :: a) p2 H) ;
    intros ; destruct a0 ; auto.
  exact (Hmp (Hmp Hstarling H1) H3).
  case H0 ; intros.
  rewrite H1 ; exact Hidiot.
  exact (Hmp Hkestrel (Hasp H1)).
  exact (Hmp Hkestrel Hstarling).
  exact (Hmp Hkestrel Hkestrel).
Defined.

Theorem nd_hilbert_homomorphism : forall {a : assump} {p : proposition}, nd a p -> hilbert a p.
  intros.
  induction H.
  exact (Hmp IHnd1 IHnd2).
  exact (Hasp H).
  exact (Himpi IHnd).
Defined.

Theorem nd_hilbert_isomorphism : forall {a : assump} {p : proposition}, nd a p <-> hilbert a p.
  intros.
  exact (conj nd_hilbert_homomorphism hilbert_nd_homomorphism).
Defined.


Section Conv.
Require Export CoRNMisc.
Variable (TContR : CRing).
Require Import MathClasses.interfaces.canonical_names.

Global Instance Zero_instance_TContR : Zero TContR := [0].
Global Instance One_instance_TContR : One TContR := [1].
Global Instance Plus_instance_TContR : Plus TContR := csg_op .
Global Instance Mult_instance_TContR : Mult TContR := cr_mult.
Global Instance Negate_instance_TContR : Negate TContR := cg_inv.

Require Export MathClasses.theory.rings.
Require Export MathClasses.interfaces.abstract_algebra.

Global Instance : Ring TContR.
Proof. apply (rings.from_stdlib_ring_theory (CRing_Ring TContR)). Qed.

End Conv.


(** * Heyting algebras *)

Require Import UniMath.Foundations.Preamble.

Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Lattice.Lattice.
Require Import UniMath.Algebra.Lattice.Bounded.

Section Def.

  Context {X : hSet} (L : lattice X).
  Local Notation "x ≤ y" := (Lle L x y).
  Local Notation "x ∧ y" := (Lmin L x y).

  (** An exponential is a binary operation on [X] satisfying this law *)
  Definition exponential : UU :=
    ∑ exponential_map : X -> X -> X,
      ∏ x y z : X, z ≤ (exponential_map x y) <-> (z ∧ x) ≤ y.

  Definition make_exponential (exponential_map : X -> X -> X)
             (prop : ∏ x y z : X, z ≤ (exponential_map x y) <-> (z ∧ x) ≤ y) :
    exponential := tpair _ exponential_map prop.

  Definition exponential_map (exp : exponential) : X -> X -> X := pr1 exp.
  Coercion exponential_map : exponential >-> Funclass.

  Definition exponential_is_exponential (exp : exponential) :
    ∏ x y z : X, z ≤ (exponential_map exp x y) <-> (z ∧ x) ≤ y := pr2 exp.

End Def.


Require Import UniMath.Foundations.Preamble.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import
        UniMath.CategoryTheory.opp_precat
        UniMath.CategoryTheory.yoneda
        UniMath.CategoryTheory.categories.HSET.Core
        UniMath.CategoryTheory.categories.HSET.MonoEpiIso.
Require Import
        UniMath.CategoryTheory.RepresentableFunctors.Bifunctor
        UniMath.CategoryTheory.RepresentableFunctors.Precategories.
Require Import UniMath.MoreFoundations.Tactics.
Local Open Scope cat.
Local Open Scope Cat.

Definition isUniversal {C:category} {X:[C^op,HSET]} {c:C} (x:c ⇒ X)
  := ∏ (c':C), isweq (λ f : c' --> c, x ⟲ f).

Definition Universal {C:category} (X:[C^op,HSET]) (c:C)
  := ∑ (x:c ⇒ X), isUniversal x.

Lemma z_iso_Universal_weq {C:category} {X Y:[C^op,HSET]} (c:C) :
  z_iso X Y -> Universal X c ≃ Universal Y c.
Proof.
  intro i.
  set (I := (functor_z_iso_pointwise_if_z_iso
             C^op HSET (homset_property HSET) X Y (pr1 i) (pr2 i))).
  unshelve refine (weqbandf _ _ _ _).
  - apply hset_z_iso_equiv_weq. unfold arrow, functor_object_application. exact (I c).
  - simpl; intros x. apply weqonsecfibers; intro b. apply weqiff.
    + unshelve refine (twooutof3c_iff_1_homot _ _ _ _ _).
      * exact (pr1 i ◽ opp_ob b).
      * intro f; simpl.
        exact (eqtohomot (nat_trans_ax (pr1 i) _ _ f) x).
      * exact (hset_z_iso_is_equiv _ _ (I b)).
    + apply isapropisweq.
    + apply isapropisweq.
Defined.

Definition Representation {C:category} (X:[C^op,HSET]) : UU
  := ∑ (c:C), Universal X c.

Definition isRepresentable {C:category} (X:[C^op,HSET]) := ∥ Representation X ∥.

Lemma isaprop_Representation {C: univalent_category} (X:[C^op,HSET]) :
  isaprop (@Representation C X).
Proof.

Abort.

Definition z_iso_Representation_weq {C:category} {X Y:[C^op,HSET]} :
  z_iso X Y -> Representation X ≃ Representation Y.
Proof.
  intros i. apply weqfibtototal; intro c. apply z_iso_Universal_weq; assumption.
Defined.

(* categories of functors with representations *)

Definition RepresentedFunctor (C:category) : category
  := categoryWithStructure [C^op,HSET] Representation.

Definition toRepresentation {C:category} (X : RepresentedFunctor C) :
  Representation (pr1 X)
  := pr2 X.

Definition RepresentableFunctor (C:category) : category
  := categoryWithStructure [C^op,HSET] isRepresentable.

Definition toRepresentableFunctor {C:category} :
  RepresentedFunctor C ⟶ RepresentableFunctor C :=
  functorWithStructures (λ c, hinhpr).

(* make a representation of a functor *)

Definition makeRepresentation {C:category} {c:C} {X:[C^op,HSET]} (x:c ⇒ X) :
  (∏ (c':C), UniqueConstruction (λ f : c' --> c, x ⟲ f)) -> Representation X.
Proof.
  intros bij. exists c. exists x. intros c'. apply set_bijection_to_weq.
  - exact (bij c').
  - apply setproperty.
Defined.

(* universal aspects of represented functors *)

Definition universalObject {C:category} {X:[C^op,HSET]} (r:Representation X) : C
  := pr1 r.

Definition universalElement {C:category} {X:[C^op,HSET]} (r:Representation X) :
  universalObject r ⇒ X
  := pr1 (pr2 r).

Coercion universalElement : Representation >-> pr1hSet.

Definition universalProperty {C:category} {X:[C^op,HSET]} (r:Representation X) (c:C) :
  c --> universalObject r ≃ (c ⇒ X)
  := make_weq (λ f : c --> universalObject r, r ⟲ f)
             (pr2 (pr2 r) c).

Definition universalMap {C:category} {X:[C^op,HSET]} (r:Representation X) {c:C} :
  c ⇒ X -> c --> universalObject r
  := invmap (universalProperty _ _).

Notation "r \\ x" := (universalMap r x) (at level 50, left associativity) : cat.

Definition universalMap' {C:category} {X:[C^op^op,HSET]} (r:Representation X) {c:C} :
  X ⇐ c -> c <-- universalObject r
  := invmap (universalProperty _ _).

Notation "x // r" := (universalMap' r x) (at level 50, left associativity) : cat.

Definition universalMapProperty {C:category} {X:[C^op,HSET]} (r:Representation X)
      {c:C} (x : c ⇒ X) :
  r ⟲ (r \\ x) = x
  := homotweqinvweq (universalProperty r c) x.

Definition mapUniqueness {C:category} (X:[C^op,HSET]) (r : Representation X) (c:C)
           (f g: c --> universalObject r) :
  r ⟲ f = r ⟲ g -> f = g
  := invmaponpathsweq (universalProperty _ _) _ _.

Definition universalMapUniqueness {C:category} {X:[C^op,HSET]} {r:Representation X}
      {c:C} (x : c ⇒ X) (f : c --> universalObject r) :
  r ⟲ f = x -> f = r \\ x
  := pathsweq1 (universalProperty r c) f x.

Definition universalMapIdentity {C:category} {X:[C^op,HSET]} (r:Representation X) :
  r \\ r = identity _.
Proof.
  apply pathsinv0. apply universalMapUniqueness. apply arrow_mor_id.
Qed.

Definition universalMapUniqueness' {C:category} {X:[C^op,HSET]} {r:Representation X}
      {c:C} (x : c ⇒ X) (f : c --> universalObject r) :
  f = r \\ x -> r ⟲ f = x
  := pathsweq1' (universalProperty r c) f x.

Lemma univ_arrow_mor_assoc {C:category} {a b:C} {Z:[C^op,HSET]}
      (f : a --> b) (z : b ⇒ Z) (t : Representation Z) :
  (t \\ z) ∘ f = t \\ (z ⟲ f).
Proof.
  apply universalMapUniqueness.
  unshelve refine (arrow_mor_mor_assoc _ _ _ @ _).
  apply maponpaths.
  apply universalMapProperty.
Qed.

(*  *)

Lemma uOF_identity {C:category} {X:[C^op,HSET]} (r:Representation X) :
  r \\ (identity X ⟳ r) = identity _.
Proof.
  unfold nat_trans_id; simpl.
  unshelve refine (transportb (λ k, _ \\ k = _) (identityFunction' _ _) _).
  apply universalMapIdentity.
Qed.

Lemma uOF_comp {C:category} {X Y Z:[C^op,HSET]}
      (r:Representation X)
      (s:Representation Y)
      (t:Representation Z)
      (p:X-->Y) (q:Y-->Z) :
    t \\ ((q ∘ p) ⟳ r) = (t \\ (q ⟳ s)) ∘ (s \\ (p ⟳ r)).
Proof.
  unshelve refine (transportf (λ k, _ \\ k = _) (nattrans_nattrans_arrow_assoc _ _ _) _).
  unshelve refine (_ @ !univ_arrow_mor_assoc _ _ _).
  apply maponpaths.
  unshelve refine (_ @ nattrans_arrow_mor_assoc _ _ _).
  apply (maponpaths (λ k, q ⟳ k)).
  apply pathsinv0.
  apply universalMapProperty.
Qed.

Definition universalObjectFunctor (C:category) : RepresentedFunctor C ⟶ C.
Proof.
  unshelve refine (makeFunctor _ _ _ _).
  - intro X. exact (universalObject (pr2 X)).
  - intros X Y p; simpl. exact (pr2 Y \\ (p ⟳ pr2 X)).
  - intros X; simpl. apply uOF_identity.
  - intros X Y Z p q; simpl. apply uOF_comp.
Defined.

Definition universalObjectFunctor_on_map (C:category) {X Y:RepresentedFunctor C} (p:X-->Y) :
  universalObjectFunctor C ▭ p = pr2 Y \\ (p ⟳ pr2 X).
Proof.
  reflexivity.
Defined.

Lemma universalObjectFunctor_comm (C:category) {X Y:RepresentedFunctor C} (p:X-->Y) :
  p ⟳ universalElement (pr2 X) = universalElement (pr2 Y) ⟲ universalObjectFunctor C ▭ p.
Proof.
  change (universalObjectFunctor C ▭ p) with (pr2 Y \\ (p ⟳ pr2 X)).
  apply pathsinv0, universalMapProperty.
Defined.

(** transferring universal properties between isomorphic objects *)

Definition isUniversal_isom {C:category} {X:[C^op,HSET]} {c c':C}
           (x:c ⇒ X) (f : z_iso c' c) :
  isUniversal x <-> isUniversal (x ⟲ f).
Proof.

Abort.

(** transferring representability via embeddings and isomorphisms of categories  *)

Definition embeddingRepresentability {C D:category}
           {X:[C^op,HSET]} {Y:[D^op,HSET]}
           (s:Representation Y)
           (i:categoryEmbedding C D) :
  z_iso (Y □ functorOp (opp_ob (pr1 i))) X ->
  (∑ c, i c = universalObject s) -> Representation X.
Proof.
  intros j ce.
  apply (z_iso_Representation_weq j).
  exists (pr1 ce).
  exists (transportf (λ d, Y ◾ d : hSet) (!pr2 ce) s).
  intro c'. apply (twooutof3c (# i) (λ g, _ ⟲ g)).
  - apply (pr2 i).
  - induction (! pr2 ce). exact (weqproperty (universalProperty _ _)).
Defined.

Definition isomorphismRepresentability {C D:category}
           {X:[C^op,HSET]} {Y:[D^op,HSET]}
           (s:Representation Y)
           (i:categoryIsomorphism C D) :
  z_iso (Y □ functorOp (opp_ob (pr1 (pr1 i)))) X -> Representation X
  := λ j, embeddingRepresentability s i j (iscontrpr1 (pr2 i (universalObject s))).

(*** Some standard functors to consider representing *)

(** the functor represented by an object *)

Definition Hom1 {C:category} (c:C) : [C^op,HSET].
Proof.
  unshelve refine (makeFunctor_op _ _ _ _).
  - intro b. exact (Hom C b c).
  - intros b a f g; simpl. exact (g ∘ f).
  - abstract (intros b; simpl; apply funextsec; intro g; apply id_left) using _L_.
  - abstract (intros i j k f g; simpl; apply funextsec; intro h;
              rewrite <- assoc; reflexivity) using _L_.
Defined.

Lemma Hom1_Representation {C:category} (c:C) : Representation (Hom1 c).
Proof.
  exists c. exists (identity c). intro b. apply (isweqhomot (idweq _)).
  - abstract (intro f; unfold arrow_morphism_composition; unfold Hom1; simpl;
              apply pathsinv0, id_right) using _R_.
  - abstract (apply weqproperty) using _T_.
Defined.

(** maps from Hom1 to functors *)

Lemma compose_SET {X Y Z:HSET} (f:X-->Y) (g:Y-->Z) : g∘f = λ x, g(f x).
Proof.
  reflexivity.
Defined.

Definition element_to_nattrans {C:category} (X:[C^op,HSET]) (c:C) :
  c ⇒ X -> Hom1 c --> X.
Proof.
  intros x. unshelve refine (makeNattrans_op _ _).
  - unfold Hom1; simpl; intros b f. exact (x ⟲ f).
  - abstract (intros a b f; apply funextsec; intro g; apply arrow_mor_mor_assoc) using _L_.
Defined.

(** representable functors are isomorphic to one represented by an object  *)

Theorem Representation_to_z_iso {C:category} (X:[C^op,HSET]) (r:Representation X) :
  z_iso (Hom1 (universalObject r)) X.
Proof.
  refine (z_iso_from_nat_z_iso _ ((element_to_nattrans X (universalObject r) (universalElement r)),,_)).
  intro b. apply (pr2 (weq_iff_z_iso_SET _)). exact (pr2 (pr2 r) b).
Defined.

(** initial and final objects and zero maps  *)

Definition UnitFunctor (C:category) : [C,SET].
  unshelve refine (_,,_).
  { exists (λ c, unitset). exact (λ a b f t, t). }
  { split.
    { intros a. reflexivity. }
    { intros a b c f g. reflexivity. } }
Defined.

Definition TerminalObject (C:category) := Representation (UnitFunctor C^op).

Definition terminalObject {C} (t:TerminalObject C) : ob C := universalObject t.

Definition terminalArrow {C} (t:TerminalObject C) (c:ob C) :
  Hom C c (terminalObject t)
  := t \\ tt.

Definition InitialObject (C:category) := TerminalObject C^op.

Definition initialObject {C} (i:InitialObject C) : ob C := universalObject i.

Definition initialArrow {C} (i:InitialObject C) (c:ob C) :
  Hom C (initialObject i) c
  := rm_opp_mor (tt // i).

Definition init_to_opp {C:category} : InitialObject C -> TerminalObject C^op
  := λ i, i.

Definition term_to_opp {C:category} : TerminalObject C -> InitialObject C^op.
Proof.
  intros. unfold InitialObject. now induction (opp_opp_precat C).
Defined.

(** zero objects, as an alternative to ZeroObject.v *)

Definition ZeroObject (C:category)
  := ∑ z:ob C, Universal (UnitFunctor C^op) z × Universal (UnitFunctor C^op^op) z.

Definition zero_to_terminal (C:category) : ZeroObject C -> TerminalObject C
  := λ z, pr1 z ,, pr1 (pr2 z).

Definition zero_to_initial (C:category) : ZeroObject C -> InitialObject C
  := λ z, pr1 z ,, pr2 (pr2 z).

Definition zero_opp (C:category) : ZeroObject C -> ZeroObject C^op.
Proof.
  intro z. induction z as [z k]. exists z.
  induction (opp_opp_precat C).
  exact (pr2 k,,pr1 k).
Defined.

Definition hasZeroObject (C:category) := ∥ ZeroObject C ∥.

Definition haszero_opp (C:category) : hasZeroObject C -> hasZeroObject C^op
  := hinhfun (zero_opp C).

Definition zeroMap' (C:category) (a b:ob C) (o:ZeroObject C) : Hom C a b
  := (zero_to_initial C o \\ tt) ∘ (zero_to_terminal C o \\ tt).

Lemma zero_eq_zero_opp (C:category) (a b:ob C) (o:ZeroObject C) :
  zeroMap' C^op (opp_ob b) (opp_ob a) (zero_opp C o)
  =
  opp_mor (zeroMap' C a b o).
Proof.
  intros.
  try reflexivity.

Abort.

(** binary products and coproducts *)

Definition HomPair {C:category} (a b:C) : [C^op,SET].
Proof.
  unshelve refine (makeFunctor_op _ _ _ _).
  - intro c. exact (Hom C c a × Hom C c b) % set.
  - simpl. intros c d f x. exact (pr1 x ∘ f ,, pr2 x ∘ f).
  - abstract (simpl; intro c; apply funextsec; intro x;
              apply dirprodeq; apply id_left) using _B_.
  - abstract (simpl; intros c d e f g;
              apply funextsec; intro x;
              apply dirprodeq; apply pathsinv0, assoc) using _C_.
Defined.

Definition HomPair_1 {C:category} (a b c:C) :
  (((HomPair a b : C^op ⟶ SET) c : hSet) -> Hom C c a)
  := pr1.

Definition HomPair_2 {C:category} (a b c:C) :
  (((HomPair a b : C^op ⟶ SET) c : hSet) -> Hom C c b)
  := pr2.

Definition BinaryProduct {C:category} (a b:C) :=
  Representation (HomPair a b).

Definition BinaryProducts (C:category) := ∏ (a b:C), BinaryProduct a b.

Definition pr_1 {C:category} {a b:C} (prod : BinaryProduct a b) :
  universalObject prod --> a
  := pr1 (universalElement prod).

Definition pr_2 {C:category} {a b:C} (prod : BinaryProduct a b) :
  universalObject prod --> b
  := pr2 (universalElement prod).

Definition binaryProductMap {C:category} {a b:C} (prod : BinaryProduct a b)
           {c:C} : c --> a -> c --> b -> c --> universalObject prod
  := λ f g, prod \\ (f,,g).

Definition binaryProduct_pr_1_eqn {C:category} {a b:C} (prod : BinaryProduct a b)
      {c:C} (f : c --> a) (g : c --> b) :
  pr_1 prod ∘ binaryProductMap prod f g = f
  := maponpaths (HomPair_1 a b (opp_ob c)) (pr2 (pr1 (pr2 (pr2 prod) c (f,,g)))).

Definition binaryProduct_pr_2_eqn {C:category} {a b:C} (prod : BinaryProduct a b)
      {c:C} (f : c --> a) (g : c --> b) :
  pr_2 prod ∘ binaryProductMap prod f g = g
  := maponpaths (HomPair_2 a b (opp_ob c)) (pr2 (pr1 (pr2 (pr2 prod) c (f,,g)))).

Lemma binaryProductMapUniqueness {C:category} {a b:C} (prod : BinaryProduct a b)
      {c:C} (f g : Hom C c (universalObject prod)) :
  pr_1 prod ∘ f = pr_1 prod ∘ g ->
  pr_2 prod ∘ f = pr_2 prod ∘ g -> f = g.
Proof.
  intros r s. apply mapUniqueness. apply dirprodeq. exact r. exact s.
Defined.

Definition binaryProductMap_2 {C:category} {a b a' b':C}
           (prod : BinaryProduct a b)
           (prod' : BinaryProduct a' b')
           (f : a --> a')
           (g : b --> b')
           : rm_opp_ob (universalObject prod) --> rm_opp_ob (universalObject prod').
Proof.
  unshelve refine (binaryProductMap _ _ _).
  { exact (f ∘ pr_1 prod). }
  { exact (g ∘ pr_2 prod). }
Defined.

Definition BinarySum {C:category} (a b:C) :=
  BinaryProduct (opp_ob a) (opp_ob b).

Definition BinarySums (C:category) := ∏ (a b:C), BinarySum a b.

Lemma binarySumsToProducts {C:category} :
  BinarySums C -> BinaryProducts C^op.
Proof.
  intros sum. exact sum.
Defined.

Lemma binaryProductToSums {C:category} :
  BinaryProducts C -> BinarySums C^op.
Proof.
  intro prod. exact prod.
Defined.

Definition in_1 {C:category} {a b:C} (sum : BinarySum a b) :
  Hom C a (universalObject sum)
  := pr_1 sum.

Definition in_2 {C:category} {a b:C} (sum : BinarySum a b) :
  Hom C b (universalObject sum)
  := pr_2 sum.

Definition binarySumProperty {C:category} {a b c:C} (f:a-->c) (g:b-->c) :=
  isUniversal ((f ,, g) : HomPair (opp_ob a) (opp_ob b) ◾ c : hSet).

Definition binarySumMap {C:category} {a b:C} (sum : BinarySum a b)
           {c:C} : a --> c -> b --> c -> rm_opp_ob (universalObject sum) --> c
  := λ f g, rm_opp_mor (sum \\ (opp_mor f,,opp_mor g)).

Definition binarySum_in_1_eqn {C:category} {a b:C} (sum : BinarySum a b)
      {c:C} (f : a --> c) (g : b --> c) :
  binarySumMap sum f g ∘ in_1 sum = f
  := maponpaths (HomPair_1 (opp_ob a) (opp_ob b) c) ((pr2 (pr1 (pr2 (pr2 sum) c (f,,g))))).

Definition binarySum_in_2_eqn {C:category} {a b:C} (sum : BinarySum a b)
      {c:C} (f : a --> c) (g : b --> c) :
  binarySumMap sum f g ∘ in_2 sum = g
  := maponpaths (HomPair_2 (opp_ob a) (opp_ob b) c) ((pr2 (pr1 (pr2 (pr2 sum) c (f,,g))))).

Lemma binarySumMapUniqueness {C:category} {a b:C} (sum : BinarySum a b)
      {c:C} (f g : Hom C (rm_opp_ob (universalObject sum)) c) :
  f ∘ in_1 sum = g ∘ in_1 sum ->
  f ∘ in_2 sum = g ∘ in_2 sum -> f = g.
Proof.
  intros r s. apply opp_mor_eq, mapUniqueness, dirprodeq; assumption.
Defined.

Definition binarySumMap_2 {C:category} {a b a' b':C}
           (sum : BinarySum a b)
           (sum' : BinarySum a' b')
           (f : a --> a')
           (g : b --> b')
           : rm_opp_ob (universalObject sum) --> rm_opp_ob (universalObject sum').
Proof.
  unshelve refine (binarySumMap _ _ _).
  { exact (in_1 sum' ∘ f). }
  { exact (in_2 sum' ∘ g). }
Defined.

(** products and coproducts *)

Definition HomFamily (C:category) {I} (c:I -> ob C) : C^op ⟶ SET.
Proof.
  unshelve refine (_,,_).
  - unshelve refine (_,,_).
    + intros x. exact (∏ i, Hom C x (c i)) % set.
    + intros x y f p i; simpl; simpl in p.
      exact (compose (C:=C) f (p i)).
  - abstract (split;
    [ intros a; apply funextsec; intros f; apply funextsec; intros i; simpl;
      apply id_left
    | intros x y z p q;
      apply funextsec; intros f; apply funextsec; intros i; simpl;
      apply pathsinv0, assoc]) using _L_.
Defined.

Definition Product {C:category} {I} (c:I -> ob C)
  := Representation (HomFamily C c).

Definition pr_ {C:category} {I} {c:I -> ob C} (prod : Product c) (i:I) :
  universalObject prod --> c i
  := universalElement prod i.

Definition productMapExistence {C:category} {I} {c:I -> ob C} (prod : Product c)
      {a:C} :
  (∏ i, Hom C a (c i)) -> Hom C a (universalObject prod)
  := λ f, prod \\ f.

Lemma productMapUniqueness {C:category} {I} {c:I -> ob C} (prod : Product c)
      {a:C} (f g : Hom C a (universalObject prod)) :
  (∏ i, pr_ prod i ∘ f = pr_ prod i ∘ g) -> f = g.
Proof.
  intro e. apply mapUniqueness. apply funextsec; intro i. apply e.
Defined.

Definition Sum {C:category} {I} (c:I -> ob C)
  := Representation (HomFamily C^op c).

Definition in_ {C:category} {I} {c:I -> ob C} (sum : Sum c) (i:I) :
  c i --> universalObject sum
  := rm_opp_mor (universalElement sum i).

Definition sumMapExistence {C:category} {I} {c:I -> ob C} (sum : Sum c)
      {a:C} :
  (∏ i, Hom C (c i) a) -> Hom C (universalObject sum) a
  := λ f, f // sum.

Lemma sumMapUniqueness {C:category} {I} {c:I -> ob C} (sum : Sum c)
      {a:C} (f g : Hom C (universalObject sum) a) :
  (∏ i, f ∘ in_ sum i = g ∘ in_ sum i) -> f = g.
Proof.
  intro e. apply opp_mor_eq, mapUniqueness. apply funextsec; intro i. apply e.
Defined.

(** equalizers and coequalizers *)

Definition Equalization {C:category} {c d:C} (f g:c-->d) :
  C^op ⟶ SET.
Proof.
  unshelve refine (makeFunctor_op _ _ _ _).
  - intro b. unshelve refine (_,,_).
    + exact (∑ p:b --> c, f∘p = g∘p).
    + abstract (apply isaset_total2;
      [ apply homset_property
      | intro; apply isasetaprop; apply homset_property]) using _L_.
  - intros b a e w; simpl in *. exists (pr1 w ∘ e).
    abstract (rewrite <- 2? assoc; apply maponpaths; exact (pr2 w)) using _M_.
  - abstract (
        intros b; apply funextsec; intro w; apply subtypePath;
        [ intro; apply homset_property
        | simpl; apply id_left]) using _N_.
  - abstract (
        intros a'' a' a r s; apply funextsec;
        intro w; apply subtypePath;
        [ intro; apply homset_property
        | apply pathsinv0, assoc ]) using _O_.
Defined.

Definition Equalizer {C:category} {c d:C} (f g:c-->d) :=
  Representation (Equalization f g).

Definition equalizerMap {C:category} {c d:C} {f g:c-->d} (eq : Equalizer f g) :
  universalObject eq --> c
  := pr1 (universalElement eq).

Definition equalizerEquation {C:category} {c d:C} {f g:c-->d} (eq : Equalizer f g) :
  f ∘ equalizerMap eq = g ∘ equalizerMap eq
  := pr2 (universalElement eq).

Definition Coequalizer {C:category} {c d:C} (f g:c-->d) :=
  Representation (Equalization (opp_mor f) (opp_mor g)).

Definition coequalizerMap {C:category} {c d:C} {f g:c-->d} (coeq : Coequalizer f g) :
  d --> universalObject coeq
  := pr1 (universalElement coeq).

Definition coequalizerEquation {C:category} {c d:C} {f g:c-->d} (coeq : Coequalizer f g) :
  coequalizerMap coeq ∘ f = coequalizerMap coeq ∘ g
  := pr2 (universalElement coeq).

(** pullbacks and pushouts  *)

Definition PullbackCone {C:category} {a b c:C} (f:a-->c) (g:b-->c) :
  C^op ⟶ SET.
Proof.
  intros.
  unshelve refine (makeFunctor_op _ _ _ _).
  - intros t. unshelve refine (_,,_).
    + exact (∑ (p: t --> a × t --> b), f ∘ pr1 p = g ∘ pr2 p).
    + abstract (apply isaset_total2;
      [ apply isasetdirprod; apply homset_property
      | intro; apply isasetaprop; apply homset_property]) using _L_.
  - intros t u p w; simpl in *.
    exists (pr1 (pr1 w) ∘ p,, pr2 (pr1 w) ∘ p).
    abstract (
        simpl; rewrite <- 2? assoc; apply maponpaths; exact (pr2 w)) using _M_.
  - abstract (intros t; simpl; apply funextsec; intro w;
              induction w as [w eq]; induction w as [p q];
              simpl in *; unshelve refine (two_arg_paths_f _ _);
              [ rewrite 2? id_left; reflexivity
              | apply proofirrelevance; apply homset_property]) using _N_.
  - abstract (
        intros r s t p q; simpl in *; apply funextsec; intro w;
        unshelve refine (total2_paths2_f _ _);
        [ simpl; rewrite 2? assoc; reflexivity
        | apply proofirrelevance; apply homset_property]) using _P_.
Defined.

Definition Pullback {C:category} {a b c:C} (f:a-->c) (g:b-->c) :=
  Representation (PullbackCone f g).

Definition pb_1 {C:category} {a b c:C} {f:a-->c} {g:b-->c} (pb : Pullback f g) :
  universalObject pb --> a
  := pr1 (pr1 (universalElement pb)).

Definition pb_2 {C:category} {a b c:C} {f:a-->c} {g:b-->c} (pb : Pullback f g) :
  universalObject pb --> b
  := pr2 (pr1 (universalElement pb)).

Definition pb_eqn {C:category} {a b c:C} {f:a-->c} {g:b-->c} (pb : Pullback f g) :
  f ∘ pb_1 pb = g ∘ pb_2 pb
  := pr2 (universalElement pb).

Definition Pushout {C:category} {a b c:C} (f:a-->b) (g:a-->c) :=
  Representation (PullbackCone (opp_mor f) (opp_mor g)).

Definition po_1 {C:category} {a b c:C} {f:a-->b} {g:a-->c} (po : Pushout f g) :
  b --> universalObject po
  := pr1 (pr1 (universalElement po)).

Definition po_2 {C:category} {a b c:C} {f:a-->b} {g:a-->c} (po : Pushout f g) :
  c --> universalObject po
  := pr2 (pr1 (universalElement po)).

Definition po_eqn {C:category} {a b c:C} {f:a-->c} {g:a-->c} (po : Pushout f g) :
  po_1 po ∘ f = po_2 po ∘ g
  := pr2 (universalElement po).

(** kernels and cokernels *)

Definition Annihilator (C:category) (zero:ZeroMaps C) {c d:C} (f:c --> d) :
  C^op ⟶ SET.
Proof.
  unshelve refine (_,,_).
  { unshelve refine (_,,_).
    { intro b. exists (∑ g:Hom C b c, f ∘ g = pr1 zero b d).
      abstract (apply isaset_total2; [ apply setproperty |
      intro g; apply isasetaprop; apply homset_property ]) using _L_. }
    { intros a b p ge; simpl.
      exists (pr1 ge ∘ opp_mor p).
      { abstract (
            unshelve refine (! assoc _ _ _ @ _); rewrite (pr2 ge);
            apply (pr2 (pr2 zero) _ _ _ _)) using _M_. } } }
  { abstract (split;
    [ intros x; apply funextsec; intros [r rf0];
      apply subtypePath;
      [ intro; apply homset_property
      | simpl; unfold opp_mor; apply id_left ]
    | intros w x y t u; apply funextsec; intros [r rf0];
      apply subtypePath;
      [ intro; apply homset_property
      | simpl; unfold opp_mor; apply pathsinv0, assoc ] ]) using _N_. }
Defined.

Definition Kernel {C:category} (zero:ZeroMaps C) {c d:ob C} (f:c --> d) :=
  Representation (Annihilator C zero f).

Definition Cokernel {C:category} (zero:ZeroMaps C) {c d:ob C} (f:c --> d) :=
  Representation (Annihilator C^op (ZeroMaps_opp C zero) f).

Definition kernelMap {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d}
           (r : Kernel zero f) : universalObject r --> c
  := pr1 (universalElement r).

Definition kernelEquation {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d}
           (ker : Kernel zero f) :
  f ∘ kernelMap ker = pr1 zero _ _
  := pr2 (universalElement ker).

Definition cokernelMap {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d}
           (r : Cokernel zero f) : d --> universalObject r
  := pr1 (universalElement r).

Definition cokernelEquation {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d}
           (coker : Cokernel zero f) :
  cokernelMap coker ∘ f = pr1 zero _ _
  := pr2 (universalElement coker).

(** fibers of maps between functors *)

Definition fiber {C:category} {X Y:[C^op,SET]} (p : X --> Y) {c:C} (y : c ⇒ Y) :
  C^op ⟶ SET.
Proof.
  unshelve refine (makeFunctor_op _ _ _ _).
  - intro b.
    exists (∑ fx : (b --> c) × (b ⇒ X), p ⟳ pr2 fx = y ⟲ pr1 fx).
    abstract (apply isaset_total2;
        [ apply isaset_dirprod, setproperty; apply homset_property
        | intros [f x]; apply isasetaprop; apply setproperty ]) using _K_.
  - simpl; intros b b' g fxe.
    exists (pr1 (pr1 fxe) ∘ g,, pr2 (pr1 fxe) ⟲ g).
    abstract (simpl; rewrite nattrans_arrow_mor_assoc, arrow_mor_mor_assoc;
              apply maponpaths; exact (pr2 fxe)) using _M_.
  - abstract (intro b; apply funextsec; intro w;
              induction w as [w e]; induction w as [f x]; simpl;
              unshelve refine (two_arg_paths_f _ _);
              [ apply dirprodeq; [ apply id_left | apply arrow_mor_id ]
              | apply setproperty]) using _R_.
  - abstract (intros b b' b'' g g''; apply funextsec; intro w;
              induction w as [w e]; induction w as [f x]; simpl;
              unshelve refine (total2_paths2_f _ _);
              [ apply dirprodeq;
                [ apply pathsinv0, assoc | apply arrow_mor_mor_assoc ]
              | apply setproperty ]) using _T_.
Defined.

(* this is representability of a map between two functors, in the sense of
   Grothendieck.  See EGA Chapter 0. *)

Definition Representation_Map {C:category} {X Y:[C^op,SET]} (p : X --> Y) :=
  ∏ (c : C) (y : c ⇒ Y), Representation (fiber p y).

Definition isRepresentable_Map {C:category} {X Y:[C^op,SET]} (p : X --> Y) :=
  ∏ (c : C) (y : c ⇒ Y), isRepresentable (fiber p y).

(** limits and colimits  *)

Definition cone {I C:category} (c:C) (D: [I,C]) : UU
  := ∑ (φ : ∏ i, Hom C c (D ◾ i)),
     ∏ i j (e : i --> j), D ▭ e ∘ φ i = φ j.

Lemma cone_eq {C I:category} (c:C^op) (D: I⟶C) (p q:cone (C:=C) c D) :
  pr1 p ~ pr1 q -> p = q.
Proof.
  intros h. apply subtypePath.
  { intro r.
    apply impred_isaprop; intro i;
    apply impred_isaprop; intro j;
    apply impred_isaprop; intro e.
    apply homset_property. }
  apply funextsec; intro i; apply h.
Qed.

Definition cone_functor {I C:category} : [I,C] ⟶ [C^op,SET].
Proof.
  intros.
  unshelve refine (_,,_).
  { unshelve refine (_,,_).
    { intros D. unshelve refine (_,,_).
      { unshelve refine (_,,_).
        - intro c. exists (cone (C:=C) c D).
          abstract (
              apply isaset_total2;
              [ apply impred_isaset; intro i; apply homset_property
              | intros φ;
                apply impred_isaset; intro i;
                apply impred_isaset; intro j;
                apply impred_isaset; intro e; apply isasetaprop;
                apply homset_property]) using LLL.
        - simpl; intros a b f φ.
          exists (λ i, pr1 φ i ∘ f).
          abstract (
              intros i j e; simpl;
              rewrite <- assoc;
              apply maponpaths;
              apply (pr2 φ)) using _M_. }
      { abstract (split;
        [ intro c; simpl;
          apply funextsec; intro p;
          apply cone_eq;
          intro i; simpl;
          apply id_left
        | intros a b c f g; simpl; apply funextsec; intro p;
          apply cone_eq; simpl; intro i; apply pathsinv0, assoc ]) using _N_. } }
    { intros D D' f; simpl.
      unshelve refine (_,,_).
      - simpl. unfold cone. intros c φ.
        unshelve refine (_,,_).
        + intros i. exact (pr1 f i ∘ pr1 φ i).
        + abstract (
              simpl; intros i j e; assert (L := pr2 φ i j e); simpl in L;
              rewrite <- L; rewrite <- assoc; rewrite <- assoc;
              apply maponpaths; apply pathsinv0; apply nat_trans_ax) using _P_.
      - abstract (intros a b g; simpl;
                  apply funextsec; intro p; apply cone_eq; intro i; simpl;
                  apply pathsinv0, assoc) using _Q_. } }
  { abstract (split;
    [ intros D; simpl;
      apply nat_trans_eq;
      [ exact (homset_property SET)
      | intros c; apply funextsec; intro φ; simpl;
      apply cone_eq; intro i; apply id_right]
    | intros D D' D'' p q; apply nat_trans_eq;
      [ apply homset_property
      | intro c; apply funextsec; intro K; apply cone_eq; intros i; apply assoc ]]). }
Defined.

Definition cocone_functor {I C:category} : [I,C]^op ⟶ [C^op^op,SET] :=
  cone_functor □ functorOp.

Definition Limit {C I:category} (D: I⟶C) := Representation (cone_functor D).

Definition Colimit {C I:category} (D: I⟶C) := Representation (cocone_functor D).

Definition proj_ {C I:category} {D: I⟶C} (lim:Limit D) (i:I) : universalObject lim --> D i.
Proof.
  intros. exact ((pr1 (universalElement lim) i)).
Defined.

Definition inj_ {C I:category} {D: I⟶C} (colim:Colimit D) (i:I) : D i --> universalObject colim.
Proof.
  intros. exact ((pr1 (universalElement colim) i)).
Defined.

Definition proj_comm {C I:category} {D: I⟶C} (lim:Limit D) {i j:I} (f:i-->j) :
  # D f ∘ proj_ lim i = proj_ lim j.
Proof.
  intros. exact (pr2 (universalElement lim) _ _ f).
Defined.

Definition inj_comm {C I:category} {D: I⟶C} (colim:Colimit D) {i j:I} (f:i-->j) :
  inj_ colim j ∘ # D f = inj_ colim i.
Proof.
  intros. exact (pr2 (universalElement colim) _ _ f).
Defined.

Definition Limits (C:category) := ∏ (I:category) (D: I⟶C), Limit D.

Definition Colimits (C:category) := ∏ (I:category) (D: I⟶C), Colimit D.

Definition lim_functor (C:category) (lim:Limits C) (I:category) :
  [I,C] ⟶ C
  := universalObjectFunctor C □ addStructure cone_functor (lim I).

Definition colim_functor (C:category) (colim:Colimits C) (I:category) :
  [I,C] ⟶ C
  := functorRmOp (
         universalObjectFunctor C^op □ addStructure cocone_functor (colim I)).

Lemma bifunctor_assoc_repn {B C:category} (X : [B, [C^op,SET]]) :
  (∏ b, Representation (X ◾ b)) -> Representation (bifunctor_assoc X).
Proof.
  intro r. set (X' := addStructure X r).
  change (categoryWithStructure [C ^op, SET] Representation) with (RepresentedFunctor C) in X'.
  set (F := universalObjectFunctor C □ X').
  exists F. unshelve refine (_,,_).
  { unshelve refine (_,,_).
    { intro b. exact (universalElement (r b)). }
    { abstract (intros b b' f; exact (!universalObjectFunctor_comm C (X' ▭ f))) using _K_. } }
  { intro F'. apply UniqueConstruction_to_weq.
    split.
    { intro x'. unfold arrow in x'.
      unshelve refine (_,,_).
      { unshelve refine (makeNattrans _ _).
        { intro b. exact (r b \\ pr1 x' b). }
        { abstract (intros b b' f; simpl;
                    unshelve refine (univ_arrow_mor_assoc (F' ▭ f) (pr1 x' b') (r b') @ _);
                    intermediate_path (r b' \\ (X ▭ f ⟳ pr1 x' b));
                    [ apply maponpaths, (pr2 x' b b' f)
                    | unfold F;
                      rewrite comp_func_on_mor;
                      rewrite (universalObjectFunctor_on_map C (X' ▭ f));
                      change (pr2 (X' ◾ b')) with (r b');
                      change (pr2 (X' ◾ b)) with (r b);
                      change (X' ▭ f) with (X ▭ f);
                      unshelve refine (_ @ !univ_arrow_mor_assoc _ _ _);
                      apply maponpaths;
                      rewrite <- nattrans_arrow_mor_assoc;
                      apply (maponpaths (λ k, X ▭ f ⟳ k));
                      apply pathsinv0;
                      exact (universalMapProperty (r b) (pr1 x' b)) ]) using _R_. } }
      { abstract (unshelve refine (total2_paths_f _ _);
        [ simpl; apply funextsec; intro b; unshelve refine (universalMapProperty _ _)
        | apply funextsec; intro b;
          apply funextsec; intro b';
          apply funextsec; intro f; simpl; apply setproperty ] ) using _L_. } }
    { abstract (intros p q e; apply nat_trans_eq;
                [ apply homset_property
                | intros b; apply (mapUniqueness _ (r b) _ (p ◽ b) (q ◽ b));
                  exact (maponpaths (λ k, pr1 k b) e)]) using _M_. } }
Defined.

Theorem functorcategoryTerminalObject (B C:category) :
  TerminalObject C -> TerminalObject [B,C].
Proof.
  intro t.
  apply (@z_iso_Representation_weq _ (bifunctor_assoc (constantFunctor B (UnitFunctor C^op)))).
  { unshelve refine (makeNatiso _ _).
    { intros F. apply hset_equiv_z_iso.
      unfold bifunctor_assoc; simpl.
      unshelve refine (weq_iso _ _ _ _).
      - intros _. exact tt.
      - intros x. unshelve refine (_,,_).
        + unfold θ_1; simpl. intro b. exact tt.
        + eqn_logic.
      - simpl. intros w. apply subtypePath.
        { intros f. apply impred; intro b; apply impred; intro b'; apply impred; intro g. apply isasetunit. }
        apply funextfun; intro b. apply isapropunit.
      - eqn_logic. }
    { eqn_logic. } }
  { apply bifunctor_assoc_repn; intro b. exact t. }
Defined.

Goal ∏ B C t b,
       universalObject(functorcategoryTerminalObject B C t) ◾ b = universalObject t.
  reflexivity.
Defined.

Definition binaryProductFunctor {B C:category} (F G:[B,C]) : [B,[C^op,SET]].
Proof.
  unshelve refine (makeFunctor _ _ _ _).
  - intro b. exact (HomPair (F ◾ b) (G ◾ b)).
  - intros b b' f.
    unshelve refine (makeNattrans_op _ _).
    + intros c w. exact (F ▭ f ∘ pr1 w ,, G ▭ f ∘ pr2 w).
    + abstract (intros c c' g; simpl; apply funextsec; intro v;
                apply dirprodeq; ( simpl; apply pathsinv0, assoc )) using _L_.
  - abstract (intro b; apply nat_trans_eq;
              [ apply homset_property
              | intro c; simpl;
                apply funextsec; intro v;
                apply dirprodeq;
                ( simpl; rewrite functor_on_id; rewrite id_right; reflexivity )]) using _L_.
  - abstract (intros b b' b'' f g; apply nat_trans_eq;
    [ apply homset_property
    | intro c; apply funextsec; intro w; apply dirprodeq ;
      ( simpl; rewrite functor_on_comp; rewrite assoc; reflexivity) ]) using _L_.
Defined.

Lemma BinaryProductFunctorAssoc {B C : category}
      (prod : BinaryProducts C)
      (F G : [B, C]) :
  z_iso (bifunctor_assoc (binaryProductFunctor F G)) (HomPair F G).
Proof.
  unshelve refine (makeNatiso (C := [B, C]^op) _ _).
  { intro H. apply hset_equiv_z_iso.
    unshelve refine (weq_iso _ _ _ _).
    { intros w.
      unshelve refine (_,,_).
      { unshelve refine (makeNattrans _ _).
        { intro b. exact (pr1 (pr1 w b)). }
        { abstract (intros b b' f; exact (maponpaths dirprod_pr1 (pr2 w b b' f))) using _L_. } }
      { unshelve refine (makeNattrans _ _).
        { intro b. exact (pr2 (pr1 w b)). }
        { abstract (intros b b' f; exact (maponpaths dirprod_pr2 (pr2 w b b' f))) using _L_. } } }
    { simpl. intros pq.
      unshelve refine (_,,_).
      { intros b. exact (pr1 pq b ,, pr2 pq b). }
      { abstract (intros b b' f; simpl;
                  apply dirprodeq; ( simpl; apply nattrans_naturality )) using _L_. } }
    { abstract (intros w;
                unshelve refine (total2_paths_f _ _);
                [ apply funextsec; intro b; apply pathsinv0; reflexivity
                | (apply funextsec; intro b;
                   apply funextsec; intro b';
                   apply funextsec; intro f;
                   apply isaset_dirprod; apply homset_property) ]) using _M_. }
    { abstract (intros pq; apply dirprodeq;
                ( apply nat_trans_eq;
                  [ apply homset_property | intro b; reflexivity ] )) using _L_. } }
  { abstract (intros H H' p;
              apply funextsec; intros v;
              apply dirprodeq;
              ( simpl; apply nat_trans_eq;
                [ apply homset_property
                | intros b; unfold makeNattrans; simpl; reflexivity ] )) using _L_. }
Defined.

Theorem functorBinaryProduct {B C:category} :
  BinaryProducts C -> BinaryProducts [B,C].
Proof.
  intros prod F G. unshelve refine (z_iso_Representation_weq _ _).
  { exact (bifunctor_assoc (binaryProductFunctor F G)). }
  { now apply BinaryProductFunctorAssoc. }
  { apply bifunctor_assoc_repn. intro b. apply prod. }
Defined.

Lemma functorBinaryProduct_eqn {B C:category} (prod : BinaryProducts C)
      (F G : [B,C]) (b:B) :
  universalObject (functorBinaryProduct prod F G) ◾ b
  =
  universalObject (prod (F ◾ b) (G ◾ b)).
Proof.
  reflexivity.
Defined.

Lemma functorBinaryProduct_map_eqn {B C:category} (prod : BinaryProducts C)
      (F G F' G' : [B,C]) (p:F-->F') (q:G-->G') (b:B) :
  binaryProductMap_2 (functorBinaryProduct prod F G) (functorBinaryProduct prod F' G') p q ◽ b
  =
  binaryProductMap_2 (prod (F ◾ b) (G ◾ b)) (prod (F' ◾ b) (G' ◾ b)) (p ◽ b) (q ◽ b).
Proof.
  reflexivity.
Defined.

Lemma HomPairOp {B C : category} (F G : [B, C]) :
  z_iso (HomPair (functorOp F) (functorOp G) □ functorOp')
      (HomPair (opp_ob F) (opp_ob G)).
(* This should be replaced by a general statement where [B,C]^op and
   [B^op,C^op] are replaced by arbitrary isomorphic categories.  And there
   should be lemmas saying that having binary sums or products is preserved by
   isomorphisms of categories. *)
Proof.
  unshelve refine (makeNatiso _ _).
  { intros H. apply hset_equiv_z_iso.
    apply weqdirprodf; exact (invweq (isomorphismOnMor functorOpIso H _)). }
  { abstract (intros H J p; apply funextsec; intro w;
              apply dirprodeq;
              ( apply nat_trans_eq; [ apply homset_property | reflexivity ] )). }
Defined.

Theorem functorBinarySum {B C:category} :
  BinarySums C -> BinarySums [B,C].
Proof.
  intros sum F G.
  exact (isomorphismRepresentability
           (functorBinaryProduct (binarySumsToProducts sum)
                                 (functorOp F) (functorOp G))
           functorOpIso
           (HomPairOp F G)).
Defined.

Lemma functorBinarySum_eqn {B C:category} (sum : BinarySums C)
      (F G : [B,C]) (b:B) :
  universalObject (functorBinarySum sum F G) ◾ b
  =
  universalObject (sum (F ◾ b) (G ◾ b)).
Proof.
  reflexivity.
Defined.

Lemma functorBinarySum_map_eqn {B C:category} (sum : BinarySums C)
      (F G F' G' : [B,C]) (p:F-->F') (q:G-->G') (b:B) :
  binarySumMap_2 (functorBinarySum sum F G) (functorBinarySum sum F' G') p q ◽ b
  =
  binarySumMap_2 (sum (F ◾ b) (G ◾ b)) (sum (F' ◾ b) (G' ◾ b)) (p ◽ b) (q ◽ b).
Proof.
  try reflexivity.
  (* This failure might be what prevents using this framework with
     SubstitutionSystems on the branch "colimits". Since
     [functorBinaryProduct_map_eqn] admits a trivial proof, that's an argument
     for replacing the proof of functorBinarySum by one that's parallel to the
     proof of functorBinaryProduct, rather than deducing it as a corollary.
     Maybe then we could also write [universalObject sum] instead of [rm_opp_ob
     (universalObject sum)] *)
Abort.

Theorem functorLimits (B C:category) : Limits C -> Limits [B,C].
Proof.
  intros lim I D.
  unfold Limits, Limit in lim.
  set (D' := bifunctor_comm _ _ _ D).
  assert (M := bifunctor_assoc_repn (cone_functor □ D') (λ b, lim I (D' ◾ b))); clear lim.
  exists (universalObject M).
  unfold Representation in M.

Abort.

Theorem functorColimits (B C:category) : Colimits C -> Colimits [B,C].
Proof.
Abort.

(* --- *)


Require Import Program.

Require Import Misc.
Require Level.

Inductive t : Set -> Set -> Type :=
  | Nil  : forall A, t A A
  | Cons : forall A B, Level.t A -> t (A * A) B -> t A B.

Arguments Nil [A].
Arguments Cons [A] [B] _ _.

Fixpoint all_yellows {A B : Set} (s : t A B) (is_last : bool): Prop :=
  match s with
  | Nil _ => True
  | Cons _ _ lvl (Nil _) => Level.color lvl is_last = Yellow
  | Cons _ _ lvl rest =>
    Level.color lvl false = Yellow /\ all_yellows rest is_last
  end.

Definition well_formed {A B : Set} (stack : t A B) is_last :=
  match stack with
  | Nil _ => False
  | Cons _ _ _top_level rest => all_yellows rest is_last
  end.

Definition is_empty {A B : Set} (stack : t A B) : Prop :=
  match stack with
  | Nil _ => True
  | Cons _ _ lvl (Nil _) => Level.is_empty lvl
  | _ => False
  end.

Definition dec_is_empty {A B} (s : t A B) : { is_empty s } + { ~ is_empty s }.
Proof.
  destruct s.
  + left ; simpl ; trivial.
  + dependent destruction s ; simpl.
    - apply Level.dec_is_empty.
    - right ; auto.
Defined.

Program Definition empty (A : Set) :
  { s : t A (A * A) | well_formed s false /\ is_empty s } :=
  Cons (Level.empty A) Nil.

Next Obligation.
Proof. compute ; tauto. Qed.

Definition color {A B} (s : t A B) b :=
  match s with
  | Nil _ => Red
  | Cons _ _ lvl (Nil _) => Level.color lvl b
  | Cons _ _ lvl _ => Level.color lvl false
  end.