Require Import Reals.
Require Import Lra.

Require Import Rsequence.
Require Import Rpser_def Rpser_base_facts.
Require Import Rpser_cv_facts.
Require Import Rpser_sums Rpser_derivative.

Local Open Scope R_scope.

(** * Comparison of Taylor development *)

Section Taylor.

Variable Un : nat -> R.
Variable En : nat -> R.
Variable r : R.

(* begin hide *)
Lemma partial_sum_null : forall N x,
  Rseq_pps (fun n => if le_lt_dec n N then 0 else Un n) x N = 0.
Proof.
intros N x ; assert (Hrec : forall n, (n <= N)%nat ->
  Rseq_pps (fun n => if le_lt_dec n N then 0 else Un n) x n = 0).
  intros n Hn ; induction n.
   unfold Rseq_pps, gt_pser, Rseq_mult ; simpl ; apply Rmult_0_l.
   rewrite Rseq_pps_simpl, IHn, Rplus_0_l ;
   destruct (le_lt_dec (S n) N) as [H | Hf].
    apply Rmult_0_l.
    exfalso ; lia.
   lia.
   exfalso ; lia.
apply Hrec ; trivial.
Qed.

Lemma partial_sum : forall N x
  (Vn := fun n : nat => if le_lt_dec n N then 0 else Un n) n
  (Hle : (N<= n)%nat),
  Rseq_pps Un x n = Rseq_pps Un x N + Rseq_pps Vn x n.
Proof.
intros N x Vn n Hle ; induction Hle.
unfold Vn ; rewrite partial_sum_null ; ring.
do 2 rewrite Rseq_pps_simpl ; rewrite IHHle ; unfold Vn at 3.
destruct (le_lt_dec (S m ) N).
  exfalso ; lia.
  apply Rplus_assoc.
Qed.
(* end hide *)

Lemma Rpser_big_O_partial_sum :
  forall N (H : 0 < r) (Hcv : Rseq_cv En 0) (pr : Cv_radius_weak Un r),
    (fun p => weaksum_r Un r pr (En p) - Rseq_pps Un (En p) N)
    = O((fun p => (En p) ^ (S N))).
Proof.
intros N H Hcv pr.
pose (Vn := fun n => if le_lt_dec n N then 0 else Un n).
pose (Wn := fun n => Un (n + S N)%nat).
assert (prv : Cv_radius_weak Vn r).
  destruct pr as [M HM].
  exists M; intros m Hm.
  destruct Hm as [i Hi]; rewrite Hi.
  unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
  unfold Vn; destruct le_lt_dec.
  rewrite Rmult_0_l; rewrite Rabs_R0.
  eapply Rle_trans.
    apply Rabs_pos.
    apply HM.
    exists i; reflexivity.
  apply HM.
  unfold EUn, gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
  exists i; reflexivity.
assert (prw : Cv_radius_weak Wn r).
  destruct pr as [M HM].
  exists (M / r ^ (S N)); intros m Hm.
  destruct Hm as [i Hi]; rewrite Hi.
  unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult, Wn.
  apply (Rmult_le_reg_l (r ^ (S N))).
  apply pow_lt; assumption.
  replace (r ^ (S N) * (M / r ^ (S N)))
    with M by (field; apply Rgt_not_eq; apply pow_lt; assumption).
  rewrite <- (Rabs_right (r ^ (S N))); [|apply Rle_ge; apply pow_le; lra].
  rewrite <- Rabs_mult.
  rewrite Rmult_comm.
  rewrite Rmult_assoc.
  rewrite <- pow_add.
  apply HM.
  unfold EUn, gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
  exists (i + (S N))%nat; reflexivity.
pose (St := fun x => weaksum_r Un r pr x).
pose (Sr := fun x => weaksum_r Vn r prv x).
pose (Sp := fun x => sum_f_R0 (fun n => Un n * x ^ n) N).
pose (Ss := fun x => weaksum_r Wn r prw x).
assert (Hsum : forall x, Rabs x < r -> St x = Sp x + Sr x).
  intros x Hx.
  eapply Rseq_cv_unique.
    apply weaksum_r_sums; assumption.
    assert (Hcvv := weaksum_r_sums Vn r prv x Hx).
    intros eps Heps; destruct (Hcvv eps Heps) as [n0 Hn0].
    exists (Max.max N n0); intros n Hn.
    assert (Rseq_pps Un x n = Rseq_pps Un x N + Rseq_pps Vn x n) as ->; swap 1 2.
    assert (Hrw : exists p, n = (N + p)%nat).
      exists (n - N)%nat.
      assert (n >= N)%nat.
        eapply le_trans; [apply Max.le_max_l|eexact Hn].
      lia.
    destruct Hrw as [p Hp]; subst n.
    unfold R_dist.
    rewrite Rplus_comm.
    unfold Rminus.
    rewrite Rplus_assoc.
    rewrite Ropp_plus_distr.
    rewrite <- Rplus_assoc with (r2 := - Sp x).
    rewrite Rplus_opp_r.
    rewrite Rplus_0_l.
    apply Hn0; eapply le_trans; [apply Max.le_max_r|eexact Hn].
    assert (Hle : (N <= n)%nat).
      eapply le_trans; [apply Max.le_max_l|eexact Hn].
    clear - Un Hle.
    apply partial_sum; apply Hle.
assert (Hmul : forall x, Rabs x < r -> Sr x = x ^ (S N) * Ss x).
  intros x Hx.
  eapply Rseq_cv_unique.
    apply weaksum_r_sums; assumption.
    assert (Hcvw := weaksum_r_sums Wn r prw x Hx).
    destruct (Req_dec x 0) as [Hz|Hnz].
      rewrite Hz.
      intros eps Heps.
      exists 0%nat; intros n _.
      assert (Rseq_pps Vn 0 n = 0) as ->; swap 1 2.
      rewrite pow_ne_zero; [|lia].
      rewrite Rmult_0_l.
      rewrite R_dist_eq.
      assumption.
      induction n; simpl.
        rewrite Rseq_pps_0_simpl ; unfold Vn.
        destruct le_lt_dec; [field|apply False_ind; lia].
        rewrite Rseq_pps_simpl.
        rewrite pow_i, Rmult_0_r, Rplus_0_r.
        assumption.
        lia.
      intros eps Heps.
      destruct (Hcvw (eps / Rabs (x ^ (S N)))) as [n0 Hn0].
        unfold Rdiv; apply Rmult_gt_0_compat.
          assumption.
          apply Rinv_0_lt_compat.
          apply Rabs_pos_lt; apply pow_nonzero; assumption.
      exists (n0 + S N)%nat; intros n Hn.
      assert (Rseq_pps Vn x n = x ^ S N * Rseq_pps Wn x (n - (S N))) as ->; swap 1 2.
      unfold R_dist; rewrite <- Rmult_minus_distr_l.
      rewrite Rabs_mult.
      apply (Rmult_lt_reg_l (/ Rabs (x ^ S N))).
      apply Rinv_0_lt_compat.
      apply Rabs_pos_lt; apply pow_nonzero; assumption.
      rewrite <- Rmult_assoc.
      rewrite Rinv_l.
      rewrite Rmult_1_l.
      rewrite Rmult_comm.
      apply Hn0; lia.
      apply Rgt_not_eq.
      apply Rabs_pos_lt; apply pow_nonzero; assumption.
    assert (Hrw : exists p, (n = N + S p)%nat).
      exists (n - (S N))%nat; lia.
    destruct Hrw as [p Hp]; subst n.
    clear - p.
      induction p; simpl.
        replace (N + 1)%nat with (S N) by lia.
        replace (S N - S N)%nat with 0%nat by lia.
        unfold Vn, Wn.
        rewrite Rseq_pps_simpl, Rseq_pps_O_simpl, partial_sum_null.
        destruct le_lt_dec as [H|_]; [apply False_ind; lia|].
        simpl ; ring.
        rewrite <- plus_n_Sm.
        replace (S (N + S p) - S N)%nat with (S (N + S p - S N))%nat by lia.
        rewrite Rseq_pps_simpl, IHp.
        replace (S (N + S p)) with ((S N) + (S p))%nat by lia ;
        rewrite (pow_add _ (S N)).
        transitivity (x ^ S N * (Rseq_pps Wn x (N + S p - S N) +
         x ^ S p * Vn (S N + S p)%nat)).
        ring.
        simpl ; do 2 (repeat rewrite Rmult_assoc ; apply Rmult_eq_compat_l).
        rewrite Rseq_pps_simpl ; apply Rplus_eq_compat_l.
        unfold Vn, Wn.
        destruct le_lt_dec as [H|_]; [apply False_ind; lia|].
        replace (S (N + S p - S N) + S N)%nat with (S (N + S p))%nat by lia.
        replace (N + S p - S N)%nat with p by lia.
        simpl ; ring.
assert (Hct : continuity_pt Ss 0).
  apply continuity_pt_weaksum_r.
  rewrite Rabs_R0; assumption.
destruct (Hct 1) as [alp [Halp Hd]]; [lra|].
assert (Hradius : exists P, forall p, (p >= P)%nat -> Rabs (En p) < r /\ Rabs (En p) < alp).
  destruct (Hcv r H) as [P1 HP1].
  destruct (Hcv alp Halp) as [P2 HP2].
  exists (Max.max P1 P2); intros p Hp.
  rewrite <- (Rminus_0_r (En p)); split.
  apply HP1; eapply le_trans; [apply Max.le_max_l|apply Hp].
  apply HP2; eapply le_trans; [apply Max.le_max_r|apply Hp].
destruct Hradius as [P HP].
exists (Rabs (Ss 0) + 1); split.
  apply Rle_ge; apply Rplus_le_le_0_compat.
    apply Rabs_pos.
    lra.
  exists P; intros p Hp.
  assert (Hp1 : Rabs (En p) < r).
    apply (HP p); assumption.
  assert (Hp2 : Rabs (En p) < alp).
    apply (HP p); assumption.
  rewrite Hsum; [|assumption].
  rewrite Rplus_comm.
  unfold Rminus; rewrite Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_r.
  rewrite Hmul; [|assumption].
  rewrite Rabs_mult.
  rewrite Rmult_comm.
  apply Rmult_le_compat_r; [apply Rabs_pos|].
  rewrite <- (Rplus_0_l (Rabs (Ss (En p)))).
  pattern 0 at 1; erewrite <- Rplus_opp_r.
  rewrite Rplus_assoc.
  apply Rplus_le_compat_l.
  rewrite Rplus_comm.
  eapply Rle_trans.
    apply Rabs_triang_inv.
    destruct (Req_dec (En p) 0) as [He|He].
      rewrite He; unfold Rminus; rewrite Rplus_opp_r.
      rewrite Rabs_R0; lra.
    apply Rlt_le; apply (Hd (En p)); split.
      compute; auto.
      simpl; unfold R_dist; rewrite Rminus_0_r.
      apply Hp2.
Qed.

Lemma Rpser_little_O_partial_sum :
  forall N (H : 0 < r) (Hcv : Rseq_cv En 0) (pr : Cv_radius_weak Un r),
    (fun p => weaksum_r Un r pr (En p) - sum_f_R0 (fun n => Un n * (En p) ^ n) N) = o((fun p => (En p) ^ N)).
Proof.
intros N H Hcv pr.
eapply Rseq_big_O_little_O_trans; [apply Rpser_big_O_partial_sum; assumption|].
intros eps Heps.
destruct (Hcv eps Heps) as [M HM].
exists M; intros n Hn.
simpl pow; rewrite Rabs_mult.
apply Rmult_le_compat_r; [apply Rabs_pos|].
apply Rlt_le; replace (En n) with (En n - 0) by field.
apply HM; assumption.
Qed.

End Taylor.


(**********************************************************************************
 * typedopsem.v                                                                   *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

Require Import Coq.Program.Equality.
Require Import typedlambda.

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

(*==========================================================================
  Evaluation relation
  ==========================================================================*)

(** printing =>> %\ensuremath{\Downarrow}% *)
(** printing n1 %\ensuremath{n_1}% *)
(** printing n2 %\ensuremath{n_2}% *)
(** printing v1 %\ensuremath{v_1}% *)
(** printing v2 %\ensuremath{v_2}% *)
(** printing e1 %\ensuremath{e_1}% *)
(** printing e2 %\ensuremath{e_2}% *)

Open Scope Sub_scope.
Notation "x '<v=' y" := (x <= y)%N (at level 55).
Reserved Notation "e =>> v" (at level 70, no associativity).
(*=Ev *)
Inductive Ev: forall t, CExp t -> CValue t -> Prop :=
| e_Val: forall t (v : CValue t), TVAL v =>> v
| e_Op: forall op n1 n2, TOP op (TINT n1) (TINT n2) =>> TINT (op n1 n2)
| e_Gt : forall n1 n2, TGT (TINT n1) (TINT n2) =>> TBOOL (n2 <v=  n1)
| e_Fst : forall t1 t2 (v1 : CValue t1) (v2 : CValue t2), TFST (TPAIR v1 v2) =>> v1
| e_Snd : forall t1 t2 (v1 : CValue t1) (v2 : CValue t2), TSND (TPAIR v1 v2) =>> v2
| e_App : forall t1 t2 e (v1 : CValue t1) (v2 : CValue t2),
            subExp [ v1, TFIX e ] e =>> v2 -> TAPP (TFIX e) v1 =>> v2
| e_Let : forall t1 t2 e1 e2 (v1 : CValue t1) (v2 : CValue t2),
            e1 =>> v1 -> subExp [ v1 ] e2 =>> v2 -> TLET e1 e2 =>> v2
| e_IfTrue : forall t (e1 e2 : CExp t) v, e1 =>> v -> TIF (TBOOL true) e1 e2 =>> v
| e_IfFalse : forall t (e1 e2 : CExp t) v, e2 =>> v -> TIF (TBOOL false) e1 e2 =>> v
where "e '=>>' v" := (Ev e v).
(*=End *)
(*==========================================================================
  Determinacy of evaluation
  ==========================================================================*)

Lemma Determinacy: forall ty, forall (e : CExp ty) v1, e =>> v1 -> forall v2, e =>> v2 -> v1 = v2.
Proof.
intros ty e v1 Ev1.
induction Ev1.

(* e_Val *)
intros v2 Ev2. dependent destruction Ev2; trivial.
(* e_Op *)
intros v2 Ev2. dependent destruction Ev2; trivial.
(* e_Gt *)
intros v2 Ev2. dependent destruction Ev2; trivial.
(* e_Fst *)
intros v3 Ev3. dependent destruction Ev3; trivial.
(* e_Snd *)
intros v3 Ev3. dependent destruction Ev3; trivial.
(* e_App *)
intros v3 Ev3. dependent destruction Ev3; auto.
(* e_Let *)
intros v3 Ev3. dependent destruction Ev3. rewrite (IHEv1_1 _ Ev3_1) in IHEv1_2. auto.
(* e_IfTrue *)
intros v3 Ev3. dependent destruction Ev3; auto.
(* e_IfFalse *)
intros v3 Ev3. dependent destruction Ev3; auto.
Qed.

Unset Implicit Arguments.


(* 要导入Reals才能使用Z_scope *)
Require Import Reals.
Open Scope Z_scope.

(* 2.3.2 section和局部变量 *)
Section binomial_def.
 Variables a b : Z.
 Definition binomial z:Z := a*z + b.
 Print binomial.
 Section trinomial_def.
  Variable c:Z.
  Definition trinomial z:Z := (binomial z)*z +c.
  Print trinomial.
 End trinomial_def.
 Print trinomial.
End binomial_def.
Print binomial.
Print trinomial.

Definition p1 : Z->Z := binomial 5 (-3).
Definition p2 : Z->Z := trinomial 1 0 (-1).
Definition p3 := trinomial 1 (-2) 1.

(* 2.5.1 Set大类 *)
Check Z.
Check ((Z->Z)->nat->nat).
Check Set.
Check Type.


Require Export SeparationLogicProofSystem.Syntax.

Definition rsatisfy {Sigma: signature} {M: model Sigma}
  (t: replacement Sigma) (s: valuation M) (phi: rformula Sigma): Prop :=
satisfy s (rformula_replace t phi).

Definition rrelation {Sigma: signature} (M: model Sigma)
  (t: replacement Sigma) (phi: binrformula Sigma): M -> M -> Prop :=
fun d d' => rsatisfy t (update (update (nulval M) x d) y d') phi.

Fixpoint slsatisfy {Sigma: signature} {M: model Sigma}
  (R: binformula Sigma) (s: valuation M) (phi: slformula Sigma): Prop :=
match phi with
| sleq t1 t2 => interp s t1 = interp s t2
| slhasval t1 t2 => relation M R (interp s t1, interp s t2)
| slprim p arg => pred p (Vector.map (interp s) arg)
| slnot phi => ~slsatisfy R s phi
| sland phi psi => slsatisfy R s phi /\ slsatisfy R s psi
| slforall x phi => forall (d: domain M), slsatisfy R (update s x d) phi
| sand phi psi => exists (R1 R2: binformula Sigma),
    DisjointUnion (relation M R) (relation M R1) (relation M R2) /\
    slsatisfy R1 s phi /\ slsatisfy R2 s psi
| simp phi psi => forall (R': binformula Sigma),
    Disjoint (relation M R) (relation M R') ->
    slsatisfy R' s phi -> slsatisfy (union R R') s psi
end.

Definition rootedsatisfy {Sigma: signature} {M: model Sigma}
  (t: replacement Sigma) (s: valuation M) (phip: rooted Sigma): Prop :=
match phip with
| mkrooted phi p => slsatisfy (binrformula_binformula t p) s phi
end.

Definition sequentsatisfy {Sigma: signature} {M: model Sigma}
  (s: valuation M) (seq: sequent Sigma): Prop :=
let (left, right) := seq in forall t,
  List.fold_left and (List.map (rootedsatisfy t s) left) True /\
  List.fold_right or False (List.map (rootedsatisfy t s) right).

Definition sequenttrue {Sigma: signature} (M: model Sigma) (seq: sequent Sigma): Prop :=
forall (s: valuation M), sequentsatisfy s seq.

Definition sequentvalid {Sigma: signature} (seq: sequent Sigma): Prop :=
forall (M: model Sigma), sequenttrue M seq.


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

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

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

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

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

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

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

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
   induction l1.
   - intros. simpl. f_equal. apply IHl1.
   - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
   induction l.
   - simpl. f_equal. apply IHl.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), len (append x y) = len (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite IHx. apply lem.
   - intros.  simpl. lfind.
Admitted.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Logic.PropositionalLogic.DeepEmbedded.PropositionalLanguage.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Module IntuitionisticPropositionalLogic.

Section IntuitionisticPropositionalLogic.

Context {Sigma: PropositionalLanguage.PropositionalVariables}.

(* TODO: why this "existing instance" is in fact no longer needed. *)
Existing Instances PropositionalLanguage.L
                   PropositionalLanguage.minL
                   PropositionalLanguage.andpL
                   PropositionalLanguage.orpL
                   PropositionalLanguage.falsepL.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x).

Instance GP: Provable PropositionalLanguage.L := Build_Provable _ provable.

Instance GD: Derivable PropositionalLanguage.L := Provable2Derivable.

Instance GammaDP: DerivableProvable PropositionalLanguage.L GP GD :=
  Provable2Derivable_Normal.

Instance minAX: MinimumAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance andpAX: AndAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
Qed.

Instance orpAX: OrAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
Qed.

Instance falsepAX: FalseAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  apply falsep_elim.
Qed.

End IntuitionisticPropositionalLogic.

End IntuitionisticPropositionalLogic.

Module DeMorganPropositionalLogic.

Section DeMorganPropositionalLogic.

Context {Sigma: PropositionalLanguage.PropositionalVariables}.

Existing Instances PropositionalLanguage.L
                   PropositionalLanguage.minL
                   PropositionalLanguage.andpL
                   PropositionalLanguage.orpL
                   PropositionalLanguage.falsepL
                   PropositionalLanguage.negpL
                   PropositionalLanguage.negpDef.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| weak_excluded_middle: forall x, provable (~~ x || ~~ ~~ x).

Instance GP: Provable  PropositionalLanguage.L :=
  Build_Provable _ provable.

Instance GD: Derivable PropositionalLanguage.L := Provable2Derivable.

Instance GammaDP: DerivableProvable PropositionalLanguage.L GP GD :=
  Provable2Derivable_Normal.

Instance minAX: MinimumAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance andpAX: AndAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
Qed.

Instance orpAX: OrAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
Qed.

Instance falsepAX: FalseAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  apply falsep_elim.
Qed.

Instance inegpAX: IntuitionisticNegAxiomatization PropositionalLanguage.L GP :=
  NegFromDefToAX_False_Imp.

Instance dmpAX: DeMorganAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  apply weak_excluded_middle.
Qed.

End DeMorganPropositionalLogic.

End DeMorganPropositionalLogic.

Module GodelDummettPropositionalLogic.

Section GodelDummettPropositionalLogic.

Context {Sigma: PropositionalLanguage.PropositionalVariables}.

Existing Instances PropositionalLanguage.L
                   PropositionalLanguage.minL
                   PropositionalLanguage.andpL
                   PropositionalLanguage.orpL
                   PropositionalLanguage.falsepL
                   PropositionalLanguage.negpL
                   PropositionalLanguage.negpDef.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| impp_choice: forall x y, provable ((x --> y) || (y --> x)).

Instance GP: Provable PropositionalLanguage.L :=
  Build_Provable _ provable.

Instance GD: Derivable PropositionalLanguage.L := Provable2Derivable.

Instance GammaDP: DerivableProvable PropositionalLanguage.L GP GD :=
  Provable2Derivable_Normal.

Instance minAX: MinimumAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance andpAX: AndAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
Qed.

Instance orpAX: OrAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
Qed.

Instance falsepAX: FalseAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  apply falsep_elim.
Qed.

Instance inegpAX: IntuitionisticNegAxiomatization PropositionalLanguage.L GP :=
  NegFromDefToAX_False_Imp.

Instance gdpAX: GodelDummettAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  apply impp_choice.
Qed.

Instance dmpAX: DeMorganAxiomatization PropositionalLanguage.L GP :=
  GodelDummett2DeMorgan.

End GodelDummettPropositionalLogic.

End GodelDummettPropositionalLogic.

Module ClassicalPropositionalLogic.

Section ClassicalPropositionalLogic.

Context {Sigma: PropositionalLanguage.PropositionalVariables}.

Existing Instances PropositionalLanguage.L
                   PropositionalLanguage.minL
                   PropositionalLanguage.andpL
                   PropositionalLanguage.orpL
                   PropositionalLanguage.falsepL
                   PropositionalLanguage.negpL
                   PropositionalLanguage.negpDef.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| peirce_law: forall x y, provable (((x --> y) --> x) --> x).

Instance GP: Provable PropositionalLanguage.L := Build_Provable _ provable.

Instance GD: Derivable PropositionalLanguage.L := Provable2Derivable.

Instance GammaDP: DerivableProvable PropositionalLanguage.L GP GD :=
  Provable2Derivable_Normal.

Instance minAX: MinimumAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance andpAX: AndAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
Qed.

Instance orpAX: OrAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
Qed.

Instance falsepAX: FalseAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  apply falsep_elim.
Qed.

Instance inegpAX: IntuitionisticNegAxiomatization PropositionalLanguage.L GP :=
  NegFromDefToAX_False_Imp.

Instance cpAX: ClassicalAxiomatization PropositionalLanguage.L GP.
Proof.
  constructor.
  apply peirce_law.
Qed.

Instance gdpAX: GodelDummettAxiomatization PropositionalLanguage.L GP :=
  Classical2GodelDummett.

Instance dmpAX: DeMorganAxiomatization PropositionalLanguage.L GP :=
  GodelDummett2DeMorgan.

End ClassicalPropositionalLogic.

End ClassicalPropositionalLogic.


(* ******************************************************************************* *)
(** * Displayed bicategories
    Benedikt Ahrens, Marco Maggesi
    February 2018

  This file develops displayed bicategories analogous to
  displayed (1-)categories as presented in
  Benedikt Ahrens and Peter LeFanu Lumsdaine, Displayed categories
  http://dx.doi.org/10.4230/LIPIcs.FSCD.2017.5

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

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

(* =================================================================================== *)
(** ** Displayed bicategories.                                                         *)
(* =================================================================================== *)

(* ----------------------------------------------------------------------------------- *)
(** ** Transport of displayed cells.

    Transport of displayed cells is used pervasively, to make the code more terse
    and ease certain proofs we define some ad hoc functions and theorems.

    TODO: These definitions are not used yet.                                          *)
(* ----------------------------------------------------------------------------------- *)

(* ----------------------------------------------------------------------------------- *)
(** ** Definition of displayed bicategories.                                           *)
(* ----------------------------------------------------------------------------------- *)

Definition disp_2cell_struct {C : prebicat_1_id_comp_cells} (D : disp_cat_ob_mor C) : UU
  := ∏ (c c' : C) (f g : C⟦c,c'⟧) (x : f ==> g)
       (d : D c) (d' : D c') (f' : d -->[f] d') (g' : d -->[g] d'), UU.

Definition disp_prebicat_1_id_comp_cells (C : prebicat_1_id_comp_cells) : UU
  := ∑ D : disp_cat_data C, disp_2cell_struct D.

Coercion disp_cat_data_from_disp_prebicat_1_id_comp_cells
         {C : prebicat_1_id_comp_cells} (D : disp_prebicat_1_id_comp_cells C)
  : disp_cat_data C
  := pr1 D.

Definition disp_2cells {C : prebicat_1_id_comp_cells}
           {D : disp_prebicat_1_id_comp_cells C}
           {c c' : C} {f g : C⟦c,c'⟧} (x : f ==> g)
           {d : D c} {d' : D c'} (f' : d -->[f] d') (g' : d -->[g] d')
  : UU
  := pr2 D c c' f g x d d' f' g'.

Section Cell_Transport.

Context {C : bicat} {D : disp_prebicat_1_id_comp_cells C}.

Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60).

Definition cell_transportf
           {a b : C} {f g : C⟦a,b⟧}
           {α β : f ==> g}
           (e : α = β)
           {aa : D a} {bb : D b}
           {ff : aa -->[f] bb}
           {gg : aa -->[g] bb}
           (αα : ff ==>[α] gg)
  : ff ==>[β] gg
  := transportf (λ x : f ==> g, ff ==>[x] gg) e αα.

Definition cell_transportb
           {a b : C} {f g : C⟦a,b⟧}
           {α β : f ==> g}
           (e : α = β)
           {aa : D a} {bb : D b}
           {ff : aa -->[f] bb}
           {gg : aa -->[g] bb}
           (ββ : ff ==>[β] gg)
  : ff ==>[α] gg
  := transportb (λ x : f ==> g, ff ==>[x] gg) e ββ.

Lemma cell_transportf_pathsinv0
      {a b : C} {f g : C⟦a,b⟧}
      {α β : f ==> g}
      (e : α = β)
      {aa : D a} {bb : D b}
      {ff : aa -->[f] bb}
      {gg : aa -->[g] bb}
      {αα : ff ==>[α] gg}
      {ββ : ff ==>[β] gg}
      (ee : cell_transportf (!e) ββ = αα)
  : cell_transportf e αα = ββ.
Proof.
  unfold cell_transportf.
  apply (transportf_pathsinv0 (λ x : f ==> g, ff ==>[x] gg)).
  exact ee.
Defined.

Lemma cell_transportb_to_f
      {a b : C} {f g : C⟦a,b⟧}
      {α β : f ==> g}
      {e : α = β}
      {aa : D a} {bb : D b}
      {ff : aa -->[f] bb}
      {gg : aa -->[g] bb}
      {αα : ff ==>[α] gg}
      {ββ : ff ==>[β] gg}
      (ee : αα = cell_transportb e ββ)
  : cell_transportf e αα = ββ.
Proof.
  apply cell_transportf_pathsinv0.
  apply pathsinv0.
  exact ee.
Defined.

Lemma cell_transportf_to_b
      {a b : C} {f g : C⟦a,b⟧}
      {α β : f ==> g}
      {e : α = β}
      {aa : D a} {bb : D b}
      {ff : aa -->[f] bb}
      {gg : aa -->[g] bb}
      {αα : ff ==>[α] gg}
      {ββ : ff ==>[β] gg}
      (ee : cell_transportf e αα = ββ)
  :  αα = cell_transportb e ββ.
Proof.
  apply pathsinv0.
  apply (transportf_pathsinv0 (λ x : f ==> g, ff ==>[ x] gg)).
  etrans.
  { apply maponpaths_2.
    apply pathsinv0inv0. }
  exact ee.
Defined.

End Cell_Transport.

(* ----------------------------------------------------------------------------------- *)
(** ** Operations on bicategories                                                      *)
(* ----------------------------------------------------------------------------------- *)

Section disp_prebicat.

Context {C : bicat}.

Local Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60).
Local Notation "f' <==[ x ] g'" := (disp_2cells x g' f') (at level 60, only parsing).

Definition disp_prebicat_ops (D : disp_prebicat_1_id_comp_cells C) : UU
  :=   (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        f' ==>[id2 _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        id_disp x ;; f' ==>[lunitor _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        f' ;; id_disp y ==>[runitor _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        id_disp x ;; f' <==[linvunitor _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        f' ;; id_disp y <==[rinvunitor _] f')
     × (∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧)
          (w : D a) (x : D b) (y : D c) (z : D d)
          (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z),
        (ff ;; gg) ;; hh ==>[rassociator _ _ _] ff ;; (gg ;; hh))
     × (∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧)
          (w : D a) (x : D b) (y : D c) (z : D d)
          (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z),
        ff ;; (gg ;; hh) ==>[lassociator _ _ _] (ff ;; gg) ;; hh)
     × (∏ (a b : C) (f g h : C⟦a,b⟧) (r : f ==> g) (s : g ==> h)
          (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y),
        ff ==>[r] gg  →  gg ==>[s] hh  →  ff ==>[r • s] hh)
     × (∏ (a b c : C) (f : C⟦a,b⟧) (g1 g2 : C⟦b,c⟧)
          (r : g1 ==> g2) (x : D a) (y : D b) (z : D c)
          (ff : x -->[f] y) (gg1 : y -->[g1] z) (gg2 : y -->[g2] z),
        gg1 ==>[r] gg2  →  ff ;; gg1  ==>[f ◃ r] ff ;; gg2)
     × (∏ (a b c : C) (f1 f2 : C⟦a,b⟧) (g : C⟦b,c⟧)
          (r : f1 ==> f2) (x : D a) (y : D b) (z : D c)
          (ff1 : x -->[f1] y) (ff2 : x -->[f2] y) (gg : y -->[g] z),
        ff1 ==>[r] ff2 → ff1 ;; gg ==>[r ▹ g] ff2 ;; gg).

Definition disp_prebicat_data : UU
  := ∑ D : disp_prebicat_1_id_comp_cells C, disp_prebicat_ops D.

Coercion disp_prebicat_ob_mor_cells_1_id_comp_from_disp_prebicat_data
         (D : disp_prebicat_data)
  : disp_prebicat_1_id_comp_cells C
  := pr1 D.

Coercion disp_prebicat_ops_from_disp_prebicat_data (D : disp_prebicat_data)
  : disp_prebicat_ops D
  := pr2 D.

(* ----------------------------------------------------------------------------------- *)
(** ** Data projections                                                                *)
(* ----------------------------------------------------------------------------------- *)

Section disp_prebicat_ops_projections.

Context {D : disp_prebicat_data}.

Definition disp_id2 {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : f' ==>[id2 _] f'
  := pr1 (pr2 D) a b f x y f'.

Definition disp_lunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : id_disp x ;; f' ==>[lunitor _] f'
  := pr1 (pr2 (pr2 D)) a b f x y f'.

Definition disp_runitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : f' ;; id_disp y ==>[runitor _] f'
  := pr1 (pr2 (pr2 (pr2 D))) _ _ f _ _ f'.

Definition disp_linvunitor
           {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : id_disp x ;; f' <==[linvunitor _] f'
  := pr1 (pr2 (pr2 (pr2 (pr2 D)))) _ _ f _ _ f'.

Definition disp_rinvunitor
           {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : f' ;; id_disp y <==[rinvunitor _] f'
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 D))))) _ _ f _ _ f'.

Definition disp_rassociator
           {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧}
       {w : D a} {x : D b} {y : D c} {z : D d}
       (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z)
  : (ff ;; gg) ;; hh ==>[rassociator _ _ _] ff ;; (gg ;; hh)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))) _ _ _ _ _ _ _ w _ _ _ ff gg hh.

Definition disp_lassociator
           {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z)
  : ff ;; (gg ;; hh) ==>[lassociator _ _ _] (ff ;; gg) ;; hh
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))) _ _ _ _ _ _ _ w _ _ _ ff gg hh.

Definition disp_vcomp2
           {a b : C} {f g h : C⟦a,b⟧}
           {r : f ==> g} {s : g ==> h}
           {x : D a} {y : D b}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y}
  : ff ==>[r] gg  →  gg ==>[s] hh  →  ff ==>[r • s] hh
  := λ rr ss,  pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))
                   _ _ _ _ _ _ _ _ _ _ _ _ rr ss.

Definition disp_lwhisker
           {a b c : C} {f : C⟦a,b⟧} {g1 g2 : C⟦b,c⟧}
           {r : g1 ==> g2}
           {x : D a} {y : D b} {z : D c}
           (ff : x -->[f] y) {gg1 : y -->[g1] z} {gg2 : y -->[g2] z}
  : gg1 ==>[r] gg2  →  ff ;; gg1  ==>[f ◃ r] ff ;; gg2
  := λ rr, pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))
               _ _ _ _ _ _ _ _ _ _ _ _ _ rr.

Definition disp_rwhisker
           {a b c : C} {f1 f2 : C⟦a,b⟧} {g : C⟦b,c⟧}
           {r : f1 ==> f2}
           {x : D a} {y : D b} {z : D c}
           {ff1 : x -->[f1] y} {ff2 : x -->[f2] y} (gg : y -->[g] z)
  : ff1 ==>[r] ff2 → ff1 ;; gg ==>[r ▹ g] ff2 ;; gg
  := λ rr, pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))
               _ _ _ _ _ _ _ _ _ _ _ _ _ rr.

End disp_prebicat_ops_projections.

Local Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60).
Local Notation "ff ◃◃ rr" := (disp_lwhisker ff rr) (at level 60).
Local Notation "rr ▹▹ gg" := (disp_rwhisker gg rr) (at level 60).

Section disp_prebicat_laws.

Context (D : disp_prebicat_data).

Definition disp_id2_left_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     disp_id2 _ •• ηη = transportb (λ α, _ ==>[α] _) (id2_left _) ηη.

Definition disp_id2_right_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     ηη •• disp_id2 _ = transportb (λ α, _ ==>[α] _) (id2_right _) ηη.

Definition disp_vassocr_law : UU
  := ∏ (a b : C) (f g h k : C⟦a,b⟧) (η : f ==> g) (φ : g ==> h) (ψ : h ==> k)
       (x : D a) (y : D b)
       (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y) (kk : x -->[k] y)
       (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk),
     ηη •• (φφ •• ψψ) =
     transportb (λ α, _ ==>[α] _) (vassocr _ _ _) ((ηη •• φφ) •• ψψ).

Definition disp_lwhisker_id2_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧)
       (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z),
     ff ◃◃ disp_id2 gg =
     transportb (λ α, _ ==>[α] _) (lwhisker_id2 _ _) (disp_id2 (ff ;; gg)).

Definition disp_id2_rwhisker_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧)
       (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z),
     disp_id2 ff ▹▹ gg =
     transportb (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 (ff ;; gg)).

Definition disp_lwhisker_vcomp_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g h i : C⟦b,c⟧)
      (η : g ==> h) (φ : h ==> i)
      (x : D a) (y : D b) (z : D c) (ff : x -->[f] y)
      (gg : y -->[g] z) (hh : y -->[h] z) (ii : y -->[i] z)
      (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii),
     (ff ◃◃ ηη) •• (ff ◃◃ φφ) =
     transportb (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) (ff ◃◃ (ηη •• φφ)).

Definition disp_rwhisker_vcomp_law : UU
  := ∏ (a b c : C) (f g h : C⟦a,b⟧) (i : C⟦b,c⟧) (η : f ==> g) (φ : g ==> h)
       (x : D a) (y : D b) (z : D c)
       (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y)
       (ii : y -->[i] z)
       (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh),
     (ηη ▹▹ ii) •• (φφ ▹▹ ii) =
     transportb (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη •• φφ) ▹▹ ii).

Definition disp_vcomp_lunitor_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     (id_disp _ ◃◃ ηη) •• disp_lunitor gg =
     transportb (λ α, _ ==>[α] _) (vcomp_lunitor _ _ _) (disp_lunitor ff •• ηη).

Definition disp_vcomp_runitor_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     (ηη ▹▹ id_disp _) •• disp_runitor gg =
     transportb (λ α, _ ==>[α] _) (vcomp_runitor _ _ _) (disp_runitor ff •• ηη).

Definition disp_lwhisker_lwhisker_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h i : c --> d) (η : h ==> i)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z)
       (ηη : hh ==>[η] ii),
     ff ◃◃ (gg ◃◃ ηη) •• disp_lassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (lwhisker_lwhisker _ _ _)
                (disp_lassociator _ _ _ •• (ff ;; gg ◃◃ ηη)).

Definition disp_rwhisker_lwhisker_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g h : C⟦b,c⟧) (i : c --> d) (η : g ==> h)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y) (hh : x -->[h] y) (ii : y -->[i] z)
       (ηη : gg ==>[η] hh),
     (ff ◃◃ (ηη ▹▹ ii)) •• disp_lassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (rwhisker_lwhisker _ _ _)
                (disp_lassociator _ _ _ •• ((ff ◃◃ ηη) ▹▹ ii)).

Definition disp_rwhisker_rwhisker_law : UU
  := ∏ (a b c d : C) (f g : C⟦a,b⟧) (h : C⟦b,c⟧) (i : c --> d) (η : f ==> g)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : w -->[g] x) (hh : x -->[h] y) (ii : y -->[i] z)
       (ηη : ff ==>[η] gg),
     disp_lassociator _ _ _ •• ((ηη ▹▹ hh) ▹▹ ii) =
     transportb (λ α, _ ==>[α] _) (rwhisker_rwhisker _ _ _)
                ((ηη ▹▹ hh ;; ii) •• disp_lassociator _ _ _).

Definition disp_vcomp_whisker_law : UU
  := ∏ (a b c : C) (f g : C⟦a,b⟧) (h i : C⟦b,c⟧)
       (η : f ==> g) (φ : h ==> i)
       (x : D a) (y : D b) (z : D c)
       (ff : x -->[f] y) (gg : x -->[g] y)
       (hh : y -->[h] z) (ii : y -->[i] z)
       (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii),
     (ηη ▹▹ hh) •• (gg ◃◃ φφ) =
     transportb (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ff ◃◃ φφ) •• (ηη ▹▹ ii)).

Definition disp_lunitor_linvunitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_lunitor ff •• disp_linvunitor _ =
     transportb (λ α, _ ==>[α] _) (lunitor_linvunitor _) (disp_id2 (id_disp _ ;; ff)).

Definition disp_linvunitor_lunitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_linvunitor ff •• disp_lunitor _ =
     transportb (λ α, _ ==>[α] _) (linvunitor_lunitor _) (disp_id2 _).

Definition disp_runitor_rinvunitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_runitor ff •• disp_rinvunitor _ =
     transportb (λ α, _ ==>[α] _) (runitor_rinvunitor _) (disp_id2 _).

Definition disp_rinvunitor_runitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_rinvunitor ff •• disp_runitor _ =
     transportb (λ α, _ ==>[α] _) (rinvunitor_runitor _) (disp_id2 _).

Definition disp_lassociator_rassociator_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y)
       (hh : y -->[h] z),
     disp_lassociator ff gg hh •• disp_rassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (lassociator_rassociator _ _ _ ) (disp_id2  _).

Definition disp_rassociator_lassociator_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y)
       (hh : y -->[h] z),
     disp_rassociator ff gg hh •• disp_lassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (rassociator_lassociator _ _ _ ) (disp_id2 _).

Definition disp_runitor_rwhisker_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧)
       (x : D a) (y : D b) (z : D c)
       (ff : x -->[f] y) (gg : y -->[g] z),
     disp_lassociator _ _ _ •• (disp_runitor ff ▹▹ gg) =
     transportb (λ α, _ ==>[α] _) (runitor_rwhisker _ _) (ff ◃◃ disp_lunitor gg).

Definition disp_lassociator_lassociator_law : UU
  := ∏ (a b c d e: C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d) (i : C⟦d,e⟧)
       (v : D a) (w : D b) (x : D c) (y : D d) (z : D e)
       (ff : v -->[f] w) (gg : w -->[g] x)
       (hh : x -->[h] y) (ii : y -->[i] z),

     (ff ◃◃ disp_lassociator gg hh ii) •• disp_lassociator _ _ _ ••
     (disp_lassociator _ _ _ ▹▹ ii) =
     transportb (λ α, _ ==>[α] _) (lassociator_lassociator _ _ _ _)
                (disp_lassociator ff gg _ •• disp_lassociator _ _ _).

(* ----------------------------------------------------------------------------------- *)
(** ** Laws                                                                            *)
(* ----------------------------------------------------------------------------------- *)

Definition disp_prebicat_laws : UU
  :=   disp_id2_left_law
     × disp_id2_right_law
     × disp_vassocr_law
     × disp_lwhisker_id2_law
     × disp_id2_rwhisker_law
     × disp_lwhisker_vcomp_law
     × disp_rwhisker_vcomp_law
     × disp_vcomp_lunitor_law
     × disp_vcomp_runitor_law
     × disp_lwhisker_lwhisker_law
     × disp_rwhisker_lwhisker_law
     × disp_rwhisker_rwhisker_law
     × disp_vcomp_whisker_law
     × disp_lunitor_linvunitor_law
     × disp_linvunitor_lunitor_law
     × disp_runitor_rinvunitor_law
     × disp_rinvunitor_runitor_law
     × disp_lassociator_rassociator_law
     × disp_rassociator_lassociator_law
     × disp_runitor_rwhisker_law
     × disp_lassociator_lassociator_law.

End disp_prebicat_laws.

(* ----------------------------------------------------------------------------------- *)
(** Laws projections                                                                   *)
(* ----------------------------------------------------------------------------------- *)

Definition disp_prebicat : UU
  := ∑ D : disp_prebicat_data, disp_prebicat_laws D.

Coercion disp_prebicat_data_from_disp_prebicat (D : disp_prebicat)
  : disp_prebicat_data
  := pr1 D.

Section disp_prebicat_law_projections.

Context {D : disp_prebicat}.

Definition disp_id2_left {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : disp_id2 _ •• ηη = transportb (λ α, _ ==>[α] _) (id2_left _) ηη
  := pr1 (pr2 D) _ _ _ _ _ x y ff gg ηη.

Definition disp_id2_right {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : ηη •• disp_id2 _ = transportb (λ α, _ ==>[α] _) (id2_right _) ηη
  := pr1 (pr2 (pr2 D)) _ _ _ _ _ _ _ _ _ ηη.

Definition disp_vassocr {a b : C} {f g h k : C⟦a,b⟧}
           {η : f ==> g} {φ : g ==> h} {ψ : h ==> k}
           {x : D a} {y : D b}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y}
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk)
  : ηη •• (φφ •• ψψ) =
    transportb (λ α, _ ==>[α] _) (vassocr _ _ _) ((ηη •• φφ) •• ψψ)
  := pr1 (pr2 (pr2 (pr2 D))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ ψψ .

Definition disp_vassocr' {a b : C} {f g h k : C⟦a,b⟧}
           {η : f ==> g} {φ : g ==> h} {ψ : h ==> k}
           {x : D a} {y : D b}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y}
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk)
  : transportf (λ α, _ ==>[α] _) (vassocr _ _ _) (ηη •• (φφ •• ψψ)) =
    ((ηη •• φφ) •• ψψ).
Proof.
  use (transportf_transpose_left (P := λ x' : f ==> k, ff ==>[x'] kk)).
  apply disp_vassocr.
Defined.

Definition disp_lwhisker_id2 {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z)
  : ff ◃◃ disp_id2 gg =
    transportb (λ α, _ ==>[α] _) (lwhisker_id2 _ _) (disp_id2 (ff ;; gg))
  := pr1 (pr2 (pr2 (pr2 (pr2 D)))) _ _ _ _ _ _ _ _ ff gg.

Definition disp_id2_rwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {x : D a} {y : D b} {z : D c}
           (ff : x -->[f] y) (gg : y -->[g] z)
  : disp_id2 ff ▹▹ gg =
    transportb (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 (ff ;; gg))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 D))))) _ _ _ _ _ _ _ _ ff gg.

Definition disp_lwhisker_vcomp {a b c : C} {f : C⟦a,b⟧} {g h i : C⟦b,c⟧}
           {η : g ==> h} {φ : h ==> i}
           {x : D a} {y : D b} {z : D c} {ff : x -->[f] y}
           {gg : y -->[g] z} {hh : y -->[h] z} {ii : y -->[i] z}
           (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii)
  : (ff ◃◃ ηη) •• (ff ◃◃ φφ) =
    transportb (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) (ff ◃◃ (ηη •• φφ))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ.

Definition disp_rwhisker_vcomp {a b c : C} {f g h : C⟦a,b⟧} {i : C⟦b,c⟧}
           {η : f ==> g} {φ : g ==> h}
           {x : D a} {y : D b} {z : D c}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {ii : y -->[i] z}
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh)
  : (ηη ▹▹ ii) •• (φφ ▹▹ ii) =
    transportb (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη •• φφ) ▹▹ ii)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))
         _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ.

Definition disp_vcomp_lunitor {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : (id_disp _ ◃◃ ηη) •• disp_lunitor gg =
    transportb (λ α, _ ==>[α] _) (vcomp_lunitor _ _ _) (disp_lunitor ff •• ηη)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))) _ _ _ _ _ _ _ _ _  ηη.

Definition disp_vcomp_runitor {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : (ηη ▹▹ id_disp _) •• disp_runitor gg =
    transportb (λ α, _ ==>[α] _) (vcomp_runitor _ _ _) (disp_runitor ff •• ηη)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))) _ _ _ _ _ _ _ _ _  ηη.

Definition disp_lwhisker_lwhisker {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {h i : c --> d} {η : h ==> i}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y) {hh : y -->[h] z} {ii : y -->[i] z}
           (ηη : hh ==>[η] ii)
  : ff ◃◃ (gg ◃◃ ηη) •• disp_lassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (lwhisker_lwhisker _ _ _)
               (disp_lassociator _ _ _ •• (ff ;; gg ◃◃ ηη))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))
         _ _ _ _ _ _ _ _ _  _ _ _ _ _ _ _ _ ηη.

Definition disp_rwhisker_lwhisker {a b c d : C} {f : C⟦a,b⟧} {g h : C⟦b,c⟧}
           {i : c --> d} {η : g ==> h}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) {gg : x -->[g] y} {hh : x -->[h] y} (ii : y -->[i] z)
           (ηη : gg ==>[η] hh)
  : (ff ◃◃ (ηη ▹▹ ii)) •• disp_lassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (rwhisker_lwhisker _ _ _)
               (disp_lassociator _ _ _ •• ((ff ◃◃ ηη) ▹▹ ii))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))
         _ _ _ _ _ _ _ _ _  _ _ _ _ _ _ _ _ ηη.

Definition disp_rwhisker_rwhisker {a b c d : C} {f g : C⟦a,b⟧} {h : C⟦b,c⟧}
           (i : c --> d) (η : f ==> g)
           {w : D a} {x : D b} {y : D c} {z : D d}
           {ff : w -->[f] x} {gg : w -->[g] x} (hh : x -->[h] y) (ii : y -->[i] z)
           (ηη : ff ==>[η] gg)
  : disp_lassociator _ _ _ •• ((ηη ▹▹ hh) ▹▹ ii) =
    transportb (λ α, _ ==>[α] _) (rwhisker_rwhisker _ _ _)
               ((ηη ▹▹ hh ;; ii) •• disp_lassociator _ _ _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))
         _ _ _ _ _ _ _ _ _  _ _ _ _ _ _ _ _ ηη.

Definition disp_vcomp_whisker {a b c : C} {f g : C⟦a,b⟧} {h i : C⟦b,c⟧}
           (η : f ==> g) (φ : h ==> i)
           (x : D a) (y : D b) (z : D c)
           (ff : x -->[f] y) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z)
           (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii)
  : (ηη ▹▹ hh) •• (gg ◃◃ φφ) =
    transportb (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ff ◃◃ φφ) •• (ηη ▹▹ ii))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ.

Definition disp_lunitor_linvunitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_lunitor ff •• disp_linvunitor _ =
    transportb (λ α, _ ==>[α] _) (lunitor_linvunitor _) (disp_id2 (id_disp _ ;; ff))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))
         _ _ _ _ _ ff.

Definition disp_linvunitor_lunitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_linvunitor ff •• disp_lunitor _ =
    transportb (λ α, _ ==>[α] _) (linvunitor_lunitor _) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))) _ _ _ _ _ ff.

Definition disp_runitor_rinvunitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_runitor ff •• disp_rinvunitor _ =
    transportb (λ α, _ ==>[α] _) (runitor_rinvunitor _) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))) _ _ _ _ _ ff.

Definition disp_rinvunitor_runitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_rinvunitor ff •• disp_runitor _ =
    transportb (λ α, _ ==>[α] _) (rinvunitor_runitor _) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))) _ _ _ _ _ ff.

Definition disp_lassociator_rassociator {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {h : c --> d} {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z)
  : disp_lassociator ff gg hh •• disp_rassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (lassociator_rassociator _ _ _ ) (disp_id2  _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ ff gg hh.

Definition disp_rassociator_lassociator
           {a b c d : C} (f : C⟦a,b⟧) {g : C⟦b,c⟧} {h : c --> d}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y)
           (hh : y -->[h] z)
  : disp_rassociator ff gg hh •• disp_lassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (rassociator_lassociator _ _ _ ) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ ff gg hh.

Definition disp_runitor_rwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z)
  : disp_lassociator _ _ _ •• (disp_runitor ff ▹▹ gg) =
    transportb (λ α, _ ==>[α] _) (runitor_rwhisker _ _) (ff ◃◃ disp_lunitor gg)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))))))
         _ _ _ _ _ _ _ _ ff gg.

Definition disp_lassociator_lassociator {a b c d e: C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {h : c --> d} {i : C⟦d,e⟧}
           {v : D a} {w : D b} {x : D c} {y : D d} {z : D e}
           (ff : v -->[f] w) (gg : w -->[g] x) (hh : x -->[h] y) (ii : y -->[i] z)
  : (ff ◃◃ disp_lassociator gg hh ii) •• disp_lassociator _ _ _ ••
    (disp_lassociator _ _ _ ▹▹ ii) =
    transportb (λ α, _ ==>[α] _) (lassociator_lassociator _ _ _ _)
               (disp_lassociator ff gg _ •• disp_lassociator _ _ _)
  := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ _ _ _ ff gg hh ii.

End disp_prebicat_law_projections.

Definition disp_hcomp
           {D : disp_prebicat}
           {b₁ b₂ b₃ : C}
           {f₁ f₂ : b₁ --> b₂}
           {g₁ g₂ : b₂ --> b₃}
           {α : f₁ ==> f₂}
           {β : g₁ ==> g₂}
           {bb₁ : D b₁}
           {bb₂ : D b₂}
           {bb₃ : D b₃}
           {ff₁ : bb₁ -->[ f₁ ] bb₂}
           {ff₂ : bb₁ -->[ f₂ ] bb₂}
           {gg₁ : bb₂ -->[ g₁ ] bb₃}
           {gg₂ : bb₂ -->[ g₂ ] bb₃}
           (αα : ff₁ ==>[ α ] ff₂)
           (ββ : gg₁ ==>[ β ] gg₂)
  : ff₁ ;; gg₁ ==>[ β ⋆⋆ α ] ff₂ ;; gg₂
  := (αα ▹▹ gg₁) •• (ff₂ ◃◃ ββ).

(* ----------------------------------------------------------------------------------- *)
(** ** Invertible displayed 2-cells.                                                   *)
(* ----------------------------------------------------------------------------------- *)

Lemma disp_vassocl {D : disp_prebicat} {a b : C} {f g h k : C⟦a,b⟧}
      {η : f ==> g} {φ : g ==> h} {ψ : h ==> k} {x : D a} {y : D b}
      {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y}
      (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk)
  : (ηη •• φφ) •• ψψ
    = transportb (λ α, _ ==>[α] _) (vassocl _ _ _) (ηη •• (φφ •• ψψ)).
Proof.
  apply (transportf_transpose_right (P := λ x', _ ==>[x'] _)).
  apply pathsinv0.
  etrans.
  { apply disp_vassocr. }
  apply maponpaths_2.
  unfold vassocl.
  apply pathsinv0, pathsinv0inv0.
Qed.

Section Display_Invertible_2cell.
  Context {D : disp_prebicat}.

  Section Def_inv_2cell.

  Context {c c' : C} {f f' : C⟦c,c'⟧} {d : D c} {d' : D c'}.

  Definition is_disp_invertible_2cell' {α : invertible_2cell f f'}
             {ff : d -->[f] d'} {ff' : d -->[f'] d'} (x : ff ==>[α] ff')
    : UU
    := ∑ (y : ff' ==>[α^-1] ff),
         (x •• y =
          transportb (λ α, _ ==>[α] _) (vcomp_rinv α)
                     (disp_id2 ff))
       × (y •• x =
          transportb (λ α, _ ==>[α] _) (vcomp_linv α)
                     (disp_id2 ff')).

  Definition is_disp_invertible_2cell {α : f ==> f'} (inv_α : is_invertible_2cell α)
             {ff : d -->[f] d'} {ff' : d -->[f'] d'} (x : ff ==>[α] ff')
    : UU
    := ∑ (y : ff' ==>[inv_α^-1] ff),
         (x •• y =
          transportb (λ α, _ ==>[α] _) (vcomp_rinv inv_α)
                     (disp_id2 ff))
       × (y •• x =
          transportb (λ α, _ ==>[α] _) (vcomp_linv inv_α)
                     (disp_id2 ff')).

  Definition disp_invertible_2cell (α : invertible_2cell f f')
             (ff : d -->[f] d') (ff' : d -->[f'] d')
    : UU
    := ∑ (x : ff ==>[α] ff'), is_disp_invertible_2cell α x.

  Coercion disp_cell_from_invertible_2cell {α : invertible_2cell f f'}
           {ff : d -->[f] d'} {ff' : d -->[f'] d'}
           (e : disp_invertible_2cell α ff ff')
    : ff ==>[α] ff'
    := pr1 e.

  Definition disp_inv_cell {α : invertible_2cell f f'}
             {ff : d -->[f] d'} {ff' : d -->[f'] d'}
             (e : disp_invertible_2cell α ff ff')
    : ff' ==>[α^-1] ff
    := pr1 (pr2 e).

  Definition disp_vcomp_rinv {α : invertible_2cell f f'}
             {ff : d -->[f] d'} {ff' : d -->[f'] d'}
             (e : disp_invertible_2cell α ff ff')
    : e •• disp_inv_cell e =
      transportb (λ α, _ ==>[α] _) (vcomp_rinv α) (disp_id2 ff)
    := pr1 (pr2 (pr2 e)).

  Definition disp_vcomp_linv {α : invertible_2cell f f'}
             {ff : d -->[f] d'} {ff' : d -->[f'] d'}
             (e : disp_invertible_2cell α ff ff')
    : disp_inv_cell e •• e =
      transportb (λ α, _ ==>[α] _) (vcomp_linv α) (disp_id2 ff')
    := pr2 (pr2 (pr2 e)).

  End Def_inv_2cell.

  Lemma disp_mor_transportf_postwhisker (a b : C) {x y z : C⟦a,b⟧} {f f' : x ==> y}
        (ef : f = f') {g : y ==> z} {aa : D a} {bb : D b}
        {xx : aa -->[x] bb} {yy} {zz} (ff : xx ==>[f] yy) (gg : yy ==>[g] zz)
    : (transportf (λ x, _ ==>[x] _) ef ff) •• gg
      = transportf (λ x, _ ==>[x] _) (maponpaths (λ h, h • g) ef) (ff •• gg).
  Proof.
    induction ef; apply idpath.
  Qed.

  Lemma disp_mor_transportf_prewhisker (a b : C) {x y z : C⟦a,b⟧}
        {f : x ==> y} {g g' : y ==> z} (ef : g = g')
        {aa : D a} {bb : D b}
        {xx : aa -->[x] bb} {yy} {zz} (ff : xx ==>[f] yy) (gg : yy ==>[g] zz)
    : ff •• (transportf (λ x, _ ==>[x] _) ef gg)
      = transportf (λ x, _ ==>[x] _) (maponpaths (λ h, f • h) ef) (ff •• gg).
  Proof.
    induction ef; apply idpath.
  Qed.

  Lemma disp_mor_transportf_prewhisker_gen (a b : C) {x y z : C⟦a,b⟧} {f : x ==> y}
        {A : UU} {t : A → y ==> z} {g g' : A} (ef : g = g')
        {aa : D a} {bb : D b}
        {xx : aa -->[x] bb} {yy} {zz} (ff : xx ==>[f] yy) (gg : yy ==>[t g] zz)
    : ff •• (transportf (λ x, _ ==>[t x] _) ef gg)
      = transportf (λ x, _ ==>[x] _) (maponpaths (λ h, f • t h) ef) (ff •• gg).
  Proof.
    induction ef; apply idpath.
  Qed.

  Lemma disp_lhs_right_invert_cell' {a b : C} {f g h : a --> b}
        {x : f ==> g} {y : invertible_2cell g h} {z : f ==> h}
        {p : x = z • y^-1}
        {aa : D a} {bb : D b}
        {ff : aa -->[f] bb}
        {gg : aa -->[g] bb}
        {hh : aa -->[h] bb}
        (xx : ff ==>[x] gg)
        (yy : gg ==>[y] hh)
        (zz : ff ==>[z] hh)
        (H : is_disp_invertible_2cell y yy)
        (q := lhs_right_invert_cell _ _ _ _ p)
        (pp : xx = transportb (λ x, _ ==>[x] _) p (zz •• disp_inv_cell (yy,,H)))
    : xx •• yy = transportb (λ x, _ ==>[x] _) q zz.
  Proof.
    set (yy' := (yy,,H) : disp_invertible_2cell _ _ _).
    etrans. { apply maponpaths_2. apply pp. }
    etrans. { apply disp_mor_transportf_postwhisker. }
    etrans. { apply maponpaths. apply disp_vassocl. }
    etrans. { unfold transportb. apply (transport_f_f (λ x' : f ==> h, ff ==>[x'] hh)). }
    etrans. { apply maponpaths. apply maponpaths.
              apply disp_vcomp_linv. }
    etrans. { apply maponpaths.
              apply disp_mor_transportf_prewhisker. }
    etrans. { unfold transportb. apply (transport_f_f (λ x' : f ==> h, ff ==>[x'] hh)). }
    etrans. { apply maponpaths.
              apply disp_id2_right. }
    etrans. { unfold transportb. apply (transport_f_f (λ x' : f ==> h, ff ==>[x'] hh)). }
    unfold transportb.
    apply maponpaths_2.
    apply cellset_property.
  Qed.

  Lemma disp_lhs_right_invert_cell {a b : C} {f g h : a --> b}
        {x : f ==> g} {y : g ==> h} {z : f ==> h}
        (inv_y : is_invertible_2cell y)
        {aa : D a} {bb : D b}
        {ff : aa -->[f] bb}
        {gg : aa -->[g] bb}
        {hh : aa -->[h] bb}
        (xx : ff ==>[x] gg)
        (yy : gg ==>[y] hh)
        (zz : ff ==>[z] hh)
        (H : is_disp_invertible_2cell inv_y yy)
        (q : x • y = z)
        (p  := rhs_right_inv_cell _ _ _ inv_y q : x = z • inv_y^-1)
        (pp : xx =
              transportb
                (λ x, _ ==>[x] _) p
                (zz •• disp_inv_cell ((yy,,H):disp_invertible_2cell (y,,inv_y) gg hh)))
    : xx •• yy = transportb (λ x, _ ==>[x] _) q zz.
  Proof.
    etrans.
    { use (disp_lhs_right_invert_cell' _ _ _ _ pp). }
    apply maponpaths_2.
    apply cellset_property.
  Qed.

  Lemma disp_lhs_left_invert_cell {a b : C} {f g h : a --> b}
        {x : f ==> g} {y : g ==> h} {z : f ==> h} {inv_x : is_invertible_2cell x}
        {aa : D a} {bb : D b}
        {ff : aa -->[f] bb}
        {gg : aa -->[g] bb}
        {hh : aa -->[h] bb}
        (xx : ff ==>[x] gg)
        (yy : gg ==>[y] hh)
        (zz : ff ==>[z] hh)
        (inv_xx : is_disp_invertible_2cell inv_x xx)
        (q :  x • y = z)
        (p := rhs_left_inv_cell _ _ _ inv_x q : y = inv_x^-1 • z)
        (pp : yy =
              transportb
                (λ x, _ ==>[x] _) p
                (disp_inv_cell ((xx,,inv_xx):disp_invertible_2cell (x,,inv_x) ff gg) •• zz))
    : xx •• yy = transportb (λ x, _ ==>[x] _) q zz.
  Proof.
    etrans. { apply maponpaths. apply pp. }
    etrans.
    { apply disp_mor_transportf_prewhisker. }
    etrans. { apply maponpaths.
              apply disp_vassocr. }
    etrans. { apply (transport_f_f (λ x, _ ==>[x] _)). }
    etrans. { apply maponpaths.
              apply maponpaths_2.
              apply (disp_vcomp_rinv
                       ((xx,,inv_xx):disp_invertible_2cell (x,,inv_x) _ _)). }
    etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. }
    etrans. { unfold transportb. apply (transport_f_f (λ x, _ ==>[x] _)). }
    etrans. { apply maponpaths. apply disp_id2_left. }
    etrans. { unfold transportb. apply (transport_f_f (λ x, _ ==>[x] _)). }
    unfold transportb.
    apply maponpaths_2. apply cellset_property.
  Qed.

End Display_Invertible_2cell.

(* ----------------------------------------------------------------------------------- *)
(** ** Derived laws                                                                    *)
(* ----------------------------------------------------------------------------------- *)

Section Derived_Laws.

Context {D : disp_prebicat}.

Definition is_disp_invertible_2cell_lassociator {a b c d : C}
           {f1 : C⟦a,b⟧} {f2 : C⟦b,c⟧} {f3 : C⟦c,d⟧}
           {aa : D a} {bb : D b} {cc : D c} {dd : D d}
           (ff1 : aa -->[f1] bb)
           (ff2 : bb -->[f2] cc)
           (ff3 : cc -->[f3] dd)
  : is_disp_invertible_2cell (is_invertible_2cell_lassociator _ _ _)
                             (disp_lassociator ff1 ff2 ff3).
Proof.
  exists (disp_rassociator ff1 ff2 ff3).
  split.
  - apply disp_lassociator_rassociator.
  - apply disp_rassociator_lassociator.
Defined.

Definition is_disp_invertible_2cell_rassociator {a b c d : C}
           {f1 : C⟦a,b⟧} {f2 : C⟦b,c⟧} {f3 : C⟦c,d⟧}
           {aa : D a} {bb : D b} {cc : D c} {dd : D d}
           (ff1 : aa -->[f1] bb)
           (ff2 : bb -->[f2] cc)
           (ff3 : cc -->[f3] dd)
  : is_disp_invertible_2cell (is_invertible_2cell_rassociator _ _ _)
                             (disp_rassociator ff1 ff2 ff3).
Proof.
  exists (disp_lassociator ff1 ff2 ff3).
  split.
  - apply disp_rassociator_lassociator.
  - apply disp_lassociator_rassociator.
Defined.

Lemma disp_lassociator_to_rassociator_post' {a b c d : C}
      {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧} {k : C⟦a,d⟧}
      {x : k ==> (f · g) · h}
      {y : k ==> f · (g · h)}
      (p : x = y • lassociator f g h)
      {aa : D a} {bb : D b} {cc : D c} {dd : D d}
      {ff : aa -->[f] bb}
      {gg : bb -->[g] cc}
      {hh : cc -->[h] dd}
      {kk : aa -->[k] dd}
      (xx : kk ==>[x] (ff ;; gg) ;; hh)
      (yy : kk ==>[y] ff ;; (gg ;; hh))
      (q := lassociator_to_rassociator_post x y p)
      (pp : xx = transportb (λ x, _ ==>[x] _) p (yy •• disp_lassociator ff gg hh))
  : xx •• disp_rassociator ff gg hh = transportb (λ x, _ ==>[x] _) q (yy).
Proof.
  etrans.
  { use disp_lhs_right_invert_cell.
    - exact y.
    - apply is_invertible_2cell_rassociator.
    - exact yy.
    - apply is_disp_invertible_2cell_rassociator.
    - apply lassociator_to_rassociator_post. exact p.
    - cbn. etrans. { apply pp. }
      apply maponpaths_2.
      apply cellset_property.
  }
  apply maponpaths_2. apply cellset_property.
Qed.

Lemma disp_lassociator_to_rassociator_post {a b c d : C}
      {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧} {k : C⟦a,d⟧}
      {x : k ==> (f · g) · h}
      {y : k ==> f · (g · h)}
      {aa : D a} {bb : D b} {cc : D c} {dd : D d}
      {ff : aa -->[f] bb}
      {gg : bb -->[g] cc}
      {hh : cc -->[h] dd}
      {kk : aa -->[k] dd}
      (xx : kk ==>[x] (ff ;; gg) ;; hh)
      (yy : kk ==>[y] ff ;; (gg ;; hh))
      (q : x • rassociator f g h = y)
      (p := rassociator_to_lassociator_post _ _ q : x = y • lassociator f g h)
      (pp : xx = transportb (λ x, _ ==>[x] _) p (yy •• disp_lassociator ff gg hh))
  : xx •• disp_rassociator ff gg hh = transportb (λ x, _ ==>[x] _) q (yy).
Proof.
  etrans.
  { use disp_lassociator_to_rassociator_post'.
    - exact y.
    - exact p.
    - exact yy.
    - exact pp.
  }
  apply maponpaths_2. apply cellset_property.
Qed.

Lemma disp_lassociator_to_rassociator_pre {a b c d : C}
      {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c, d⟧} {k : C⟦a,d⟧}
      {x : f · (g · h) ==> k}
      {y : (f · g) · h ==> k}
      {aa : D a} {bb : D b} {cc : D c} {dd : D d}
      {ff : aa -->[f] bb}
      {gg : bb -->[g] cc}
      {hh : cc -->[h] dd}
      {kk : aa -->[k] dd}
      (xx : ff ;; (gg ;; hh) ==>[x] kk)
      (yy : (ff ;; gg) ;; hh ==>[y] kk)
      (q : rassociator f g h • x = y)
      (p := rassociator_to_lassociator_pre _ _ q : x = lassociator f g h • y)
      (pp : xx = transportb (λ x, _ ==>[x] _) p (disp_lassociator ff gg hh •• yy))
  : disp_rassociator ff gg hh •• xx = transportb (λ x, _ ==>[x] _) q (yy).
Proof.
  etrans.
  { use disp_lhs_left_invert_cell.
    - exact y.
    - apply is_invertible_2cell_rassociator.
    - exact yy.
    - apply is_disp_invertible_2cell_rassociator.
    - apply lassociator_to_rassociator_pre. exact p.
    - cbn. etrans. { apply pp. }
      apply maponpaths_2.
      apply cellset_property.
  }
  apply maponpaths_2.
  apply cellset_property.
Qed.

Lemma disp_lunitor_lwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
      {aa : D a} {bb : D b} {cc : D c}
      (ff : aa -->[f] bb)
      (gg : bb -->[g] cc)
  : (disp_rassociator _ _ _ •• (ff ◃◃ disp_lunitor gg)) =
    transportb (λ α, _ ==>[α] _) (lunitor_lwhisker _ _)
               (disp_runitor ff ▹▹ gg).
Proof.
  etrans.
  { use disp_lassociator_to_rassociator_pre.
    - exact (runitor f ▹ g).
    - exact (disp_runitor ff ▹▹ gg).
    - apply lunitor_lwhisker.
    - apply pathsinv0.
      etrans.
      { apply maponpaths. apply disp_runitor_rwhisker. }
      etrans.
      { apply (transport_f_f (λ α, _ ==>[α] _)). }
      apply (transportf_set (λ α, _ ==>[α] _)).
      apply cellset_property.
  }
  apply maponpaths_2, cellset_property.
Qed.

Lemma disp_rwhisker_transport_left {a b c : C}
      {f1 f2 : C⟦a,b⟧} {g : C⟦b,c⟧}
      {x x' : f1 ==> f2} (p : x = x')
      {aa : D a} {bb : D b} {cc : D c}
      {ff1 : aa -->[f1] bb}
      {ff2 : aa -->[f2] bb}
      (xx : ff1 ==>[x] ff2)
      (gg : bb -->[g] cc)
  : (transportf (λ x, _ ==>[x] _) p xx) ▹▹ gg =
    transportf (λ x, _ ==>[x ▹ g] _) p (xx ▹▹ gg).
Proof.
  induction p. apply idpath.
Defined.

Lemma disp_rwhisker_transport_left_new {a b c : C}
      {f1 f2 : C⟦a,b⟧} {g : C⟦b,c⟧}
      {x x' : f1 ==> f2} (p : x = x')
      {aa : D a} {bb : D b} {cc : D c}
      {ff1 : aa -->[f1] bb}
      {ff2 : aa -->[f2] bb}
      (xx : ff1 ==>[x] ff2)
      (gg : bb -->[g] cc)
  : (transportf (λ x, _ ==>[x] _) p xx) ▹▹ gg =
    transportf (λ x, _ ==>[x] _) (maponpaths (λ x, x ▹ g) p) (xx ▹▹ gg).
Proof.
  induction p. apply idpath.
Defined.

Lemma disp_rwhisker_transport_right {a b c : C}
      {f : C⟦a,b⟧} {g1 g2 : C⟦b,c⟧}
      {x x' : g1 ==> g2} (p : x = x')
      {aa : D a} {bb : D b} {cc : D c}
      {ff : aa -->[f] bb}
      (gg1 : bb -->[g1] cc)
      (gg2 : bb -->[g2] cc)
      (xx : gg1 ==>[x] gg2)
  : ff ◃◃ (transportf (λ x, _ ==>[x] _) p xx) =
    transportf (λ x, _ ==>[x] _) (maponpaths (λ x, f ◃ x) p) (ff ◃◃ xx).
Proof.
  induction p. apply idpath.
Defined.

Definition disp_lwhisker_vcomp_alt
           {a b c : C} {f : C⟦a,b⟧} {g h i : C⟦b,c⟧}
           {η : g ==> h} {φ : h ==> i}
           {x : D a} {y : D b} {z : D c} {ff : x -->[f] y}
           {gg : y -->[g] z} {hh : y -->[h] z} {ii : y -->[i] z}
           (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii)
  : ff ◃◃ (ηη •• φφ)
    =
    transportf (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) ((ff ◃◃ ηη) •• (ff ◃◃ φφ)).
Proof.
  refine (!_).
  apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)).
  apply disp_lwhisker_vcomp.
Qed.

Definition disp_rwhisker_vcomp_alt
           {a b c : C} {f g h : C⟦a,b⟧} {i : C⟦b,c⟧}
           {η : f ==> g} {φ : g ==> h}
           {x : D a} {y : D b} {z : D c}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {ii : y -->[i] z}
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh)
  : (ηη •• φφ) ▹▹ ii
    =
    transportf (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη ▹▹ ii) •• (φφ ▹▹ ii)).
Proof.
  refine (!_).
  apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)).
  apply disp_rwhisker_vcomp.
Qed.

Definition disp_vcomp_whisker_alt
           {a b c : C} {f g : C⟦a,b⟧} {h i : C⟦b,c⟧}
           (η : f ==> g) (φ : h ==> i)
           (x : D a) (y : D b) (z : D c)
           (ff : x -->[f] y) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z)
           (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii)
  : (ff ◃◃ φφ) •• (ηη ▹▹ ii)
    =
    transportf (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ηη ▹▹ hh) •• (gg ◃◃ φφ)).
Proof.
  refine (!_).
  apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)).
  apply disp_vcomp_whisker.
Qed.

Definition disp_id2_rwhisker_alt
           {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {x : D a} {y : D b} {z : D c}
           (ff : x -->[f] y) (gg : y -->[g] z)
  : transportf (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 ff ▹▹ gg)
    =
    disp_id2 (ff ;; gg).
Proof.
  apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)).
  apply disp_id2_rwhisker.
Qed.

Definition disp_vcomp_runitor_alt
           {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : disp_runitor ff •• ηη
    =
    transportf
      (λ α, _ ==>[α] _)
      (vcomp_runitor _ _ _)
      ((ηη ▹▹ id_disp _) •• disp_runitor gg).
Proof.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    apply disp_vcomp_runitor.
  }
  apply (transportfbinv (λ z, _ ==>[ z ] _) _ _).
Qed.

Definition disp_vcomp_lcancel
           {b₁ b₂ : C}
           {f g h : b₁ --> b₂}
           {α : f ==> g}
           {β : g ==> h}
           (Hα : is_invertible_2cell α)
           {bb₁ : D b₁}
           {bb₂ : D b₂}
           {ff : bb₁ -->[ f ] bb₂}
           {gg : bb₁ -->[ g ] bb₂}
           {hh : bb₁ -->[ h ] bb₂}
           {αα : ff ==>[ α ] gg}
           {ββ₁ ββ₂ : gg ==>[ β ] hh}
           (Hαα : is_disp_invertible_2cell Hα αα)
           (p : αα •• ββ₁ = αα •• ββ₂)
  : ββ₁ = ββ₂.
Proof.
  pose (αα_cell := (αα ,, Hαα) : disp_invertible_2cell (make_invertible_2cell Hα) ff gg).
  assert (q := maponpaths (λ z, disp_inv_cell αα_cell •• z) p).
  cbn in q.
  rewrite !disp_vassocr in q.
  pose (disp_vcomp_linv αα_cell) as z.
  cbn in z.
  rewrite !z in q.
  unfold transportb in q.
  rewrite !disp_mor_transportf_postwhisker in q.
  rewrite !transport_f_f in q.
  rewrite !disp_id2_left in q.
  unfold transportb in q.
  rewrite !transport_f_f in q.
  pose (q' := @transportb_transpose_right
                _
                (λ z, _ ==>[ z ] _)
                _ _ _ _ _
                q).
  rewrite transportbfinv in q'.
  exact q'.
Qed.

Definition disp_vcomp_rcancel
           {b₁ b₂ : C}
           {f g h : b₁ --> b₂}
           {α : f ==> g}
           {β : g ==> h}
           (Hβ : is_invertible_2cell β)
           {bb₁ : D b₁}
           {bb₂ : D b₂}
           {ff : bb₁ -->[ f ] bb₂}
           {gg : bb₁ -->[ g ] bb₂}
           {hh : bb₁ -->[ h ] bb₂}
           {αα₁ : ff ==>[ α ] gg}
           {αα₂ : ff ==>[ α ] gg}
           {ββ : gg ==>[ β ] hh}
           (Hββ : is_disp_invertible_2cell Hβ ββ)
           (p : αα₁ •• ββ = αα₂ •• ββ)
  : αα₁ = αα₂.
Proof.
  assert (q := maponpaths (λ z, z •• pr1 Hββ) p).
  cbn in q.
  rewrite !disp_vassocl in q.
  rewrite !(pr12 Hββ) in q.
  unfold transportb in q.
  rewrite !disp_mor_transportf_prewhisker in q.
  rewrite !transport_f_f in q.
  rewrite !disp_id2_right in q.
  unfold transportb in q.
  rewrite !transport_f_f in q.
  pose (q' := @transportb_transpose_right
                _
                (λ z, _ ==>[ z ] _)
                _ _ _ _ _
                q).
  rewrite transportbfinv in q'.
  exact q'.
Qed.

Definition disp_id2_left_alt
           {x y : C}
           {f g : x --> y}
           {η : f ==> g}
           {xx : D x}
           {yy : D y}
           {ff : xx -->[ f ] yy}
           {gg : xx -->[ g ] yy}
           (ηη : ff ==>[ η ] gg)
  : ηη
    =
    transportf (λ z, ff ==>[ z ] gg) (id2_left η) (disp_id2 ff •• ηη).
Proof.
  exact (!(@transportf_transpose_left
             _
             (λ z, _ ==>[ z ] _)
             _ _
             _
             _ _
             (disp_id2_left ηη))).
Qed.

Definition disp_rwhisker_rwhisker_rassociator
           {w x y z : C}
           {f₁ f₂ : w --> x}
           {α : f₁ ==> f₂}
           {g : x --> y}
           {h : y --> z}
           {ww : D w}
           {xx : D x}
           {yy : D y}
           {zz : D z}
           {ff₁ : ww -->[ f₁ ] xx}
           {ff₂ : ww -->[ f₂ ] xx}
           (αα : ff₁ ==>[ α ] ff₂)
           (gg : xx -->[ g ] yy)
           (hh : yy -->[ h ] zz)
  : transportb
      (λ z, _ ==>[ z ] _)
      (rwhisker_rwhisker_alt h g α)
      (disp_rassociator ff₁ gg hh •• (αα ▹▹ (gg ;; hh)))
    =
    (αα ▹▹ gg ▹▹ hh) •• disp_rassociator ff₂ gg hh.
Proof.
  refine (!_).
  refine (disp_id2_left_alt _ @ _).
  etrans.
  {
    apply maponpaths.
    apply maponpaths_2.
    exact (!(@transportf_transpose_left
               _
               (λ z, _ ==>[ z ] _)
               _ _
               _
               _ _
               (disp_rassociator_lassociator _ ff₁ gg hh))).
  }
  rewrite disp_mor_transportf_postwhisker.
  rewrite transport_f_f.
  rewrite !disp_vassocl.
  unfold transportb.
  rewrite transport_f_f.
  etrans.
  {
    do 2 apply maponpaths.
    rewrite disp_vassocr.
    rewrite disp_rwhisker_rwhisker.
    unfold transportb.
    rewrite disp_mor_transportf_postwhisker.
    rewrite transport_f_f.
    rewrite !disp_vassocl.
    rewrite disp_lassociator_rassociator.
    unfold transportb.
    rewrite disp_mor_transportf_prewhisker.
    rewrite disp_id2_right.
    unfold transportb.
    rewrite !transport_f_f.
    apply idpath.
  }
  rewrite disp_mor_transportf_prewhisker.
  rewrite transport_f_f.
  apply maponpaths_2.
  apply cellset_property.
Qed.

End Derived_Laws.

(* ----------------------------------------------------------------------------------- *)
(** ** Total bicategory of a displayed bicategory                                      *)
(* ----------------------------------------------------------------------------------- *)

Section total_prebicat.

Variable D : disp_prebicat.

Definition total_prebicat_1_data : precategory_data
  := total_category_ob_mor D ,, total_category_id_comp D.

Definition total_prebicat_cell_struct : prebicat_2cell_struct (total_category_ob_mor D)
  := λ a b f g, ∑ η : pr1 f ==> pr1 g, pr2 f ==>[η] pr2 g.

Definition total_prebicat_1_id_comp_cells : prebicat_1_id_comp_cells
  := (total_prebicat_1_data,, total_prebicat_cell_struct).

Definition total_prebicat_2_id_comp_struct
  : prebicat_2_id_comp_struct total_prebicat_1_id_comp_cells.
Proof.
  repeat split; cbn; unfold total_prebicat_cell_struct.
  - intros. exists (id2 _). exact (disp_id2 _).
  - intros. exists (lunitor _). exact (disp_lunitor _).
  - intros. exists (runitor _). exact (disp_runitor _).
  - intros. exists (linvunitor _). exact (disp_linvunitor _).
  - intros. exists (rinvunitor _). exact (disp_rinvunitor _).
  - intros. exists (rassociator _ _ _).
    exact (disp_rassociator _ _ _).
  - intros. exists (lassociator _ _ _).
    exact (disp_lassociator _ _ _).
  - intros a b f g h r s. exists (pr1 r • pr1 s).
    exact (pr2 r •• pr2 s).
  - intros a b d f g1 g2 r. exists (pr1 f ◃ pr1 r).
    exact (pr2 f ◃◃ pr2 r).
  - intros a b c f1 f2 g r. exists (pr1 r ▹ pr1 g).
    exact (pr2 r ▹▹ pr2 g).
Defined.

Definition total_prebicat_data : prebicat_data
  := _ ,, total_prebicat_2_id_comp_struct.

Lemma total_prebicat_laws : prebicat_laws total_prebicat_data.
Proof.
  repeat split; intros.
  - use total2_paths_b.
    + apply id2_left.
    + apply disp_id2_left.
  - use total2_paths_b.
    + apply id2_right.
    + apply disp_id2_right.
  - use total2_paths_b.
    + apply vassocr.
    + apply disp_vassocr.
  - use total2_paths_b.
    + apply lwhisker_id2.
    + apply disp_lwhisker_id2.
  - use total2_paths_b.
    + apply id2_rwhisker.
    + apply disp_id2_rwhisker.
  - use total2_paths_b.
    + apply lwhisker_vcomp.
    + apply disp_lwhisker_vcomp.
  - use total2_paths_b.
    + apply rwhisker_vcomp.
    + apply disp_rwhisker_vcomp.
  - use total2_paths_b.
    + apply vcomp_lunitor.
    + apply disp_vcomp_lunitor.
  - use total2_paths_b.
    + apply vcomp_runitor.
    + apply disp_vcomp_runitor.
  - use total2_paths_b.
    + apply lwhisker_lwhisker.
    + apply disp_lwhisker_lwhisker.
  - use total2_paths_b.
    + apply rwhisker_lwhisker.
    + apply disp_rwhisker_lwhisker.
  - use total2_paths_b.
    + apply rwhisker_rwhisker.
    + apply disp_rwhisker_rwhisker.
  - use total2_paths_b.
    + apply vcomp_whisker.
    + apply disp_vcomp_whisker.
  - use total2_paths_b.
    + apply lunitor_linvunitor.
    + apply disp_lunitor_linvunitor.
  - use total2_paths_b.
    + apply linvunitor_lunitor.
    + apply disp_linvunitor_lunitor.
  - use total2_paths_b.
    + apply runitor_rinvunitor.
    + apply disp_runitor_rinvunitor.
  - use total2_paths_b.
    + apply rinvunitor_runitor.
    + apply disp_rinvunitor_runitor.
  - use total2_paths_b.
    + apply lassociator_rassociator.
    + apply disp_lassociator_rassociator.
  - use total2_paths_b.
    + apply rassociator_lassociator.
    + apply disp_rassociator_lassociator.
  - use total2_paths_b.
    + apply runitor_rwhisker.
    + apply disp_runitor_rwhisker.
  - use total2_paths_b.
    + apply lassociator_lassociator.
    + apply disp_lassociator_lassociator.
Defined.

Definition total_prebicat : prebicat := _ ,, total_prebicat_laws.
End total_prebicat.

Definition has_disp_cellset (D : disp_prebicat) : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (x : f ==> g)
       (aa : D a) (bb : D b)
       (ff : aa -->[f] bb)
       (gg : aa -->[g] bb),
     isaset (ff ==>[x] gg).

Definition disp_bicat : UU
  := ∑ D : disp_prebicat, has_disp_cellset D.

Coercion disp_prebicat_of_disp_bicat (D : disp_bicat)
  : disp_prebicat
  := pr1 D.

Definition disp_cellset_property (D : disp_bicat)
  : has_disp_cellset D
  := pr2 D.

Lemma isaset_cells_total_prebicat (D : disp_bicat)
  : isaset_cells (total_prebicat D).
Proof.
red.
cbn.
intros.
unfold total_prebicat_cell_struct.
apply isaset_total2.
- apply cellset_property.
- intros.
  apply disp_cellset_property.
Qed.

Definition total_bicat (D : disp_bicat) : bicat
  := total_prebicat D,, isaset_cells_total_prebicat D.

End disp_prebicat.

Arguments disp_prebicat_1_id_comp_cells _ : clear implicits.
Arguments disp_prebicat_data _ : clear implicits.
Arguments disp_prebicat _ : clear implicits.
Arguments disp_bicat _ : clear implicits.

(* ----------------------------------------------------------------------------------- *)
(** ** Displayed left and right unitors coincide on the identity                       *)
(* ----------------------------------------------------------------------------------- *)

Theorem disp_lunitor_runitor_identity {C : bicat} {D : disp_bicat C} (a : C) (aa : D a)
  : disp_lunitor (id_disp aa) =
    cell_transportb (lunitor_runitor_identity a) (disp_runitor (id_disp aa)).
Proof.
  set (TT := fiber_paths (lunitor_runitor_identity (C := total_bicat D) (a ,, aa))).
  cbn in TT.
  apply cell_transportf_to_b.
  etrans.
  2: now apply TT.
  unfold cell_transportf.
  apply maponpaths_2.
  apply cellset_property.
Qed.

Theorem disp_runitor_lunitor_identity {C : bicat} {D : disp_bicat C} {a : C} (aa : D a)
  : disp_runitor (id_disp aa) =
    transportb (λ x, disp_2cells x _ _) (runitor_lunitor_identity a)
               (disp_lunitor (id_disp aa)).
Proof.
  apply (transportf_transpose_right (P := (λ x, disp_2cells x _ _))).
  apply pathsinv0.
  etrans.
  1: now apply disp_lunitor_runitor_identity.
  unfold cell_transportb.
  apply maponpaths_2, cellset_property.
Qed.

Lemma adjequiv_base_adjequiv_tot
      {B : bicat}
      (HB : is_univalent_2_0 B)
      {D : disp_bicat B}
      {a b : B}
  : adjoint_equivalence a b → ∏ (aa : D a), ∑ (bb : D b), @adjoint_equivalence (total_bicat D) (a ,, aa) (b ,, bb).
Proof.
  use (J_2_0 HB (λ _ _ _, _)).
  intros c aa.
  exact (aa ,, internal_adjoint_equivalence_identity _).
Defined.

(* ----------------------------------------------------------------------------------- *)
(** ** Useful properties                                                               *)
(* ----------------------------------------------------------------------------------- *)

Definition disp_2cells_isaprop
           {B : bicat} (D : disp_prebicat_1_id_comp_cells B)
  := ∏ (a b : B) (f g : a --> b) (x : f ==> g)
       (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb),
     isaprop (disp_2cells x ff gg).

Definition disp_locally_groupoid
           {B : bicat} (D : disp_bicat B)
  := ∏ (a b : B) (f g : a --> b) (x : invertible_2cell f g)
       (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb)
       (xx : disp_2cells x ff gg), is_disp_invertible_2cell x xx.

Definition disp_locally_sym
           {B : bicat} (D : disp_bicat B)
  := ∏ (a b : B) (f g : a --> b) (x : invertible_2cell f g)
       (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb)
       (xx : disp_2cells x ff gg), disp_2cells (x^-1) gg ff.

Definition make_disp_locally_groupoid
           {B : bicat} (D : disp_bicat B)
           (H : disp_locally_sym D)
           (HD : disp_2cells_isaprop D)
  : disp_locally_groupoid D.
Proof.
  intros a b f g x aa bb ff gg xx.
  use tpair.
  - apply H.
    exact xx.
  - split; apply HD.
Defined.

Definition disp_locally_groupoid_over_id
           {B : bicat} (D : disp_bicat B)
  : UU
  := ∏ (a b : B)
       (f : B ⟦ a, b ⟧)
       (aa : D a)
       (bb : D b)
       (ff gg : aa -->[ f] bb)
       (xx : disp_2cells (id2_invertible_2cell f) ff gg),
     is_disp_invertible_2cell (is_invertible_2cell_id₂ f) xx.

Definition make_disp_locally_groupoid_univalent_2_1
           {B : bicat} (D : disp_bicat B)
           (HD : disp_locally_groupoid_over_id D)
           (HB : is_univalent_2_1 B)
  : disp_locally_groupoid D.
Proof.
  use (J_2_1 HB).
  exact HD.
Defined.

Section HomDisplayedCategory.
  Context {B : bicat}
          {D : disp_bicat B}.

  Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60).
  Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60).

  Definition disp_hom_ob_mor
             {x y : B}
             (xx : D x)
             (yy : D y)
  : disp_cat_ob_mor (hom x y).
  Proof.
    simple refine (_ ,, _).
    - exact (λ f, xx -->[ f ] yy).
    - exact (λ f g ff gg α, ff ==>[ α ] gg).
  Defined.

  Definition disp_hom_id_comp
             {x y : B}
             (xx : D x)
             (yy : D y)
    : disp_cat_id_comp _ (disp_hom_ob_mor xx yy).
  Proof.
    simple refine (_ ,, _).
    - exact (λ f ff, disp_id2 ff).
    - exact (λ f g h α β ff gg hh αα ββ, αα •• ββ).
  Defined.

  Definition disp_hom_data
             {x y : B}
             (xx : D x)
             (yy : D y)
    : disp_cat_data (hom x y).
  Proof.
    simple refine (_ ,, _).
    - exact (disp_hom_ob_mor xx yy).
    - exact (disp_hom_id_comp xx yy).
  Defined.

  Definition disp_hom_laws
             {x y : B}
             (xx : D x)
             (yy : D y)
    : disp_cat_axioms _ (disp_hom_data xx yy).
  Proof.
    repeat split ; intro ; intros ; cbn.
    - rewrite disp_id2_left.
      apply maponpaths_2.
      apply cellset_property.
    - rewrite disp_id2_right.
      apply maponpaths_2.
      apply cellset_property.
    - rewrite disp_vassocr.
      apply maponpaths_2.
      apply cellset_property.
    - apply D.
  Qed.

  Definition disp_hom
             {x y : B}
             (xx : D x)
             (yy : D y)
    : disp_cat (hom x y).
  Proof.
    simple refine (_ ,, _).
    - exact (disp_hom_data xx yy).
    - exact (disp_hom_laws xx yy).
  Defined.
End HomDisplayedCategory.

(* ----------------------------------------------------------------------------------- *)
(** ** Notations.                                                                      *)
(* ----------------------------------------------------------------------------------- *)

Module Notations.

Export Bicat.Notations.

Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60).
Notation "f' <==[ x ] g'" := (disp_2cells x g' f') (at level 60, only parsing).
Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60).
Notation "ff ◃◃ rr" := (disp_lwhisker ff rr) (at level 60).
Notation "rr ▹▹ gg" := (disp_rwhisker gg rr) (at level 60).

End Notations.


(** * Booleans *)

Require Import UniMath.Foundations.Init.
Require Import UniMath.Foundations.Sets.

Definition andb : bool -> bool -> bool.
Proof.
  intros b1 b2; induction b1; [exact b2|exact false].
Defined.

Definition orb : bool -> bool -> bool.
Proof.
  intros b1 b2; induction b1; [exact true|exact b2].
Defined.

Definition implb : bool -> bool -> bool.
Proof.
  intros b1 b2; induction b1; [exact b2|exact true].
Defined.

Lemma andb_is_associative :
  ∏ b1 b2 b3 : bool, andb (andb b1 b2) b3 = andb b1 (andb b2 b3).
Proof.
  intros; induction b1; induction b2; induction b3; reflexivity.
Qed.

Lemma orb_is_associative :
  ∏ b1 b2 b3 : bool, orb (orb b1 b2) b3 = orb b1 (orb b2 b3).
Proof.
  intros; induction b1; induction b2; induction b3; reflexivity.
Qed.

Lemma andb_is_commutative :
  ∏ b1 b2 : bool, andb b1 b2 = andb b2 b1.
Proof.
  intros; induction b1; induction b2; reflexivity.
Qed.

Lemma orb_is_commutative :
  ∏ b1 b2 : bool, orb b1 b2 = orb b2 b1.
Proof.
  intros; induction b1; induction b2; reflexivity.
Qed.