(* (c) Copyright Microsoft Corporation and Inria. You may distribute   *)
(* under the terms of either the CeCILL-B License or the CeCILL        *)
(* version 2 License, as specified in the README file.                 *)
(* version 2 License, as specified in the README file.                 *)
(*                                                                     *)
(***********************************************************************)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice.
Require Import fintype finfun finset groups morphisms automorphism.

(***********************************************************************)
(* This file contains the definitions of:                              *)
(*                                                                     *)
(*   coset_of H           == right cosets by the group H (see below)   *)
(*   coset_groupType H    == the groupType induced by 'N(H) / H        *)
(*   coset H              == the canonical projection induced by H     *)
(*   A / B                == the quotient of A by B,                   *)
(*                               made to coincide w/ (A :&: 'N(B)) / B *)
(*   quotm (nHG: H <| G) (nGf : f@* G = G) (nHf : f@*H = H)            *)
(*                        == the quotient morphism induced by f and H  *)
(***********************************************************************)
(* Lemmas for these notions, plus the three isomorphism theorems, and  *)
(* counting lemmas for morphisms.                                      *)
(***********************************************************************)

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

Import GroupScope.

(********************************************************************)
(*       Cosets are right cosets of elements in the normaliser      *)
(********************************************************************)

Section Cosets.

Variables (gT : finGroupType) (Q A : {set gT}).

(* We let cosets coerce to GroupSet.sort, so they inherit the group  *)
(* subset base group structure. Later we will define a proper group  *)
(* structure on cosets, which will then hide the inherited structure *)
(* once coset_of unifies with FinGroup.sort; the coercion to         *)
(* GroupSet.sort will no longer be used.                             *)
(*   Note that for Hx Hy : coset_of H, Hx * Hy : {set gT} can mean   *)
(*      either set_of_coset (mulg Hx Hy)                             *)
(*          OR mulg (set_of_coset Hx) (set_of_coset Hy)              *)
(* However, since the two terms are actually convertible, we can     *)
(* live with this ambiguity.                                         *)
(*   We take great care that neither the type coset_of H, its        *)
(* finGroupType structure, nor the coset H morphism depend on the    *)
(* actual group structure of H. Otherwise, rewriting would be        *)
(* extremely awkward because all our equalities are stated at the    *)
(* set level.                                                        *)
(*   The trick we use is to interpret coset_of A, when A is any set, *)
(* as the type of cosets of the group <A> generated by A, in the     *)
(* group <A, N(A)> generated by A and its normaliser. This coincides *)
(* with the type of bilateral cosets of A when A is a group. We      *)
(* restrict the domain of coset_of A to 'N(A), so that we get almost *)
(* all the same conversion equalities as if we had forced A to be a  *)
(* group in the first place -- the only exception is that            *)
(*      1 : coset_of A : set _ = <<A>> rather than A,                *)
(* is covered by the genGid lemma.                                   *)

Notation H := <<A>>.
Definition coset_range := [pred B \in rcosets H 'N(A)].

Record coset_of : Type :=
  Coset { set_of_coset :> GroupSet.sort gT; _ : coset_range set_of_coset }.

Canonical Structure coset_subType :=
  Eval hnf in [subType for set_of_coset by coset_of_rect].
Definition coset_eqMixin := Eval hnf in [eqMixin of coset_of by <:].
Canonical Structure coset_eqType := Eval hnf in EqType coset_eqMixin.
Definition coset_choiceMixin := [choiceMixin of coset_of by <:].
Canonical Structure coset_choiceType :=
  Eval hnf in ChoiceType coset_choiceMixin.
Definition coset_countMixin := [countMixin of coset_of by <:].
Canonical Structure coset_countType := Eval hnf in CountType coset_countMixin.
Canonical Structure coset_subCountType :=
  Eval hnf in [subCountType of coset_of].
Definition coset_finMixin := [finMixin of coset_of by <:].
Canonical Structure coset_finType := Eval hnf in FinType coset_finMixin.
Canonical Structure coset_subFinType := Eval hnf in [subFinType of coset_of].

(* We build a new (canonical) structure of groupType for cosets.      *)
(* When A is a group, this is the largest possible quotient 'N(A) / A *)

Lemma coset_one_proof : coset_range H.
Proof. by apply/rcosetsP; exists (1 : gT); rewrite (group1, mulg1). Qed.
Definition coset_one := Coset coset_one_proof.

Let nNH := subsetP (norm_gen A).

Lemma coset_range_mul : forall B C : coset_of, coset_range (B * C).
Proof.
case=> B /=; case/rcosetsP=> x Nx ->{B} [C] /=; case/rcosetsP=> y Ny ->{C}.
by apply/rcosetsP; exists (x * y); rewrite !(groupM, rcoset_mul, nNH).
Qed.

Definition coset_mul B C := Coset (coset_range_mul B C).

Lemma coset_range_inv : forall B : coset_of, coset_range B^-1.
Proof.
case=> B /=; case/rcosetsP=> x Nx ->{B}.
rewrite norm_rlcoset ?nNH // invg_lcoset.
by apply/rcosetsP; exists x^-1; rewrite ?groupV.
Qed.

Definition coset_inv B := Coset (coset_range_inv B).

Lemma coset_mulP : associative coset_mul.
Proof. by move=> B C D; apply: val_inj; rewrite /= mulgA. Qed.

Lemma coset_oneP : left_id coset_one coset_mul.
Proof.
case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}.
by rewrite mulgA mulGid.
Qed.

Lemma coset_invP : left_inverse coset_one coset_inv coset_mul.
Proof.
case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}.
rewrite invg_rcoset -mulgA (mulgA H) mulGid.
by rewrite norm_rlcoset ?nNH // -lcosetM mulVg mul1g.
Qed.

Definition coset_of_groupMixin :=
  FinGroup.Mixin coset_mulP coset_oneP coset_invP.

Canonical Structure coset_baseGroupType :=
  Eval hnf in BaseFinGroupType coset_of_groupMixin.
Canonical Structure coset_groupType := FinGroupType coset_invP.

(* Projection of the initial group type over the cosets groupType  *)

Definition coset x : coset_of := insubd (1 : coset_of) (H :* x).

(* This is a primitive lemma -- we'll need to restate it for *)
(* the case where A is a group. *)
Lemma val_coset_prim : forall x, x \in 'N(A) -> coset x :=: H :* x.
Proof.
by move=> x Nx; rewrite val_insubd /= mem_rcosets -{1}(mul1g x) mem_mulg.
Qed.

Lemma coset_morphM : {in 'N(A) &, {morph coset : x y / x * y}}.
Proof.
move=> x y Nx Ny; apply: val_inj.
by rewrite /= !val_coset_prim ?groupM //= rcoset_mul ?nNH.
Qed.

Canonical Structure coset_morphism := Morphism coset_morphM.

Lemma ker_coset_prim : 'ker coset = 'N_H(A).
Proof.
apply/setP=> z; rewrite !in_setI andbC 2!inE -val_eqE /=.
case Nz: (z \in 'N(A)); rewrite ?andbF ?val_coset_prim // !andbT.
by apply/eqP/idP=> [<-| Az]; rewrite (rcoset_refl, rcoset_id).
Qed.

Implicit Type xbar : coset_of.

Lemma coset_mem : forall y xbar, y \in xbar -> coset y = xbar.
Proof.
move=> y [/= Hx NHx] /= Hxy; apply: val_inj=> /=.
case/rcosetsP: NHx (NHx) Hxy => x Nx -> NHx Hxy.
by rewrite val_insubd /= (rcoset_transl Hxy) NHx.
Qed.

(* coset is an inverse to repr *)

Lemma mem_repr_coset : forall xbar, repr xbar \in xbar.
Proof. case=> xbar /=; case/rcosetsP=> x _ ->; exact: mem_repr_rcoset. Qed.

Lemma repr_coset1 : repr (1 : coset_of) = 1.
Proof. exact: repr_group. Qed.

Lemma coset_reprK : cancel (fun xbar => repr xbar) coset.
Proof. move=> xbar; exact: coset_mem (mem_repr_coset xbar). Qed.

(* cosetP is slightly stronger than using repr because we only *)
(* guarantee  repr xbar \in 'N(A) when A is a group.           *)
Lemma cosetP : forall xbar, {x | x \in 'N(A) & xbar = coset x}.
Proof.
move=> xbar; pose x := repr 'N_xbar(A).
have [xbar_x Nx]: x \in xbar /\ x \in 'N(A).
  apply/setIP; rewrite {}/x; case: xbar => Hy /=.
  by case/rcosetsP=> y Ny ->; apply: (@mem_repr _ y); rewrite inE rcoset_refl.
by exists x; last rewrite (coset_mem xbar_x).
Qed.

Lemma coset_id : forall x, x \in A -> coset x = 1.
Proof. move=> x Ax; apply: coset_mem; exact: mem_gen. Qed.

Lemma coset_imT : coset @* 'N(A) = setT.
Proof.
by apply/setP=> xbar; case: (cosetP xbar) => x Nx ->; rewrite inE mem_morphim.
Qed.

Lemma coset_im : forall C : {set coset_of}, C \subset coset @* 'N(A).
Proof. by move=> C; rewrite coset_imT subsetT. Qed.

Definition quotient : {set coset_of} := coset @* Q.

Lemma quotientE : quotient = coset @* Q. Proof. by []. Qed.

End Cosets.

Prenex Implicits coset_of coset.
Arguments Scope quotient [_ group_scope group_scope].

Bind Scope group_scope with coset_of.

Notation "A / B" := (quotient A B) : group_scope.

Section CosetOfGroupTheory.

Variables (gT : finGroupType) (H : {group gT}).
Implicit Types A B : {set gT}.
Implicit Types G K : {group gT}.
Implicit Types xbar yb : coset_of H.
Implicit Types C D : {set coset_of H}.
Implicit Types L M : {group coset_of H}.

Canonical Structure quotient_group G A : {group coset_of A} :=
  Eval hnf in [group of G / A].

Infix "/" := quotient_group : subgroup_scope.

Lemma val_coset : forall x, x \in 'N(H) -> coset H x :=: H :* x.
Proof. by move=> x Nx; rewrite val_coset_prim // genGid. Qed.

Lemma coset_default : forall x, (x \in 'N(H)) = false -> coset H x = 1.
Proof.
move=> x Nx; apply: val_inj.
by rewrite val_insubd /= mem_rcosets /= genGid mulSGid ?normG ?Nx.
Qed.

Lemma coset_norm : forall xbar, xbar \subset 'N(H).
Proof.
case=> Hx /=; case/rcosetsP=> x Nx ->.
by rewrite genGid mul_subG ?sub1set ?normG.
Qed.

Lemma ker_coset : 'ker (coset H) = H.
Proof. by rewrite ker_coset_prim genGid (setIidPl _) ?normG. Qed.

Lemma coset_idr : forall x, x \in 'N(H) -> coset H x = 1 -> x \in H.
Proof. by move=> x Nx Hx1; rewrite -ker_coset mem_morphpre //= Hx1 set11. Qed.

Lemma repr_coset_norm : forall xbar, repr xbar \in 'N(H).
Proof. move=> xbar; exact: subsetP (coset_norm _) _ (mem_repr_coset _). Qed.

Lemma imset_coset : forall G, coset H @: G = G / H.
Proof.
move=> G; apply/eqP; rewrite eqEsubset andbC imsetS ?subsetIr //=.
apply/subsetP=> xbar; case/imsetP=> x Gx -> {xbar}.
by case Nx: (x \in 'N(H)); rewrite ?(coset_default Nx) ?mem_morphim ?group1.
Qed.

Lemma val_quotient : forall A, val @: (A / H) = rcosets H 'N_A(H).
Proof.
move=> A; apply/setP=> B; apply/imsetP/rcosetsP=> [[xbar Axbar]|[x ANx]] ->{B}.
  case/morphimP: Axbar => x Nx Ax ->{xbar}.
  by exists x; [rewrite inE Ax | rewrite /= val_coset].
case/setIP: ANx => Ax Nx.
by exists (coset H x); [apply/morphimP; exists x | rewrite /= val_coset].
Qed.

Lemma card_quotient_subnorm : forall A, #|A / H| = #|'N_A(H) : H|.
Proof. by move=> A; rewrite -(card_imset _ val_inj) val_quotient. Qed.

Lemma card_quotient : forall A, A \subset 'N(H) -> #|A / H| = #|A : H|.
Proof. by move=> A nHA; rewrite card_quotient_subnorm (setIidPl nHA). Qed.

(* Specializing all the morphisms lemmas that have different assumptions    *)
(* (e.g., because 'ker (coset H) = H), or conclusions (e.g., because we use *)
(* A / H rather than coset H @* A). We may want to reevaluate later, and    *)
(* eliminate variants that aren't used                                  .   *)

(* Variant of morph1; no specialization for other morph lemmas. *)
Lemma coset1 : coset H 1 :=: H.
Proof. by rewrite morph1 /= genGid. Qed.

(* Variant of kerE. *)
Lemma cosetpre1 : coset H @*^-1 1 = H.
Proof. by rewrite -kerE ker_coset. Qed.

(* Variant of morphimEdom; mophimE[sub] covered by imset_coset. *)
(* morph[im|pre]Iim are also covered by quotientT.              *)
Lemma quotientT : 'N(H) / H = setT.
Proof. exact: coset_imT. Qed.

(* Variant of morphimIdom. *)
Lemma quotientInorm : forall A, 'N_A(H) / H = A / H.
Proof. by move=> A; rewrite /quotient setIC morphimIdom. Qed.

Lemma mem_quotient : forall x G, x \in G -> coset H x \in G / H.
Proof. by move=> x G Gx; rewrite -imset_coset mem_imset. Qed.

Lemma quotientS : forall A B, A \subset B -> A / H \subset B / H.
Proof. exact: morphimS. Qed.

Lemma quotient0 : set0 / H = set0.
Proof. exact: morphim0. Qed.

Lemma quotient_set1 : forall x, x \in 'N(H) -> [set x] / H = [set coset H x].
Proof. exact: morphim_set1. Qed.

Lemma quotient1 : 1 / H = 1.
Proof. exact: morphim1. Qed.

Lemma quotientV : forall A, A^-1 / H = (A / H)^-1.
Proof. exact: morphimV. Qed.

Lemma quotientMl : forall A B,
  A \subset 'N(H) -> A * B / H = (A / H) * (B / H).
Proof. exact: morphimMl. Qed.

Lemma quotientMr : forall A B,
  B \subset 'N(H) -> A * B / H = (A / H) * (B / H).
Proof. exact: morphimMr. Qed.

Lemma cosetpreM : forall C D,
  coset H @*^-1 (C * D) = coset H @*^-1 C * coset H @*^-1 D.
Proof. by move=> C D; rewrite morphpreMl ?coset_im. Qed.

Lemma quotientJ : forall A x, x \in 'N(H) -> A :^ x / H = (A / H) :^ coset H x.
Proof. exact: morphimJ. Qed.

Lemma quotientU : forall A B, (A :|: B) / H = A / H :|: B / H.
Proof. exact: morphimU. Qed.

Lemma quotientI : forall A B, (A :&: B) / H \subset A / H :&: B / H.
Proof. exact: morphimI. Qed.

Lemma coset_kerl : forall x y, x \in H -> coset H (x * y) = coset H y.
Proof.
move=> x y Hx; case Ny: (y \in 'N(H)); first by rewrite mkerl ?ker_coset.
by rewrite !coset_default ?groupMl // (subsetP (normG H)).
Qed.

Lemma coset_kerr : forall x y, y \in H -> coset H (x * y) = coset H x.
Proof.
move=> x y Hy; case Nx: (x \in 'N(H)); first by rewrite mkerr ?ker_coset.
by rewrite !coset_default ?groupMr // (subsetP (normG H)).
Qed.

Lemma rcoset_kercosetP : forall x y,
  x \in 'N(H) -> y \in 'N(H) -> reflect (coset H x = coset H y) (x \in H :* y).
Proof. rewrite -{6}ker_coset; exact: rcoset_kerP. Qed.

Lemma kercoset_rcoset : forall x y,
  x \in 'N(H) -> y \in 'N(H) ->
    coset H x = coset H y -> exists2 z, z \in H & x = z * y.
Proof. move=> x y Gx Gy eqfxy; rewrite -ker_coset; exact: ker_rcoset. Qed.

Lemma quotientGI : forall G A, H \subset G -> (G :&: A) / H = G / H :&: A / H.
Proof. rewrite -{1}ker_coset; exact: morphimGI. Qed.

Lemma quotientIG : forall A G, H \subset G -> (A :&: G) / H = A / H :&: G / H.
Proof. rewrite -{1}ker_coset. exact: morphimIG. Qed.

Lemma quotientD : forall A B, A / H :\: B / H \subset (A :\: B) / H.
Proof. exact: morphimD. Qed.

Lemma quotientDG : forall A G, H \subset G -> (A :\: G) / H = A / H :\: G / H.
Proof. rewrite -{1}ker_coset; exact: morphimDG. Qed.

Lemma quotientK : forall A, A \subset 'N(H) -> coset H @*^-1 (A / H) = H * A.
Proof. rewrite -{8}ker_coset; exact: morphimK. Qed.

Lemma quotientGK : forall G, H <| G -> coset H @*^-1 (G / H) = G.
Proof. move=> G; case/andP; rewrite -{1}ker_coset; exact: morphimGK. Qed.

Lemma cosetpre_set1 : forall x,
  x \in 'N(H) -> coset H @*^-1 [set coset H x] = H :* x.
Proof. by rewrite -{9}ker_coset; exact: morphpre_set1. Qed.

Lemma cosetpre_set1_coset : forall xbar, coset H @*^-1 [set xbar] = xbar.
Proof.
move=> xbar; case: (cosetP xbar) => x Nx ->.
by rewrite cosetpre_set1 ?val_coset.
Qed.

Lemma cosetpreK : forall C, coset H @*^-1 C / H = C.
Proof. by move=> C; rewrite /quotient morphpreK ?coset_im. Qed.

(* Variant of morhphim_ker *)
Lemma trivg_quotient : H / H = 1.
Proof. by rewrite -{3}ker_coset /quotient morphim_ker. Qed.

Lemma sub_cosetpre : forall M, H \subset coset H @*^-1 M.
Proof. rewrite -{3}ker_coset; exact: ker_sub_pre. Qed.

Lemma normal_cosetpre : forall M, H <| coset H @*^-1 M.
Proof. rewrite -{3}ker_coset; exact: ker_normal_pre. Qed.

Lemma cosetpreSK : forall C D,
  (coset H @*^-1 C \subset coset H @*^-1 D) = (C \subset D).
Proof. by move=> C D; rewrite morphpreSK ?coset_im. Qed.

Lemma sub_quotient_pre : forall A C,
  A \subset 'N(H) -> (A / H \subset C) = (A \subset coset H @*^-1 C).
Proof. by move=> A C; exact: sub_morphim_pre. Qed.

Lemma sub_cosetpre_quo : forall C G,
  H <| G -> (coset H @*^-1 C \subset G) = (C \subset G / H).
Proof. by move=> C G nHG; rewrite -cosetpreSK quotientGK. Qed.

(* Variant of ker_trivg_morphim. *)
Lemma quotient_sub1 : forall A,
  A \subset 'N(H) -> (A / H \subset [1]) = (A \subset H).
Proof. by move=> A nHA /=; rewrite -{10}ker_coset ker_trivg_morphim nHA. Qed.

Lemma quotientSK : forall A B,
  A \subset 'N(H) -> (A / H \subset B / H) = (A \subset H * B).
Proof. by move=> A B nHA; rewrite morphimSK ?ker_coset. Qed.

Lemma quotientSGK : forall A G,
  A \subset 'N(H) -> H \subset G -> (A / H \subset G / H) = (A \subset G).
Proof. rewrite -{2}ker_coset; exact: morphimSGK. Qed.

Lemma quotient_injG :
  {in [pred G : {group gT} | H <| G] &, injective (fun G => G / H)}.
Proof. rewrite /normal -{1}ker_coset; exact: morphim_injG. Qed.

Lemma quotient_inj : forall G1 G2,
   H <| G1 -> H <| G2 -> G1 / H = G2 / H -> G1 :=: G2.
Proof. rewrite /normal -{1 3}ker_coset; exact: morphim_inj. Qed.

Lemma quotient_gen : forall A, A \subset 'N(H) -> <<A>> / H = <<A / H>>.
Proof. exact: morphim_gen. Qed.

Lemma cosetpre_gen : forall C,
  1 \in C -> coset H @*^-1 <<C>> = <<coset H @*^-1 C>>.
Proof. by move=> C C1; rewrite morphpre_gen ?coset_im. Qed.

Lemma quotientR : forall A B,
  A \subset 'N(H) -> B \subset 'N(H) -> [~: A, B] / H = [~: A / H, B / H].
Proof. exact: morphimR. Qed.

Lemma quotient_norm : forall A, 'N(A) / H \subset 'N(A / H).
Proof. exact: morphim_norm. Qed.

Lemma quotient_norms : forall A B, A \subset 'N(B) -> A / H \subset 'N(B / H).
Proof. exact: morphim_norms. Qed.

Lemma quotient_subnorm : forall A B, 'N_A(B) / H \subset 'N_(A / H)(B / H).
Proof. exact: morphim_subnorm. Qed.

Lemma quotient_normal : forall A B, A <| B -> A / H <| B / H.
Proof. exact: morphim_normal. Qed.

Lemma quotient_cent1 : forall x, 'C[x] / H \subset 'C[coset H x].
Proof.
move=> x; case Nx: (x \in 'N(H)); first exact: morphim_cent1.
by rewrite coset_default // cent11T subsetT.
Qed.

Lemma quotient_cent1s : forall A x,
  A \subset 'C[x] -> A / H \subset 'C[coset H x].
Proof.
move=> A x sAC; exact: subset_trans (quotientS sAC) (quotient_cent1 x).
Qed.

Lemma quotient_subcent1 : forall A x,
  'C_A[x] / H \subset 'C_(A / H)[coset H x].
Proof.
move=> A x; exact: subset_trans (quotientI _ _) (setIS _ (quotient_cent1 x)).
Qed.

Lemma quotient_cent : forall A, 'C(A) / H \subset 'C(A / H).
Proof. exact: morphim_cent. Qed.

Lemma quotient_cents : forall A B,
  A \subset 'C(B) -> A / H \subset 'C(B / H).
Proof. exact: morphim_cents. Qed.

Lemma quotient_abelian : forall A, abelian A -> abelian (A / H).
Proof. exact: morphim_abelian. Qed.

Lemma quotient_subcent : forall A B, 'C_A(B) / H \subset 'C_(A / H)(B / H).
Proof. exact: morphim_subcent. Qed.

Lemma cosetpre_normal : forall C D,
  (coset H @*^-1 C <| coset H @*^-1 D) = (C <| D).
Proof. by move=> C D; rewrite morphpre_normal ?coset_im. Qed.

Lemma quotient_normG : forall G, H <| G -> 'N(G) / H = 'N(G / H).
Proof.
move=> G; case/andP=> sHG nHG.
by rewrite [_ / _]morphim_normG ?ker_coset // coset_imT setTI.
Qed.

Lemma quotient_subnormG : forall A G,
   H <| G -> 'N_A(G) / H = 'N_(A / H)(G / H).
Proof.
by move=> A G; case/andP=> sHG nHG; rewrite -morphim_subnormG ?ker_coset.
Qed.

Lemma cosetpre_cent1 : forall x,
  'C_('N(H))[x] \subset coset H @*^-1 'C[coset H x].
Proof.
move=> x; case Nx: (x \in 'N(H)); first by rewrite morphpre_cent1.
by rewrite coset_default // cent11T morphpreT subsetIl.
Qed.

Lemma cosetpre_cent1s : forall C x,
  coset H @*^-1 C \subset 'C[x] -> C \subset 'C[coset H x].
Proof.
move=> C x sC; rewrite -cosetpreSK; apply: subset_trans (cosetpre_cent1 x).
by rewrite subsetI subsetIl.
Qed.

Lemma cosetpre_subcent1 : forall C x,
  'C_(coset H @*^-1 C)[x] \subset coset H @*^-1 'C_C[coset H x].
Proof.
move=> C x; rewrite -morphpreIdom -setIA setICA morphpreI setIS //.
exact: cosetpre_cent1.
Qed.

Lemma cosetpre_cent : forall A, 'C_('N(H))(A) \subset coset H @*^-1 'C(A / H).
Proof. exact: morphpre_cent. Qed.

Lemma cosetpre_cents : forall A C,
  coset H @*^-1 C \subset 'C(A) -> C \subset 'C(A / H).
Proof. by move=> A C; apply: morphpre_cents; rewrite ?coset_im. Qed.

Lemma cosetpre_subcent : forall C A,
  'C_(coset H @*^-1 C)(A) \subset coset H @*^-1 'C_C(A / H).
Proof. exact: morphpre_subcent. Qed.

Section InverseImage.

Variables (G : {group gT}) (Kbar : {group coset_of H}).

Hypothesis nHG : H <| G.

CoInductive inv_quotient_spec (P : pred {group gT}) : Prop :=
  InvQuotientSpec K of Kbar :=: K / H & H \subset K & P K.

Lemma inv_quotientS :
  Kbar \subset G / H -> inv_quotient_spec (fun K => K \subset G).
Proof.
case/andP: nHG => sHG nHG' sKbarG.
have sKdH: Kbar \subset 'N(H) / H by rewrite (subset_trans sKbarG) ?morphimS.
exists (coset H @*^-1 Kbar)%G; first by rewrite cosetpreK.
  by rewrite -{1}ker_coset morphpreS ?sub1G.
by rewrite sub_cosetpre_quo.
Qed.

Lemma inv_quotientN : Kbar <| G / H -> inv_quotient_spec (fun K => K <| G).
Proof.
move=> nKbar; case/inv_quotientS: (normal_sub nKbar) => K defKbar sHK sKG.
exists K => //; rewrite defKbar -cosetpre_normal !quotientGK // in nKbar.
exact: normalS nHG.
Qed.

End InverseImage.

Lemma quotient_mulg : forall A, A * H / H = A / H.
Proof.
move=> A; rewrite [_ /_]morphimMr ?normG //= -!quotientE.
by rewrite trivg_quotient mulg1.
Qed.

Lemma quotient_mulgr : forall A, H * A / H = A / H.
Proof.
move=> A; rewrite [_ /_]morphimMl ?normG //= -!quotientE.
by rewrite trivg_quotient mul1g.
Qed.

Lemma quotient_mulgen : forall G, G \subset 'N(H) -> G <*> H / H = G / H.
Proof.
move=> G nHG; rewrite -genM_mulgen quotientE morphim_gen -?quotientE.
  by rewrite quotient_mulg genGid.
by rewrite -(mulSGid nHG) mulgS ?normG.
Qed.

Section Injective.

Variables (G : {group gT}).
Hypotheses (nHG : G \subset 'N(H)) (trGH : G :&: H = 1).

Lemma quotient_isom : isom G (G / H) (restrm nHG (coset H)).
Proof.
by apply/isomP; rewrite ker_restrm ker_coset morphim_restrm setIid trGH.
Qed.

Lemma quotient_isog : isog G (G / H).
Proof. exact: isom_isog quotient_isom. Qed.

End Injective.

End CosetOfGroupTheory.

Notation "A / H" := (quotient_group A H) : subgroup_scope.

Section Quotient1.

Variables (gT : finGroupType) (A : {set gT}).

Lemma coset1_injm : 'injm (@coset gT 1).
Proof. by rewrite ker_coset /=. Qed.

Lemma quotient1_isom : isom A (A / 1) (coset 1).
Proof. by apply: sub_isom coset1_injm; rewrite ?norms1. Qed.

Lemma quotient1_isog : isog A (A / 1).
Proof. apply: isom_isog quotient1_isom; exact: norms1. Qed.

End Quotient1.

Section QuotientMorphism.

Variable (gT : finGroupType) (G H : {group gT}) (f : {morphism G >-> gT}).

Implicit Types A : {set gT}.
Implicit Types B : {set (coset_groupType H)}.
Hypotheses (nHG : H <| G) (nGf : f @* G = G) (nHf : f @* H = H).

Notation fH := (coset H \o f).

Lemma quotm_restr_proof : G \subset 'dom fH.
Proof. by rewrite -sub_morphim_pre // nGf; case/andP: nHG. Qed.

Notation fH_G := (restrm quotm_restr_proof fH).

Lemma quotm_fact_proof1 : G \subset 'N(H).
Proof. by case/andP: nHG. Qed.

Lemma quotm_fact_proof2 : 'ker (coset H) \subset 'ker fH_G.
Proof.
case/andP: nHG => sHG _; rewrite ker_restrm ker_comp ker_coset subsetI.
by rewrite -sub_morphim_pre sHG ?nHf /=.
Qed.

Definition quotm := factm quotm_fact_proof1 quotm_fact_proof2.
Canonical Structure quotm_morphism := Eval hnf in [morphism of quotm].

Lemma morphim_quotm : forall A, quotm @* (A / H) = f @* A / H.
Proof.
case/andP: nHG => sHG nHG' A.
by rewrite morphim_factm morphim_restrm morphim_comp morphimIdom.
Qed.

Lemma cosetpre_quotm : forall A,
  quotm @*^-1 (A / H) = f @*^-1 A / H.
Proof.
case/andP: nHG => sHG nHG' A; rewrite morphpre_factm morphpre_restrm.
rewrite morphpre_comp morphpreIdom quotientE -(morphimIdom _ A) /= -quotientE.
rewrite morphimK ?subsetIl // ker_coset morphpreMl ?nGf // -{3}nHf morphimK //.
rewrite -morphpreIim setIA -(morphpreIim _ A) !nGf (setIidPl nHG').
rewrite [_ * H]normC; last by apply: subset_trans nHG'; rewrite subsetIl.
by rewrite -mulgA quotient_mulgr -morphpreMl (mul1g, sub1G).
Qed.

Lemma ker_quotm : 'ker quotm = 'ker f / H.
Proof. by rewrite -cosetpre_quotm /quotient morphim1. Qed.

Lemma injm_quotm : 'injm f -> 'injm quotm.
Proof. by move/trivgP=> /= kf1; rewrite ker_quotm kf1 quotientE morphim1. Qed.

End QuotientMorphism.

Section FirstIsomorphism.

Variables aT rT : finGroupType.

Lemma first_isom : forall (G : {group aT}) (f : {morphism G >-> rT}),
  {g : {morphism G / 'ker f >-> rT} | 'injm g &
      forall A : {set aT}, g @* (A / 'ker f) = f @* A}.
Proof.
move=> G f; have nkG := ker_norm f.
have skk: 'ker (coset ('ker f)) \subset 'ker f by rewrite ker_coset.
exists (factm_morphism nkG skk) => /=; last exact: morphim_factm.
by rewrite ker_factm -quotientE trivg_quotient.
Qed.

Variables (G H : {group aT}) (f : {morphism G >-> rT}).
Hypothesis sHG : H \subset G.

Lemma first_isog : (G / 'ker f) \isog (f @* G).
Proof.
by case: (first_isom f) => g injg im_g; apply/isogP; exists g; rewrite ?im_g.
Qed.

Lemma first_isom_loc : {g : {morphism H / 'ker_H f >-> rT} |
 'injm g & forall A : {set aT}, A \subset H -> g @* (A / 'ker_H f) = f @* A}.
Proof.
case: (first_isom (restrm_morphism sHG f)).
rewrite ker_restrm => g injg im_g; exists g => // A sAH.
by rewrite im_g morphim_restrm (setIidPr sAH).
Qed.

Lemma first_isog_loc : (H / 'ker_H f) \isog (f @* H).
Proof.
by case: first_isom_loc => g injg im_g; apply/isogP; exists g; rewrite ?im_g.
Qed.

End FirstIsomorphism.

Section SecondIsomorphism.

Variables (gT : finGroupType) (H K : {group gT}).

Hypothesis nKH : H \subset 'N(K).

Lemma second_isom : {f : {morphism H / (K :&: H) >-> coset_of K} |
  'injm f & forall A : {set gT}, A \subset H -> f @* (A / (K :&: H)) = A / K}.
Proof.
have ->: K :&: H = 'ker_H (coset K) by rewrite ker_coset setIC.
exact: first_isom_loc.
Qed.

Lemma second_isog : H / (K :&: H) \isog H / K.
Proof. rewrite setIC -{1 3}(ker_coset K); exact: first_isog_loc. Qed.

Lemma weak_second_isog : H / (K :&: H) \isog H * K / K.
Proof. rewrite quotient_mulg; exact: second_isog. Qed.

End SecondIsomorphism.

Section ThirdIsomorphism.

Variables (gT : finGroupType) (G H K : {group gT}).

Hypothesis sHK : H \subset K.
Hypothesis snHG : H <| G.
Hypothesis snKG : K <| G.

Theorem third_isom : {f : {morphism (G / H) / (K / H) >-> coset_of K} | 'injm f
   & forall A : {set gT}, A \subset G -> f @* (A / H / (K / H)) = A / K}.
Proof.
case/andP: snKG => sKG nKG; case/andP: snHG => sHG nHG.
have sHker: 'ker (coset H) \subset 'ker (restrm nKG (coset K)).
  by rewrite ker_restrm !ker_coset subsetI sHG.
have:= first_isom_loc (factm_morphism nHG sHker) (subxx _) => /=.
rewrite ker_factm_loc ker_restrm ker_coset !(setIidPr sKG) /= -!quotientE.
case=> f injf im_f; exists f => // A sAG; rewrite im_f ?morphimS //.
by rewrite morphim_factm morphim_restrm (setIidPr sAG).
Qed.

Theorem third_isog : (G / H / (K / H)) \isog (G / K).
Proof.
by case: third_isom => f inj_f im_f; apply/isogP; exists f; rewrite ?im_f.
Qed.

End ThirdIsomorphism.

Lemma char_from_quotient : forall (gT : finGroupType) (G H K : {group gT}),
  H <| K -> H \char G -> K / H \char G / H -> K \char G.
Proof.
move=> gT G H K; case/andP=> sHK nHK chHG; case/charP=> sKG chKG.
have nHG := char_normal chHG; case: (andP nHG) => sHG nHG'.
rewrite -(ker_coset H) in sHK; rewrite morphimSGK ?ker_coset // in sKG.
apply/charP; split=> // f injf Gf; apply/morphim_fixP => //.
have{chHG} Hf: f @* H = H by case/charP: chHG => _; apply.
rewrite -(morphimSGK _ sHK) -?quotientE; last first.
  by apply: subset_trans nHG'; rewrite -{3}Gf morphimS.
rewrite -(morphim_quotm nHG Gf Hf) {}chKG // ?injm_quotm //.
by rewrite morphim_quotm Gf.
Qed.

(* Counting lemmas for morphisms. *)

Section CardMorphism.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Implicit Types G H : {group aT}.
Implicit Types L M : {group rT}.

Lemma card_morphim : forall G, #|f @* G| = #|D :&: G : 'ker f|.
Proof.
move=> G; rewrite -morphimIdom -indexgI -card_quotient; last first.
  by rewrite normsI ?normG ?subIset ?ker_norm.
by apply: esym (isog_card _); rewrite first_isog_loc ?subsetIl.
Qed.

Lemma dvdn_morphim :  forall G, #|f @* G| %| #|G|.
Proof.
move=> G; rewrite card_morphim (dvdn_trans (dvdn_indexg _ _)) //.
by rewrite cardSg ?subsetIr.
Qed.

Lemma index_morphim_ker : forall G H,
    H \subset G -> G \subset D ->
  (#|f @* G : f @* H| * #|'ker_G f : H|)%N = #|G : H|.
Proof.
move=> G H sHG sGD; apply/eqP.
rewrite -(eqn_pmul2l (cardG_gt0 (f @* H))) mulnA LaGrange ?morphimS //.
rewrite !card_morphim (setIidPr sGD) (setIidPr (subset_trans sHG sGD)).
rewrite -(eqn_pmul2l (cardG_gt0 ('ker_H f))) /=.
by rewrite -{1}(setIidPr sHG) setIAC mulnCA mulnC mulnA !LaGrangeI LaGrange.
Qed.

Lemma index_morphim : forall G H,
  G :&: H \subset D -> #|f @* G : f @* H| %| #|G : H|.
Proof.
move=> G H dGH; rewrite -(indexgI G) -(setIidPr dGH) setIA.
apply: dvdn_trans (indexSg (subsetIl _ H) (subsetIr D G)).
rewrite -index_morphim_ker ?subsetIl ?subsetIr ?dvdn_mulr //= morphimIdom.
by rewrite indexgS ?morphimS ?subsetIr.
Qed.

Lemma index_injm : forall G H,
  'injm f -> G \subset D -> #|f @* G : f @* H| = #|G : H|.
Proof.
move=> G H injf dG; rewrite -{2}(setIidPr dG) -(indexgI _ H) /=.
rewrite -index_morphim_ker ?subsetIl ?subsetIr //= setIAC morphimIdom setIC.
rewrite injmI ?subsetIr // indexgI /= morphimIdom setIC ker_injm //.
by rewrite -(indexgI (1 :&: _)) /= -setIA !(setIidPl (sub1G _)) indexgg muln1.
Qed.

Lemma card_morphpre : forall L,
  L \subset f @* D -> #|f @*^-1 L| = (#|'ker f| * #|L|)%N.
Proof.
move=> L; move/morphpreK=> defL; rewrite -{2}defL card_morphim morphpreIdom.
by rewrite LaGrange // morphpreS ?sub1G.
Qed.

Lemma index_morphpre : forall L M,
  L \subset f @* D -> #|f @*^-1 L : f @*^-1 M| = #|L : M|.
Proof.
move=> L M dL; rewrite -!divgI -morphpreI card_morphpre //.
have: L :&: M \subset f @* D by rewrite subIset ?dL.
by move/card_morphpre->; rewrite divn_pmul2l ?cardG_gt0.
Qed.

End CardMorphism.

Section CardCosetpre.

Variables (gT : finGroupType) (G H K : {group gT}) (L M : {group coset_of H}).

Lemma dvdn_quotient : #|G / H| %| #|G|.
Proof. exact: dvdn_morphim. Qed.

Lemma index_quotient_ker :
     K \subset G -> G \subset 'N(H) ->
  (#|G / H : K / H| * #|G :&: H : K|)%N = #|G : K|.
Proof. rewrite -{5}(ker_coset H); exact: index_morphim_ker. Qed.

Lemma index_quotient : G :&: K \subset 'N(H) -> #|G / H : K / H| %| #|G : K|.
Proof. exact: index_morphim. Qed.

Lemma index_quotient_eq :
    G :&: H \subset K -> K \subset G -> G \subset 'N(H) ->
 #|G / H : K / H| = #|G : K|.
Proof.
move=> sGH_K sKG sGN; rewrite -index_quotient_ker {sKG sGN}//.
by rewrite -(indexgI _ K) (setIidPl sGH_K) indexgg muln1.
Qed.

Lemma card_cosetpre : #|coset H @*^-1 L| = (#|H| * #|L|)%N.
Proof. by rewrite card_morphpre ?ker_coset ?coset_im. Qed.

Lemma index_cosetpre : #|coset H @*^-1 L : coset H @*^-1 M| = #|L : M|.
Proof. by rewrite index_morphpre ?coset_im. Qed.

End CardCosetpre.


(* File: Derivable_Def.v  (last edited on 1/11/2000) (c) Klaus Weich  *)

From IPC Require Export Derivations.

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

Inductive Derivable (context : flist) (a : form) : Set :=
    Derivable_Intro :
      forall t : proof_term, derives context t a -> Derivable context a.

Inductive Derivable2 (context : flist) (a b : form) : Set :=
    Derivable2_Intro :
      Derivable context a -> Derivable context b -> Derivable2 context a b.


(*
This is the second of a sequence of files with the purpose of showing that the bicategory of univalent monoidal categories is again univalent.
In this file we construct one side of the first displayed layer above the bicategory of univalent categories, more precisely:
The total category corresponding to this displayed layer is the univalent bicategory defined as follows:
- The objects are categories together with a binary operation (which will be the tensor product for the monoidal structure).
- The morphisms are functors which preserve the tensor in a lax/weak sense (i.e. a non-necessarily isomorphic morphism).
- The 2-cells are natural transformations which (at tensor products) commute the tensor-preserving morphisms.
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.Core.Univalence.

Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Import TensorNotation.

Section TensorLayer.

  Import TensorNotation.

  Definition disp_tensor_disp_ob_mor : disp_cat_ob_mor bicat_of_univ_cats.
  Proof.
    exists (λ C, tensor (C : univalent_category)).
    exact (λ C D TC TD F, preserves_tensor TC TD F).
  Defined.

  Definition disp_tensor_disp_id_comp : disp_cat_id_comp bicat_of_univ_cats disp_tensor_disp_ob_mor.
  Proof.
    split.
    - intros C TC.
      apply identityfunctor_preserves_tensor.
    - intros C D E F G TC TD TE.
      apply compositions_preserves_tensor.
  Defined.

  Definition disp_tensor_disp_catdata : disp_cat_data bicat_of_univ_cats
    := (disp_tensor_disp_ob_mor,,disp_tensor_disp_id_comp).

  Definition bidisp_tensor_disp_2cell_struct : disp_2cell_struct disp_tensor_disp_ob_mor.
  Proof.
    intros C D F G α TC TD.
    exact (λ ptF ptG, preservestensor_commutes (pr1 ptF) (pr1 ptG) α).
  Defined.

  Lemma isaprop_bidisp_tensor_disp_2cell_struct
        {C D : bicat_of_univ_cats}
        {F G : bicat_of_univ_cats ⟦C,D⟧ }
        {α : prebicat_cells bicat_of_univ_cats F G}
        {TC : disp_tensor_disp_catdata C}
        {TD : disp_tensor_disp_catdata D}
        (ptF : TC -->[ F] TD)
        (ptG : TC -->[ G] TD)
    : isaprop (bidisp_tensor_disp_2cell_struct C D F G α TC TD ptF ptG).
  Proof.
    apply isaprop_preservestensor_commutes.
  Qed.

  Definition bidisp_tensor_disp_prebicat_1_id_comp_cells
    :  disp_prebicat_1_id_comp_cells bicat_of_univ_cats
    := (disp_tensor_disp_catdata,, bidisp_tensor_disp_2cell_struct).

  Definition bidisp_tensor_disp_prebicat_ops : disp_prebicat_ops bidisp_tensor_disp_prebicat_1_id_comp_cells.
  Proof.
    repeat split.
    - intros C D F TC TD ptF.
      apply identitynattrans_preservestensor_commutes.
    - intros C D F TC TD ptF.
      intros x y.
      rewrite id_right.
      simpl.
      rewrite tensor_id.
      rewrite id_left.
      unfold identityfunctor_preserves_tensor_data.
      unfold compositions_preserves_tensor_data.
      rewrite functor_id.
      apply id_right.
    - intros C D F TC TD ptF.
      intros x y.
      rewrite id_right.
      cbn.
      unfold compositions_preserves_tensor_data.
      unfold identityfunctor_preserves_tensor_data.
      rewrite id_left.
      simpl.
      rewrite tensor_id.
      rewrite id_left.
      apply idpath.
    - intros C D F TC TD ptF.
      intros x y.
      rewrite id_right.
      simpl.
      rewrite tensor_id.
      rewrite id_left.
      cbn.
      unfold compositions_preserves_tensor_data.
      cbn.
      unfold identityfunctor_preserves_tensor_data.
      rewrite functor_id.
      rewrite id_right.
      apply idpath.
    - intros C D F TC TD ptF.
      intros x y.
      rewrite id_right.
      cbn.
      rewrite tensor_id.
      unfold compositions_preserves_tensor_data.
      unfold identityfunctor_preserves_tensor_data.
      simpl.
      rewrite id_left.
      rewrite id_left.
      apply idpath.
    - intros C D E W F G H TC TD TE TW ptF ptG ptH.
      intros x y.
      simpl.
      rewrite id_right.
      rewrite tensor_id.
      rewrite id_left.
      cbn.
      unfold compositions_preserves_tensor_data.
      cbn.
      rewrite assoc'.
      rewrite functor_comp.
      apply idpath.
    - intros C D E W F G H TC TD TE TW ptF ptG ptH.
      intros x y.
      simpl.
      rewrite id_right.
      rewrite tensor_id.
      rewrite id_left.
      cbn.
      unfold compositions_preserves_tensor_data.
      cbn.
      rewrite assoc'.
      rewrite functor_comp.
      apply idpath.
    - intros C D F G H α β TC TD ptF ptG ptH ptcα ptcβ.
      intros x y.
      simpl.
      rewrite assoc.
      rewrite ptcα.
      rewrite assoc'.
      rewrite ptcβ.
      rewrite assoc.
      rewrite tensor_comp.
      apply idpath.
    - intros C D E F G H α TC TD TE ptF ptG ptH ptcα.
      intros x y.
      cbn.
      unfold compositions_preserves_tensor_data.
      rewrite assoc'.
      rewrite (pr2 α).
      rewrite assoc.
      rewrite ptcα.
      rewrite assoc.
      apply idpath.
    - intros C D E F G H α TC TD TE ptF ptG ptH ptcα.
      intros x y.
      cbn.
      unfold compositions_preserves_tensor_data.
      rewrite assoc'.
      etrans. {
        apply maponpaths.
        apply (pathsinv0 (functor_comp _ _ _)).
      }
      etrans. {
        do 2 apply maponpaths.
        apply ptcα.
      }
      rewrite assoc.
      rewrite functor_comp.
      rewrite assoc.
      apply cancel_postcomposition.
      etrans. { apply (pr2 ptH). }
      apply maponpaths.
      apply idpath.
  Defined.

  Definition bidisp_tensor_disp_prebicat_data : disp_prebicat_data bicat_of_univ_cats
    := (bidisp_tensor_disp_prebicat_1_id_comp_cells,, bidisp_tensor_disp_prebicat_ops).

  Definition bidisp_tensor_disp_prebicat_laws : disp_prebicat_laws bidisp_tensor_disp_prebicat_data.
  Proof.
    repeat split; intro; intros; apply isaprop_bidisp_tensor_disp_2cell_struct.
  Qed.

  Definition bidisp_tensor_disp_prebicat : disp_prebicat bicat_of_univ_cats
    := (bidisp_tensor_disp_prebicat_data,,bidisp_tensor_disp_prebicat_laws).

  Definition bidisp_tensor_disp_bicat : disp_bicat bicat_of_univ_cats.
  Proof.
    refine (bidisp_tensor_disp_prebicat,, _).
    intros C D F G α TC TD ptF ptG.
    apply isasetaprop.
    unfold disp_2cells.
    unfold bidisp_tensor_disp_prebicat.
    simpl.
    unfold bidisp_tensor_disp_2cell_struct.
    unfold preservestensor_commutes.
    repeat (apply impred_isaprop ; intro).
    apply univalent_category_has_homsets.
  Defined.

  (** We now show that this displayed bicategory is locally univalent *)
  Definition disp_inv_to_eq1
             {C D : bicat_of_univ_cats}
             {F : bicat_of_univ_cats⟦C,D⟧}
             {TC : bidisp_tensor_disp_bicat C}
             {TD : bidisp_tensor_disp_bicat D}
             (ptF ptG : TC -->[F] TD)
    : disp_invertible_2cell (id2_invertible_2cell F) ptF ptG -> pr1 ptF = pr1 ptG.
  Proof.
    intro i.
    apply funextsec ; intro ; apply funextsec ; intro.
    set (ix := (pr1 i) x x0).
    cbn in ix.
    rewrite id_right in ix.
    rewrite tensor_id in ix.
    rewrite id_left in ix.
    exact ix.
  Defined.

  Definition disp_inv_to_eq
             {C D : bicat_of_univ_cats}
             {F : bicat_of_univ_cats⟦C,D⟧}
             {TC : bidisp_tensor_disp_bicat C}
             {TD : bidisp_tensor_disp_bicat D}
             (ptF ptG : TC -->[F] TD)
    : disp_invertible_2cell (id2_invertible_2cell F) ptF ptG -> ptF = ptG.
  Proof.
    intro i.
    use total2_paths_b.
    - apply (disp_inv_to_eq1 ptF ptG i).
    - apply funextsec ; intro ; apply funextsec ; intro.
      repeat (apply impred_isaprop ; intro).
      apply univalent_category_has_homsets.
  Defined.

  Theorem bidisp_tensor_disp_bicat_is_locally_univalent :
    disp_univalent_2_1 bidisp_tensor_disp_bicat.
  Proof.
    apply fiberwise_local_univalent_is_univalent_2_1.
    intros C D F TC TD ptF1 ptF2.
    use isweqimplimpl.
    - apply disp_inv_to_eq.
    - cbn in ptF1 ; cbn in ptF2.
      rewrite idpath_transportf.
      unfold preserves_tensor in ptF1 ; unfold preserves_tensor in ptF2.
      assert (pf : isaset (preserves_tensor TC TD F)). {
        apply isaset_total2.
        - repeat (apply impred_isaset ; intro).
          apply univalent_category_has_homsets.
        - intro pt.
          apply isasetaprop.
          repeat (apply impred_isaprop ; intro).
          apply univalent_category_has_homsets.
      }
      apply pf.
    - apply isaproptotal2.
      + intro.
        apply isaprop_is_disp_invertible_2cell.
      + intros.
        apply isaprop_bidisp_tensor_disp_2cell_struct.
  Defined.

  (** We now show that this displayed bicategory is globally univalent **)

  Definition tensor_iso {C : univalent_category} (TC TD : tensor C) : UU
    := ∑ α : ∏ x y : C, z_iso (x ⊗_{TD} y) (x ⊗_{TC} y),
          ∏ (a1 a2 b1 b2 : C) (f : C⟦a1,a2⟧) (g : C⟦b1,b2⟧),
          (pr1 (α a1 b1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (pr1 (α a2 b2)).

  Definition tensor_eq {C : univalent_category} (TC TD : tensor C) : UU
    := ∑ (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)),
    ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
      (idtomor _ _ (α x1 y1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (idtomor _ _ (α x2 y2)).

  Definition tensor_eq' {C : univalent_category} (TC TD : tensor C) : UU
    := ∑ (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)),
    ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
      transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g)
      = (transportf _ (α x2 y2) (f ⊗^{TD} g)).

  Lemma idtomor_to_transport {C : univalent_category} (TC TD : tensor C)
        (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y))
        (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧)
    : (idtomor _ _ (α x1 y1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (idtomor _ _ (α x2 y2))
      -> transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g)
        = (transportf _ (α x2 y2) (f ⊗^{TD} g)).
  Proof.
    intro q.
    rewrite (! eq_idtoiso_idtomor _ _ _) in q.
    rewrite (! eq_idtoiso_idtomor _ _ _) in q.
    etrans. {
      apply (! idtoiso_precompose _ _ _ _ _ _).
    }
    etrans. {
      apply cancel_postcomposition.
      do 2 apply maponpaths.
      apply pathsinv0inv0.
    }
    etrans. { exact q. }
    apply idtoiso_postcompose.
  Qed.

  Lemma transport_to_idtomor {C : univalent_category} (TC TD : tensor C)
        (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y))
        (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧)
    : transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g)
      = (transportf _ (α x2 y2) (f ⊗^{TD} g))
      -> (idtomor _ _ (α x1 y1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (idtomor _ _ (α x2 y2)).
  Proof.
    intro q.
    etrans. {
      apply cancel_postcomposition.
      apply (! eq_idtoiso_idtomor _ _ _).
    }
    rewrite (! idtoiso_precompose _ _ _ _ _ _) in q.
    rewrite (! idtoiso_postcompose _ _ _ _ _ _) in q.
    rewrite pathsinv0inv0 in q.
    etrans. { apply q. }
    apply maponpaths.
    apply eq_idtoiso_idtomor.
  Qed.

  Lemma tensor_eq_equiv_tensor_eq' {C : univalent_category} (TC TD : tensor C)
    : tensor_eq' TC TD ≃ tensor_eq TC TD.
  Proof.
    apply weq_subtypes_iff.
    - intro.
      repeat (apply impred_isaprop ; intro).
      apply homset_property.
    - intro.
      repeat (apply impred_isaprop ; intro).
      apply homset_property.
    - intro pob.
      split.
      + intros q ? ? ? ? f g.
        apply transport_to_idtomor.
        exact (q _ _ _ _ f g).
      + intros q ? ? ? ? f g.
        apply idtomor_to_transport.
        exact (q _ _ _ _ f g).
  Defined.

  Definition tensor_eq'' {C : univalent_category} (TC TD : tensor C) : UU
    := ∑ (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)),
    ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
      f ⊗^{TC} g
      = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (α x1 y1) (transportf _ (α x2 y2) (f ⊗^{TD} g)).

  Lemma transport_to_transport_f_f {C : univalent_category} (TC TD : tensor C)
        (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y))
        (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧)
    : transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g)
      = transportf _ (α x2 y2) (f ⊗^{TD} g)
      -> f ⊗^{TC} g
        = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (α x1 y1) (transportf _ (α x2 y2) (f ⊗^{TD} g)).
  Proof.
    intro q.
    apply (transportf_transpose_right (P := λ x : C, C ⟦ x, x2 ⊗_{ TC} y2 ⟧)).
    exact q.
  Qed.

  Lemma transport_f_f_to_transport {C : univalent_category} (TC TD : tensor C)
        (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y))
        (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧)
    : f ⊗^{TC} g
      = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (α x1 y1) (transportf _ (α x2 y2) (f ⊗^{TD} g))
      -> transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g)
      = (transportf _ (α x2 y2) (f ⊗^{TD} g)).
  Proof.
    intro q.
    apply (transportf_transpose_left (P :=  (λ x : C, C ⟦ x, x2 ⊗_{ TC} y2 ⟧))).
    unfold transportb.
    rewrite pathsinv0inv0.
    apply q.
  Qed.

  Lemma tensor_eq'_equiv_tensor_eq'' {C : univalent_category} (TC TD : tensor C)
    : tensor_eq'' TC TD  ≃ tensor_eq' TC TD.
  Proof.
    apply weq_subtypes_iff.
    - intro.
      repeat (apply impred_isaprop ; intro).
      apply homset_property.
    - intro.
      repeat (apply impred_isaprop ; intro).
      apply homset_property.
    - intro pob.
      split.
      + intros q ? ? ? ? f g.
        apply transport_f_f_to_transport.
        exact (q _ _ _ _ f g).
      + intros q ? ? ? ? f g.
        apply transport_to_transport_f_f.
        exact (q _ _ _ _ f g).
  Defined.

  Lemma tensor_iso_equiv_tensor_eq {C : univalent_category} (TC TD : tensor C)
    : tensor_eq TC TD ≃ tensor_iso TC TD.
  Proof.
    use weqtotal2.
    - apply weqonsecfibers ; intro x ; apply weqonsecfibers ; intro y.
      use weq_iso.
      + apply idtoiso.
      + apply isotoid.
        apply univalent_category_is_univalent.
      + intro.
        apply isotoid_idtoiso.
      + intro.
        apply idtoiso_isotoid.
    - intro iso_tob.
      repeat (apply weqonsecfibers ; intro).
      use weq_iso.
      + intro p.
        cbn in p.
        rewrite (! eq_idtoiso_idtomor _ _ _) in p.
        rewrite (! eq_idtoiso_idtomor _ _ _) in p.
        apply p.
      + intro p.
        etrans. {
          apply cancel_postcomposition.
          apply (! eq_idtoiso_idtomor _ _ _).
        }
        etrans. { apply p. }
        apply cancel_precomposition.
        apply eq_idtoiso_idtomor.
      + intro ; apply homset_property.
      + intro ; apply homset_property.
  Defined.

  Lemma disp_eq_to_tensoriso {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C)
    : disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) TC TD -> tensor_iso TC TD.
  Proof.
    intro dae.
    induction dae as [[ptd ptnat] [data [ax equiv]]].
    induction data as [ptdinv [ptunit ptcounit]].
    cbn in *.

    use tpair.
    - intros x y.
      use make_z_iso.
      + exact (ptd x y).
      + exact (pr1 ptdinv x y).
      + split.
        * set (t := ptcounit x y).
          cbn in t.
          unfold identityfunctor_preserves_tensor_data in t.
          rewrite id_right in t.
          rewrite tensor_id in t.
          rewrite id_right in t.
          unfold compositions_preserves_tensor_data in t.
          unfold functor_identity in t.
          exact t.
        * set (t := ! ptunit x y).
          cbn in t.
          unfold identityfunctor_preserves_tensor_data in t.
          rewrite id_left in t.
          rewrite tensor_id in t.
          rewrite id_left in t.
          unfold compositions_preserves_tensor_data in t.
          exact t.
    - intros x1 x2 y1 y2 f g.
      exact (ptnat x1 x2 y1 y2 f g).
  Defined.

  Lemma swap_along_zisos {C : category} {x1 x2 y1 y2 : C}
      (p1 : z_iso x1 y1) (p2 : z_iso x2 y2) :
  ∏ (f: C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
    (pr1 p1) · g = f · (pr1 p2) -> (inv_from_z_iso p1) · f = g · (inv_from_z_iso p2) .
  Proof.
    intros f g p.
    apply z_iso_inv_on_right.
    rewrite assoc.
    apply z_iso_inv_on_left.
    apply p.
  Qed.

  Definition tensoriso_to_disp_eq {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C)
    : tensor_iso TC TD -> disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) TC TD.
  Proof.
    intro ti.
    use tpair.
    - use tpair.
      + intros x y.
        apply ti.
      + intros x1 x2 y1 y2 f g.
        exact ((pr2 ti) x1 x2 y1 y2 f g).

    (* disp_left_adjoint_equivalence *)
    - use tpair.
      + (* data *)
      repeat (use tpair).
      * intros x y.
        apply ti.
      * intros x1 x2 y1 y2 f g.
        induction ti as [n i].
        apply (swap_along_zisos (n x1 y1) (n x2 y2) (f ⊗^{pr1 TD} g) (f ⊗^{pr1 TC} g)).
        exact (i x1 x2 y1 y2 f g).
      * intros x y.
        cbn.
        unfold identityfunctor_preserves_tensor_data.
        unfold compositions_preserves_tensor_data.
        rewrite id_left.
        rewrite tensor_id.
        rewrite id_left.
        apply (! z_iso_after_z_iso_inv ((pr1 ti x y))).
      * intros x y.
        cbn.
        unfold compositions_preserves_tensor_data.
        unfold identityfunctor_preserves_tensor_data.
        rewrite id_right.
        rewrite tensor_id.
        rewrite id_left.
        cbn.
        apply (z_iso_inv_after_z_iso ((pr1 ti x y))).
      + (* axioms *)
        split.
        * split.
          -- abstract (repeat (apply funextsec ; intro) ;
             apply univalent_category_has_homsets).
          -- apply funextsec ; intro ; apply funextsec ; intro.
             apply univalent_category_has_homsets.
        * split.
          -- use tpair.
             ++ intros x y.
                cbn.
                unfold compositions_preserves_tensor_data.
                unfold identityfunctor_preserves_tensor_data.
                cbn.
                rewrite id_right.
                rewrite id_right.
                rewrite tensor_id.
                apply (z_iso_after_z_iso_inv ((pr1 ti x y))).
             ++ split.
                ** abstract (repeat (apply funextsec ; intro) ;
                   apply univalent_category_has_homsets).
                ** abstract (repeat (apply funextsec ; intro) ;
                   apply univalent_category_has_homsets).
          -- use tpair.
             ++ intros x y.
                cbn.
                unfold compositions_preserves_tensor_data.
                unfold identityfunctor_preserves_tensor_data.
                cbn.
                rewrite id_right.
                rewrite tensor_id.
                rewrite id_left.
                apply (! z_iso_inv_after_z_iso ((pr1 ti x y))).
             ++ split.
                ** abstract (repeat (apply funextsec ; intro) ;
                   apply univalent_category_has_homsets).
                ** abstract (repeat (apply funextsec ; intro) ;
                   apply univalent_category_has_homsets).
  Defined.

  Lemma tensor_iso_disp_eq_equiv {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C)
    : tensor_iso TC TD ≃ disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) TC TD.
  Proof.
    use weq_iso.
    - intro ti.
      apply (tensoriso_to_disp_eq TC TD ti).
    - intro dae.
      exact (disp_eq_to_tensoriso TC TD dae).
    - intro i.
      induction i.
      use subtypePath.
      + intro f.
        repeat (apply impred_isaprop ; intro).
        apply univalent_category_has_homsets.
      + repeat (apply funextsec ; intro).
        use subtypePath.
        * intro f.
          apply isaprop_is_z_isomorphism.
        * repeat (apply funextsec ; intro).
          apply idpath.
    - intro dae.
      use subtypePath.
      + intro f.
        apply isaprop_disp_left_adjoint_equivalence.
        * apply univalent_cat_is_univalent_2_1.
        * apply bidisp_tensor_disp_bicat_is_locally_univalent.
      + apply idpath.
  Defined.

  Definition tensor_eqi'' {C : univalent_category} (TC TD : tensor C) : UU
    := ∑ (α : ∏ x y : C, (x ⊗_{TC} y) = (x ⊗_{TD} y)),
    ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
      f ⊗^{TC} g
      = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (transportf _ (! α x2 y2) (f ⊗^{TD} g)).

  Lemma tensor_eq''_equiv_tensor_eqi'' {C : univalent_category} (TC TD : tensor C)
    : tensor_eqi'' TC TD ≃ tensor_eq'' TC TD.
  Proof.
    use weq_iso.
    - intro tei.
      use tpair.
      + intros x y.
        exact (! pr1 tei x y).
      + intros x1 x2 y1 y2 f g.
        exact (pr2 tei _ _ _ _ f g).
    - intro te.
      use tpair.
      + intros x y.
        exact (! pr1 te x y).
      + intros x1 x2 y1 y2 f g.
        rewrite pathsinv0inv0.
        rewrite pathsinv0inv0.
        apply (pr2 te).
    - intro te.
      use total2_paths_b.
      + repeat (apply funextsec ; intro).
        apply pathsinv0inv0.
      + repeat (apply funextsec ; intro).
        apply homset_property.
    - intro tei.
      use total2_paths_b.
      + repeat (apply funextsec ; intro).
        apply pathsinv0inv0.
      + repeat (apply funextsec ; intro).
        apply homset_property.
  Defined.

  Definition tensor_eqi''' {C : univalent_category} (TC TD : tensor C) : UU
    := ∑ (α : ∏ x y : C, (x ⊗_{TC} y) = (x ⊗_{TD} y)),
    ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
      transportf (λ x : C, C⟦x , x2 ⊗_{TD} y2⟧) (α x1 y1) (transportf (λ x : C, C⟦x1 ⊗_{TC} y1 , x⟧) (α x2 y2) (f ⊗^{TC} g)) = (f ⊗^{TD} g).

  Lemma independent_transportation_commutes {C : univalent_category}
        {F G : C -> C -> C}
        {x1 x2 y1 y2 : C}
        (p1 : F x1 y1 = G x1 y1)
        (p2 : F x2 y2 = G x2 y2)
        (f : C⟦F x1 y1, F x2 y2⟧)
    :  transportf (λ c : C, C ⟦ G x1 y1, c ⟧) p2
    (transportf (λ c : C, C ⟦ c, F x2 y2 ⟧) p1 f) =
  transportf (λ c : C, C ⟦ c, G x2 y2 ⟧) p1
             (transportf (λ c : C, C ⟦ F x1 y1, c ⟧) p2 f).
  Proof.
    induction p1 ; induction p2.
    apply idpath.
  Qed.

  Lemma tensor_eqi''_equiv_tensor_eqi''' {C : univalent_category} (TC TD : tensor C)
    : tensor_eqi''' TC TD ≃ tensor_eqi'' TC TD.
  Proof.
    apply weqfibtototal.
    intro.
    repeat (apply weqonsecfibers ; intro).
    use weq_iso.
    - intro q.
      apply pathsinv0.
      etrans. {
        apply maponpaths.
        apply maponpaths.
        exact (! q).
      }
      rewrite (! independent_transportation_commutes _ _ _).
      rewrite transport_f_f.
      rewrite pathsinv0r.
      rewrite idpath_transportf.
      rewrite transport_f_f.
      rewrite pathsinv0r.
      apply idpath_transportf.
    - intro q.
      etrans. {
        apply maponpaths.
        apply maponpaths.
        exact q.
      }
      rewrite (! independent_transportation_commutes _ _ _).
      rewrite transport_f_f.
      rewrite pathsinv0l.
      rewrite idpath_transportf.
      rewrite transport_f_f.
      rewrite pathsinv0l.
      apply idpath_transportf.
    - intro q.
      apply homset_property.
    - intro q.
      apply homset_property.
  Defined.

  Lemma transport_of_bifunctor_map_is_pointwise {C : univalent_category}
      {F0 G0 : ob C -> ob C -> ob C}
      (F1 : ∏ x1 x2 y1 y2 : ob C, C⟦x1,x2⟧ -> C⟦y1,y2⟧ -> C⟦F0 x1 y1, F0 x2 y2⟧)
      (gamma : F0  = G0)
      {x1 x2 y1 y2 : ob C} (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧) :
  transportf (fun T : C -> C -> C =>
                ∏ a1 a2 b1 b2 : C, C⟦a1,a2⟧ -> C⟦b1,b2⟧ -> C⟦T a1 b1, T a2 b2⟧)
             gamma F1 x1 x2 y1 y2 f g =
    double_transport
      (toforallpaths (λ _ : ob C, C) (F0 x1) (G0 x1) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x1) y1)
      (toforallpaths (λ _ : ob C, C) (F0 x2) (G0 x2) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x2) y2)
                   (F1 _ _ _ _ f g).
  Proof.
    induction gamma.
    apply idpath.
  Qed.

  Definition tensor_eqi'''_to_eq1 {C : univalent_category} (TC TD : tensor C) : tensor_eqi''' TC TD -> pr11 TC = pr11 TD.
  Proof.
    intro te.
    apply funextsec ; intro ; apply funextsec ; intro ; apply (pr1 te).
  Defined.

  Definition tensor_eqi'''_to_eq {C : univalent_category} (TC TD : tensor C) : tensor_eqi''' TC TD -> TC = TD.
  Proof.
    intro te.
    use total2_paths_f.
    - use total2_paths_f.
      + (* apply funextsec ; intro ; apply funextsec ; intro ; apply (pr1 te). *)
        exact (tensor_eqi'''_to_eq1 TC TD te).
      + repeat (apply funextsec ; intro).
        etrans.
        2: apply (pr2 te).

        etrans. {
          apply transport_of_bifunctor_map_is_pointwise.
        }
        unfold double_transport.
        unfold tensor_eqi'''_to_eq1.
        rewrite toforallpaths_funextsec.
        rewrite toforallpaths_funextsec.
        rewrite toforallpaths_funextsec.
        apply independent_transportation_commutes.
    - use total2_paths_f.
      + abstract (repeat (apply impred_isaprop ; intro) ;
        apply homset_property).
      + abstract (repeat (apply impred_isaprop ; intro) ;
        apply homset_property).
  Defined.

  Lemma id_tensor_eqi'''_2 {C : univalent_category} (TC TD : tensor C)
    : pr11 TC = pr11 TD ->  ∏ x y : C, x ⊗_{ TC} y = x ⊗_{ TD} y.
  Proof.
    intros p x y.
    exact (toforallpaths _ _ _ (toforallpaths _ _ _ p x) y).
  Defined.

  Lemma id_tensor_eqi'''_1 {C : univalent_category} (TC TD : tensor C)
    : TC = TD ->  ∏ x y : C, x ⊗_{ TC} y = x ⊗_{ TD} y.
  Proof.
    intros p.
    set (eqonob := base_paths _ _ (base_paths _ _ p)).
    (* exact (toforallpaths _ _ _ (toforallpaths _ _ _ eqonob x) y). *)
    exact (id_tensor_eqi'''_2 TC TD eqonob).
  Defined.

  Lemma id_tensor_eqi''' {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C)
    : TC = TD -> tensor_eqi''' TC TD.
  Proof.
    intro p.
    (* induction p. *)
    use tpair.
    - exact (id_tensor_eqi'''_1 TC TD p).

      (* induction p.
      apply idpath. *)
    - intros ? ? ? ? f g.
      induction p.
      etrans.
      { apply (! idpath_transportf _ _). }
      apply idpath_transportf.
  Defined.

  Lemma total2_paths_idpath {A : UU} {B : A -> UU} (x : ∑ y : A, B y)
    : total2_paths_f (idpath (pr1 x)) (idpath_transportf B (pr2 x)) = idpath x.
  Proof.
    apply idpath.
  Qed.

  Lemma maponpaths_total {A : UU} {B : A -> UU} (x : ∑ y : A, B y)
        (p0 : pr1 x = pr1 x) (p1 : transportf B p0 (pr2 x) = pr2 x)
        (q0 : pr1 x = pr1 x) (q1 : transportf B q0 (pr2 x) = pr2 x)
    : p0=q0 ->  (∏ a : A, isaset (B a)) -> total2_paths_f p0 p1 = total2_paths_f q0 q1.
  Proof.
    intro k0.
    induction k0.
    intro pfset.
    apply maponpaths.
    apply pfset.
  Qed.

  Lemma cancellation_lemma {A B : UU} (a : A) (b : B) (f : A -> B) (g : B -> A)
    : (∏ b0 : B, f (g b0) = b0) -> g (f a) = g(b) -> f a = b.
  Proof.
    intros i e.
    set (k0 := ! i (f a)).
    rewrite e in k0.
    exact (k0 @ i b).
  Qed.

  Lemma funextsec_id'' {C : univalent_category} (T : C -> C -> C)
    : ∏ x : C, toforallpaths (λ _ : C,C) _ _ (funextsec (λ _ : C, C) (T x) (T x) (λ x0 : C, idpath (T x x0))) =
        toforallpaths (λ _ : C, C) _ _ (toforallpaths (λ _ : C, C → C) T T (idpath T) x).
  Proof.
    intro x.
    etrans. {
      apply toforallpaths_funextsec.
    }
    apply funextsec ; intro y.
    apply idpath.
  Qed.

  Lemma funextsec_id' {C : univalent_category} (T : C -> C -> C)
    : toforallpaths (λ _ : C, C → C) T T (
        (funextsec (λ _ : C, C → C) T T
                (λ x : C, funextsec (λ _ : C, C) (T x) (T x) (λ x0 : C, idpath (T x x0))))) = toforallpaths (λ _ : C, C → C) T T (idpath T).
  Proof.
    etrans. {
      apply toforallpaths_funextsec.
    }
    apply funextsec ; intro x.
    apply (cancellation_lemma _ _ _ (toforallpaths (λ _: C,C) (T x) (T x))).
    - intro q.
      apply funextsec_toforallpaths.
    - apply funextsec_id''.
  Qed.

  Lemma funextsec_id {C : univalent_category} {T : C -> C -> C}
    : funextsec (λ _ : C, C → C) T T
                (λ x : C, funextsec (λ _ : C, C) (T x) (T x) (λ x0 : C, idpath (T x x0)))
      = idpath T.
  Proof.
    apply (cancellation_lemma _ _ _ (toforallpaths (λ _ : C, C -> C) T T)).
    - intro q.
      apply funextsec_toforallpaths.
    - apply funextsec_id'.
  Qed.

  Lemma id_to_teqi'''_to_id
        {C : bicat_of_univ_cats}
        {TC TD : bidisp_tensor_disp_bicat C}
        (p : TC = TD)
    : tensor_eqi'''_to_eq TC TD (id_tensor_eqi''' TC TD p) = p.
  Proof.
    unfold tensor_eqi'''_to_eq.
    unfold id_tensor_eqi'''.
    induction p.
    use pathscomp0.
    3: apply total2_paths_idpath.

    apply maponpaths_total.
    - use pathscomp0.
      3: apply total2_paths_idpath.
      apply maponpaths_total.
      + apply funextsec_id.
      + intro T.
        repeat (apply impred_isaset ; intro).
        apply homset_property.
    - intro T.
      apply isaset_dirprod; repeat (apply impred_isaset ; intro) ; apply isasetaprop ; apply homset_property.
  Qed.

  Lemma pr_id_tensor_eqi'''_funextsec {C : univalent_category} {TC TD : tensor C} (p : TC = TD) (x y : C)
    : pr1 (id_tensor_eqi''' TC TD p) x y = id_tensor_eqi'''_1 TC TD p x y.
  Proof.
    apply idpath.
  Qed.

  Lemma distributer {C : univalent_category} {TC TD : tensor C} (p : tensor_eqi''' TC TD)
    :  id_tensor_eqi'''_1 TC TD (tensor_eqi'''_to_eq TC TD p) = id_tensor_eqi'''_2 TC TD (tensor_eqi'''_to_eq1 TC TD p).
  Proof.
    unfold id_tensor_eqi'''_1.
    apply maponpaths.
    etrans. {
      apply maponpaths.
      apply base_total2_paths.
    }
    apply base_total2_paths.
  Qed.

  Lemma distributer_funext {C : univalent_category} {TC TD : tensor C} (p : tensor_eqi''' TC TD) (x y : C)
    :  id_tensor_eqi'''_1 TC TD (tensor_eqi'''_to_eq TC TD p) x y = id_tensor_eqi'''_2 TC TD (tensor_eqi'''_to_eq1 TC TD p) x y.
  Proof.
    rewrite distributer.
    apply idpath.
  Qed.

  Lemma teqi'''_to_id_to_teqi'''
        {C : bicat_of_univ_cats}
        {TC TD : bidisp_tensor_disp_bicat C}
        (p : tensor_eqi''' TC TD)
    : id_tensor_eqi''' TC TD (tensor_eqi'''_to_eq TC TD p) = p.
  Proof.
    use total2_paths_f.
    - apply funextsec ; intro x ; apply funextsec ; intro y.
      etrans. {
        apply pr_id_tensor_eqi'''_funextsec.
      }
      etrans. {
        apply distributer_funext.
      }
      unfold id_tensor_eqi'''_2.
      unfold tensor_eqi'''_to_eq1.
      rewrite toforallpaths_funextsec.
      rewrite toforallpaths_funextsec.
      apply idpath.
    - repeat (apply funextsec ; intro).
      apply homset_property.
  Qed.

  Definition tensor_eqi'''_equiv_eq {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C)
    : TC = TD ≃ tensor_eqi''' TC TD.
  Proof.
    use weq_iso.
    - intro eq.
      exact (id_tensor_eqi''' TC TD eq).
    - intro teq.
      exact (tensor_eqi'''_to_eq _ _ teq).
    - intro eq.
      apply id_to_teqi'''_to_id.
    - intro teq.
      apply teqi'''_to_id_to_teqi'''.
  Defined.

  Lemma bicatcattensor_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_tensor_disp_bicat.
  Proof.
   intros C D equalcats TC TD.
   induction equalcats.
   use weqhomot.
   - set (i1 := tensor_iso_disp_eq_equiv TC TD).
     set (i2 := tensor_iso_equiv_tensor_eq TC TD).
     set (i3 := tensor_eq_equiv_tensor_eq' TC TD).
     set (i4 := tensor_eq'_equiv_tensor_eq'' TC TD).
     set (i5 := tensor_eq''_equiv_tensor_eqi'' TC TD).
     set (i6 := tensor_eqi''_equiv_tensor_eqi''' TC TD).
     set (i7 := tensor_eqi'''_equiv_eq TC TD).
     exact ((i1 ∘ i2 ∘ i3 ∘ i4 ∘ i5 ∘ i6 ∘ i7)%weq).
   - intro p.
     induction p.
     use subtypePath.
     + intro.
       apply (@isaprop_disp_left_adjoint_equivalence bicat_of_univ_cats  bidisp_tensor_disp_bicat).
       * exact univalent_cat_is_univalent_2_1.
       * exact bidisp_tensor_disp_bicat_is_locally_univalent.
     + use total2_paths_b.
       * repeat (apply funextsec ; intro).
         apply idpath.
       * repeat (apply funextsec ; intro).
         apply homset_property.
  Qed.

  Lemma bidisp_tensor_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_tensor_disp_bicat.
  Proof.
    apply make_disp_univalent_2.
    - apply bicatcattensor_disp_prebicat_is_globally_univalent.
    - apply bidisp_tensor_disp_bicat_is_locally_univalent.
  Defined.

  Definition bidisp_tensor_disp_2cells_isaprop : disp_2cells_isaprop bidisp_tensor_disp_bicat.
  Proof.
    intros C D F G α TC TD ptC ptD.
    apply isaprop_bidisp_tensor_disp_2cell_struct.
  Qed.

  Definition bidisp_tensor_disp_locally_groupoid : disp_locally_groupoid bidisp_tensor_disp_bicat.
  Proof.
    unfold disp_locally_groupoid.
    intros C D F G α TC TD ptC ptD ptc.
    unfold is_disp_invertible_2cell.
    use tpair.
    - intros x y.

      set (α_natiso := (invertible_2cell_to_nat_z_iso F G α)).
      set (α_natisox := nat_z_iso_pointwise_z_iso α_natiso x : z_iso (pr1 F x) (pr1 G x)).
      set (α_natisoy := nat_z_iso_pointwise_z_iso α_natiso y : z_iso (pr1 F y) (pr1 G y)).
      set (α_natisoxty := nat_z_iso_pointwise_z_iso α_natiso (x ⊗_{ TC: tensor (C : univalent_category)} y)
             : z_iso (pr1 F (x ⊗_{ TC: tensor (C : univalent_category)} y))
                     (pr1 G (x ⊗_{ TC: tensor (C : univalent_category)} y))
          ).
      transparent assert (α_natisotxmym
                           : (z_iso
                                (pr1 G x ⊗_{ TD: tensor (D : univalent_category)} pr1 G y)
                                (pr1 F x ⊗_{ TD: tensor (D : univalent_category)} pr1 F y)
                             )
                         ).
      {
        exists (pr1 (α ^-1)%bicategory x ⊗^{ TD: tensor (D : univalent_category)} pr1 (α ^-1)%bicategory y).
        exists (pr11 α%bicategory x ⊗^{ TD: tensor (D : univalent_category)} pr11 α%bicategory y).
        split.
        - rewrite <- tensor_comp.
          etrans.
          {
            apply (maponpaths (t2:=identity (pr1 G x)) (fun l => l ⊗^{ TD: tensor (D : univalent_category)} (pr1 (α ^-1)%bicategory y · (pr11 α) y))).
            apply (pr222 α_natisox).
          }
          etrans.
          { apply maponpaths. apply (pr222 α_natisoy). }
          apply tensor_id.
        - rewrite <- tensor_comp.
          etrans.
          {
            apply (maponpaths (t2:=identity (pr1 F x)) (fun l => l ⊗^{ TD: tensor (D : univalent_category)} ((pr11 α) y · pr1 (α ^-1)%bicategory y))).
            apply (pr122 α_natisox).
          }
          etrans.
          { apply maponpaths. apply (pr122 α_natisoy). }
          apply tensor_id.
      }

      apply (z_iso_inv_to_left _ _ _ α_natisotxmym).
      rewrite assoc.

      apply pathsinv0, (z_iso_inv_on_left _ _ _ _ α_natisoxty).
      cbn.
      cbn in ptc. unfold bidisp_tensor_disp_2cell_struct in ptc. red in ptc.
      apply pathsinv0, ptc.
    - split ; apply isaprop_bidisp_tensor_disp_2cell_struct.
  Qed.

End TensorLayer.


From Coq Require Import ssreflect ssrfun ssrbool.
Require Import stdpp.tactics.

Require Import depleted.proset.
Require Import depleted.bounds.
Require Import depleted.adjunction.
Require Import depleted.monoidal.
Local Open Scope proset_scope.
Local Open Scope proset_util_scope.

Definition down (X : Type) `{Proset X} : Type := Hom (op X) Prop.
Identity Coercion down_to_hom : down >-> Hom.

Lemma danti `{Proset X} (F : down X) {A B : X}
  : A ⊢ B -> F B -> F A.
Proof. move=> /opify /(mono F) //. Qed.
Hint Resolve danti.

Program Definition yo `{Proset X} (A : X) : down X :=
  fun B : X => B ⊢ A.
Next Obligation. move=> * ? * ?; by etransitivity. Qed.
Instance: Params (@yo) 3 := {}.
Lemma yoneda `{Proset X} (A : X) (F : down X)
  : yo A ⊢ F <-> F A.
Proof.
  split.
  - apply; by simpl.
  - move=> FA A' D; by apply: danti FA.
Qed.

Instance yo_mono `{Proset X} : Monotone (yo (X:=X)).
Proof. move=> /= * ? ?; by etransitivity. Qed.
Instance yo_reflect `{Proset X} : Reflecting (yo (X:=X)).
Proof. move=> A B /(_ A) /=; by apply. Qed.
Instance yo_continuous `{Proset X} : Continuous (yo (X:=X)).
Proof.
  move=> R J A [C U]; split=> [r | A' C'] B /=.
  - move=> ->; apply: C.
  - move=> /yoneda D; apply: U => r; apply: (reflect yo); etransitivity; firstorder.
Qed.
Definition principal `{Proset X} (F : down X) : Prop :=
  exists A, F ⟛ yo A.


Require Import Fiat.Common.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.Enumerable.ReflectiveForall.
Require Import Fiat.Common.Equality.

Section reflective_forall.
  Context {A : Type} (P : A -> bool)
          {eq_A : BoolDecR A}
          {Abl : BoolDec_bl (@eq A)}
          {Alb : BoolDec_lb (@eq A)}
          {Henum : Enumerable { x : A | is_true (P x) }}
          {R_enum : Type}
          {eq_R_enum : BoolDecR R_enum}
          {R_enum_bl : BoolDec_bl (@eq R_enum)}
          {R_enum_lb : BoolDec_lb (@eq R_enum)}.

  Section inner.
    Context {R : Type}
            (x : A)
            (f : A -> R_enum)
            (g : R_enum -> R)
            (base : R).

    Definition forall_enumerable_by_beq_aggregate : R
      := let all := List.map (@proj1_sig _ _) (enumerate { x : A | is_true (P x) }) in
         let possibilities := uniquize eq_R_enum (List.map f all) in
         List.fold_right
           (fun y else_case
            => If
                 (List.fold_right
                    orb
                    false
                    (List.map
                       (fun z => if beq (f z) y then beq x z else false)
                       all))
               Then
                 g y
               Else
                 else_case)
           base
           possibilities.

    Definition forall_enumerable_by_beq_aggregate' : R
      := let all := List.map (@proj1_sig _ _) (enumerate { x : A | is_true (P x) }) in
         let possibilities := uniquize eq_R_enum (List.map f all) in
         List.fold_right
           (fun y else_case
            => If beq (f x) y Then g y Else else_case)
           base
           possibilities.

    Lemma forall_enumerable_by_beq_aggregate'_eq
          (H_f_good : forall y, f x = f y -> P y -> P x)
      : forall_enumerable_by_beq_aggregate = forall_enumerable_by_beq_aggregate'.
    Proof.
      unfold forall_enumerable_by_beq_aggregate', forall_enumerable_by_beq_aggregate.
      destruct (P x) eqn:Hx.
      { match goal with
        | [ |- context[uniquize ?beq ?ls] ]
          => induction (uniquize beq ls) as [|y ys IHys]
        end.
        { reflexivity. }
        { simpl; rewrite IHys; clear IHys.
          repeat match goal with
                 | [ |- _ = _ ] => reflexivity
                 | _ => progress subst
                 | [ H : beq _ _ = true |- _ ] => apply bl in H
                 | [ H : context[beq ?x ?x] |- _ ] => rewrite lb in H by reflexivity
                 | _ => discriminate
                 | [ H : context[if ?b then _ else _] |- _ ]
                   => destruct b eqn:?; simpl in *
                 | [ |- context[If ?b Then _ Else _] ]
                   => destruct b eqn:?; simpl
                 | [ H : List.fold_right orb false (List.map _ _) = _ |- _ ]
                   => apply fold_right_orb_map_sig1 in H
                 | [ H : List.fold_right orb false (List.map _ _) = false |- _ ]
                   => rewrite fold_right_orb_map_sig2 in H; [ | clear H ]
                 | _ => progress destruct_head sig
                 | _ => progress destruct_head and
                 | [ |- { _ : _ | _ } ] => eexists
                 | [ |- _ /\ _ ] => split
                 | [ |- List.In ?x (List.map (@proj1_sig ?A ?B) ?ls) ]
                   => apply (fun x0 x1 => List.in_map (@proj1_sig A B) ls (exist _ x0 x1))
                 | [ |- context[beq ?x ?y] ] => unify x y; rewrite lb by reflexivity
                 | [ |- List.In _ (enumerate _) ] => apply enumerate_correct
                 end. } }
      { match goal with
        | [ |- context[uniquize _ (List.map _ ?ls)] ]
          => destruct (list_bin beq x ls) eqn:Heq; [ exfalso | ]
        end.
        { apply (list_in_bl bl), List.in_map_iff in Heq.
          destruct_head ex;
          destruct_head sig;
          destruct_head and;
          subst.
          congruence. }
        match goal with
        | [ |- List.fold_right (fun y else_case => If (@?T y) Then _ Else _) _ _ = _ ]
          => assert (forall y, P y -> T (f y) = false)
        end.
        { intros y' Hy'.
          match goal with
          | [ |- context[enumerate ?T] ]
            => induction (enumerate T) as [|y ys IHys]
          end.
          { reflexivity. }
          { simpl in *.
            repeat match goal with
                   | [ H : orb _ _ = false |- _ ] => apply Bool.orb_false_iff in H
                   | _ => progress destruct_head and
                   | _ => progress specialize_by assumption
                   | [ H : beq _ _ = true |- _ ] => apply bl in H
                   | [ H : context[beq ?x ?x] |- _ ] => rewrite lb in H by reflexivity
                   | _ => rewrite IHys'; []; clear IHys'
                   | [ |- context[beq ?x ?y] ]
                     => destruct (beq x y) eqn:?
                   | _ => progress subst
                   | _ => progress simpl
                   | _ => congruence
                   end. } }
        simpl in *.
        match goal with
        | [ |- context[uniquize ?beq (List.map _ (List.map _ ?ls))] ]
          => induction ls as [|y ys IHys]
        end.
        { reflexivity. }
        { simpl in *.
          repeat match goal with
                 | [ H : orb _ _ = false |- _ ] => apply Bool.orb_false_iff in H
                 | _ => progress destruct_head and
                 | _ => progress specialize_by assumption
                 | [ |- List.fold_right ?f ?k (if ?b then ?x else ?y)
                        = List.fold_right ?f' ?k (if ?b then ?x else ?y) ]
                   => transitivity (if b then List.fold_right f k x else List.fold_right f k y);
                     [ destruct b; reflexivity
                     | transitivity (if b then List.fold_right f' k x else List.fold_right f' k y);
                       [
                       | destruct b; reflexivity ] ]
                 | [ |- (if ?b then ?x else ?x) = _ ]
                   => transitivity x; [ destruct b; reflexivity | ]
                 | [ |- _ = (if ?b then ?x else ?x) ]
                   => transitivity x; [ | destruct b; reflexivity ]
                 | [ |- (if ?b then ?x else (If ?b' Then ?y Else ?x)) = _ ]
                   => transitivity (If (b || negb b')%bool Then x Else y); [ destruct b, b'; reflexivity | ]
                 | _ => progress simpl in *
                 | _ => progress subst
                 | _ => progress destruct_head sig
                 | [ H : beq _ _ = true |- _ ] => apply bl in H
                 | [ H : context[beq ?x ?x] |- _ ] => rewrite lb in H by reflexivity
                 | [ |- context[beq ?x ?y] ]
                   => destruct (beq x y) eqn:?
                 | [ H : forall y', ?k = ?f y' -> is_true (?P y') -> is_true false,
                       H' : is_true (?P ?y),
                       H'' : ?k = ?f ?y |- _ ]
                   => specialize (H _ H'' H')
                 | _ => congruence
                 | [ H : forall y, _ -> orb _ _ = false |- _ ]
                   => pose proof (fun y k => Bool.orb_false_elim _ _ (H y k)); clear H
                 | _ => progress split_and
                 | [ H : forall y, is_true (?P y) -> _ = false,
                       H' : is_true (?P ?x0)
                       |- context[List.fold_right orb false (List.map (fun z => if beq (?f z) (?f ?x0) then beq _ _ else _) _)] ]
                   => rewrite (H _ H')
                 | _ => rewrite Bool.orb_true_r
                 end.
          rewrite <- IHys; clear IHys.
          match goal with
          | [ |- List.fold_right (fun x' y' => If orb (if @?A x' y' then false else false) (@?B x' y') Then @?C x' y' Else @?D x' y') ?E ?ls
                 = List.fold_right (fun x'' y'' => If (@?B x'' y'') Then @?C x'' y'' Else @?D x'' y'') ?E ?ls ]
            => clear; induction ls as [|l0 ls0 IHls0];
               [ reflexivity
               | simpl; rewrite IHls0; clear IHls0 ]
          end.
          match goal with
          | [ |- context[if ?e then false else false] ]
            => destruct e eqn:?; reflexivity
          end. } }
      Unshelve.
      assumption.
    Qed.

    Lemma forall_enumerable_by_beq_aggregate_correct
          (H_f_good : forall y, f x = f y -> P y -> P x)
    : forall_enumerable_by_beq_aggregate = if P x then g (f x) else base.
    Proof.
      rewrite forall_enumerable_by_beq_aggregate'_eq by assumption.
      rewrite <- (forall_enumerable_by_beq_correct P x (fun y => g (f y)) base).
      unfold forall_enumerable_by_beq_aggregate', forall_enumerable_by_beq.
      change eq_R_enum with beq.
      progress change (@beq _ (@beq _ eq_R_enum)) with (@beq _ eq_R_enum).
      rewrite fold_right_uniquize.
      rewrite !fold_right_beq_in_correct'.
      repeat match goal with
             | [ |- ?x = ?x ] => reflexivity
             | _ => discriminate
             | [ |- context[list_bin ?beq ?x ?y] ]
               => destruct (list_bin beq x y) eqn:?
             | [ H : list_bin _ _ _ = true |- _ ]
               => apply (list_in_bl bl) in H
             | [ H : List.In _ (List.map _ _) |- _ ] => apply List.in_map_iff in H
             | [ |- List.In _ (List.map _ _) ] => apply List.in_map_iff
             | _ => progress subst
             | _ => progress destruct_head ex
             | _ => progress destruct_head sig
             | _ => progress destruct_head and
             | _ => progress simpl in *
             | [ H : list_bin ?beq ?x ?y = false |- _ ]
               => exfalso; rewrite (list_in_lb lb) in H; [ | clear H ]
             | [ |- _ /\ _ ] => split
             | [ |- @ex (sig _) _ ] => eexists (exist _ _ _)
             | [ |- ex _ ] => eexists
             | [ |- _ = ?x ] => is_var x; reflexivity
             | [ |- ?f _ = ?f ?x ] => is_var x; reflexivity
             | [ |- List.In _ (enumerate _) ] => apply enumerate_correct
             end.
      Unshelve.
      simpl; eapply H_f_good; first [ eassumption | symmetry; eassumption ].
      eassumption.
    Qed.

    Lemma forall_enumerable_by_beq_aggregate_correct_reachable
          (H : is_true (P x))
    : forall_enumerable_by_beq_aggregate = g (f x).
    Proof.
      rewrite forall_enumerable_by_beq_aggregate_correct, H by (rewrite H; reflexivity).
      reflexivity.
    Qed.
  End inner.
End reflective_forall.


(* ============================== *)
(* Syntax for the source language *)
(* ============================== *)

Require Import String.
Require Import Basics.

(* ----------------- *)
(* The core language *)
(* ----------------- *)

Inductive ty :=
| Longtid_ty : longtid -> ty
| Arr_ty : ty -> ty -> ty.

Inductive exp :=
| Longvid_exp : longvid -> exp
| Lam_exp : vid -> exp -> exp
| App_exp : exp -> exp -> exp
| Typ_exp : exp -> ty -> exp.

Inductive dec :=
| Val_dec : vid -> exp -> dec.

(* ------------------------------- *)
(* Module types and specifications *)
(* ------------------------------- *)

Inductive mty :=
| Bra_mty : spec -> mty
| Mtid_mty : mtid -> mty
| Arr_mty : option mid -> mty -> mty -> mty
| With_mty : mty -> longtid -> ty -> mty
with spec :=
| Type_spec : tid -> option ty -> spec
| Val_spec : vid -> ty -> spec
| Module_spec : mid -> mty -> spec
| Include_spec : mty -> spec
| Seq_spec : spec -> spec -> spec
| Emp_spec : spec.

(* ----------------------------------- *)
(* Module expressions and declarations *)
(* ----------------------------------- *)

Inductive mexp :=
| Bra_mexp : mdec -> mexp
| Mid_mexp : mid -> mexp
| Prj_mexp : mexp -> mid -> mexp
| Funct_mexp : mid -> mty -> mexp -> mexp
| App_mexp : longmid -> mexp -> mexp
with mdec :=
| Dec_mdec : dec -> mdec
| Type_mdec : tid -> ty -> mdec
| Mod_mdec : mid -> mexp -> mdec
| ModTyp_mdec : mtid -> mty -> mdec
| Open_mdec : mexp -> mdec
| Seq_mdec : mdec -> mdec -> mdec
| Emp_mdec : mdec.


Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.Monotone.
Require Import UFO.Rel.Compat_map.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Set Implicit Arguments.

Section section_compat_md_ev.

Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (σ : ms ∅ (inc EV) LV ∅) (ℓ : lbl LV ∅).
Context (m₁ m₂ : md (inc EV) LV V ∅).

Hint Resolve subset_trans.

Lemma compat_md_ev n :
n ⊨ ⟦ (EV_shift_XEnv Ξ) (EV_shift_ty ∘ Γ) ⊢ m₁ ≼ˡᵒᵍₘ m₂ : σ ^ ℓ ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (md_ev m₁) ≼ˡᵒᵍₘ (md_ev m₂) : (ms_ev σ) ^ ℓ ⟧.
Proof.
intro Hm.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
simpl 𝓜_Fun.
repeat ieexists ; repeat isplit ; [ crush | ].
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
iintro E₁ ; iintro E₂ ; iintro φ ; iintro Hφ.
ispecialize Hm ξ₁' ; ispecialize Hm ξ₂'.
ispecialize Hm (env_ext δ₁ E₁) ; ispecialize Hm (env_ext δ₂ E₂) ;
ispecialize Hm (env_ext δ φ).
iespecialize Hm.
ispecialize Hm.
{ iintro_prop ; ielim_prop Hξ ; unfold 𝜩 ; rewrite EV_map_XEnv_dom.
  eapply 𝜩_monotone ; eauto.
}
ispecialize Hm.
{ clear - Hδ Hφ Hξ₁' Hξ₂'.
  iintro α ; destruct α as [ | α ] ; simpl ; [ crush | ].
  repeat iintro ; iespecialize Hδ ; ispecialize Hδ ; [ eassumption | ].
  apply postfix_is_subset in Hξ₁' ; apply postfix_is_subset in Hξ₂'.
  ielim_prop Hδ ; destruct Hδ ; split ; eauto.
}
ispecialize Hm.
{ iintro_prop ; eapply ρ₁ρ₂_are_closed_monotone ; eauto. }
ispecialize Hm.
{ iintro x ; ispecialize Hγ x.
  apply 𝓥_monotone with (ξ₁ := ξ₁) (ξ₂ := ξ₂) ; [auto|auto| ].
  erewrite <- I_iff_elim_M ; [ exact Hγ | apply EV_map_𝓥 ].
  - crush.
  - crush.
  - repeat iintro ; apply auto_contr_id.
}

clear - Hm.
repeat erewrite <- EV_V_bind_md, EV_bind_bind_md ; try apply Hm.
{ intro α ; destruct α ; simpl ; [ crush | ].
  erewrite EV_bind_map_eff, EV_map_eff_id, EV_bind_eff_id ; reflexivity.
}
{ intro ; erewrite EV_bind_map_val, EV_map_val_id, EV_bind_val_id ; reflexivity. }
{ intro α ; destruct α ; simpl ; [ crush | ].
  erewrite EV_bind_map_eff, EV_map_eff_id, EV_bind_eff_id ; reflexivity.
}
{ intro ; erewrite EV_bind_map_val, EV_map_val_id, EV_bind_val_id ; reflexivity. }
Qed.

End section_compat_md_ev.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import omega.Omega.
From LF Require Import Maps.
From LF Require Import Imp.

(* First, define a little Ltac macro to compress a common pattern into a single command.*)
Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
Qed.

(* The auto Tactic *)

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

(**
  The auto tactic solves goals that are solvable by any combination of
  intros and
  apply (of hypotheses from the local context, by default).

  Using auto is always "safe" in the sense that it will never fail and will never change the proof state:
  either it completely solves the current goal, or it does nothing.
*)

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  (* When it cannot solve the goal, [auto] does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

Example auto_example_5: 2 = 2.
Proof.
  info_auto.
Qed.

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. (* picks up hint from database *)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.  (* does nothing *)
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto. (* try also: info_auto. *)
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inversion E2; subst; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. discriminate.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. discriminate.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. discriminate.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. discriminate.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

(** When we are using a particular tactic many times in a proof, we
    can use a variant of the [Proof] command to make that tactic into
    a default within the proof.  Saying [Proof with t] (where [t] is
    an arbitrary tactic) allows us to use [t1...] as a shorthand for
    [t1;t] within the proof.  As an illustration, here is an alternate
    version of the previous proof, using [Proof with auto]. *)

Theorem ceval_deterministic'_alt: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inversion E2; subst...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. discriminate.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. discriminate.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. discriminate.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. discriminate.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

(* Searching For Hypotheses *)

Ltac rwd H1 H2 := rewrite H1 in H2; discriminate.

Theorem ceval_deterministic'': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inversion E2; subst; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwd H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwd H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwd H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwd H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

Ltac find_rwd :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwd H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inversion E2; subst; try find_rwd; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

Theorem ceval_deterministic'''': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inversion E2; subst; try find_rwd; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

Theorem ceval_deterministic''''': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inversion E2; subst; try find_rwd;
    repeat find_eqn; auto.
Qed.

Module Repeat.

Inductive com : Type :=
  | CSkip
  | CAsgn (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CRepeat (c : com) (b : bexp).

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
   CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'REPEAT' c 'UNTIL' b 'END'" :=
  (CRepeat c b) (at level 80, right associativity).

Reserved Notation "st '=[' c ']=>' st'"
                  (at level 40).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ SKIP ]=> st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=> st'' ->
      st  =[ c1 ;; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st  =[ c ]=> st' ->
      st' =[ WHILE b DO c END ]=> st'' ->
      st  =[ WHILE b DO c END ]=> st''
  | E_RepeatEnd : forall st st' b c,
      st  =[ c ]=> st' ->
      beval st' b = true ->
      st  =[ REPEAT c UNTIL b END ]=> st'
  | E_RepeatLoop : forall st st' st'' b c,
      st  =[ c ]=> st' ->
      beval st' b = false ->
      st' =[ REPEAT c UNTIL b END ]=> st'' ->
      st  =[ REPEAT c UNTIL b END ]=> st''

  where "st =[ c ]=> st'" := (ceval c st st').

(** Our first attempt at the determinacy proof does not quite succeed:
    the [E_RepeatEnd] and [E_RepeatLoop] cases are not handled by our
    previous automation. *)

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inversion E2; subst; try find_rwd; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwd.
       (* oops: why didn't [find_rwd] solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwd.
Qed.

(** Fortunately, to fix this, we just have to swap the invocations of
    [find_eqn] and [find_rwd]. *)

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inversion E2; subst; repeat find_eqn; try find_rwd; auto.
Qed.

End Repeat.

Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  (* We supply the intermediate state [st']... *)
  apply E_Seq with (X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Example ceval'_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := (Y !-> 2 ; X !-> 1).
Definition st21 := (Y !-> 1 ; X !-> 2).

Example eauto_example : exists s',
  st21 =[
    TEST X <= Y
      THEN Z ::= Y - X
      ELSE Y ::= X + Z
    FI
  ]=> s'.
Proof. info_eauto. Qed.

(** The [eauto] tactic works just like [auto], except that it uses
    [eapply] instead of [apply]; [info_eauto] shows us which facts
    [auto] uses. *)

(** Pro tip: One might think that, since [eapply] and [eauto] are more
    powerful than [apply] and [auto], we should just use them all the
    time.  Unfortunately, they are also significantly slower --
    especially [eauto].  Coq experts tend to use [apply] and [auto]
    most of the time, only switching to the [e] variants when the
    ordinary variants don't do the job. *)