(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Nth.
Require option.Option.
Require list.NthLength.
Require list.Append.
Require list.NthLengthAppend.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Definition pal {a:Type} {a_WT:WhyType a} (x:(list a)) (n:Z): Prop :=
  forall (i:Z), ((0%Z <= i)%Z /\ (i < n)%Z) -> ((list.Nth.nth i
  x) = (list.Nth.nth ((n - 1%Z)%Z - i)%Z x)).

(* Why3 goal *)
Theorem WP_parameter_palindrome_rec : forall {a:Type} {a_WT:WhyType a},
  forall (x:(list a)) (y:(list a)),
  ((list.Length.length y) <= (list.Length.length x))%Z -> forall (x1:a)
  (x2:(list a)), (y = (Init.Datatypes.cons x1 x2)) -> forall (x3:a)
  (x4:(list a)), (x2 = (Init.Datatypes.cons x3 x4)) -> forall (x5:a)
  (x6:(list a)), (x = (Init.Datatypes.cons x5 x6)) ->
  (((list.Length.length x4) <= (list.Length.length x6))%Z -> ((exists i:Z,
  ((0%Z <= i)%Z /\ (i < (list.Length.length x4))%Z) /\ ~ ((list.Nth.nth i
  x6) = (list.Nth.nth (((list.Length.length x4) - 1%Z)%Z - i)%Z x6))) ->
  exists i:Z, ((0%Z <= i)%Z /\ (i < (list.Length.length y))%Z) /\
  ~ ((list.Nth.nth i
  x) = (list.Nth.nth (((list.Length.length y) - 1%Z)%Z - i)%Z x)))).
intros a a_WT x y h1 x1 x2 h2 x3 x4 h3 x5 x6 h4 hl (i,(hi1,hi2)).
subst.
exists (i+1)%Z; intuition.
unfold Length.length. fold Length.length.
omega.
unfold Length.length in *. fold Length.length in *.
assert (Nth.nth (i+1) (x5 :: x6) = Nth.nth i x6).
  unfold Nth.nth; fold Nth.nth.
  generalize (Zeq_bool_eq (i+1) 0).
  destruct (Zeq_bool (i+1) 0).
  intuition.
  elimtype False.
  omega.
  intuition.
  replace (i+1-1)%Z with i by omega. auto.
replace (1 + (1 + Length.length x4) - 1 - (i + 1))%Z
         with (1 + Length.length x4 - 1 - i)%Z
  in H1 by omega.
assert (Nth.nth (1 + Length.length x4 - 1 - i) (x5 :: x6) =
        Nth.nth (Length.length x4 - 1 - i) x6).
    unfold Nth.nth; fold Nth.nth.
  generalize (Zeq_bool_eq (1 + Length.length x4 - 1 - i) 0).
    destruct (Zeq_bool (1 + Length.length x4 - 1 - i) 0).
  intuition; elimtype False; omega.
  intuition.
  replace (1 + Length.length x4 - 1 - i - 1)%Z with (Length.length x4 - 1 - i)%Z
  by omega; auto.
congruence.
Qed.


(* generated by Ott 0.10.17 ***locally nameless*** from: FzipCore.ott *)

Require Import Metatheory.

Inductive tag {A : Type} : Type :=
  | T : A -> tag
  | U : tag
  | E : tag
  | Eq : A -> tag.

Definition pure {A: Type} (G: list (atom * @tag A)) := forall a, ~ binds a E G.
Hint Unfold pure.

(** syntax *)
Definition termvar := var.
Definition typvar := var.

Inductive typ : Set :=
 | typ_var_b : nat -> typ
 | typ_var_f : typvar -> typ
 | typ_arrow : typ -> typ -> typ
 | typ_prod : typ -> typ -> typ
 | typ_forall : typ -> typ
 | typ_exists : typ -> typ.

Inductive term : Set :=
 | term_var_b : nat -> term
 | term_var_f : termvar -> term
 | term_abs : typ -> term -> term
 | term_app : term -> term -> term
 | term_let : term -> term -> term
 | term_pair : term -> term -> term
 | term_fst : term -> term
 | term_snd : term -> term
 | term_gen : term -> term
 | term_inst : term -> typ -> term
 | term_exists : term -> term
 | term_open : typ -> term -> term
 | term_nu : term -> term
 | term_sigma : typ -> typ -> term -> term
 | term_coerce : term -> typ -> term.

Definition typing_env : Set := list (atom * @tag typ).

Inductive red_tag : Set :=
 | NoEps : red_tag
 | Eps : red_tag.

(* EXPERIMENTAL *)

(** opening up abstractions *)
Fixpoint open_typ_wrt_typ_rec (k:nat) (t_5:typ) (t__6:typ) {struct t__6}: typ :=
  match t__6 with
  | (typ_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => typ_var_b nat
        | inleft (right _) => t_5
        | inright _ => typ_var_b (nat - 1)
      end
  | (typ_var_f a) => typ_var_f a
  | (typ_arrow t1 t2) => typ_arrow (open_typ_wrt_typ_rec k t_5 t1) (open_typ_wrt_typ_rec k t_5 t2)
  | (typ_prod t1 t2) => typ_prod (open_typ_wrt_typ_rec k t_5 t1) (open_typ_wrt_typ_rec k t_5 t2)
  | (typ_forall t) => typ_forall (open_typ_wrt_typ_rec (S k) t_5 t)
  | (typ_exists t) => typ_exists (open_typ_wrt_typ_rec (S k) t_5 t)
end.

Fixpoint open_term_wrt_term_rec (k:nat) (e_5:term) (e__6:term) {struct e__6}: term :=
  match e__6 with
  | (term_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => term_var_b nat
        | inleft (right _) => e_5
        | inright _ => term_var_b (nat - 1)
      end
  | (term_var_f x) => term_var_f x
  | (term_abs t e) => term_abs t (open_term_wrt_term_rec (S k) e_5 e)
  | (term_app e1 e2) => term_app (open_term_wrt_term_rec k e_5 e1) (open_term_wrt_term_rec k e_5 e2)
  | (term_let e1 e2) => term_let (open_term_wrt_term_rec k e_5 e1) (open_term_wrt_term_rec (S k) e_5 e2)
  | (term_pair e1 e2) => term_pair (open_term_wrt_term_rec k e_5 e1) (open_term_wrt_term_rec k e_5 e2)
  | (term_fst e) => term_fst (open_term_wrt_term_rec k e_5 e)
  | (term_snd e) => term_snd (open_term_wrt_term_rec k e_5 e)
  | (term_gen e) => term_gen (open_term_wrt_term_rec k e_5 e)
  | (term_inst e t) => term_inst (open_term_wrt_term_rec k e_5 e) t
  | (term_exists e) => term_exists (open_term_wrt_term_rec k e_5 e)
  | (term_open t e) => term_open t (open_term_wrt_term_rec k e_5 e)
  | (term_nu e) => term_nu (open_term_wrt_term_rec k e_5 e)
  | (term_sigma t1 t2 e) => term_sigma t1 t2 (open_term_wrt_term_rec k e_5 e)
  | (term_coerce e t) => term_coerce (open_term_wrt_term_rec k e_5 e) t
end.

Fixpoint open_term_wrt_typ_rec (k:nat) (t_5:typ) (e_5:term) {struct e_5}: term :=
  match e_5 with
  | (term_var_b nat) => term_var_b nat
  | (term_var_f x) => term_var_f x
  | (term_abs t e) => term_abs (open_typ_wrt_typ_rec k t_5 t) (open_term_wrt_typ_rec k t_5 e)
  | (term_app e1 e2) => term_app (open_term_wrt_typ_rec k t_5 e1) (open_term_wrt_typ_rec k t_5 e2)
  | (term_let e1 e2) => term_let (open_term_wrt_typ_rec k t_5 e1) (open_term_wrt_typ_rec k t_5 e2)
  | (term_pair e1 e2) => term_pair (open_term_wrt_typ_rec k t_5 e1) (open_term_wrt_typ_rec k t_5 e2)
  | (term_fst e) => term_fst (open_term_wrt_typ_rec k t_5 e)
  | (term_snd e) => term_snd (open_term_wrt_typ_rec k t_5 e)
  | (term_gen e) => term_gen (open_term_wrt_typ_rec (S k) t_5 e)
  | (term_inst e t) => term_inst (open_term_wrt_typ_rec k t_5 e) (open_typ_wrt_typ_rec k t_5 t)
  | (term_exists e) => term_exists (open_term_wrt_typ_rec (S k) t_5 e)
  | (term_open t e) => term_open (open_typ_wrt_typ_rec k t_5 t) (open_term_wrt_typ_rec k t_5 e)
  | (term_nu e) => term_nu (open_term_wrt_typ_rec (S k) t_5 e)
  | (term_sigma t1 t2 e) => term_sigma (open_typ_wrt_typ_rec k t_5 t1) (open_typ_wrt_typ_rec k t_5 t2) (open_term_wrt_typ_rec (S k) t_5 e)
  | (term_coerce e t) => term_coerce (open_term_wrt_typ_rec k t_5 e) (open_typ_wrt_typ_rec k t_5 t)
end.

Definition open_typ_wrt_typ t_5 t__6 := open_typ_wrt_typ_rec 0 t__6 t_5.

Definition open_term_wrt_term e_5 e__6 := open_term_wrt_term_rec 0 e__6 e_5.

Definition open_term_wrt_typ t_5 e_5 := open_term_wrt_typ_rec 0 e_5 t_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_typ *)
Inductive lc_typ : typ -> Prop :=    (* defn lc_typ *)
 | lc_typ_var_f : forall (a:typvar),
     (lc_typ (typ_var_f a))
 | lc_typ_arrow : forall (t1 t2:typ),
     (lc_typ t1) ->
     (lc_typ t2) ->
     (lc_typ (typ_arrow t1 t2))
 | lc_typ_prod : forall (t1 t2:typ),
     (lc_typ t1) ->
     (lc_typ t2) ->
     (lc_typ (typ_prod t1 t2))
 | lc_typ_forall : forall (t:typ),
      ( forall a , lc_typ  ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     (lc_typ (typ_forall t))
 | lc_typ_exists : forall (t:typ),
      ( forall a , lc_typ  ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     (lc_typ (typ_exists t)).

(* defns LC_term *)
Inductive lc_term : term -> Prop :=    (* defn lc_term *)
 | lc_term_var_f : forall (x:termvar),
     (lc_term (term_var_f x))
 | lc_term_abs : forall (t:typ) (e:term),
     (lc_typ t) ->
      ( forall x , lc_term  ( open_term_wrt_term e (term_var_f x) )  )  ->
     (lc_term (term_abs t e))
 | lc_term_app : forall (e1 e2:term),
     (lc_term e1) ->
     (lc_term e2) ->
     (lc_term (term_app e1 e2))
 | lc_term_let : forall (e1 e2:term),
     (lc_term e1) ->
      ( forall x , lc_term  ( open_term_wrt_term e2 (term_var_f x) )  )  ->
     (lc_term (term_let e1 e2))
 | lc_term_pair : forall (e1 e2:term),
     (lc_term e1) ->
     (lc_term e2) ->
     (lc_term (term_pair e1 e2))
 | lc_term_fst : forall (e:term),
     (lc_term e) ->
     (lc_term (term_fst e))
 | lc_term_snd : forall (e:term),
     (lc_term e) ->
     (lc_term (term_snd e))
 | lc_term_gen : forall (e:term),
      ( forall a , lc_term  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     (lc_term (term_gen e))
 | lc_term_inst : forall (e:term) (t:typ),
     (lc_term e) ->
     (lc_typ t) ->
     (lc_term (term_inst e t))
 | lc_term_exists : forall (e:term),
      ( forall a , lc_term  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     (lc_term (term_exists e))
 | lc_term_open : forall (t:typ) (e:term),
     (lc_typ t) ->
     (lc_term e) ->
     (lc_term (term_open t e))
 | lc_term_nu : forall (e:term),
      ( forall a , lc_term  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     (lc_term (term_nu e))
 | lc_term_sigma : forall (t1 t2:typ) (e:term),
     (lc_typ t1) ->
     (lc_typ t2) ->
      ( forall a , lc_term  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     (lc_term (term_sigma t1 t2 e))
 | lc_term_coerce : forall (e:term) (t:typ),
     (lc_term e) ->
     (lc_typ t) ->
     (lc_term (term_coerce e t)).

(** free variables *)
Fixpoint ftv_typ (t_5:typ) : vars :=
  match t_5 with
  | (typ_var_b nat) => {}
  | (typ_var_f a) => {{a}}
  | (typ_arrow t1 t2) => (ftv_typ t1) \u (ftv_typ t2)
  | (typ_prod t1 t2) => (ftv_typ t1) \u (ftv_typ t2)
  | (typ_forall t) => (ftv_typ t)
  | (typ_exists t) => (ftv_typ t)
end.

Fixpoint fv_term (e_5:term) : vars :=
  match e_5 with
  | (term_var_b nat) => {}
  | (term_var_f x) => {{x}}
  | (term_abs t e) => (fv_term e)
  | (term_app e1 e2) => (fv_term e1) \u (fv_term e2)
  | (term_let e1 e2) => (fv_term e1) \u (fv_term e2)
  | (term_pair e1 e2) => (fv_term e1) \u (fv_term e2)
  | (term_fst e) => (fv_term e)
  | (term_snd e) => (fv_term e)
  | (term_gen e) => (fv_term e)
  | (term_inst e t) => (fv_term e)
  | (term_exists e) => (fv_term e)
  | (term_open t e) => (fv_term e)
  | (term_nu e) => (fv_term e)
  | (term_sigma t1 t2 e) => (fv_term e)
  | (term_coerce e t) => (fv_term e)
end.

Fixpoint ftv_term (e_5:term) : vars :=
  match e_5 with
  | (term_var_b nat) => {}
  | (term_var_f x) => {}
  | (term_abs t e) => (ftv_typ t) \u (ftv_term e)
  | (term_app e1 e2) => (ftv_term e1) \u (ftv_term e2)
  | (term_let e1 e2) => (ftv_term e1) \u (ftv_term e2)
  | (term_pair e1 e2) => (ftv_term e1) \u (ftv_term e2)
  | (term_fst e) => (ftv_term e)
  | (term_snd e) => (ftv_term e)
  | (term_gen e) => (ftv_term e)
  | (term_inst e t) => (ftv_term e) \u (ftv_typ t)
  | (term_exists e) => (ftv_term e)
  | (term_open t e) => (ftv_typ t) \u (ftv_term e)
  | (term_nu e) => (ftv_term e)
  | (term_sigma t1 t2 e) => (ftv_typ t1) \u (ftv_typ t2) \u (ftv_term e)
  | (term_coerce e t) => (ftv_term e) \u (ftv_typ t)
end.

(** substitutions *)
Fixpoint tsubst_typ (t_5:typ) (a5:typvar) (t__6:typ) {struct t__6} : typ :=
  match t__6 with
  | (typ_var_b nat) => typ_var_b nat
  | (typ_var_f a) => (if eq_var a a5 then t_5 else (typ_var_f a))
  | (typ_arrow t1 t2) => typ_arrow (tsubst_typ t_5 a5 t1) (tsubst_typ t_5 a5 t2)
  | (typ_prod t1 t2) => typ_prod (tsubst_typ t_5 a5 t1) (tsubst_typ t_5 a5 t2)
  | (typ_forall t) => typ_forall (tsubst_typ t_5 a5 t)
  | (typ_exists t) => typ_exists (tsubst_typ t_5 a5 t)
end.

Fixpoint subst_term (e_5:term) (x5:termvar) (e__6:term) {struct e__6} : term :=
  match e__6 with
  | (term_var_b nat) => term_var_b nat
  | (term_var_f x) => (if eq_var x x5 then e_5 else (term_var_f x))
  | (term_abs t e) => term_abs t (subst_term e_5 x5 e)
  | (term_app e1 e2) => term_app (subst_term e_5 x5 e1) (subst_term e_5 x5 e2)
  | (term_let e1 e2) => term_let (subst_term e_5 x5 e1) (subst_term e_5 x5 e2)
  | (term_pair e1 e2) => term_pair (subst_term e_5 x5 e1) (subst_term e_5 x5 e2)
  | (term_fst e) => term_fst (subst_term e_5 x5 e)
  | (term_snd e) => term_snd (subst_term e_5 x5 e)
  | (term_gen e) => term_gen (subst_term e_5 x5 e)
  | (term_inst e t) => term_inst (subst_term e_5 x5 e) t
  | (term_exists e) => term_exists (subst_term e_5 x5 e)
  | (term_open t e) => term_open t (subst_term e_5 x5 e)
  | (term_nu e) => term_nu (subst_term e_5 x5 e)
  | (term_sigma t1 t2 e) => term_sigma t1 t2 (subst_term e_5 x5 e)
  | (term_coerce e t) => term_coerce (subst_term e_5 x5 e) t
end.

Fixpoint tsubst_term (t_5:typ) (a5:typvar) (e_5:term) {struct e_5} : term :=
  match e_5 with
  | (term_var_b nat) => term_var_b nat
  | (term_var_f x) => term_var_f x
  | (term_abs t e) => term_abs (tsubst_typ t_5 a5 t) (tsubst_term t_5 a5 e)
  | (term_app e1 e2) => term_app (tsubst_term t_5 a5 e1) (tsubst_term t_5 a5 e2)
  | (term_let e1 e2) => term_let (tsubst_term t_5 a5 e1) (tsubst_term t_5 a5 e2)
  | (term_pair e1 e2) => term_pair (tsubst_term t_5 a5 e1) (tsubst_term t_5 a5 e2)
  | (term_fst e) => term_fst (tsubst_term t_5 a5 e)
  | (term_snd e) => term_snd (tsubst_term t_5 a5 e)
  | (term_gen e) => term_gen (tsubst_term t_5 a5 e)
  | (term_inst e t) => term_inst (tsubst_term t_5 a5 e) (tsubst_typ t_5 a5 t)
  | (term_exists e) => term_exists (tsubst_term t_5 a5 e)
  | (term_open t e) => term_open (tsubst_typ t_5 a5 t) (tsubst_term t_5 a5 e)
  | (term_nu e) => term_nu (tsubst_term t_5 a5 e)
  | (term_sigma t1 t2 e) => term_sigma (tsubst_typ t_5 a5 t1) (tsubst_typ t_5 a5 t2) (tsubst_term t_5 a5 e)
  | (term_coerce e t) => term_coerce (tsubst_term t_5 a5 e) (tsubst_typ t_5 a5 t)
end.

(** definitions *)

(* defns Jval *)
Inductive val : term -> Prop :=    (* defn val *)
 | val_abs : forall (t:typ) (e:term),
     lc_typ t ->
     lc_term (term_abs t e) ->
     val (term_abs t e)
 | val_gen : forall (e:term),
     lc_term (term_gen e) ->
     val (term_gen e)
 | val_pair : forall (e1 e2:term),
     val e1 ->
     val e2 ->
     val (term_pair e1 e2)
 | val_coerce : forall (e:term) (t:typ),
     lc_typ t ->
     val e ->
      (forall e' t, ( e ) <> term_coerce e' t)  ->
     val (term_coerce e t)
 | val_exists : forall (L:vars) (t':typ) (e e':term),
     e = term_exists (term_sigma (typ_var_b 0) t' e') ->
     (forall b, b \notin L -> lc_typ (open_typ_wrt_typ t' (typ_var_f b))) ->
     (forall b a, b \notin L -> a \notin L \u {{ b }} ->
         forall e1 e2 t1,
           term_sigma (typ_var_f b) t1 e1 =
           open_term_wrt_typ (term_sigma (typ_var_b 0) t' e') (typ_var_f b) ->
           e2 = open_term_wrt_typ e1 (typ_var_f a) ->
           val e2) ->
     val e

with result : term -> Prop :=    (* defn result *)
 | result_val : forall (e:term),
     val e ->
     result e
 | result_sigma : forall (L:vars) (b:typvar) (t:typ) (e:term),
     lc_typ t ->
      ( forall a , a \notin  L  -> result  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     result (term_sigma (typ_var_f b) t e).

(* defns Jzip *)
Inductive zip : typing_env -> typing_env -> typing_env -> Prop :=    (* defn zip *)
 | zip_empty :
     zip  nil   nil   nil
 | zip_TT : forall (G1:typing_env) (x:termvar) (t:typ) (G2 G:typing_env),
     lc_typ t ->
      x  `notin` dom  G1  ->
      x  `notin` dom  G2  ->
     zip G1 G2 G ->
     zip  ( x ~(T  t ) ++  G1 )   ( x ~(T  t ) ++  G2 )   ( x ~(T  t ) ++  G )
 | zip_UU : forall (G1:typing_env) (a:typvar) (G2 G:typing_env),
      a  `notin` dom  G1  ->
      a  `notin` dom  G2  ->
     zip G1 G2 G ->
     zip  ( a ~U ++  G1 )   ( a ~U ++  G2 )   ( a ~U ++  G )
 | zip_EU : forall (G1:typing_env) (a:typvar) (G2 G:typing_env),
      a  `notin` dom  G1  ->
      a  `notin` dom  G2  ->
     zip G1 G2 G ->
     zip  ( a ~E ++  G1 )   ( a ~U ++  G2 )   ( a ~E ++  G )
 | zip_E : forall (G1 G2:typing_env) (a:typvar) (G:typing_env),
      a  `notin` dom  G1  ->
      a  `notin` dom  G2  ->
     zip G1 G2 G ->
     zip G1  ( a ~E ++  G2 )   ( a ~E ++  G )
 | zip_EqEq : forall (G1:typing_env) (a:typvar) (t:typ) (G2 G:typing_env),
     lc_typ t ->
      a  `notin` dom  G1  ->
      a  `notin` dom  G2  ->
     zip G1 G2 G ->
     zip  ( a ~(Eq  t ) ++  G1 )   ( a ~(Eq  t ) ++  G2 )   ( a ~(Eq  t ) ++  G ) .

(* defns Jwf_env_typ *)
Inductive wfenv : typing_env -> Prop :=    (* defn wfenv *)
 | wfenv_empty :
     wfenv  nil
 | wfenv_cons_T : forall (G:typing_env) (x:termvar) (t:typ),
      x  `notin` dom  G  ->
     wftyp G t ->
     wfenv  ( x ~(T  t ) ++  G )
 | wfenv_cons_U : forall (G:typing_env) (a:typvar),
      a  `notin` dom  G  ->
     wfenv G ->
     wfenv  ( a ~U ++  G )
 | wfenv_cons_E : forall (G:typing_env) (a:typvar),
      a  `notin` dom  G  ->
     wfenv G ->
     wfenv  ( a ~E ++  G )
 | wfenv_cons_Eq : forall (G:typing_env) (a:typvar) (t:typ),
      a  `notin` dom  G  ->
     wftyp G t ->
     wfenv  ( a ~(Eq  t ) ++  G )
with wftyp : typing_env -> typ -> Prop :=    (* defn wftyp *)
 | wftyp_var : forall (G:typing_env) (a:typvar),
      (binds ( a ) U ( G ) \/ binds ( a ) E ( G ) \/ exists t, binds ( a ) (Eq t) ( G ))  ->
     wfenv G ->
     wftyp G (typ_var_f a)
 | wftyp_arrow : forall (G:typing_env) (t1 t2:typ),
     wftyp G t1 ->
     wftyp G t2 ->
     wftyp G (typ_arrow t1 t2)
 | wftyp_pair : forall (G:typing_env) (t1 t2:typ),
     wftyp G t1 ->
     wftyp G t2 ->
     wftyp G (typ_prod t1 t2)
 | wftyp_forall : forall (L:vars) (G:typing_env) (t:typ),
      ( forall a , a \notin  L  -> wftyp  ( a ~U ++  G )   ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     wftyp G (typ_forall t)
 | wftyp_exists : forall (L:vars) (G:typing_env) (t:typ),
      ( forall a , a \notin  L  -> wftyp  ( a ~U ++  G )   ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     wftyp G (typ_exists t).

(* defns Jwftypeq *)
Inductive wftypeq : typing_env -> typ -> typ -> Prop :=    (* defn wftypeq *)
 | wftypeq_var : forall (G:typing_env) (a:typvar),
      (binds ( a ) U ( G ) \/ binds ( a ) E ( G ) \/ exists t, binds ( a ) (Eq t) ( G ))  ->
     wfenv G ->
     wftypeq G (typ_var_f a) (typ_var_f a)
 | wftypeq_eq : forall (G:typing_env) (a:typvar) (t:typ),
      binds ( a ) (Eq ( t )) ( G )  ->
     wfenv G ->
     wftypeq G (typ_var_f a) t
 | wftypeq_arrow : forall (G:typing_env) (t1 t2 t1' t2':typ),
     wftypeq G t1 t1' ->
     wftypeq G t2 t2' ->
     wftypeq G (typ_arrow t1 t2) (typ_arrow t1' t2')
 | wftypeq_prod : forall (G:typing_env) (t1 t2 t1' t2':typ),
     wftypeq G t1 t1' ->
     wftypeq G t2 t2' ->
     wftypeq G (typ_prod t1 t2) (typ_prod t1' t2')
 | wftypeq_forall : forall (L:vars) (G:typing_env) (t1 t2:typ),
      ( forall a , a \notin  L  -> wftypeq  ( a ~U ++  G )   ( open_typ_wrt_typ t1 (typ_var_f a) )   ( open_typ_wrt_typ t2 (typ_var_f a) )  )  ->
     wftypeq G (typ_forall t1) (typ_forall t2)
 | wftypeq_exists : forall (L:vars) (G:typing_env) (t1 t2:typ),
      ( forall a , a \notin  L  -> wftypeq  ( a ~U ++  G )   ( open_typ_wrt_typ t1 (typ_var_f a) )   ( open_typ_wrt_typ t2 (typ_var_f a) )  )  ->
     wftypeq G (typ_exists t1) (typ_exists t2)
 | wftypeq_sym : forall (G:typing_env) (t1 t2:typ),
     wftypeq G t2 t1 ->
     wftypeq G t1 t2
 | wftypeq_trans : forall (G:typing_env) (t1 t3 t2:typ),
     wftypeq G t1 t2 ->
     wftypeq G t2 t3 ->
     wftypeq G t1 t3.

(* defns Jwfterm *)
Inductive wfterm : typing_env -> term -> typ -> Prop :=    (* defn wfterm *)
 | wfterm_var : forall (G:typing_env) (x:termvar) (t:typ),
      (pure ( G ))  ->
     wfenv G ->
      binds ( x ) (T ( t )) ( G )  ->
     wfterm G (term_var_f x) t
 | wfterm_app : forall (G:typing_env) (e1 e2:term) (t1:typ) (G1 G2:typing_env) (t2:typ),
     zip G1 G2 G ->
     wfterm G1 e1 (typ_arrow t2 t1) ->
     wfterm G2 e2 t2 ->
     wfterm G (term_app e1 e2) t1
 | wfterm_abs : forall (L:vars) (G:typing_env) (t1:typ) (e:term) (t2:typ),
      (pure ( G ))  ->
      ( forall x , x \notin  L  -> wfterm  ( x ~(T  t1 ) ++  G )   ( open_term_wrt_term e (term_var_f x) )  t2 )  ->
     wfterm G (term_abs t1 e) (typ_arrow t1 t2)
 | wfterm_let : forall (L:vars) (G:typing_env) (e1 e2:term) (t2:typ) (G1 G2:typing_env) (t1:typ),
     zip G1 G2 G ->
     wfterm G1 e1 t1 ->
      ( forall x , x \notin  L  -> wfterm  ( x ~(T  t1 ) ++  G2 )   ( open_term_wrt_term e2 (term_var_f x) )  t2 )  ->
     wfterm G (term_let e1 e2) t2
 | wfterm_pair : forall (G:typing_env) (e1 e2:term) (t1 t2:typ) (G1 G2:typing_env),
     zip G1 G2 G ->
     wfterm G1 e1 t1 ->
     wfterm G2 e2 t2 ->
     wfterm G (term_pair e1 e2) (typ_prod t1 t2)
 | wfterm_fst : forall (G:typing_env) (e:term) (t1 t2:typ),
     wfterm G e (typ_prod t1 t2) ->
     wfterm G (term_fst e) t1
 | wfterm_snd : forall (G:typing_env) (e:term) (t2 t1:typ),
     wfterm G e (typ_prod t1 t2) ->
     wfterm G (term_snd e) t2
 | wfterm_inst : forall (G:typing_env) (e:term) (t t':typ),
     wftyp G t ->
     wfterm G e (typ_forall t') ->
     wfterm G (term_inst e t)  (open_typ_wrt_typ  t'   t )
 | wfterm_gen : forall (L:vars) (G:typing_env) (e:term) (t:typ),
      (pure ( G ))  ->
      ( forall a , a \notin  L  -> wfterm  ( a ~U ++  G )   ( open_term_wrt_typ e (typ_var_f a) )   ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     wfterm G (term_gen e) (typ_forall t)
 | wfterm_exists : forall (L:vars) (G:typing_env) (e:term) (t:typ),
      ( forall a , a \notin  L  -> wfterm  ( a ~E ++  G )   ( open_term_wrt_typ e (typ_var_f a) )   ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     wfterm G (term_exists e) (typ_exists t)
 | wfterm_open : forall (G1:typing_env) (b:typvar) (G2:typing_env) (e:term) (t:typ),
      b  `notin` dom   (  (( G2 ) ++ ( G1 ))  )   ->
     wfterm  (( G2 ) ++ ( G1 ))  e (typ_exists t) ->
     wfterm  (( G2 ) ++ (  (  ( b ~E ++  G1 )  )  ))  (term_open (typ_var_f b) e)  (open_typ_wrt_typ  t   (typ_var_f b) )
 | wfterm_nu : forall (L:vars) (G:typing_env) (e:term) (t:typ),
      ( forall a , a \notin  L  -> wfterm  ( a ~E ++  G )   ( open_term_wrt_typ e (typ_var_f a) )  t )  ->
     wfterm G (term_nu e) t
 | wfterm_sigma : forall (L:vars) (G1:typing_env) (b:typvar) (G2:typing_env) (t':typ) (e:term) (t:typ),
      b  `notin` dom   (  (( G2 ) ++ ( G1 ))  )   ->
      ( forall a , a \notin  L  -> wfterm  ( a ~(Eq  t' ) ++   (  (( G2 ) ++ ( G1 ))  )  )   ( open_term_wrt_typ e (typ_var_f a) )   (tsubst_typ (typ_var_f a) b  t) )  ->
     wfterm  (( G2 ) ++ (  (  ( b ~E ++  G1 )  )  ))  (term_sigma (typ_var_f b) t' e) t
 | wfterm_coerce : forall (G:typing_env) (e:term) (t t':typ),
     wftypeq G t' t ->
     wfterm G e t' ->
     wfterm G (term_coerce e t) t.

(* defns Jred0 *)
Inductive red0 : term -> red_tag -> term -> Prop :=    (* defn red0 *)
 | red0_beta_v_red : forall (t:typ) (e1 e2:term),
     lc_typ t ->
     lc_term (term_abs t e1) ->
     val e2 ->
     red0 (term_app  ( (term_abs t e1) )  e2) NoEps (term_let e2 e1)
 | red0_beta_v_let : forall (e1 e2:term),
     lc_term (term_let e1 e2) ->
     val e1 ->
     red0 (term_let e1 e2) NoEps  (open_term_wrt_term  e2   e1 )
 | red0_pi_fst : forall (e1 e2:term),
     val (term_pair e1 e2) ->
     red0 (term_fst (term_pair e1 e2)) NoEps e1
 | red0_pi_snd : forall (e1 e2:term),
     val (term_pair e1 e2) ->
     red0 (term_snd (term_pair e1 e2)) NoEps e2
 | red0_beta_t : forall (e:term) (t:typ),
     lc_term (term_gen e) ->
     lc_typ t ->
     red0 (term_inst  ( (term_gen e) )  t) NoEps  (open_term_wrt_typ   e    t )
 | red0_open_exists : forall (L:vars) (b:typvar) (e:term),
      ( forall a , a \notin  L  -> result  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     red0 (term_open (typ_var_f b) (term_exists e))  NoEps   (open_term_wrt_typ   e    (typ_var_f b) )
 | red0_nu_sigma : forall (L:vars) (t:typ) (e e':term),
   ( forall b , b \notin  L  ->  lc_typ (  ( open_typ_wrt_typ t (typ_var_f b) )  )  )  ->
   ( forall b , b \notin  L  ->  b  `notin` ftv_typ (  ( open_typ_wrt_typ t (typ_var_f b) )  )  )  ->
   ( forall b a, b \notin  L -> a \notin   L  \u {{ b }}  ->
     forall t1 e1 e2,
       open_term_wrt_typ (term_sigma (typ_var_b 0) t e) (typ_var_f b)
       = term_sigma (typ_var_f b) t1 e1 ->
       open_term_wrt_typ e1 (typ_var_f a) = e2 ->
       result e2 ) ->
   ( forall b a, b \notin L -> a \notin L \u {{ b }} ->
     forall e1 e2,
       open_term_wrt_typ (term_sigma (typ_var_b 0) t e) (typ_var_f b)
       = term_sigma (typ_var_f b) (open_typ_wrt_typ t (typ_var_f b)) e1 ->
       open_term_wrt_typ e1 (typ_var_f a) = e2 ->
       e' = tsubst_term (open_typ_wrt_typ t (typ_var_f b)) a (tsubst_term (typ_var_f a) b e2)) ->
   red0 (term_nu (term_sigma (typ_var_b 0) t e)) NoEps e'
 | red0_coerce_app : forall (t2':typ) (e1:term) (t2 t1:typ) (e2:term),
     lc_typ t2 ->
     lc_term (term_abs t2' e1) ->
     lc_typ t2' ->
     lc_typ t1 ->
     val e2 ->
     red0 (term_app (term_coerce (term_abs t2' e1) (typ_arrow t2 t1)) e2) NoEps (term_coerce (term_app  ( (term_abs t2' e1) )  (term_coerce e2 t2')) t1)
 | red0_coerce_fst : forall (e1 e2:term) (t1 t2:typ),
     lc_typ t2 ->
     lc_typ t1 ->
     val (term_pair e1 e2) ->
     red0 (term_fst (term_coerce (term_pair e1 e2) (typ_prod t1 t2))) NoEps (term_coerce (term_fst (term_pair e1 e2)) t1)
 | red0_coerce_snd : forall (e1 e2:term) (t1 t2:typ),
     lc_typ t1 ->
     lc_typ t2 ->
     val (term_pair e1 e2) ->
     red0 (term_snd (term_coerce (term_pair e1 e2) (typ_prod t1 t2))) NoEps (term_coerce (term_snd (term_pair e1 e2)) t2)
 | red0_coerce_inst : forall (e:term) (t1 t2:typ),
     lc_typ (typ_forall t1) ->
     lc_term (term_gen e) ->
     lc_typ t2 ->
     red0 (term_inst (term_coerce (term_gen e) (typ_forall t1)) t2) NoEps (term_coerce (term_inst  ( (term_gen e) )  t2)  (open_typ_wrt_typ  t1   t2 ) )
 | red0_coerce_open : forall (b:typvar) (e:term) (t:typ),
     lc_typ (typ_exists t) ->
     val (term_exists e) ->
     red0 (term_open (typ_var_f b) (term_coerce (term_exists e) (typ_exists t))) NoEps (term_coerce (term_open (typ_var_f b) (term_exists e))  (open_typ_wrt_typ  t   (typ_var_f b) ) )
 | red0_coerce_coerce : forall (e:term) (t1 t2:typ),
     lc_typ t2 ->
     val (term_coerce e t1) ->
     red0 (term_coerce (term_coerce e t1) t2) NoEps (term_coerce e t2)
 | red0_sigma_appL : forall (L:vars) (b:typvar) (t:typ) (e1 e2 e2':term),
     result (term_sigma (typ_var_f b) t e1) ->
     result e2 ->
     (forall a , a \notin  L -> open_term_wrt_typ e2' (typ_var_f a) = tsubst_term (typ_var_f a) b e2) ->
     red0 (term_app (term_sigma (typ_var_f b) t e1) e2) NoEps (term_sigma (typ_var_f b) t  (term_app e1  e2'))
 | red0_sigma_appR : forall (L:vars) (e1 e1':term) (b:typvar) (t:typ) (e2:term),
     val e1 ->
     result (term_sigma (typ_var_f b) t e2) ->
     (forall a , a \notin  L  -> open_term_wrt_typ e1' (typ_var_f a) = tsubst_term (typ_var_f a) b e1) ->
      red0 (term_app e1 (term_sigma (typ_var_f b) t e2)) NoEps (term_sigma (typ_var_f b) t (term_app e1' e2))
 | red0_sigma_letL : forall (L:vars) (b:typvar) (t:typ) (e1 e2 e2':term),
     lc_term (term_let  ( (term_sigma (typ_var_f b) t e1) )  e2) ->
     result (term_sigma (typ_var_f b) t e1) ->
     (forall a , a \notin  L ->
       open_term_wrt_typ e2' (typ_var_f a) = tsubst_term (typ_var_f a) b e2) ->
     red0 (term_let (term_sigma (typ_var_f b) t e1) e2) NoEps (term_sigma (typ_var_f b) t  (term_let e1  e2'))
 | red0_sigma_pairL : forall (L:vars) (b:typvar) (t:typ) (e1 e2 e2':term),
     result (term_sigma (typ_var_f b) t e1) ->
     result e2 ->
     (forall a , a \notin  L -> open_term_wrt_typ e2' (typ_var_f a) = tsubst_term (typ_var_f a) b e2) ->
     red0 (term_pair (term_sigma (typ_var_f b) t e1) e2) NoEps (term_sigma (typ_var_f b) t  (term_pair e1  e2'))
 | red0_sigma_pairR : forall (L:vars) (e1 e1':term) (b:typvar) (t:typ) (e2:term),
     val e1 ->
     result (term_sigma (typ_var_f b) t e2) ->
     (forall a , a \notin  L  -> open_term_wrt_typ e1' (typ_var_f a) = tsubst_term (typ_var_f a) b e1) ->
      red0 (term_pair e1 (term_sigma (typ_var_f b) t e2)) NoEps (term_sigma (typ_var_f b) t (term_pair e1' e2))
 | red0_sigma_fst : forall (b:typvar) (t:typ) (e:term),
     result (term_sigma (typ_var_f b) t e) ->
     red0 (term_fst (term_sigma (typ_var_f b) t e)) NoEps (term_sigma (typ_var_f b) t (term_fst e))
 | red0_sigma_snd : forall (b:typvar) (t:typ) (e:term),
     result (term_sigma (typ_var_f b) t e) ->
     red0 (term_snd (term_sigma (typ_var_f b) t e)) NoEps (term_sigma (typ_var_f b) t (term_snd e))
 | red0_sigma_inst : forall (L:vars) (b:typvar) (t:typ) (e:term) (t' t'':typ),
     lc_typ t' ->
     result (term_sigma (typ_var_f b) t e) ->
     (forall a , a \notin  L  -> open_typ_wrt_typ t'' (typ_var_f a) = tsubst_typ (typ_var_f a) b t') ->
     red0 (term_inst (term_sigma (typ_var_f b) t e) t') NoEps
     (term_sigma (typ_var_f b) t  (term_inst e t''))
 | red0_sigma_open : forall (c b:typvar) (t:typ) (e:term),
     result (term_sigma (typ_var_f b) t e) ->
     red0 (term_open (typ_var_f c) (term_sigma (typ_var_f b) t e)) NoEps (term_sigma (typ_var_f b) t (term_open (typ_var_f c) e))
 | red0_sigma_exists : forall (L:vars) (b:typvar) (t t':typ) (e e':term),
      ( forall c , c \notin  L  ->  lc_typ (  ( open_typ_wrt_typ t (typ_var_f c) )  )  )  ->
      ( forall c , c \notin  L  ->  c  `notin` ftv_typ (  ( open_typ_wrt_typ t (typ_var_f c) )  )  )  ->
      ( forall c a, c \notin  L  ->  ( a \notin   L  \u {{ c }}  -> result  ( open_term_wrt_typ  ( open_term_wrt_typ_rec 1 (typ_var_f c) e )  (typ_var_f a) )  )  )  ->
      (forall c, c \notin L -> t' = open_typ_wrt_typ t (typ_var_f c)) ->
      (forall c a, c \notin L -> a \notin L \u {{ c }} ->
      open_term_wrt_typ (open_term_wrt_typ_rec 1 (typ_var_f c) e) (typ_var_f a)
    = open_term_wrt_typ (open_term_wrt_typ_rec 1 (typ_var_f a) e') (typ_var_f c)) ->
      red0 (term_exists (term_sigma (typ_var_f b) t e)) NoEps (term_sigma (typ_var_f b) t' (term_exists e'))
 | red0_sigma_coerce : forall (L:vars) (b:typvar) (t:typ) (e:term) (t' t'':typ),
     lc_typ t' ->
     result (term_sigma (typ_var_f b) t e) ->
     (forall a , a \notin  L  -> open_typ_wrt_typ t'' (typ_var_f a) = tsubst_typ (typ_var_f a) b t') ->
     red0 (term_coerce (term_sigma (typ_var_f b) t e) t') NoEps
     (term_sigma (typ_var_f b) t  (term_coerce e t''))
 | red0_sigma_sigma : forall (L:vars) (b1:typvar) (t1 t1':typ) (b2:typvar) (t2:typ) (e e':term),
     lc_term (term_sigma (typ_var_f b1) t1 (term_sigma (typ_var_f b2) t2 e)) ->
      ( forall a1 , a1 \notin  L  ->  ( forall a2 , a2 \notin   L  \u {{ a1 }}  -> result  (open_term_wrt_typ_rec 0 (typ_var_f a1) (open_term_wrt_typ_rec 1 (typ_var_f a2) e) )  )  )  ->
      ( forall a2, a2 \notin L -> t1 = open_typ_wrt_typ t1' (typ_var_f a2) ) ->
      ( forall a1 a2, a1 \notin L -> a2 \notin L \u {{ a1 }} ->
        open_term_wrt_typ_rec 0 (typ_var_f a2) (open_term_wrt_typ_rec 1 (typ_var_f a1) e)
        = open_term_wrt_typ_rec 0 (typ_var_f a1) (open_term_wrt_typ_rec 1 (typ_var_f a2) e') ) ->
      red0 (term_sigma (typ_var_f b1) t1 (term_sigma (typ_var_f b2) t2 e)) Eps (term_sigma (typ_var_f b2) (open_typ_wrt_typ t2 t1) (term_sigma (typ_var_f b1) t1' e')) .

(* defns Jred1 *)
Inductive red1 : term -> red_tag -> term -> Prop :=    (* defn red1 *)
 | red1_empty : forall (e:term) (A:red_tag) (e':term),
     red0 e A e' ->
     red1 e A e'
 | red1_let : forall (e1 e2:term) (A:red_tag) (e1':term),
     lc_term (term_let e1 e2) ->
     red1 e1 A e1' ->
     red1 (term_let e1 e2) A (term_let e1' e2)
 | red1_appL : forall (e1 e2:term) (A:red_tag) (e1':term),
     lc_term e2 ->
     red1 e1 A e1' ->
     red1 (term_app e1 e2) A (term_app e1' e2)
 | red1_appR : forall (e1 e2:term) (A:red_tag) (e2':term),
     lc_term e1 ->
     red1 e2 A e2' ->
     red1 (term_app e1 e2) A (term_app e1 e2')
 | red1_pairL : forall (e1 e2:term) (A:red_tag) (e1':term),
     lc_term e2 ->
     red1 e1 A e1' ->
     red1 (term_pair e1 e2) A (term_pair e1' e2)
 | red1_pairR : forall (e1 e2:term) (A:red_tag) (e2':term),
     lc_term e1 ->
     red1 e2 A e2' ->
     red1 (term_pair e1 e2) A (term_pair e1 e2')
 | red1_fst : forall (e:term) (A:red_tag) (e':term),
     red1 e A e' ->
     red1 (term_fst e) A (term_fst e')
 | red1_snd : forall (e:term) (A:red_tag) (e':term),
     red1 e A e' ->
     red1 (term_snd e) A (term_snd e')
 | red1_inst : forall (e:term) (t:typ) (A:red_tag) (e':term),
     lc_typ t ->
     red1 e A e' ->
     red1 (term_inst e t) A (term_inst e' t)
 | red1_exists : forall (L:vars) (e:term) (A:red_tag) (e':term),
      ( forall a , a \notin  L  -> red1  ( open_term_wrt_typ e (typ_var_f a) )  A  ( open_term_wrt_typ e' (typ_var_f a) )  )  ->
     red1 (term_exists e) A (term_exists e')
 | red1_open : forall (b:typvar) (e:term) (A:red_tag) (e':term),
     red1 e A e' ->
     red1 (term_open (typ_var_f b) e) A (term_open (typ_var_f b) e')
 | red1_nu : forall (L:vars) (e:term) (A:red_tag) (e':term),
      ( forall a , a \notin  L  -> red1  ( open_term_wrt_typ e (typ_var_f a) )  A  ( open_term_wrt_typ e' (typ_var_f a) )  )  ->
     red1 (term_nu e) A (term_nu e')
 | red1_sigma : forall (L:vars) (b:typvar) (t:typ) (e:term) (A:red_tag) (e':term),
     lc_typ t ->
      ( forall a , a \notin  L  -> red1  ( open_term_wrt_typ e (typ_var_f a) )  A  ( open_term_wrt_typ e' (typ_var_f a) )  )  ->
     red1 (term_sigma (typ_var_f b) t e) A (term_sigma (typ_var_f b) t e')
 | red1_coerce : forall (e:term) (t:typ) (A:red_tag) (e':term),
     lc_typ t ->
     red1 e A e' ->
     red1 (term_coerce e t) A (term_coerce e' t).

(** infrastructure *)

(* additional definitions *)

(* instanciation of tactics *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let D1 := gather_atoms_with (fun x => fv_term x) in
  let D2 := gather_atoms_with (fun x => ftv_typ x) in
  let D3 := gather_atoms_with (fun x => ftv_term x) in
  constr:(A \u B \u D1 \u D2 \u D3).

Hint Constructors val result zip wfenv wftyp wftypeq wfterm red0 red1 lc_typ lc_term.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Cone.
Require Import Category.Structure.Limit.
Require Import Category.Structure.Span.
Require Import Category.Structure.Pullback.
Require Import Category.Construction.Opposite.
Require Import Category.Functor.Opposite.
Require Import Category.Instance.Roof.

Generalizable All Variables.

Definition Pullback_Limit {C : Category} (F : Cospan C) := Limit F.
Arguments Pullback_Limit {_%category} F%functor /.

Definition Pushout_Limit {C : Category} (F : Span C) := Colimit F.
Arguments Pushout_Limit {_%category} F%functor /.

Program Definition Pullback_to_Universal {C : Category}
        (F : Cospan C) (P : Pullback_Limit F) :
  Pullback (unop (fmap[F] ZeroNeg)) (unop (fmap[F] ZeroPos)) := {|
  Pull := P;
  pullback_fst := (vertex_map _);
  pullback_snd := (vertex_map _)
|}.
Next Obligation.
  pose proof (@cone_coherence _ (@vertex_obj  _ _ _ (limit_cone)) _ F (coneFrom)).
  unfold unop.
  rewrite !X.
  reflexivity.
Qed.
Next Obligation.
  given (cone : Cone F). {
    unshelve (refine {| vertex_obj := Q |}); unshelve econstructor; intros.
    - destruct x; auto.
      exact (unop (fmap[F] ZeroPos) ∘ q2).
    - simpl;
      destruct x, y; auto with roof_laws; simpl in f;
      rewrite (RoofHom_inv _ _ f); cat.
  }
  destruct P, limit_cone; simpl in *.
  exists (unique_obj (ump_limits cone)). {
    split;
    [ pose proof (unique_property (ump_limits cone) RNeg)
    | pose proof (unique_property (ump_limits cone) RPos) ];
    unfold cone in *; simpl in *; clear cone;
    rewrites; reflexivity.
  }
  intros.
  apply (uniqueness (ump_limits cone)); intros.
  simpl in *.
  destruct x, X0; simpl; auto.
  rewrites.
  rewrite comp_assoc.
  unfold unop.
  rewrite cone_coherence.
  reflexivity.
Qed.

Program Definition Pullback_from_Universal {C : Category}
        {x y z : C} (f : x ~> z) (g : y ~> z) (P : Pullback f g) :
  Pullback_Limit (@ASpan (C^op) _ _ _ f g)^op := {|
  limit_cone := {| vertex_obj := P ; coneFrom := {| vertex_map := _; cone_coherence := _ |} |}
|}.
Next Obligation.
  destruct x0;
    destruct P; simpl in *; auto.
  exact (f ∘ pullback_fst).
Defined.
Next Obligation.
  destruct x0, y0;
  destruct P; simpl in *; auto with roof_laws; cat.
Qed.
Next Obligation.
  destruct P, N, coneFrom; simpl in *.
  assert (eqv : f ∘ (vertex_map RNeg) ≈
                  g ∘ (vertex_map RPos)). {
    rewrite (cone_coherence RNeg RZero ZeroNeg).
    rewrite (cone_coherence RPos RZero ZeroPos).
    reflexivity.
  }
  unfold Pullback_from_Universal_obligation_1; simpl.
  destruct (ump_pullbacks vertex_obj (vertex_map RNeg) (vertex_map RPos) eqv).
  construct; simplify; auto.
  - destruct x0; auto.
    rewrite <- comp_assoc.
    rewrite unique_property.
    apply (cone_coherence RNeg RZero ZeroNeg).
  - apply uniqueness.
    split.
    + apply (X RNeg).
    + apply (X RPos).
Defined.


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

 Comprehension bicategories

 In this file we define comprehension bicategories and properties
 of comprehension bicategories.

 1. Comprehension bicategories
 2. Variances of comprehension bicategories

 *******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.

Local Open Scope cat.

(**
 1. Comprehension bicategories
 *)
Definition comprehension_bicat_structure
           (B : bicat)
  : UU
  := ∑ (D : disp_bicat B)
       (χ : disp_psfunctor D (cod_disp_bicat B) (id_psfunctor B)),
     global_cleaving D × global_cartesian_disp_psfunctor χ.

Definition make_comprehension_bicat_structure
           (B : bicat)
           (D : disp_bicat B)
           (χ : disp_psfunctor D (cod_disp_bicat B) (id_psfunctor B))
           (HD : global_cleaving D)
           (Hχ : global_cartesian_disp_psfunctor χ)
  : comprehension_bicat_structure B
  := D ,, χ ,, HD ,, Hχ.

(** Projections of a comprehension bicategory *)
Definition ty_of
           {B : bicat}
           (comp_B : comprehension_bicat_structure B)
  : disp_bicat B
  := pr1 comp_B.

Definition comp_of
           {B : bicat}
           (comp_B : comprehension_bicat_structure B)
  : disp_psfunctor (ty_of comp_B) (cod_disp_bicat B) (id_psfunctor B)
  := pr12 comp_B.

Definition ty_of_global_cleaving
           {B : bicat}
           (comp_B : comprehension_bicat_structure B)
  : global_cleaving (ty_of comp_B)
  := pr122 comp_B.

Definition comp_of_global_cartesian
           {B : bicat}
           (comp_B : comprehension_bicat_structure B)
  : global_cartesian_disp_psfunctor (comp_of comp_B)
  := pr222 comp_B.

(**
 2. Variances of comprehension bicategories
 *)
Definition is_covariant
           {B : bicat}
           (comp_B : comprehension_bicat_structure B)
  : UU
  := let D := ty_of comp_B in
     let χ := comp_of comp_B in
     local_opcleaving D
     × lwhisker_opcartesian D
     × rwhisker_opcartesian D
     × local_opcartesian_disp_psfunctor χ.

Definition is_contravariant
           {B : bicat}
           (comp_B : comprehension_bicat_structure B)
  : UU
  := let D := ty_of comp_B in
     let χ := comp_of comp_B in
     local_cleaving D
     × lwhisker_cartesian D
     × rwhisker_cartesian D
     × local_cartesian_disp_psfunctor χ.

Definition comprehension_bicat
  : UU
  := ∑ (B : bicat)
       (comp_B : comprehension_bicat_structure B),
     is_covariant comp_B.

Definition contravariant_comprehension_bicat
  : UU
  := ∑ (B : bicat)
       (comp_B : comprehension_bicat_structure B),
     is_contravariant comp_B.


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

Require Import ILL.Definitions.
Require Import bsm_defs mm_defs eill ill.

Require Import PCP_BPCP BPCP_iBPCP iBPCP_BSM BSM_MM MM_EILL EILL_ILL.

(** * List of all results *)

(** Reduction results for the following problems:

    0) PCP: Post Correspondence Problem
    1) BPCP: Binary Post Correspondence Problem (see Definitions.v)
    2) BSM_HALTING: given a Binary Stack Machine P and an initial
       state st, starting at the first instruction of P with st
       as initial value for stacks, does the computation halt ?
       (see Bsm/bsm_defs.v)
    3) MM_HALTING: given a Minsky Machine P starting at instruction 1,
       and an initial state v (the initial values of registers),
       does the computation starting from (1,v) reach the state (0,vec_zero) ?
       (see Mm/mm_defs.v)
    4) EILL_PROVABILITY: given an EILL sequent (elementary fragment of ILL)
       is it provable in G_EILL ? (see Ll/eill.v)
    5) ILL_PROVABILITY: given a sequent of the (!,&,-o) fragment of ILL
       is it provable in G_ILL ? (see Ll/ill.v)
 *)

Check PCP_BPCP.                           Print Assumptions PCP_BPCP.
Check BPCP_iBPCP.                         Print Assumptions BPCP_iBPCP.
Check iBPCP_BSM_HALTING.                  Print Assumptions iBPCP_BSM_HALTING.
Check BSM_MM_HALTING.                     Print Assumptions BSM_MM_HALTING.
Check BSM_MM_HALTS_ON_ZERO.               Print Assumptions BSM_MM_HALTS_ON_ZERO.
Check MM_HALTS_ON_ZERO_EILL_PROVABILITY.  Print Assumptions MM_HALTS_ON_ZERO_EILL_PROVABILITY.
Check EILL_ILL_PROVABILITY.               Print Assumptions EILL_ILL_PROVABILITY.

Theorem PCP_BSM_HALTING : PCP ⪯ BSM_HALTING.
Proof.
  eapply reduces_transitive. exact PCP_BPCP.
  eapply reduces_transitive. exact BPCP_iBPCP.
  exact iBPCP_BSM_HALTING.
Qed.

Theorem PCP_MM_HALTS_ON_ZERO : PCP ⪯ MM_HALTS_ON_ZERO.
Proof.
  eapply reduces_transitive. exact PCP_BSM_HALTING.
  exact BSM_MM_HALTS_ON_ZERO.
Qed.

Theorem PCP_MM_HALTING : PCP ⪯ MM_HALTING.
Proof.
  eapply reduces_transitive. exact PCP_BSM_HALTING.
  exact BSM_MM_HALTING.
Qed.

Theorem PCP_ILL : PCP ⪯ ILL_PROVABILITY.
Proof.
  eapply reduces_transitive. exact PCP_MM_HALTS_ON_ZERO.
  eapply reduces_transitive. exact MM_HALTS_ON_ZERO_EILL_PROVABILITY.
  exact EILL_ILL_PROVABILITY.
Qed.

(** * Formal Undecidability *)

Module Def_of_undec.

  Inductive dec {X} (P : X -> Prop) : Prop := is_dec (H : forall x, { P x} + {~ P x}).

  Notation compl P := (fun x => ~ P x).

  Notation "Q ⪯T P" := (dec (P) -> dec (Q)) (at level 20).

  Lemma red_turing X Y (P : X -> Prop) (Q : Y -> Prop) : P ⪯ Q -> P ⪯T Q.
  Proof.
    intros (f & Hf) [ H ].
    exists.
    intros x; destruct (H (f x)) as [ H1 | H1 ];
      rewrite <- Hf in H1; tauto.
  Qed.

  (* Lemma red_turing_compl X Y (Q : Y -> Prop) (P : X -> Prop) : *)
  (*   Q ⪯ P -> compl Q ⪯T compl P. *)
  (* Proof. *)
  (*   intros [f] [d]. econstructor. intros x. *)
  (*   destruct (d (f x)). *)
  (*   + left. firstorder. *)
  (*   + right. firstorder. *)
  (* Qed. *)

  Inductive undec : forall X, (X -> Prop) -> Prop :=
    undec_seed : undec PCP
  | undec_red X (P : X -> Prop) Y (Q : Y -> Prop) : Q ⪯T P -> undec Q -> undec P.

  Lemma red_undec  X Y (Q : Y -> Prop) (P : X -> Prop) :
    Q ⪯ P -> undec Q -> undec P.
  Proof.
    intros. eapply undec_red. eapply red_turing; eauto. eauto.
  Qed.

  Lemma undec_compl X (P : X -> Prop) :
    undec (compl P) -> undec P.
  Proof.
    intros. eapply undec_red; try eassumption. firstorder.
  Qed.

  Lemma undec_PCP X (P : X -> Prop) :
    undec P <-> (PCP ⪯T P).
  Proof.
    split; intros.
    - induction H; eauto.
    - eauto using undec.
  Qed.

End Def_of_undec.


(**
Monads as a bicategory. The construction has 3 layers.
In the first layer: we take algebras on the identity functor.
In the second layer: we add η an μ. This is done by adding 2-cells (as in Add2Cell)
In the third layer: we take the full subcategory and we add the monad laws.
*)
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.Univalence.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.AlgebraMap.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.

Local Open Scope cat.

Definition monad_support (C : bicat)
  : bicat
  := bicat_algebra (id_psfunctor C).

Definition monad_support_is_univalent_2_1 {C : bicat}
           (HC_1 : is_univalent_2_1 C)
  : is_univalent_2_1 (monad_support C).
Proof.
  apply bicat_algebra_is_univalent_2_1.
  exact HC_1.
Defined.

Definition monad_support_is_univalent_2_0 {C : bicat}
           (HC : is_univalent_2 C)
  : is_univalent_2_0 (monad_support C).
Proof.
  apply bicat_algebra_is_univalent_2_0.
  exact HC.
Defined.

Definition monad_support_is_univalent_2 {C : bicat}
           (HC : is_univalent_2 C)
  : is_univalent_2 (monad_support C).
Proof.
  split.
  - apply monad_support_is_univalent_2_0; assumption.
  - apply monad_support_is_univalent_2_1.
    exact (pr2 HC).
Defined.

Definition add_unit (C : bicat)
  : disp_bicat (monad_support C).
Proof.
  use add_cell_disp_cat.
  - exact (id_psfunctor _).
  - exact (id_psfunctor _).
  - exact (var _ _).
  - exact (alg_map _).
Defined.

Definition add_mu (C : bicat)
  : disp_bicat (monad_support C).
Proof.
  use add_cell_disp_cat.
  - exact (id_psfunctor _).
  - exact (id_psfunctor _).
  - exact ((alg_map _) · (alg_map _)).
  - exact (alg_map _).
Defined.

Definition monad_data (C : bicat)
  : disp_bicat C
  := sigma_bicat _ _ (disp_dirprod_bicat (add_unit C) (add_mu C)).

Definition lawless_monad (C : bicat) := total_bicat (monad_data C).

Definition lawless_monad_is_univalent_2_1 (C : bicat)
           (HC_1 : is_univalent_2_1 C)
  : is_univalent_2_1 (lawless_monad C).
Proof.
  apply sigma_is_univalent_2_1.
  - exact HC_1.
  - apply disp_alg_bicat_univalent_2_1.
  - apply is_univalent_2_1_dirprod_bicat.
    + apply add_cell_disp_cat_univalent_2_1.
    + apply add_cell_disp_cat_univalent_2_1.
Defined.

Definition lawless_monad_is_univalent_2_0 (C : bicat)
           (HC : is_univalent_2 C)
  : is_univalent_2_0 (lawless_monad C).
Proof.
  pose (HC_1 := pr2 HC).
  apply sigma_is_univalent_2_0.
  - exact HC.
  - split.
    + apply disp_alg_bicat_univalent_2_0.
      apply HC.
    + apply disp_alg_bicat_univalent_2_1.
  - split.
    + apply is_univalent_2_0_dirprod_bicat.
      * apply total_is_univalent_2_1.
        ** exact (pr2 HC).
        ** apply disp_alg_bicat_univalent_2_1.
      * apply add_cell_disp_cat_univalent_2.
        ** exact (pr2 HC).
          ** apply disp_alg_bicat_univalent_2_1.
      * apply add_cell_disp_cat_univalent_2.
        ** exact (pr2 HC).
        ** apply disp_alg_bicat_univalent_2_1.
    + apply is_univalent_2_1_dirprod_bicat.
      * apply add_cell_disp_cat_univalent_2_1.
      * apply add_cell_disp_cat_univalent_2_1.
Defined.

Definition lawless_monad_is_univalent_2 (C : bicat)
           (HC : is_univalent_2 C)
  : is_univalent_2 (lawless_monad C).
Proof.
  split.
  - apply lawless_monad_is_univalent_2_0; assumption.
  - apply lawless_monad_is_univalent_2_1.
    exact (pr2 HC).
Defined.

Section BigProjections.

  Context {C : bicat}.

  Definition bigmonad_obj : lawless_monad C → C
    := λ m, pr1 m.

  Definition bigmonad_map : ∏ (m : lawless_monad C), bigmonad_obj m --> bigmonad_obj m
    := λ m, pr12 m.

  Definition bigmonad_unit : ∏ (m : lawless_monad C), id₁ (bigmonad_obj m) ==> bigmonad_map m
    := λ m, pr122 m.

  Definition bigmonad_mu
    : ∏ (m : lawless_monad C), bigmonad_map m · bigmonad_map m ==> bigmonad_map m
    := λ m, pr222 m.

  Definition bigmonad_laws (m : lawless_monad C) : UU
    := ((bigmonad_unit m ▹ bigmonad_map m)
          • bigmonad_mu m
        =
        lunitor (bigmonad_map m))
         ×
       ((bigmonad_map m ◃ bigmonad_unit m)
          • bigmonad_mu m
        =
        runitor (bigmonad_map m))
         ×
       ((bigmonad_map m ◃ bigmonad_mu m)
          • bigmonad_mu m
        =
        lassociator (bigmonad_map m) (bigmonad_map m) (bigmonad_map m)
          • (bigmonad_mu m ▹ bigmonad_map m)
          • bigmonad_mu m).
End BigProjections.

Definition monad (C : bicat) : disp_bicat C
  := sigma_bicat _ _ (disp_fullsubbicat (lawless_monad C) bigmonad_laws).

(** Projections *)

Section Projections.

Context {C : bicat} {x : C} (m : monad C x).

Definition monad_endo : x --> x
  := pr11 m.

Definition monad_unit : id₁ x ==> monad_endo
  := pr121 m.

Definition monad_mu : monad_endo · monad_endo ==> monad_endo
  := pr221 m.

Definition monad_ημ
  : linvunitor monad_endo • (monad_unit ▹ monad_endo) • monad_mu = id₂ monad_endo.
Proof.
  refine (vassocl _ _ _ @ _ @ linvunitor_lunitor _ ).
  refine (maponpaths _ _).
  exact (pr12 m).
Defined.

Definition monad_μη
  : rinvunitor monad_endo • (monad_endo ◃ monad_unit) • monad_mu = id₂ monad_endo.
Proof.
  refine (vassocl _ _ _ @ _ @ rinvunitor_runitor _ ).
  refine (maponpaths _ _).
  exact (pr122 m).
Defined.

Definition monad_μμ
  : (monad_endo ◃ monad_mu) • monad_mu
    =
    lassociator monad_endo monad_endo monad_endo • (monad_mu ▹ monad_endo) • monad_mu
  := pr222 m.

End Projections.

Section Projections2.

Context {C : bicat} {x y : C} {mx : monad C x} {my : monad C y}
        {f : x --> y}
        (mf : mx -->[f] my).

Definition monad_mor_natural
  : invertible_2cell (monad_endo mx · f) (f · monad_endo my)
  := pr11 mf.

Definition monad_mor_unit
  : (monad_unit mx ▹ f) • monad_mor_natural
    =
    (lunitor f • rinvunitor f) • (f ◃ monad_unit my)
  := pr121 mf.

Definition monad_mor_mu
  : (monad_mu mx ▹ _) • monad_mor_natural
    =
    ((((rassociator _ _ _ • (_ ◃ monad_mor_natural))
         • lassociator _ _ _) • (monad_mor_natural ▹ _))
       • rassociator _ _ _) • (_ ◃ monad_mu my)
  := pr221 mf.

End Projections2.

Section Projections3.

Context {C : bicat} {x y : C} {mx : monad C x} {my : monad C y}
        {f g : x --> y} {α : f ==> g}
        {mf : mx -->[f] my}
        {mg : mx -->[g] my}
        (αα : mf ==>[α] mg).

Definition monad_cell_natural
  : (monad_endo mx ◃ α) • monad_mor_natural mg
    =
    monad_mor_natural mf • (α ▹ monad_endo my)
  := pr11 αα.

End Projections3.

(** Builders. *)

Definition make_monad {C : bicat}
           (X : C)
           (f : C⟦X,X⟧)
           (η : id₁ X ==> f)
           (μ : f · f ==> f)
           (ημ : (η ▹ f) • μ
                 =
                 lunitor f)
           (μη : (f ◃ η) • μ
                 =
                 runitor f)
           (μμ : (f ◃ μ) • μ
                 =
                 lassociator f f f • (μ ▹ f) • μ)
  : monad C X.
Proof.
  use tpair.
  - use tpair.
    + exact f.
    + split.
      * exact η.
      * exact μ.
  - repeat split.
    + exact ημ.
    + exact μη.
    + exact μμ.
Defined.

Definition make_monad_mor
           {C : bicat}
           {x y : C} {mx : monad C x} {my : monad C y}
           {f : x --> y}
           (mf_nat : invertible_2cell (monad_endo mx · f) (f · monad_endo my))
           (mfη : (monad_unit mx ▹ f) • mf_nat
                     =
                     (lunitor f • rinvunitor f) • (f ◃ monad_unit my))
           (mfμ : (monad_mu mx ▹ _) • mf_nat
                  =
                  ((((rassociator _ _ _ • (_ ◃ mf_nat))
                       • lassociator _ _ _) • (mf_nat ▹ _))
                     • rassociator _ _ _) • (_ ◃ monad_mu my))
  : mx -->[f] my.
Proof.
  refine (_,, tt).
  use tpair.
  - exact mf_nat.
  - apply make_dirprod.
    + exact mfη.
    + exact mfμ.
Defined.

Definition make_monad_cell
           {C : bicat} {x y : C} {mx : monad C x} {my : monad C y}
           {f g : x --> y} {α : f ==> g}
           {mf : mx -->[f] my}
           {mg : mx -->[g] my}
           (α_nat : (monad_endo mx ◃ α) • monad_mor_natural mg
                    =
                    monad_mor_natural mf • (α ▹ monad_endo my))
  : mf ==>[ α ] mg
  := ((α_nat ,, (tt,,tt)),, tt).

Definition bigmonad (C : bicat) := total_bicat (monad C).

Definition base {C : bicat} (m : bigmonad C) : C := pr1 m.

Definition bigmonad_to_monad (C : bicat) (m : bigmonad C) : monad C (base m)
  := pr2 m.

Definition make_bigmonad {C : bicat}
           (X : C)
           (f : C⟦X,X⟧)
           (η : id₁ X ==> f)
           (μ : f · f ==> f)
           (ημ : (η ▹ f) • μ
                 =
                 lunitor f)
           (μη : (f ◃ η) • μ
                 =
                 runitor f)
           (μμ : (f ◃ μ) • μ
                 =
                 lassociator f f f • (μ ▹ f) • μ)
  : bigmonad C.
Proof.
  use tpair.
  - exact X.
  - use make_monad.
    + exact f.
    + exact η.
    + exact μ.
    + exact ημ.
    + exact μη.
    + exact μμ.
Defined.

Definition monad_is_univalent_2_1
           (C : bicat)
  : disp_univalent_2_1 (monad_data C).
Proof.
  use sigma_disp_univalent_2_1_with_props.
  - apply disp_2cells_isaprop_alg.
  - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_add_cell.
  - apply disp_alg_bicat_univalent_2_1.
  - apply is_univalent_2_1_dirprod_bicat ; apply add_cell_disp_cat_univalent_2_1.
Defined.

Definition monad_is_univalent_2_0
           (C : bicat)
           (HC : is_univalent_2 C)
  : disp_univalent_2_0 (monad_data C).
Proof.
  use sigma_disp_univalent_2_0_with_props.
  - exact HC.
  - apply disp_2cells_isaprop_alg.
  - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_add_cell.
  - apply disp_alg_bicat_univalent_2_1.
  - apply is_univalent_2_1_dirprod_bicat ; apply add_cell_disp_cat_univalent_2_1.
  - apply disp_locally_groupoid_alg.
  - apply disp_locally_groupoid_prod ; apply disp_locally_groupoid_add_cell.
  - apply disp_alg_bicat_univalent_2_0.
    exact (pr2 HC).
  - apply is_univalent_2_0_dirprod_bicat.
    + apply total_is_univalent_2_1.
      * exact (pr2 HC).
      * apply disp_alg_bicat_univalent_2_1.
    + apply add_cell_disp_cat_univalent_2.
      * exact (pr2 HC).
      * apply disp_alg_bicat_univalent_2_1.
    + apply add_cell_disp_cat_univalent_2.
      * exact (pr2 HC).
      * apply disp_alg_bicat_univalent_2_1.
Defined.

Definition bigmonad_is_univalent_2_1
           (C : bicat)
           (HC_1 : is_univalent_2_1 C)
  : is_univalent_2_1 (bigmonad C).
Proof.
  apply sigma_is_univalent_2_1.
  - exact HC_1.
  - apply monad_is_univalent_2_1.
  - apply disp_fullsubbicat_univalent_2_1.
Defined.

Definition bigmonad_is_univalent_2_0
           (C : bicat)
           (HC : is_univalent_2 C)
  : is_univalent_2_0 (bigmonad C).
Proof.
  apply sigma_is_univalent_2_0.
  - exact HC.
  - split.
    + apply monad_is_univalent_2_0.
      exact HC.
    + apply monad_is_univalent_2_1.
  - split.
    + apply disp_univalent_2_0_fullsubbicat.
      * exact (lawless_monad_is_univalent_2 C HC).
      * intro ; simpl.
        repeat (apply isapropdirprod) ; apply C.
    + apply disp_fullsubbicat_univalent_2_1.
Defined.

Definition bigmonad_is_univalent_2
           (C : bicat)
           (HC : is_univalent_2 C)
  : is_univalent_2 (bigmonad C).
Proof.
  split.
  - apply bigmonad_is_univalent_2_0; assumption.
  - apply bigmonad_is_univalent_2_1.
    exact (pr2 HC).
Defined.

Definition disp_2cells_isaprop_monad
           (C : bicat)
           (HC : is_univalent_2 C)
  : disp_2cells_isaprop (monad C).
Proof.
  apply disp_2cells_isaprop_sigma.
  - apply disp_2cells_isaprop_sigma.
    + apply disp_2cells_isaprop_alg.
    + apply disp_2cells_isaprop_prod.
      * apply disp_2cells_isaprop_add_cell.
      * apply disp_2cells_isaprop_add_cell.
  - apply disp_2cells_isaprop_fullsubbicat.
Qed.

Definition disp_locally_groupoid_monad
           (C : bicat)
           (HC : is_univalent_2 C)
  : disp_locally_groupoid (monad C).
Proof.
  apply disp_locally_groupoid_sigma.
  - exact HC.
  - apply disp_2cells_isaprop_sigma.
    + apply disp_2cells_isaprop_alg.
    + apply disp_2cells_isaprop_prod.
      * apply disp_2cells_isaprop_add_cell.
      * apply disp_2cells_isaprop_add_cell.
  - apply disp_2cells_isaprop_fullsubbicat.
  - apply disp_locally_groupoid_sigma.
    + exact HC.
    + apply disp_2cells_isaprop_alg.
    + apply disp_2cells_isaprop_prod.
      * apply disp_2cells_isaprop_add_cell.
      * apply disp_2cells_isaprop_add_cell.
    + apply disp_locally_groupoid_alg.
    + apply disp_locally_groupoid_prod.
      * apply disp_locally_groupoid_add_cell.
      * apply disp_locally_groupoid_add_cell.
  - apply disp_locally_groupoid_fullsubbicat.
Qed.

(* ------------------------------------------------------------------------- *)
(* C = bicat_of_univ_cats.                                                        *)
(* ------------------------------------------------------------------------- *)

Definition make_cat_monad
           (C : univalent_category)
           (M : C ⟶ C)
           (η : functor_identity C ⟹ M)
           (μ : M ∙ M ⟹ M)
           (lid : ∏ (X : C), #M (η X) · μ X = id₁ (M X))
           (rid : ∏ (X : C), η (M X) · μ X = id₁ (M X))
           (massoc :  ∏ (X : C), μ (M X) · μ X = #M (μ X) · μ X)
  : monad bicat_of_univ_cats C.
Proof.
  use make_monad.
  - exact M.
  - exact η.
  - exact μ.
  - abstract
      (use nat_trans_eq; try apply homset_property;
       intros X ; cbn;
       apply lid).
  - abstract
      (use nat_trans_eq; try apply homset_property;
       intros X ; cbn;
       apply rid).
  - abstract
      (use nat_trans_eq; try apply homset_property;
       intros X ; cbn;
       rewrite id_left;
       apply massoc).
Defined.

Definition cat_monad_ημ {C : univalent_category} (M : monad bicat_of_univ_cats C)
  : ∏ (X : C), #(pr1(monad_endo M)) (pr1(monad_unit M) X) · pr1(monad_mu M) X = id₁ _.
Proof.
  intros X.
  pose (nat_trans_eq_pointwise (monad_ημ M) X) as p.
  cbn in p.
  rewrite id_left in p.
  exact p.
Qed.

Definition cat_monad_μη {C : univalent_category} (M : monad bicat_of_univ_cats C)
  : ∏ (X : C), pr1(monad_unit M) (pr1(monad_endo M) X) · pr1(monad_mu M) X = id₁ _.
Proof.
  intros X.
  pose (nat_trans_eq_pointwise (monad_μη M) X) as p.
  cbn in p.
  rewrite id_left in p.
  exact p.
Qed.

Definition cat_monad_μμ {C : univalent_category} (M : monad bicat_of_univ_cats C)
  : ∏ (X : C),
    pr1(monad_mu M) (pr1(monad_endo M) X) · pr1(monad_mu M) X
    =
    #(pr1(monad_endo M)) (pr1(monad_mu M) X) · pr1(monad_mu M) X.
Proof.
  intros X.
  pose (nat_trans_eq_pointwise (monad_μμ M) X) as p.
  cbn in p.
  rewrite id_left in p.
  exact p.
Qed.

(* ------------------------------------------------------------------------- *)
(* Bind and associated fusion laws.                                          *)
(* ------------------------------------------------------------------------- *)

Section Bind.

Context {C : univalent_category}
        (M : monad bicat_of_univ_cats C).

Definition monad_bind
           {A B : C}
           (f : C⟦A, (monad_endo M : _ ⟶ _) B⟧)
  : C⟦(monad_endo M : _ ⟶ _) A, (monad_endo M : _ ⟶ _) B⟧
  := #(monad_endo M : _ ⟶ _) f · pr1 (monad_mu M) B.

Definition cat_monad_map_as_bind
           {x y : pr1 C}
           (f : x --> y)
  : #(monad_endo M : _ ⟶ _) f = monad_bind (f · pr1 (monad_unit M) y).
Proof.
  unfold monad_bind.
  refine (!_).
  etrans.
  {
    apply maponpaths_2.
    apply functor_comp.
  }
  rewrite assoc'.
  etrans.
  {
    apply maponpaths.
    apply cat_monad_ημ.
  }
  apply id_right.
Qed.

Lemma cat_monad_bind_unit
      {A B : C}
      (f : C⟦A, (monad_endo M : _ ⟶ _) B⟧)
  : (monad_unit M : _ ⟹ _) A · monad_bind f = f.
Proof.
  unfold monad_bind.
  etrans.
  { rewrite assoc.
    apply maponpaths_2.
    apply (!(nat_trans_ax ((monad_unit M : _ ⟹ _)) A _ f)).
  }
  etrans.
  2: apply id_right.
  rewrite assoc'.
  apply maponpaths.
  apply (cat_monad_μη M).
Qed.

Lemma cat_monad_unit_bind
      {A : C}
  : monad_bind ((monad_unit M : _ ⟹ _) A) = id₁ _.
Proof.
  apply (cat_monad_ημ M).
Qed.

Lemma cat_monad_bind_bind
      {a b c : C}
      (f : C⟦a, (monad_endo M : _ ⟶ _) b⟧)
      (g : C⟦b, (monad_endo M : _ ⟶ _) c⟧)
  : monad_bind f · monad_bind g = monad_bind (f · monad_bind g).
Proof.
  unfold monad_bind.
  etrans.
  2: {
    rewrite (functor_comp (monad_endo M : _ ⟶ _)).
    rewrite assoc'.
    apply maponpaths.
    rewrite (functor_comp (monad_endo M : _ ⟶ _)).
    rewrite assoc'.
    apply maponpaths.
    apply (cat_monad_μμ M).
  }
  pose (nat_trans_ax ((monad_mu M : _ ⟹ _)) _ _ g) as Hμ.
  simpl in Hμ.
  rewrite assoc'.
  apply maponpaths.
  etrans.
  { rewrite assoc.
    apply maponpaths_2.
    apply (!Hμ).
  }
  rewrite assoc.
  apply idpath.
Qed.

End Bind.

(* ------------------------------------------------------------------------- *)
(* Monad morphism on C = bicat_of_cats.                                      *)
(* ------------------------------------------------------------------------- *)

Definition make_cat_monad_mor
           {C D : univalent_category}
           {mx : monad bicat_of_univ_cats C} {my : monad bicat_of_univ_cats D}
           {F : C ⟶ D}
           (mf_nat : nat_z_iso (monad_endo mx ∙ F) (F ∙ monad_endo my))
           (mfη : ∏ (X : C), # F (pr1 (monad_unit mx) X) · mf_nat X
                             =
                             pr1 (monad_unit my) (F X))
           (mfμ : ∏ (X : C),
                  # F (pr1 (monad_mu mx) X) · mf_nat X
                  =
                  mf_nat (pr1 (monad_endo mx) X)
                         · # (pr1 (monad_endo my)) (mf_nat X)
                         · pr1 (monad_mu my) (F X))
  : mx -->[F] my.
Proof.
  use make_monad_mor.
  - apply nat_z_iso_to_invertible_2cell.
    exact mf_nat.
  - abstract
      (use nat_trans_eq; try apply homset_property;
       intros X ; cbn;
       do 2 rewrite id_left;
       apply mfη).
  - abstract
      (use nat_trans_eq; try apply homset_property;
       intros X ; cbn;
       rewrite id_left, !id_right;
       apply mfμ).
Defined.

Definition make_cat_monad_cell
           {C D : univalent_category}
           {mx : monad bicat_of_univ_cats C}
           {my : monad bicat_of_univ_cats D}
           {f g : C ⟶ D}
           {α : f ⟹ g}
           {mf : mx -->[f] my}
           {mg : mx -->[g] my}
           (H : ∏ (X : C),
                α (pr1 (monad_endo mx) X) · (pr11 (monad_mor_natural mg)) X
                =
                (pr11 (monad_mor_natural mf)) X · # (pr1 (monad_endo my)) (pr1 α X))
  : mf ==>[α: prebicat_cells bicat_of_univ_cats _ _] mg.
Proof.
  apply make_monad_cell.
  use nat_trans_eq; try apply homset_property.
  intros X; cbn.
  apply H.
Qed.

Definition monad_mor_nat_z_iso
           {C₁ C₂ : univalent_category}
           {F : C₁ ⟶ C₂}
           {M₁ : monad bicat_of_univ_cats C₁}
           {M₂ : monad bicat_of_univ_cats C₂}
           (FF : M₁ -->[F] M₂)
  : nat_z_iso (monad_endo M₁ ∙ F) (F ∙ monad_endo M₂)
  := invertible_2cell_to_nat_z_iso _ _ (monad_mor_natural FF).

Definition monad_mor_natural_pointwise
           {C₁ C₂ : univalent_category}
           {F : C₁ ⟶ C₂}
           {M₁ : monad bicat_of_univ_cats C₁}
           {M₂ : monad bicat_of_univ_cats C₂}
           (FF : M₁ -->[F] M₂)
           (X : C₁)
  : z_iso ((monad_endo M₂ : C₂ ⟶ C₂) (F X)) (F ((monad_endo M₁ : C₁ ⟶ C₁) X))
  := CompositesAndInverses.nat_z_iso_to_pointwise_z_iso
       (nat_z_iso_inv (monad_mor_nat_z_iso FF)) X.

Definition monad_mor_z_iso
           {C₁ C₂ : univalent_category}
           {F : C₁ ⟶ C₂}
           {M₁ : monad bicat_of_univ_cats C₁}
           {M₂ : monad bicat_of_univ_cats C₂}
           (FF : M₁ -->[F] M₂)
  : ∏ X : C₁, z_iso (F ((monad_endo M₁ : C₁ ⟶ C₁) X)) ((monad_endo M₂ : C₂ ⟶ C₂) (F X))
  := CompositesAndInverses.nat_z_iso_to_pointwise_z_iso (monad_mor_nat_z_iso FF).

Lemma monad_mor_bind
      {C₁ C₂ : univalent_category}
      {F : C₁ ⟶ C₂}
      {M₁ : monad bicat_of_univ_cats C₁}
      {M₂ : monad bicat_of_univ_cats C₂}
      (FF : M₁ -->[F] M₂)
      {A B : C₁}
      (f : A --> (monad_endo M₁ : _ ⟶ _) B)
  : #F (monad_bind M₁ f) · monad_mor_z_iso FF B
    =
    monad_mor_z_iso FF A · monad_bind M₂ (# F f · pr1 (monad_mor_z_iso FF B)).
Proof.
  unfold monad_bind, monad_mor_z_iso.
  simpl.
  etrans.
  2: {
    rewrite assoc.
    apply maponpaths_2.
    rewrite (functor_comp (monad_endo M₂ : _ ⟶ _)).
    rewrite assoc.
    apply maponpaths_2.
    apply (nat_trans_ax (pr1 (monad_mor_natural FF)) _ _ f).
  }
  simpl.
  rewrite functor_comp.
  do 3 rewrite assoc'.
  apply maponpaths.
  etrans.
  { pose (nat_trans_eq_pointwise (monad_mor_mu FF) B) as H.
    simpl in H.
    rewrite id_left in H.
    do 2 rewrite id_right in H.
    apply H.
  }
  rewrite assoc'.
  apply idpath.
Qed.

Lemma monad_mor_bind_alt
      {C₁ C₂ : univalent_category}
      {F : C₁ ⟶ C₂}
      {M₁ : monad bicat_of_univ_cats C₁}
      {M₂ : monad bicat_of_univ_cats C₂}
      (FF : M₁ -->[F] M₂)
      {A B : C₁}
      (f : A --> (monad_endo M₁ : _ ⟶ _) B)
  : #F (monad_bind M₁ f)
    =
    monad_mor_z_iso FF A
      · monad_bind M₂ (# F f · pr1 (monad_mor_z_iso FF B))
      · inv_from_z_iso (monad_mor_z_iso FF B).
Proof.
  use z_iso_inv_on_left.
  apply pathsinv0.
  apply monad_mor_bind.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import Functor.Representable.Hom_Func.
From Categories Require Import Cat.Cat Cat.Cat_Iso.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat NatTrans.NatIso.

Local Open Scope functor_scope.

Section Hom_Func_Twist.
  Context (C : Category).

  (** (Hom_Func Cᵒᵖ) = (Hom_Func C) ∘ (Twist_Func C Cᵒᵖ)
       Note that:
         (Home_Func C) : Cᵒᵖ×C -> Type_Cat
       and
         (Twist_Func C Cᵒᵖ) : C×Cᵒᴾ → Cᵒᵖ×C
   *)
  Theorem Hom_Func_Twist : (Hom_Func (C^op)) = (Hom_Func C) ∘ (Twist_Func C (C^op)).
  Proof.
    Func_eq_simpl; cbn; auto.
  Qed.

End Hom_Func_Twist.

Section Prod_Func_Hom_Func_NT.
  Context {A B C D : Category}
          {F : A –≻ C^op}
          {F' : A –≻ D^op}
          {G : B –≻ C}
          {G' : B –≻ D}
          (N : (((Hom_Func C) ∘ (Prod_Functor F G))
                –≻ ((Hom_Func D) ∘ (Prod_Functor F' G')))%nattrans
          )
  .

  Local Obligation Tactic := idtac.

  (** Given a natural transformation from ((Hom_Func C) ∘ (Prod_Functor F G)) to
      ((Hom_Func D) ∘ (Prod_Functor F' G')), we construct a natural transformation
      from ((Hom_Func C^op) ∘ (Prod_Functor G F)) to
      ((Hom_Func D^op) ∘ (Prod_Functor G' F')). *)
  Program Definition Prod_Func_Hom_Func_NT :
    (((Hom_Func (C^op)) ∘ (Prod_Functor G F))
       –≻ ((Hom_Func (D^op)) ∘ (Prod_Functor G' F')))%nattrans :=
    {|
      Trans := fun c h => Trans N (snd c, fst c) h
    |}.

  Next Obligation.
  Proof.
    intros [c1 c2] [c1' c2'] [h1 h2].
    extensionality x; cbn.
    repeat rewrite assoc_sym.
    exact (equal_f (@Trans_com _ _ _ _ N (c2, c1) (c2', c1') (h2, h1)) x).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Prod_Func_Hom_Func_NT_obligation_1.
  Qed.

End Prod_Func_Hom_Func_NT.

Section Prod_Func_Hom_Func.
  Context {A B C D : Category}
          {F : A –≻ C^op}
          {F' : A –≻ D^op}
          {G : B –≻ C}
          {G' : B –≻ D}
          (N : (
                 ((Hom_Func C) ∘ (Prod_Functor F G))%functor
                   ≃ ((Hom_Func D) ∘ (Prod_Functor F' G'))%functor
               )%natiso
          )
  .

  Local Ltac TRC :=
  match goal with
    [|- ?W = _] =>
    match W with
      Trans ?A ?X (Trans ?B ?X ?Z) =>
      change W with (Trans (NatTrans_compose B A) X Z)
    end
  end.

  Local Obligation Tactic :=
    apply NatTrans_eq_simplify; FunExt; basic_simpl; TRC;
    solve [(cbn_rewrite (right_inverse N); trivial) |
           (cbn_rewrite (left_inverse N); trivial)].

  (**
Given a natural isomorphism
  ((Hom_Func C) ∘ (Prod_Functor F G)) ≃ ((Hom_Func D) ∘ (Prod_Functor F' G')),
we construct a natural ismorphism
  ((Hom_Func C^op) ∘ (Prod_Functor G F)) ≃
   ((Hom_Func D^op) ∘ (Prod_Functor G' F'))
*)
  Program Definition Prod_Func_Hom_Func :
    ((((Hom_Func (C^op)) ∘ (Prod_Functor G F))%functor)
       ≃ ((Hom_Func (D^op)) ∘ (Prod_Functor G' F'))%functor)%natiso
    :=
      {|
        iso_morphism := Prod_Func_Hom_Func_NT (iso_morphism N);
        inverse_morphism := Prod_Func_Hom_Func_NT (inverse_morphism N)
      |}
  .

End Prod_Func_Hom_Func.

Section Prod_Func_Hom_Func_invl.
  Context {A B C D : Category}
          {F : A –≻ C^op}
          {F' : A –≻ D^op}
          {G : B –≻ C}
          {G' : B –≻ D}
          (N :
             (
               ((Hom_Func C) ∘ (Prod_Functor F G))%functor
                 ≃ ((Hom_Func D) ∘ (Prod_Functor F' G'))%functor
             )%natiso
          )
  .

  (** Prod_Func_Hom_Func defined above is involutive. *)
  Theorem Prod_Func_Hom_Func_invl :
    N = Prod_Func_Hom_Func (Prod_Func_Hom_Func N).
  Proof.
    apply Isomorphism_eq_simplify;
    apply NatTrans_eq_simplify; extensionality x; trivial.
  Qed.

End Prod_Func_Hom_Func_invl.

(** If I : C ≃ D is an isomorphism of categories, then hom-functor of C is
    naturally isomorphic to hom-functor of D taken after conversion from C
    to D through I. In this section we prove this by providing both sides
    of natural isomorphism and showing that they are inverses. *)
Section Hom_Func_to_Iso_Hom_Func.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%isomorphism).

  Local Obligation Tactic := idtac.

  Program Definition Hom_Func_to_Iso_Hom_Func :
    (
      (Hom_Func C)
        –≻ ((Hom_Func D)
              ∘
              (Prod_Functor ((iso_morphism I)^op) (iso_morphism I)))
    )%nattrans :=
    {|
      Trans := fun c h => ((iso_morphism I) _a h)%morphism
    |}.

  Next Obligation.
  Proof.
    basic_simpl; auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Hom_Func_to_Iso_Hom_Func_obligation_1.
  Qed.

  Program Definition Iso_Hom_Func_to_Hom_Func :
    (((Hom_Func D) ∘ (Prod_Functor ((iso_morphism I)^op) (iso_morphism I)))
       –≻ (Hom_Func C))%nattrans
    :=
    {|
      Trans := fun c h => Cat_Iso_conv_inv I ((inverse_morphism I) _a h)
    |}.

  Next Obligation.
  Proof.
    basic_simpl; FunExt.
    repeat rewrite F_compose.
    repeat rewrite Cat_Iso_conv_inv_compose.
    repeat rewrite Cat_Iso_conv_inv_I_inv_I; trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Iso_Hom_Func_to_Hom_Func_obligation_1.
  Qed.

  Program Definition Hom_Func_Cat_Iso :
    (
      (Hom_Func C)
        ≃ ((Hom_Func D)
             ∘ (Prod_Functor ((iso_morphism I)^op) (iso_morphism I)))%functor
    )%natiso :=
    {|
      iso_morphism := Hom_Func_to_Iso_Hom_Func;
      inverse_morphism := Iso_Hom_Func_to_Hom_Func
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; basic_simpl; FunExt.
    apply Cat_Iso_conv_inv_I_inv_I.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality c; cbn.
    extensionality f.
    destruct (Cat_Iso_inv I f) as [g H].
    rewrite H.
    rewrite Cat_Iso_conv_inv_I_inv_I; trivial.
  Qed.

End Hom_Func_to_Iso_Hom_Func.