(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export cvterm.
Require Export cequiv.

Lemma isprog_add_implies {p} :
  forall (a b : @NTerm p),
    isprog a
    -> isprog b
    -> isprog (mk_add a b).
Proof.
  introv ispa ispb.
  apply isprog_vars_nil_iff_isprog.
  apply isprog_vars_add; sp.
Qed.

Definition mkc_add {p} (t1 t2 : @CTerm p) : CTerm :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist isprog (mk_add a b) (isprog_add_implies a b x y).

Lemma mkcv_add_substc {o} :
  forall v a b (t : @CTerm o),
    substc t v (mkcv_add [v] a b)
    = mkc_add (substc t v a) (substc t v b).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  repeat unfsubst.
Qed.

Lemma reduces_to_add_integer {o} :
  forall lib (k1 k2 : Z),
    @reduces_to o lib (mk_add (mk_integer k1) (mk_integer k2)) (mk_integer (k1 + k2)).
Proof.
  introv.
  apply reduces_to_if_step.
  csunf; simpl; dcwf h; simpl; auto.
Qed.

Lemma cequiv_mk_add_integer {o} :
  forall lib (k1 k2 : Z),
    @cequiv o lib (mk_add (mk_integer k1) (mk_integer k2)) (mk_integer (k1 + k2)).
Proof.
  introv.
  apply reduces_to_implies_cequiv; eauto 3 with slow.
  apply isprogram_eq; apply isprog_add_implies; eauto 3 with slow.
Qed.

Lemma cequivc_mkc_add_integer {o} :
  forall lib (k1 k2 : Z),
    @cequivc o lib (mkc_add (mkc_integer k1) (mkc_integer k2)) (mkc_integer (k1 + k2)).
Proof.
  introv.
  unfold cequivc; simpl.
  apply cequiv_mk_add_integer.
Qed.

Lemma lsubstc_mk_add {p} :
  forall t1 t2 sub,
  forall w1 : wf_term t1,
  forall w2 : @wf_term p t2,
  forall w  : wf_term (mk_add t1 t2),
  forall c1 : cover_vars t1 sub,
  forall c2 : cover_vars t2 sub,
  forall c  : cover_vars (mk_add t1 t2) sub,
    lsubstc (mk_add t1 t2) w sub c
    = mkc_add (lsubstc t1 w1 sub c1)
              (lsubstc t2 w2 sub c2).
Proof.
  sp; unfold lsubstc; simpl.
  apply cterm_eq; simpl.
  unfold csubst; simpl.
  change_to_lsubst_aux4; simpl.
  rw @sub_filter_nil_r; allrw @fold_nobnd; sp.
Qed.

Lemma lsubstc_mk_add_ex {p} :
  forall t1 t2 sub,
  forall w  : wf_term (@mk_add p t1 t2),
  forall c  : cover_vars (mk_add t1 t2) sub,
    {w1 : wf_term t1
     & {w2 : wf_term t2
     & {c1 : cover_vars t1 sub
     & {c2 : cover_vars t2 sub
        & lsubstc (mk_add t1 t2) w sub c
             = mkc_add (lsubstc t1 w1 sub c1)
                       (lsubstc t2 w2 sub c2)}}}}.
Proof.
  introv.

  assert (wf_term t1) as w1.
  { allrw @wf_arithop_iff; sp. }

  assert (wf_term t2) as w2.
  { allrw @wf_arithop_iff; sp. }

  assert (cover_vars t1 sub) as c1.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  assert (cover_vars t2 sub) as c2.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  exists w1 w2 c1 c2.
  apply lsubstc_mk_add.
Qed.

Lemma implies_approx_add {p} :
  forall lib f g a b,
    approx lib f g
    -> @approx p lib a b
    -> approx lib (mk_add f a) (mk_add g b).
Proof.
  introv H1p H2p.
  applydup @approx_relates_only_progs in H1p.
  applydup @approx_relates_only_progs in H2p.
  repnd.
  unfold mk_add.
  repeat (prove_approx);sp.
Qed.

Lemma implies_cequivc_mkc_add {o} :
  forall lib (a b c d : @CTerm o),
    cequivc lib a c
    -> cequivc lib b d
    -> cequivc lib (mkc_add a b) (mkc_add c d).
Proof.
  introv c1 c2; destruct_cterms; allunfold @cequivc; allsimpl.
  destruct c1, c2.
  split; apply implies_approx_add; auto.
Qed.


(** * Combi.SymGroup.permcent : The Centralizer of a Permutation *)
(******************************************************************************)
(*      Copyright (C) 2016-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * The Centralizer of a Permutation

The main goal is to understand the structure of the centralizer group of a
given permutation [s], compute its cardinality and deduce the cardinality
of the conjugacy class of [s].

Here are the notion defined is this file, where [s] is a fixed permutation on
a finite type [T]:

- ['CC(s)] == the group of permutations of [T] which commute with [s] and
            stabilize each cycle of [s].
- [stab_iporbits s] == the group of permutations of [T] which only move
            the cycles of [s] and sends any cycle to a cycle of the same
            length.
- [inporbits s t] == the permutation induced by [t] on the set of the cycles
            of [s]. [inporbits s] is a morphism from [{perm T}] to
            [stab_iporbits s].
- [permcycles s P] == a right inverse morphism from [stab_iporbits s] to
            [{perm T}]. If [P] belongs to [stab_iporbits s] then
            [permcycles s P] si a compatible lifting of [P] in [{perm T}],
            otherwise the identity.

- [zcard l] == $\prod_{i \in N} i^m_i * m_i!$ where $m_i$ is the number of
             occurrence of $i$ in [l].

Here are the main results:

- ['CC(s)'] is the direct product of the group generated by the cycles of [s].
  Lemma [porbitgrpE]:

  [ 'CC(s) = \big[dprod/1]_(c in cycle_dec s) <[c]>. ]

- [stab_iporbits s] is the direct product over [i] of the group permuting
  the set of the cycles of size i. Theorem [stab_iporbitsE]:

  [
    stab_iporbits s =
    \big[dprod/1]_(i < #|T|.+1) Sym (porbits s :&: 'SC_i).
  ]

- The centralizer ['C[s]] is the semidirect product of ['CC(s)'] and the
  lifting of [stab_iporbits s]. Theorem [cent1_permE]:

  [ 'C[s] = 'CC(s) ><| (permcycles s) @* (stab_iporbits s). ]

- The cardinality of the centralizer of [s] given by [zcard].
  Corollary [card_cent1_perm]:

  [ #|'C[s]| = zcard (cycle_type s). ]

- The cardinality of the conjugacy class associated to the partition [l]
  of an integer [n] is given by Theorem [card_class_of_part]:

  [ #|classCT l| = n`! %/ zcard l. ]

*******************************************************************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype.
From mathcomp Require Import tuple path bigop finset div.
From mathcomp Require Import fingroup perm action gproduct morphism.

Require Import tools partition permcomp cycles cycletype.

Import GroupScope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

#[local] Hint Resolve porbit_id : core.

Local Notation "''SC_' i " := (finset (fun x => #{x} == i))
    (at level 0).

(** ** Support and cycle in the centralizer *)
Section PermCycles.

Variable T : finType.
Implicit Type (s t c : {perm T}).

Lemma disjoint_psupport_dprodE (S : {set {perm T}}) :
  disjoint_psupports S ->
  (\big[dprod/1]_(s in S) <[s]>) = (\prod_(s in S) <[s]>)%G.
Proof using.
move=> [/trivIsetP Htriv Hinj]; apply/eqP/bigdprodYP => /= s Hs.
apply/subsetP => t; rewrite !inE negb_and negbK.
rewrite bigprodGEgen => /gen_prodgP [n [/= f Hf ->{t}]].
apply/andP; split.
- case: (altP (_ =P _)) => //=; apply contra => Hin.
  rewrite psupport_eq0 -subset0; apply/subsetP => x Hx.
  have [i Hxf] : exists i : 'I_n, x \in psupport (f i).
    apply/existsP; move: Hx; apply contraLR => /=.
    rewrite negb_exists => /forallP /= Hall; rewrite in_psupport negbK.
    apply big_rec => [ | i rec _ Hrec]; first by rewrite perm1.
    by have := Hall i; rewrite permM in_psupport negbK => /eqP ->.
  move/(_ i): Hf => /bigcupP [/= t /andP [tinS tneqs]].
  rewrite inE => /eqP Hfi; rewrite {}Hfi in Hxf.
  move: Hin Hx => /cycleP [j ->] {f} /(subsetP (psupport_expg _ _)) Hxs.
  suff : [disjoint psupport t & psupport s].
    by rewrite -setI_eq0 => /eqP/setP/(_ x) <-; rewrite inE Hxf Hxs.
  apply Htriv; try exact: imset_f.
  by move: tneqs; apply contra => /eqP/Hinj ->.
- apply group_prod => i _.
  have:= Hf i => /bigcupP [/= t /andP [tinS sneqt]].
  rewrite inE cent_cycle => /eqP -> {i f Hf}.
  apply/cent1P; apply: psupport_disjointC.
  apply Htriv; try exact: imset_f.
  by move: sneqt; apply contra => /eqP/Hinj ->.
Qed.

Lemma cent1_act_porbit s t x :
  t \in 'C[s] -> ('P)^* (porbit s x) t = porbit s (t x).
Proof using.
move=> /cent1P Hcom.
apply/setP => y; apply/imsetP/porbitP.
- move=> [z /porbitP [i -> {z}] -> {y}].
  by exists i => /=; rewrite -!permM (commuteX i Hcom) permM.
- move=> [i -> {y}].
  exists ((s ^+ i) x); first exact: mem_porbit.
  by rewrite -!permM (commuteX i Hcom) permM.
Qed.

(* Rewriting of 'C[s] \subset 'N(porbits s | ('P)^* *)
Lemma cent1_act_on_porbits s : [acts 'C[s], on porbits s | ('P)^*].
Proof using.
apply/subsetP => t Hcent; rewrite /astabs !inE /=.
apply/subsetP => C; rewrite inE => /imsetP [x _ -> {C}].
by apply/imsetP; exists (t x); [| apply: cent1_act_porbit].
Qed.

Lemma cent1_act_on_iporbits s i :
  [acts 'C[s], on porbits s :&: 'SC_i | ('P)^*].
Proof using.
apply/subsetP => t Ht; apply (subsetP (astabsI _ _ _)).
rewrite inE (subsetP (cent1_act_on_porbits s)) //=.
rewrite /astabs !inE /=; apply/subsetP => P; rewrite !inE.
by rewrite card_setact.
Qed.

Lemma commute_cyclic c t :
  c \is cyclic -> t \in 'C[c] -> perm_on (psupport c) t -> exists i, t = c ^+ i.
Proof using.
move=> /cyclicP [x Hx Hsupp] Hcent1 Hon.
have /= := cent1_act_porbit x Hcent1.
have:= Hx; rewrite -(perm_closed _ Hon).
move: Hon; rewrite Hsupp -eq_porbit_mem => Hon /eqP -> cx_stable.
move: Hcent1 => /cent1P Hcomm.
have /= := mem_setact ('P) t (porbit_id c x).
rewrite cx_stable => /porbitP [i]; rewrite apermE => Hi.
exists i; apply/permP => z.
case: (boolP (z \in (porbit c x))) => [/porbitP [j -> {z}]|].
- by rewrite -!permM -(commuteX j Hcomm) -expgD addnC expgD !permM Hi.
- move=> Hz; move: Hon => /subsetP/(_ z)/contra/(_ Hz).
  rewrite inE negbK => /eqP ->.
  by move: Hz; rewrite -Hsupp in_psupport negbK => /eqP /permX_fix ->.
Qed.

(** ** The cyclic centralizer *)
Notation "''CC' ( s )" :=
  'C_('C[s])(porbits s | ('P)^* ) (format "''CC' ( s )") : group_scope.

Lemma restr_perm_genC C s t :
  C \in porbit_set s -> t \in 'CC(s) -> restr_perm C t \in <[restr_perm C s]>%G.
Proof using.
move=> HC; rewrite inE => /andP [/cent1P Hcomm /astabP Hstab].
apply/cycleP; apply commute_cyclic.
- have: restr_perm C s \in cycle_dec s by apply/imsetP; exists C.
  by move/cyclic_dec.
- apply/cent1P; rewrite /commute.
  have HS := porbit_set_astabs HC.
  have Ht : t \in 'N(C | 'P).
    rewrite -astab1_set; apply/astab1P; apply Hstab.
    by move: HC; rewrite inE => /andP [].
  rewrite -((morphM (restr_perm_morphism C)) t s) //.
  rewrite -((morphM (restr_perm_morphism C)) s t) //.
  by rewrite Hcomm.
- rewrite psupport_perm_on (psupport_restr_perm HC).
  exact: psupport_restr_perm_incl.
Qed.

Lemma stab_porbit S s :
  s \in 'N(S | 'P) -> forall x, (x \in S) = (porbit s x \subset S).
Proof using.
move=> Hs x; apply/idP/subsetP => [Hx y /porbitP [i ->{y}] | Hsubs].
- elim: i => [|i]; first by rewrite expg0 perm1.
  by rewrite expgSr permM; move: Hs => /astabsP <- /=.
- exact: Hsubs (porbit_id s x).
Qed.

Lemma restr_perm_porbits S s :
  restr_perm S s \in 'C(porbits s | ('P)^* ).
Proof using.
case: (boolP (s \in 'N(S | 'P))) => [nSs | /triv_restr_perm -> //].
apply/astabP => /= X /imsetP [x _ ->{X}].
case: (boolP (x \in S)) => Hx.
- apply/setP => y; apply/imsetP/idP => [[z Hz ->{y}] /= | Hy].
  + have:= Hz; rewrite -eq_porbit_mem => /eqP Hsz.
    rewrite apermE restr_permE //.
    - rewrite -Hsz -{1}(expg1 s); exact: mem_porbit.
    - by rewrite (stab_porbit nSs) // Hsz -stab_porbit.
  + have HsVy : s^-1 y \in porbit s x.
      by rewrite porbit_sym -(porbit_perm _ 1) expg1 permKV porbit_sym.
    exists ((s ^-1) y); first exact: HsVy.
    rewrite /= apermE restr_permE => //; first by rewrite permKV.
    by move: Hx; rewrite (stab_porbit nSs) => /subsetP; apply.
- move: nSs; rewrite -astabsC => nSs.
  have: x \in ~: S by rewrite inE.
  rewrite (stab_porbit nSs) => Hsubs.
  apply/setP => y; apply/imsetP/idP => [[z Hz ->{y}] /= | Hy].
  + rewrite apermE (out_perm (restr_perm_on _ _)) //.
    by have:= subsetP Hsubs z Hz; rewrite inE.
  + exists y; first exact Hy.
    rewrite /= apermE (out_perm (restr_perm_on _ _)) //.
    by have:= subsetP Hsubs y Hy; rewrite inE.
Qed.

Lemma porbitgrpE s : 'CC(s) = \big[dprod/1]_(c in cycle_dec s) <[c]>.
Proof using.
rewrite disjoint_psupport_dprodE; last exact: disjoint_cycle_dec.
apply/setP => /= t; apply/idP/idP.
- rewrite inE => /andP [Hcomm Hstab].
  have:= partition_psupport s => /and3P [/eqP Hcov Htriv _].
  rewrite -(perm_decE (S := porbit_set s) (s := t)) //; first last.
  + by apply/astabP => C; rewrite /porbit_set inE => /andP [/(astabP Hstab)].
  + rewrite {}Hcov; apply/subsetP => x.
    rewrite !in_psupport (porbit_fix s); apply contra => /eqP Hx.
    have /(astabP Hstab) : porbit s x \in porbits s by apply: imset_f.
    rewrite Hx => /setP/(_ x).
    rewrite inE eq_refl /= => /imsetP [y].
    by rewrite inE => /eqP -> /=; rewrite apermE => <-.
  + rewrite /cycle_dec bigprodGE.
    apply/group_prod => c /imsetP [C HC ->{c}].
    apply mem_gen; apply/bigcupP; exists (restr_perm C s).
    * by rewrite /perm_dec; apply/imsetP; exists C.
    * by apply: restr_perm_genC; rewrite // inE Hcomm Hstab.
- rewrite bigprodGEgen; apply /subsetP; rewrite gen_subG.
  apply/subsetP => x /bigcupP [/= c /imsetP [C HC ->{c}]].
  move: HC; rewrite 3!inE => /andP [HC _] /eqP -> {x}.
  apply/andP; split.
  + by apply/cent1P; apply: restr_perm_commute.
  + exact: restr_perm_porbits.
Qed.

Lemma card_porbitgrpE s : #|'CC(s)| = (\prod_(i <- cycle_type s) i)%N.
Proof using.
rewrite -(bigdprod_card (esym (porbitgrpE s))).
rewrite /cycle_type /= /setpart_shape /cycle_dec.
rewrite big_imset /=; last exact: restr_perm_inj.
rewrite [RHS](perm_big [seq #{x} | x in porbits s]);
  last by apply/permPl; apply perm_sort.
rewrite /= [RHS]big_map big_enum.
rewrite [RHS](bigID (fun X => #{X} == 1%N)) /=.
rewrite [X in _ = (X * _)%N]big1 ?mul1n; last by move=> i /andP [_ /eqP].
rewrite [RHS](eq_bigl (mem (porbit_set s))) /=;
  last by move=> C; rewrite /porbit_set !inE.
apply eq_bigr => X HX; rewrite -orderE.
rewrite order_cyclic; last by rewrite unfold_in (porbit_set_restr HX) cards1.
by rewrite psupport_restr_perm.
Qed.

(** ** Permuting the cycles among themselves *)
Definition stab_iporbits s : {set {perm {set T}}} :=
  Sym (porbits s) :&:
    \bigcap_(i : 'I_#|T|.+1) 'N(porbits s :&: 'SC_i | 'P).
(* stab_iporbits is canonically a group *)

Definition inporbits s : {perm T} -> {perm {set T}} :=
  restr_perm (porbits s) \o actperm 'P^*.
(* inporbits is canonically a group morphism *)

Section CM.

Variable s : {perm T}.
Implicit Type P : {perm {set T}}.

Lemma stab_iporbits_stab P :
  (if P \in stab_iporbits s then P else 1) @: porbits s \subset porbits s.
Proof using.
case: (boolP (_ \in _)) => [|_].
- by rewrite !inE => /andP [/im_perm_on -> _].
- by rewrite (eq_imset (g := id)) ?imset_id // => x; rewrite perm1.
Qed.

Lemma stab_iporbits_homog P :
  {in porbits s, forall C,
       #|(if P \in stab_iporbits s then P else 1) C| = #|C| }.
Proof using.
case: (boolP (_ \in _)) => [|_].
- rewrite inE => /andP [_ /bigcapP HP] C HC; rewrite /inporbits /=.
  have:= subsetT C => /subset_leqif_cards []; rewrite -ltnS cardsT => cardC _.
  move/(_ (Ordinal cardC) isT): HP => /= /astabsP/(_ C).
  by rewrite !inE HC eq_refl /= => /andP [_ /eqP].
- by move=> C _; rewrite perm1.
Qed.

Local Definition stab_iporbits_porbitmap P :=
  PorbitMap (stab_iporbits_stab P) (stab_iporbits_homog P).
Local Definition stab_iporbits_map P := cymap (stab_iporbits_porbitmap P).

Lemma stab_iporbits_map_inj P : injective (stab_iporbits_map P).
Proof using.
apply (can_inj (g := stab_iporbits_map P^-1)) => X /=.
rewrite /stab_iporbits_map cymapK //= {X} => C HC.
rewrite groupV /= -/(stab_iporbits s).
by case: (boolP (P \in _)) => [| HP]; rewrite ?perm1 ?permK.
Qed.
Definition permcycles P := perm (@stab_iporbits_map_inj P).

Lemma permcyclesC P : commute (permcycles P) s.
Proof using.
by apply esym; apply/permP => x; rewrite !permM !permE; exact: cymapP.
Qed.

Lemma permcyclesP P : (permcycles P) \in 'C[s].
Proof using. apply/cent1P; exact: permcyclesC. Qed.

Lemma porbit_permcycles P x :
  P \in stab_iporbits s -> porbit s (permcycles P x) = P (porbit s x).
Proof using. by rewrite permE porbit_cymap /= => ->. Qed.

End CM.

Lemma permcyclesM s :
  {in stab_iporbits s &, {morph permcycles s : P Q / P * Q}}.
Proof using.
move=> /= P Q HP HQ /=; apply/permP => X.
rewrite permM !permE -[RHS]/((_ \o _) X).
apply esym; apply cymap_comp => C HC /=.
by rewrite groupM // HP HQ permM.
Qed.
Canonical permcycles_morphism s := Morphism (permcyclesM (s := s)).

Lemma permcyclesK s :
  {in stab_iporbits s, cancel (permcycles s) (inporbits s)}.
Proof using.
move=> /= P HP; apply/permP => C /=.
rewrite /inporbits /=.
case: (boolP (C \in porbits s)) => HC.
- rewrite !restr_permE // ?actpermE /=; first last.
    apply/astabsP => {HC} C; rewrite /= apermE actpermE /=.
    apply (actsP (cent1_act_on_porbits s)).
    exact: permcyclesP.
  move: HC => /imsetP [x _ ->{C}].
  rewrite cent1_act_porbit; last exact: permcyclesP.
  exact: porbit_permcycles.
- rewrite (out_perm (restr_perm_on _ _) HC).
  by move: HP; rewrite inE => /andP []; rewrite inE => /out_perm ->.
Qed.

Lemma permcycles_inj s : 'injm (permcycles s).
Proof using. apply/injmP; apply: can_in_inj; exact: permcyclesK. Qed.

Lemma inporbits_im s : inporbits s @: 'C[s] = stab_iporbits s.
Proof using.
apply/setP => /= P; apply/imsetP/idP => /= [[/= x Hx ->] | HP].
- rewrite inE; apply/andP; split.
  + by rewrite inE; apply: restr_perm_on.
  + apply/bigcapP => [[i Hi] _] /=; apply/astabsP => X.
    have/actsP/(_ _ Hx X)/= := cent1_act_on_iporbits s i.
    rewrite !inE !apermE; case: (boolP (X \in porbits s)) => /= [HX| HX _].
    * rewrite restr_permE // ?actpermE // {X HX}.
      apply/astabsP => X /=; rewrite apermE actpermE /=.
      exact: (actsP (cent1_act_on_porbits s)).
    * rewrite (out_perm (restr_perm_on _ _) HX).
      by move: HX => /negbTE ->.
- by exists (permcycles s P); [apply: permcyclesP | rewrite permcyclesK].
Qed.

Lemma trivIset_iporbits s : trivIset [set porbits s :&: 'SC_i | i : 'I_#|T|.+1].
Proof using.
apply/trivIsetP => A B /imsetP [i _ ->{A}] /imsetP [j _ ->{B}] Hij.
have {}Hij : i != j by move: Hij; apply contra => /eqP -> .
rewrite -setI_eq0; apply/eqP/setP => x.
rewrite !inE -!andbA; apply/negP => /and4P [_ /eqP -> _] /eqP /val_inj Hieqj.
by rewrite Hieqj eq_refl in Hij.
Qed.

Lemma cover_iporbits s :
  cover [set porbits s :&: 'SC_i | i : 'I_#|T|.+1] = porbits s.
Proof using.
apply/setP => C; apply/bigcupP/idP => [[/= X] | Hx].
- by move/imsetP => [/= i _ ->{X}]; rewrite inE => /andP [].
- have:= subsetT C => /subset_leqif_cards []; rewrite -ltnS cardsT => cardC _.
  exists (porbits s :&: 'SC_(Ordinal cardC)); first exact: imset_f.
  by rewrite !inE Hx /=.
Qed.

Lemma stab_iporbitsE_prod s :
  stab_iporbits s =
  (\prod_(i < #|T|.+1) Sym_group (porbits s :&: 'SC_i))%G.
Proof using.
apply/setP => t.
rewrite inE bigprodGE; apply/andP/idP => [[Ht /bigcapP/(_ _ isT) Hcyi] | Ht].
- rewrite -(perm_decE (s := t) (trivIset_iporbits s)); first last.
  + apply/astabP => /= CS /imsetP [/= i _ ->{CS}].
    by apply/astab1P; rewrite astab1_set; exact: Hcyi.
  + by move: Ht; rewrite inE -psupport_perm_on cover_iporbits.
  apply group_prod => u /imsetP [/= X /imsetP [/= i _ ->{X}] ->{u}].
  apply mem_gen; apply/bigcupP; exists i; first by [].
  by rewrite inE; exact: restr_perm_on.
split; move: t Ht; apply/subsetP; rewrite gen_subG;
  apply/subsetP => /= P /bigcupP [/= i _].
- rewrite !inE !psupport_perm_on => /subset_trans; apply.
  exact: subsetIl.
- rewrite inE => HP.
  apply/bigcapP => /= j _; apply/astabsP => /= X; rewrite apermE.
  case: (altP (P X =P X)) => [-> //| HPX].
  have:= HP => /subsetP/(_ X); rewrite inE => /(_ HPX) H.
  have:= H; rewrite -(perm_closed _ HP).
  by move: H; rewrite !inE => /andP [-> /eqP ->] /andP [-> /eqP ->].
Qed.

Theorem stab_iporbitsE s :
  stab_iporbits s = \big[dprod/1]_(i < #|T|.+1) Sym (porbits s :&: 'SC_i).
Proof using.
rewrite stab_iporbitsE_prod; apply/esym/eqP/bigdprodYP => i /= _.
apply/subsetP => /= t Ht; rewrite !inE negb_and negbK.
have {Ht} : t \in Sym (porbits s :&: [set x | #{x} != i]).
  move: Ht; rewrite bigprodGE => /gen_prodgP [n [/= f Hf ->{t}]].
  apply group_prod => j _; move/(_ j): Hf => /bigcupP [k Hk].
  rewrite !inE /perm_on => /subset_trans; apply; apply setIS.
  by apply/subsetP => C; rewrite !inE => /eqP ->.
rewrite inE => on_neqi; apply/andP; split.
- case: (altP (t =P 1)) => //=; apply contra => on_eqi.
  apply/eqP/permP => C; rewrite perm1.
  case: (boolP (#|C| == i)) => [HC | /negbTE HC].
  + by rewrite (out_perm on_neqi) // !inE HC andbF.
  + by rewrite (out_perm on_eqi) // !inE HC andbF.
- apply/centP => /= u; move: on_neqi.
  rewrite inE !psupport_perm_on -[psupport u \subset _]setCS => on_neqi on_eqi.
  apply psupport_disjointC; rewrite disjoints_subset.
  apply: (subset_trans on_neqi); apply: (subset_trans _ on_eqi).
  by apply/subsetP => X; rewrite !inE => /andP [ -> ->].
Qed.

Lemma card_stab_iporbits s :
  #|stab_iporbits s| =
    (\prod_(i < #|T|.+1) (count_mem (nat_of_ord i) (cycle_type s))`!)%N.
Proof using.
rewrite -(bigdprod_card (esym (stab_iporbitsE s))).
apply eq_bigr => i _.
rewrite card_Sym /setpart_shape; congr (_)`!.
have /permPl/seq.permP -> := perm_sort geq [seq #{x} | x in porbits s].
rewrite !cardE -size_filter /= /enum_mem.
rewrite filter_map size_map -filter_predI; congr size.
by apply eq_filter => C; rewrite !inE andbC.
Qed.

Lemma conj_porbitgrp s y z :
  y \in 'C[s] -> z \in 'CC(s) -> z ^ y \in 'CC(s).
Proof using.
move=> Hy; rewrite inE => /andP [zC /astabP zCporbits].
have /= HyV := groupVr Hy.
rewrite inE; apply/andP; split.
- by apply groupM; last exact: groupM.
- apply/astabP => C /imsetP [x _ ->{C}].
  rewrite !actM /= cent1_act_porbit // zCporbits; last exact: imset_f.
  by rewrite -cent1_act_porbit // -!actM mulVg act1.
Qed.

Lemma inporbits1 s t : t \in 'C(porbits s | ('P)^* ) -> inporbits s t = 1.
Proof using.
move=> Ht; have tfix := astab_act Ht.
apply/permP => /= X; rewrite /inporbits perm1.
case: (boolP (X \in porbits s)) => HX.
- rewrite restr_permE //= ?actpermE ?tfix // {X HX}.
  apply/astabsP => X /=; rewrite actpermK.
  by apply astabs_act; move: Ht; apply/subsetP; exact: astab_sub.
- exact: (out_perm (restr_perm_on _ _ ) HX).
Qed.

Lemma cent1_stab_iporbit_porbitgrpS s :
  'C[s] \subset permcycles s @* stab_iporbits s * 'CC(s).
Proof using.
apply/subsetP => t Ht.
pose str := permcycles s (inporbits s t^-1).
have Hstr : str \in 'C[s] by apply: permcyclesP.
rewrite -(mulKg str t); apply mem_mulg.
- rewrite groupV /= -/(stab_iporbits s); apply imset_f.
  by rewrite setIid -inporbits_im; apply imset_f; apply groupVr.
- rewrite inE; apply/andP.
  split; first exact: groupM.
  apply/astabP => C /imsetP [x _ ->{C}].
  rewrite !actM /= cent1_act_porbit //=.
  rewrite porbit_permcycles; first last.
    by rewrite -inporbits_im; apply imset_f; apply groupVr.
  rewrite /inporbits /= restr_permE; first last.
  + exact: imset_f.
  + apply/astabsP => X /=; rewrite actpermK.
    apply astabs_act; move: Ht => /groupVr; apply/subsetP => /=.
    exact: cent1_act_on_porbits.
  by rewrite actpermE /= -actM mulVg act1.
Qed.

(** * Main theorem *)
Theorem cent1_permE s :
  'C[s] = 'CC(s) ><| (permcycles s) @* (stab_iporbits s).
Proof using.
apply/esym/sdprod_normal_complP.
- apply/normalP; split; first exact: subsetIl.
  move=> /= y Hy; apply/setP => /= x; have /= HyV := groupVr Hy.
  apply/imsetP/idP => [[/= z Hz] ->{x} | Hx].
  + exact: conj_porbitgrp.
  + exists (x ^ (y^-1)); last by rewrite conjgKV.
    exact: conj_porbitgrp.
rewrite /= -/(stab_iporbits s).
rewrite inE; apply/andP; split.
- apply/eqP/trivgP; apply/subsetP => t.
  rewrite 2!inE => /andP [/imsetP [/= P]].
  rewrite setIid => HP Ht /andP [tC tCporbits]; rewrite inE.
  suff : P = 1 by rewrite Ht => ->; rewrite morphism.morph1.
  by rewrite -(permcyclesK HP) -Ht; apply: inporbits1.
- rewrite /=; apply/eqP/setP => /= t.
  apply/idP/idP => [/mulsgP [/= t' u /imsetP [P]] | Ht].
  + rewrite setIid => HP ->{t'} Hu ->{t}.
    apply groupM; first exact: permcyclesP.
    by move: Hu; rewrite inE => /andP [].
  + exact: (subsetP (cent1_stab_iporbit_porbitgrpS s)).
Qed.

Local Open Scope nat_scope.

(** ** Conjucacy class cardinality *)
Definition zcard l :=
  \prod_(i <- l) i * \prod_(i < (sumn l).+1) (count_mem (i : nat) l)`!.

Lemma zcard_nil : zcard [::] = 1.
Proof.
rewrite /zcard big_nil mul1n /= big_const fact0.
by rewrite eq_cardT // size_enum_ord /= mul1n.
Qed.

Lemma zcard_any l b :
  (sumn l < b) ->
  \prod_(i <- l) i * \prod_(i < b) (count_mem (i : nat) l)`! = zcard l.
Proof.
rewrite /zcard => /(big_ord_widen _ (fun i : nat => (count_mem i l)`!)) ->.
congr (_ * _).
rewrite (bigID (fun i : 'I_(_) => i < (sumn l).+1)) /=.
rewrite -[RHS]muln1; congr (_ * _).
apply big1 => i Hi.
suff -> : count_mem (i : nat) l = 0 by rewrite fact0.
apply /count_memPn; move: Hi; apply contra.
rewrite ltnS  => /perm_to_rem/perm_sumn -> /=.
exact: leq_addr.
Qed.

Lemma zcard_rem i l :
  i != 0 -> i \in l -> i * (count_mem i l) * (zcard (rem i l)) = zcard l.
Proof.
move => Hi /perm_to_rem Hrem.
have /zcard_any <- : sumn (rem i l) < (sumn l).+1.
  by rewrite ltnS (perm_sumn Hrem) /=; apply leq_addl.
have Hil : i < (sumn l).+1.
  by rewrite ltnS (perm_sumn Hrem) /=; apply leq_addr.
rewrite /zcard (perm_big _ Hrem) /= big_cons -!mulnA; congr (_ * _).
rewrite mulnC -mulnA; congr (_ * _).
rewrite  [in RHS](bigD1 (Ordinal Hil)) //=.
rewrite mulnC (seq.permP Hrem) /= eq_refl /= add1n.
rewrite factS -!mulnA; congr (_ * _).
rewrite  [in LHS](bigD1 (Ordinal Hil)) //=; congr (_ * _).
apply eq_bigr => j; rewrite -val_eqE => /= /negbTE Hij.
move/seq.permP: Hrem => -> /=.
by rewrite eq_sym Hij add0n.
Qed.

Corollary card_cent1_perm s : #|'C[s]| = zcard (cycle_type s).
Proof using.
have /esym/sdprod_card <- := cent1_permE s.
rewrite card_porbitgrpE card_in_imset // ?setIid; first last.
  by apply: can_in_inj; exact: permcyclesK.
by rewrite /zcard card_stab_iporbits // sumn_intpartn.
Qed.

Theorem card_class_perm s :
  #|class s [set: {perm T}]| = #|T|`! %/ zcard (cycle_type s).
Proof using.
rewrite -card_cent1_perm -index_cent1 /= -divgI.
rewrite (eq_card (B := perm_on setT)); first last.
  move=> p; rewrite inE unfold_in /perm_on /=.
  by apply/esym/subsetP => i _; rewrite in_set.
rewrite card_perm cardsE setTI; congr (_ %/ #|_|).
by rewrite /= setTI.
Qed.

End PermCycles.

Lemma dvdn_zcard_fact n (l : 'P_n) : zcard l %| n`!.
Proof.
pose l' := (CTpartn l).
have -> : zcard l = zcard l' by rewrite cast_intpartnE /=.
rewrite -(permCTP l') -(card_cent1_perm (permCT l')).
rewrite -card_Sn -cardsT; apply cardSg.
exact: subsetT.
Qed.

Lemma neq0zcard n (l : 'P_n) : zcard l != 0.
Proof.
have:= dvdn_zcard_fact l; apply contraL => /eqP ->.
by rewrite dvd0n -lt0n fact_gt0.
Qed.

Theorem card_class_of_part n (l : 'P_n) : #|classCT l| = n`! %/ zcard l.
Proof using.
rewrite /classCT card_class_perm permCTP /=.
by rewrite cast_intpartnE /= card_ord.
Qed.


(** * Finite sets. Vladimir Voevodsky . Apr. - Sep. 2011.

This file contains the definition and main properties of finite sets. At the end of the file there are several elementary examples which are used as test cases to check that our constructions do not prevent Coq from normalizing terms of type nat to numerals.

*)

(** ** Preambule *)

(** Settings *)

Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)

(** Imports. *)

Add LoadPath "../hlevel1" .
Add LoadPath "../Generalities".

Require Export stnfsets .

(** ** Sets with a given number of elements. *)

(** *** Structure of a set with [ n ] elements on [ X ] defined as a term in [ weq ( stn n ) X ]  *)

Definition nelstruct ( n : nat ) ( X : UU ) := weq ( stn n ) X .

Definition nelstructonstn ( n : nat ) : nelstruct n ( stn n ) := idweq _ .

Definition nelstructweqf { X Y : UU } { n : nat } ( w : weq X Y ) ( sx : nelstruct n X ) : nelstruct n Y := weqcomp sx w .

Definition nelstructweqb { X Y : UU } { n : nat } ( w : weq X Y ) ( sy : nelstruct n Y ) : nelstruct n X := weqcomp sy ( invweq w ) .

Definition nelstructonempty : nelstruct 0 empty := weqstn0toempty .

Definition nelstructonempty2 { X : UU } ( is : neg X ) : nelstruct 0 X :=  weqcomp weqstn0toempty ( invweq ( weqtoempty is ) ) .

Definition nelstructonunit : nelstruct 1 unit := weqstn1tounit .

Definition nelstructoncontr { X : UU } ( is : iscontr X ) : nelstruct 1 X := weqcomp weqstn1tounit ( invweq ( weqcontrtounit is ) ) .

Definition nelstructonbool : nelstruct 2 bool := weqstn2tobool .

Definition nelstructoncoprodwithunit { X : UU } { n : nat } ( sx : nelstruct n X ) : nelstruct ( S n ) ( coprod X unit ) :=  weqcomp ( invweq ( weqdnicoprod n ( lastelement n ) ) ) ( weqcoprodf sx ( idweq unit ) ) .

Definition nelstructoncompl { X : UU } { n : nat } ( x : X ) ( sx : nelstruct ( S n ) X ) : nelstruct n ( compl X x ) :=  weqcomp ( weqdnicompl n ( invweq sx x ) ) ( invweq ( weqoncompl ( invweq sx ) x ) ) .

Definition nelstructoncoprod { X  Y : UU } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( n + m ) ( coprod X Y ) := weqcomp ( invweq ( weqfromcoprodofstn n m ) ) ( weqcoprodf sx sy ) .

Definition nelstructontotal2 { X : UU } ( P : X -> UU ) ( f : X -> nat ) { n : nat } ( sx : nelstruct n X ) ( fs : forall x : X , nelstruct ( f x ) ( P x ) ) : nelstruct ( stnsum ( funcomp ( pr1 sx ) f ) ) ( total2 P )  := weqcomp ( invweq ( weqstnsum ( funcomp ( pr1 sx ) P ) ( funcomp ( pr1 sx ) f ) ( fun i : stn n => fs ( ( pr1 sx ) i ) ) ) )  ( weqfp sx P )  .

Definition nelstructondirprod { X Y : UU } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( n * m ) ( dirprod X Y ) := weqcomp ( invweq ( weqfromprodofstn n m ) ) ( weqdirprodf sx sy ) .

(** For a generalization of [ weqfromdecsubsetofstn ] see below *)

Definition nelstructonfun { X Y : UU } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( natpower m n ) ( X -> Y ) := weqcomp ( invweq ( weqfromfunstntostn n m ) ) ( weqcomp ( weqbfun _ ( invweq sx ) ) ( weqffun _ sy ) )  .

Definition nelstructonforall { X : UU } ( P : X -> UU ) ( f : X -> nat ) { n : nat } ( sx : nelstruct n X ) ( fs : forall x : X , nelstruct ( f x ) ( P x ) ) : nelstruct ( stnprod ( funcomp ( pr1 sx ) f ) ) ( forall x : X , P x )  := invweq ( weqcomp ( weqonsecbase P sx ) ( weqstnprod ( funcomp ( pr1 sx ) P ) ( funcomp ( pr1 sx ) f ) ( fun i : stn n => fs ( ( pr1 sx ) i ) ) ) )  .

Definition nelstructonweq { X : UU } { n : nat } ( sx : nelstruct n X ) : nelstruct ( factorial n ) ( weq X X ) := weqcomp ( invweq ( weqfromweqstntostn n ) ) ( weqcomp ( weqbweq _ ( invweq sx ) ) ( weqfweq _ sx ) ) .

(** *** The property of [ X ] to have [ n ] elements *)

Definition isofnel ( n : nat ) ( X : UU ) : hProp := ishinh ( weq ( stn n ) X ) .

Lemma isofneluniv { n : nat} { X : UU }  ( P : hProp ) : ( ( nelstruct n X ) -> P ) -> ( isofnel n X -> P ) .
Proof. intros.  apply @hinhuniv with ( weq ( stn n ) X ) . assumption. assumption. Defined.

Definition isofnelstn ( n : nat ) : isofnel n ( stn n ) := hinhpr _ ( nelstructonstn n ) .

Definition isofnelweqf { X Y : UU } { n : nat } ( w : weq X Y ) ( sx : isofnel n X ) : isofnel n Y := hinhfun ( fun sx0 : _ =>  nelstructweqf w sx0 ) sx .

Definition isofnelweqb { X Y : UU } { n : nat } ( w : weq X Y ) ( sy : isofnel n Y ) : isofnel n X :=  hinhfun ( fun sy0 : _ => nelstructweqb w sy0 ) sy .

Definition isofnelempty : isofnel 0 empty := hinhpr _ nelstructonempty .

Definition isofnelempty2 { X : UU } ( is : neg X ) : isofnel 0 X :=  hinhpr _ ( nelstructonempty2 is ) .

Definition isofnelunit : isofnel 1 unit := hinhpr _ nelstructonunit  .

Definition isofnelcontr { X : UU } ( is : iscontr X ) : isofnel 1 X := hinhpr _ ( nelstructoncontr is ) .

Definition isofnelbool : isofnel 2 bool := hinhpr _ nelstructonbool .

Definition isofnelcoprodwithunit { X : UU } { n : nat } ( sx : isofnel n X ) : isofnel ( S n ) ( coprod X unit ) :=   hinhfun ( fun sx0 : _ =>  nelstructoncoprodwithunit sx0 ) sx .

Definition isofnelcompl { X : UU } { n : nat } ( x : X ) ( sx : isofnel ( S n ) X ) : isofnel n ( compl X x ) := hinhfun ( fun sx0 : _ =>  nelstructoncompl x sx0 ) sx .

Definition isofnelcoprod { X  Y : UU } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( n + m ) ( coprod X Y ) :=  hinhfun2 ( fun sx0 : _ => fun sy0 : _ =>  nelstructoncoprod sx0 sy0 ) sx sy .

(** For a result corresponding to [ nelstructontotal2 ] see below . *)

Definition isofnelondirprod { X Y : UU } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( n * m ) ( dirprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ =>  nelstructondirprod sx0 sy0 ) sx sy .

Definition isofnelonfun { X Y : UU } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( natpower m n ) ( X -> Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ =>  nelstructonfun sx0 sy0 ) sx sy .

(** For a result corresponding to [ nelstructonforall ] see below . *)

Definition isofnelonweq { X : UU } { n : nat } ( sx : isofnel n X ) : isofnel ( factorial n ) ( weq X X ) := hinhfun ( fun sx0 : _ =>  nelstructonweq sx0 ) sx .

(** ** General finite sets. *)

(** *** Finite structure on a type [ X ] defined as a pair [ ( n , w ) ] where [ n : nat ] and [ w : weq ( stn n ) X ] *)

Definition finstruct  ( X : UU ) := total2 ( fun n : nat => nelstruct n X ) .
Definition fintructpair  ( X : UU )  := tpair ( fun n : nat => nelstruct n X ) .

Definition finstructonstn ( n : nat ) : finstruct ( stn n ) := tpair _ n ( nelstructonstn n ) .

Definition finstructweqf { X Y : UU } ( w : weq X Y ) ( sx : finstruct X ) : finstruct Y := tpair _ ( pr1 sx ) ( nelstructweqf w ( pr2 sx ) ) .

Definition finstructweqb { X Y : UU } ( w : weq X Y ) ( sy : finstruct Y ) : finstruct X :=  tpair _ ( pr1 sy ) ( nelstructweqb w ( pr2 sy ) ) .

Definition finstructonempty : finstruct empty := tpair _ 0 nelstructonempty .

Definition finstructonempty2 { X : UU } ( is : neg X ) : finstruct X :=  tpair _ 0 ( nelstructonempty2 is ) .

Definition finstructonunit : finstruct unit := tpair _ 1 nelstructonunit .

Definition finstructoncontr { X : UU } ( is : iscontr X ) : finstruct X := tpair _ 1 ( nelstructoncontr is ) .

(** It is not difficult to show that a direct summand of a finite set is a finite set . As a corrolary it follows that a proposition ( a type of h-level 1 ) is a finite set if and only if it is decidable . *)

Definition finstructonbool : finstruct bool := tpair _ 2 nelstructonbool .

Definition finstructoncoprodwithunit { X : UU }  ( sx : finstruct X ) : finstruct ( coprod X unit ) :=  tpair _ ( S ( pr1 sx ) ) ( nelstructoncoprodwithunit ( pr2 sx ) ) .

Definition finstructoncompl { X : UU } ( x : X ) ( sx : finstruct X ) : finstruct ( compl X x ) .
Proof . intros . unfold finstruct .  unfold finstruct in sx . destruct sx as [ n w ] . destruct n as [ | n ] .  destruct ( negstn0 ( invweq w x ) ) . split with n .   apply ( nelstructoncompl x w ) .  Defined .

Definition finstructoncoprod { X  Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( coprod X Y ) := tpair _ ( ( pr1 sx ) + ( pr1 sy ) ) ( nelstructoncoprod ( pr2 sx ) ( pr2 sy ) ) .

Definition finstructontotal2 { X : UU } ( P : X -> UU )   ( sx : finstruct X ) ( fs : forall x : X , finstruct ( P x ) ) : finstruct ( total2 P ) := tpair _ ( stnsum ( funcomp ( pr1 ( pr2 sx ) ) ( fun x : X =>  pr1 ( fs x ) ) ) ) ( nelstructontotal2 P ( fun x : X => pr1 ( fs x ) ) ( pr2 sx ) ( fun x : X => pr2 ( fs x ) ) ) .

Definition finstructondirprod { X Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( dirprod X Y ) := tpair _ ( ( pr1 sx ) * ( pr1 sy ) ) ( nelstructondirprod ( pr2 sx ) ( pr2 sy ) ) .

Definition finstructondecsubset { X : UU }  ( f : X -> bool ) ( sx : finstruct X ) : finstruct ( hfiber f true ) := tpair _ ( pr1 ( weqfromdecsubsetofstn ( funcomp ( pr1 ( pr2 sx ) ) f ) ) ) ( weqcomp ( invweq ( pr2 ( weqfromdecsubsetofstn ( funcomp ( pr1 ( pr2 sx ) ) f ) ) ) ) ( weqhfibersgwtog ( pr2 sx ) f true ) ) .

Definition finstructonfun { X Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( X -> Y ) := tpair _ ( natpower ( pr1 sy ) ( pr1 sx ) ) ( nelstructonfun ( pr2 sx ) ( pr2 sy ) ) .

Definition finstructonforall { X : UU } ( P : X -> UU )  ( sx : finstruct X ) ( fs : forall x : X , finstruct ( P x ) ) : finstruct ( forall x : X , P x )  := tpair _ ( stnprod ( funcomp ( pr1 ( pr2 sx ) ) ( fun x : X =>  pr1 ( fs x ) ) ) ) ( nelstructonforall P ( fun x : X => pr1 ( fs x ) ) ( pr2 sx ) ( fun x : X => pr2 ( fs x ) ) ) .

Definition finstructonweq { X : UU }  ( sx : finstruct X ) : finstruct ( weq X X ) := tpair _ ( factorial ( pr1 sx ) ) ( nelstructonweq ( pr2 sx ) ) .

(** *** The property of being finite *)

Definition isfinite  ( X : UU ) := ishinh ( finstruct X ) .

Definition fincard { X : UU } ( is : isfinite X ) : nat .
Proof . intros . set ( int := carrier ( fun n : nat => isofnel n X ) ) .  set ( f1  := ( fun nw : finstruct X => tpair  ( fun n : nat => isofnel n X ) ( pr1 nw ) ( hinhpr _ ( pr2 nw ) ) ) : finstruct X -> int ) .  assert ( isp : isaprop int ) . apply isapropsubtype .   intros x1 x2 is1 is2 . apply ( @hinhuniv2 ( nelstruct x1 X ) ( nelstruct x2 X ) ( hProppair _ ( isasetnat x1 x2 ) ) ) .  intros sx1 sx2 . apply ( weqtoeqstn x1 x2 ( weqcomp sx1 ( invweq sx2 ) ) ) .  apply is1 .  apply is2 .  apply ( @hinhuniv _ ( hProppair _ isp ) f1 ) .  apply is .  Defined .

Theorem ischoicebasefiniteset { X : UU } ( is : isfinite X ) : ischoicebase X .
Proof . intros . apply ( @hinhuniv ( finstruct X ) ( ischoicebase X ) ) .  intro nw . destruct nw as [ n w ] .   apply ( ischoicebaseweqf w ( ischoicebasestn n ) ) .  apply is .  Defined .

Definition isfinitestn ( n : nat ) : isfinite ( stn n ) := hinhpr _ ( finstructonstn n ) .

Definition isfiniteweqf { X Y : UU } ( w : weq X Y ) ( sx : isfinite X ) : isfinite Y :=  hinhfun ( fun sx0 : _ =>  finstructweqf w sx0 ) sx .

Definition isfiniteweqb { X Y : UU } ( w : weq X Y ) ( sy : isfinite Y ) : isfinite X :=   hinhfun ( fun sy0 : _ =>  finstructweqb w sy0 ) sy .

Definition isfiniteempty : isfinite empty := hinhpr _ finstructonempty .

Definition isfiniteempty2 { X : UU } ( is : neg X ) : isfinite X :=  hinhpr _ ( finstructonempty2 is ) .

Definition isfiniteunit : isfinite unit := hinhpr _ finstructonunit .

Definition isfinitecontr { X : UU } ( is : iscontr X ) : isfinite X := hinhpr _ ( finstructoncontr is ) .

Definition isfinitebool : isfinite bool := hinhpr _ finstructonbool .

Definition isfinitecoprodwithunit { X : UU } ( sx : isfinite X ) : isfinite ( coprod X unit ) :=  hinhfun ( fun sx0 : _ => finstructoncoprodwithunit sx0 ) sx .

Definition isfinitecompl { X : UU } ( x : X ) ( sx : isfinite X ) : isfinite ( compl X x ) := hinhfun ( fun sx0 : _ => finstructoncompl x sx0 ) sx .

Definition isfinitecoprod { X  Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( coprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructoncoprod sx0 sy0 ) sx sy .

Definition isfinitetotal2 { X : UU } ( P : X -> UU ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( total2 P ) .
Proof . intros . set ( fs' := ischoicebasefiniteset sx _ fs ) .  apply ( hinhfun2 ( fun fx0 : forall x : X , finstruct ( P x )  => fun sx0 : _ => finstructontotal2 P sx0 fx0 ) fs' sx ) .  Defined .

Definition isfinitedirprod { X Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( dirprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructondirprod sx0 sy0 ) sx sy .

Definition isfinitedecsubset { X : UU } ( f : X -> bool ) ( sx : isfinite X ) : isfinite ( hfiber f true ) := hinhfun ( fun sx0 : _ =>  finstructondecsubset f sx0 ) sx .

Definition isfinitefun { X Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( X -> Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructonfun sx0 sy0 ) sx sy .

Definition isfiniteforall { X : UU } ( P : X -> UU ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( forall x : X , P x ) .
Proof . intros . set ( fs' := ischoicebasefiniteset sx _ fs ) .  apply ( hinhfun2 ( fun fx0 : forall x : X , finstruct ( P x )  => fun sx0 : _ => finstructonforall P sx0 fx0 ) fs' sx ) .  Defined .

Definition isfiniteweq { X : UU } ( sx : isfinite X ) : isfinite ( weq X X ) := hinhfun ( fun sx0 : _ =>  finstructonweq sx0 ) sx .

(*

(* The cardinality of finite sets using double negation and decidability of equality in nat. *)

Definition carddneg  ( X : UU ) (is: isfinite X): nat:= pr1 (isfiniteimplisfinite0 X is).

Definition preweq  ( X : UU ) (is: isfinite X): isofnel (carddneg X is) X.
Proof. intros X is X0.  set (c:= carddneg X is). set (dnw:= pr2 (isfiniteimplisfinite0 X is)). simpl in dnw. change (pr1 nat (fun n : nat => isofnel0 n X) (isfiniteimplisfinite0 X is)) with c in dnw.

assert (f: dirprod (finitestruct X) (dneg (weq (stn c) X)) -> weq (stn c) X). intro H. destruct H as [ t x ].  destruct t as [ t x0 ].
assert (dw: dneg (weq (stn t) (stn c))). set (ff:= fun ab:dirprod (weq (stn t) X)(weq (stn c) X) => weqcomp _ _ _ (pr1 ab) (invweq (pr2 ab))).  apply (dnegf _ _ ff (inhdnegand _ _ (todneg _ x0) x)).
assert (e:paths t c). apply (stnsdnegweqtoeq _ _  dw). clear dnw. destruct e. assumption. unfold isofnel.
apply (hinhfun _ _ f (hinhand (finitestruct X) _ is (hinhpr _ dnw))). Defined.

*)

(* to be completed

Theorem carddnegweqf (X Y:UU)(f: X -> Y)(isw:isweq f)(isx: isfinite X): paths  (carddneg _ isx) (carddneg _ (isfiniteweqf _ _ _ isw isx)).
Proof. intros. *)

(* The cardinality of finite sets defined using the "impredicative" ishinh *)

(** ** Test computations. *)

(*Eval compute in carddneg _  (isfinitedirprod _ _ (isfinitestn (S (S (S (S O)))))  (isfinitestn (S (S (S O))))).*)

Eval compute in fincard (isfiniteempty).

Eval compute in fincard (isfiniteunit).

Eval compute in fincard (isfinitebool).

(*Eval lazy in   (pr1 (finitestructcomplement _ (dirprodpair _ _ tt tt) (finitestructdirprod _ _ (finitestructunit) (finitestructunit)))).*)

Eval compute in fincard (isfinitecompl  true isfinitebool).

Eval compute in fincard (isfinitedirprod  isfinitebool isfinitebool).

Eval compute in fincard (isfinitedirprod  isfinitebool (isfinitedirprod  isfinitebool isfinitebool)).

Eval lazy in fincard (isfinitecompl (ii1 tt) (isfinitecoprod  (isfiniteunit) (isfinitebool))).

Eval lazy in  fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))).

Eval lazy in fincard (isfinitecompl (dirprodpair tt tt) (isfinitedirprod  isfiniteunit isfiniteunit)).

Eval lazy in fincard (isfinitecompl (dirprodpair  true (dirprodpair  true false)) (isfinitedirprod  (isfinitebool) (isfinitedirprod  (isfinitebool) (isfinitebool)))).

Eval lazy in fincard ( isfiniteweq ( isfinitedirprod ( isfinitedirprod isfinitebool isfinitebool ) isfinitebool ) ) .

(* End of the file finitesets.v *)


Require Import Bank Bank_Utils.

From Verdi Require Import
  Verdi
  HandlerMonad
  LabeledNet.

From InfSeqExt Require Import
  infseq
  exteq
  classical.

From mathcomp Require Import
  ssreflect
  ssrfun
  ssrbool.

From Coq Require Import
  Classes.EquivDec
  FSets.FMapFacts
  Structures.OrderedTypeEx.

Module NatDictWF := WFacts_fun Nat_as_OT NatDict.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Set Bullet Behavior "Strict Subproofs".

Section Bank_Proofs.

  (*******
   * Basic lemmas on steps and traces
   *******)

  (* [SAFETY]
   * Empty trace => No change in network. [Converse cannot be proved] *)
  Lemma step_star_no_trace_no_step :
    forall net net' trace,
      step_async_star net net' trace ->
      trace = [] ->
      net = net'.
  Proof using.
    intros. invc H.
      (* net = net' *)
      - reflexivity.
      (* net -> x' -> net' *)
      - invc H1 ; invc H5.
  Qed.

  (* [SAFETY]
   * In a well-formed trace, every node must be present in Nodes. *)
  Lemma trace_well_formed :
    forall net trace trace' n io,
      step_async_star step_async_init net trace ->
      (trace = [] \/ (trace = trace' ++ [(n, io)] -> (In n Nodes))).
  Proof using.
    intros. invcs H.
    (* net = net' *)
    - intuition.
    (* net -> x' -> net' *)
    - right. intuition. apply all_Names_Nodes.
  Qed.

  (********
   * More complex properties
   ********)
  (* [SAFETY]
   * Min Value Balance : Over all traces, the returned account valuecoq
   *                     is always greater than the minimum value.
   *)
  Inductive min_value_invariant_state : State -> Prop :=
  | min_value_invariant_agent_state :
      forall astate, min_value_invariant_state (agent astate)
  | min_value_invariant_nil_state :
      min_value_invariant_state (server (NatDict.empty Value))
  | min_value_invariant_add_state :
      forall st acc val,
        min_value_invariant_state (server st) ->
        val >= minValue ->
        min_value_invariant_state (server (NatDict.add acc val st)).

  Inductive min_value_invariant_packet : packet -> Prop :=
  | min_value_invariant_passed_packet :
      forall src dst c a v,
        v >= minValue ->
        min_value_invariant_packet (mkPacket src dst (netM c (resp (PassMsg a v))))
  | min_value_invariant_other_packet :
      forall pkt,
        (not (exists c a v, (pBody pkt) = (netM c (resp (PassMsg a v))))) ->
        min_value_invariant_packet pkt.

  Definition min_value_invariant_network net :=
    min_value_invariant_state ((nwState net) Server) /\
    (forall p, In p (nwPackets net) -> min_value_invariant_packet p).

  Fixpoint min_value_invariant_outputs (outs : list output) : Prop :=
    match outs with
    | nil                        => True
    | (netO _ (Passed a v)) :: l => v >= 0 /\ (min_value_invariant_outputs l)
    | _ :: l                     => (min_value_invariant_outputs l)
    end.

  Fixpoint min_value_invariant_trace (trace : list (name * (input + list output)))
                                     : Prop :=
    match trace with
    | nil                  => True
    | (Agent, inr os) :: l => (min_value_invariant_outputs os)
                           /\ (min_value_invariant_trace l)
    | _ :: l               => (min_value_invariant_trace l)
    end.

  Lemma min_value_invariant_trace_app :
    forall tr1 tr2,
      min_value_invariant_trace tr1 /\
      min_value_invariant_trace tr2 ->
      min_value_invariant_trace (tr1 ++ tr2).
  Proof using.
    intros. induction tr1 ; intuition ; simpl in *.
    repeat break_match ; intuition.
  Qed.

  Lemma min_value_invariant_state_values :
    forall st k v,
      min_value_invariant_state (server st) ->
      NatDict.find k st = Some v ->
      v >= minValue.
  Proof using.
    intros. prep_induction H. induction H ; intros ; invcs H2.
    - apply NatDictWF.find_mapsto_iff, NatDictWF.empty_mapsto_iff in H0.
      intuition.
    - apply NatDictWF.find_mapsto_iff, NatDictWF.add_mapsto_iff in H1.
      intuition. apply NatDictWF.find_mapsto_iff in H3.
      apply (IHmin_value_invariant_state st k v) ; intuition.
  Qed.

  Lemma min_value_invariant_server_resp :
    forall msg st outs st' msgs lbl,
      min_value_invariant_state (server st) ->
      ServerNetHandler msg st = (lbl, outs, st', msgs) ->
      (min_value_invariant_state (server st') /\
        (forall d a c v,
          In (d, (netM c (resp (PassMsg a v)))) msgs ->
          v >= minValue)).
  Proof using.
    intros. split ; intros.
    (* state_values_gt_min_value st' *)
    - simplify_bank_handlers.
      (* create *)
      + apply (min_value_invariant_add_state st a minValue) ; intuition.
      (* deposit *)
      + pose proof (min_value_invariant_state_values st a v0) as Hv0. intuition.
        apply (min_value_invariant_add_state st a (v0 + v)) ; intuition.
      (* withdraw *)
      + pose proof (min_value_invariant_state_values st a v0) as Hv0. intuition.
        apply (min_value_invariant_add_state st a (v0 - v)) ; intuition.
    (* PassMsg *)
    - simplify_bank_handlers.
      + pose proof (min_value_invariant_state_values st a v1) as Hv1.
        intuition.
      + apply (min_value_invariant_state_values st' a v) ; intuition.
  Qed.

  Lemma min_value_invariant_step :
    forall net net' tr,
      min_value_invariant_network net ->
      step_async net net' tr ->
      (min_value_invariant_network net' /\ min_value_invariant_trace tr).
  Proof using.
    intros. unfold min_value_invariant_network in *. invc H0 ; intuition.
    (* NetHandler state *)
    - simpl ; intuition ; simplify_bank_handlers
                        ; apply min_value_invariant_add_state ; intuition
                        ; apply (min_value_invariant_state_values s a v0) in Heqo
                        ; intuition.
    (* NetHandler packets *)
    - simplify_bank_handlers
        ; try ( rewrite H1 in H3 ; pose proof (H3 p0)
              ; find_apply_lem_hyp in_app_iff ; intuition)
        ; try ( constructor ; intuition ; break_exists ; simpl in * ; discriminate)
        ; constructor ; find_apply_lem_hyp min_value_invariant_state_values ; intuition.
    (* NetHandler trace *)
    - simplify_bank_handlers.
    (* IOHandler state *)
    - simplify_bank_handlers.
    (* IOHandler packets *)
    - simpl in *. apply in_app_iff in H. intuition.
      simplify_bank_handlers ; constructor ; intuition ; break_exists
                             ; simpl in * ; find_inversion.
    (* IOHandler trace *)
    - simplify_bank_handlers.
  Qed.

  Theorem min_value_invariant :
    forall net tr,
      step_async_star step_async_init net tr ->
      (min_value_invariant_network net /\ min_value_invariant_trace tr).
  Proof using.
    intros. find_apply_lem_hyp refl_trans_1n_n1_trace.
    prep_induction H. induction H
                    ; intros ; simplify_bank_handlers
                    ; try (apply (min_value_invariant_step x' x'' cs') in H1 ; intuition).
    - constructor ; simpl in * ; intuition. constructor.
    - apply (min_value_invariant_trace_app cs cs'). intuition.
  Qed.

  Lemma true_in_reachable_min_value :
    true_in_reachable step_async step_async_init
                      (fun net => min_value_invariant_network net).
  Proof using.
    intro net. pose proof min_value_invariant net.
    assert (inductive_invariant step_async step_async_init min_value_invariant_network).
    - unfold inductive_invariant. split.
      + unfold min_value_invariant_network. intuition.
        apply min_value_invariant_nil_state.
      + unfold inductive. apply min_value_invariant_step.
    - find_apply_lem_hyp inductive_invariant_true_in_reachable. apply H0.
  Qed.

  (* [LIVENESS]
   * Finite Wait Time: No Agent remains waiting for ever, starting from any
                       reachable network state. *)
  Lemma Server_RespMsg_enables_Ready :
    forall id r,
      message_enables_label (mkPacket Server Agent (netM id (resp r))) Ready.
  Proof using.
    unfold message_enables_label. intros.
    find_apply_lem_hyp in_split. repeat (break_exists ; intuition).
    destruct (step_star_consistent_state net) ; try exists x1 ; intuition.
    repeat break_exists. destruct (AState_eq_dec x2 wait) ; last first.
    - repeat eexists. apply LabeledStepAsync_deliver with (xs := x) (ys := x0)
                                                          (d := agent x2) (l := []) ; eauto.
      simplify_bank_handlers; rewrite H1 in Heqd ; invcs Heqd ; intuition.
    - destruct r ; repeat eexists ;
      [ apply LabeledStepAsync_deliver with (xs := x) (ys := x0) (d := agent fail) (l := [])
      | apply LabeledStepAsync_deliver with (xs := x) (ys := x0) (d := agent pass) (l := [])]
      ; eauto ; simplify_bank_handlers ; rewrite H1 in Heqd ; invcs Heqd ; intuition
      ; (pose proof (H2 s) ; intuition).
  Qed.

  Lemma Server_RespMsg_delivered_Ready :
    forall id r,
      message_delivered_label (mkPacket Server Agent (netM id (resp r))) Ready.
  Proof using.
    unfold message_delivered_label. intros. invc H0; intuition.
    - rewrite H3 in H1.
      find_eapply_lem_hyp In_split_not_In; eauto.
      clear H2. subst. monad_unfold. simpl in *.
      handler_unfold. repeat break_match; repeat find_inversion; auto.
      apply step_star_consistent_state in H. intuition.
      apply H1 in Heqd0. inversion Heqd0.
    - find_false. apply in_app_iff; auto.
  Qed.

  Lemma RespMsg_in_network_eventually_Ready :
    forall s r id,
      initialized_eventseq s ->
      weak_fairness lb_step_async label_silent s ->
      In (mkPacket Server Agent (netM id (resp r))) (nwPackets (evt_a (hd s))) ->
      eventually (now (occurred Ready)) s.
  Proof using.
    intros. unfold initialized_eventseq in *. intuition.
    eapply message_labels_eventually_occur
          ; eauto using Server_RespMsg_enables_Ready, Server_RespMsg_delivered_Ready.
    - unfold label_silent. simpl. congruence.
    - unfold initialized_eventseq. intuition.
  Qed.

  Lemma Agent_ReqMsg_enables_Processed :
    forall id r,
      message_enables_label (mkPacket Agent Server (netM id (req r))) Processed.
  Proof using.
    unfold message_enables_label. intros.
    find_apply_lem_hyp in_split. repeat (break_exists ; intuition).
    destruct (step_star_consistent_state net) ; try exists x1 ; intuition.
  Admitted.

  Lemma Agent_ReqMsg_delivered_Processed :
    forall id r,
      message_delivered_label (mkPacket Agent Server (netM id (req r))) Processed.
  Proof using.
    unfold message_delivered_label. intros. invc H0; intuition.
    - rewrite H3 in H1.
      find_eapply_lem_hyp In_split_not_In; eauto.
      clear H2. subst. monad_unfold. simpl in *.
      handler_unfold. repeat break_match; repeat find_inversion; auto.
      apply step_star_consistent_state in H. intuition.
      apply H4 in Heqd0. inversion Heqd0.
    - find_false. apply in_app_iff; auto.
  Qed.

  Lemma ReqMsg_in_network_eventually_Processed :
    forall s r id,
      initialized_eventseq s ->
      weak_fairness lb_step_async label_silent s ->
      In (mkPacket Agent Server (netM id (req r))) (nwPackets (evt_a (hd s))) ->
      eventually (now (occurred Processed)) s.
  Proof using.
    unfold initialized_eventseq.
    intros. eapply message_labels_eventually_occur
          ; eauto using Agent_ReqMsg_enables_Processed, Agent_ReqMsg_delivered_Processed.
    - unfold label_silent. simpl. congruence.
    - unfold initialized_eventseq. intuition.
  Qed.

  Lemma Waiting_ReqMsg :
    forall s,
      initialized_eventseq s ->
      now (occurred Waiting) s ->
      exists id r, next (fun s => In (mkPacket Agent Server (netM id (req r)))
                                     (nwPackets (evt_a (hd s))))
                                     s.
  Proof using.
  Admitted.

  Lemma initialized_eventseq_invar :
    forall e s,
      initialized_eventseq (Cons e s) ->
      initialized_eventseq s.
  Proof using.
  Admitted.

  Theorem Waiting_eventually_Processed :
    forall s,
      initialized_eventseq s ->
      weak_fairness lb_step_async label_silent s ->
      now (occurred Waiting) s ->
      eventually (now (occurred Processed)) s.
  Proof using.
    intros [e s]. intuition.
    apply Waiting_ReqMsg in H1 ; intuition. break_exists.
    unfold next in *.
    apply ReqMsg_in_network_eventually_Processed in H1 ; intuition.
    - apply E_next. intuition.
    - apply (initialized_eventseq_invar e s) ; intuition.
    - apply (weak_fairness_invar H0).
  Qed.

End Bank_Proofs.


Require Import HoTT.Basics HoTT.Types.Bool HoTT.Types.Paths HoTT.HIT.Coeq.
Require Import Colimits.Diagram Colimits.Colimit.

Context `{Funext}.
Generalizable All Variables.

Section Coequalizer.
  Definition coequalizer_graph : graph.
    simple refine (Build_graph _ _).
    - exact Bool.
    - intros i j; exact (if i then if j then Empty else Bool else Empty).
  Defined.

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

  Definition coequalizer_diag : diagram coequalizer_graph.
    simple refine (Build_diagram _ _ _).
    - intro x; destruct x.
      exact B. exact A.
    - intros i j; destruct i, j; intro H; destruct H. exact f. exact g.
  Defined.

  Definition coequalizer_cocone `(q: A -> Q) (Hq: q o g == q o f) : cocone coequalizer_diag Q.
  Proof.
    simple refine (Build_cocone _ _).
    - destruct i; cbn. exact (q o f). exact q.
    - destruct i, j, g0; cbn. reflexivity. exact Hq.
  Defined.

  Definition path_coequalizer_cocone `{C1: cocone coequalizer_diag Q} {C2: cocone coequalizer_diag Q}
       (H1: C1 false == C2 false)
       (H2: forall x, (qq C1 true false false x @ (qq C1 true false true x)^) @ H1 (f x)
                  = H1 (g x) @ (qq C2 true false false x @ (qq C2 true false true x)^))

    : C1 = C2.
  Proof.
    simple refine (path_cocone _ _).
    - destruct i; cbn.
      + intro x. etransitivity. exact (qq C1 true false true x)^.
        etransitivity. apply H1. exact (qq C2 true false true x).
      + exact H1.
    - destruct i, j, g0; cbn; intro x.
      + hott_simpl.
      + hott_simpl. rewrite H2. hott_simpl.
  Defined.

  Definition coequalizer_cocone' `(q1: A -> Q) (Hq1: q1 o g == q1 o f)
             (q2: A -> Q) (Hq2: q2 o g == q2 o f)
             (H1: q1 == q2)
             (H2: forall x, Hq1 x @ H1 (f x) = H1 (g x) @ Hq2 x)
    : coequalizer_cocone q1 Hq1 = coequalizer_cocone q2 Hq2.
  Proof.
    simple refine (path_coequalizer_cocone _ _).
    - exact H1.
    - cbn. intro; hott_simpl.
  Defined.

  (* ***************** *)
  (* ***** Coeq ****** *)
  (* ***************** *)

  Definition Coeq_cocone : cocone coequalizer_diag (Coeq f g).
    simple refine (Build_cocone _ _).
    - intros i x; destruct i; simpl in *. exact (coeq (g x)). exact (coeq x).
    - intros i j φ x; destruct i, j, φ; simpl. exact (cp x). reflexivity.
  Defined.

  Lemma is_coequalizer_Coeq : is_colimit coequalizer_diag (Coeq f g).
    simple refine (Build_is_colimit Coeq_cocone _).
    intros X.
    simple refine (isequiv_adjointify _ _ _).
    - intros C. simple refine (Coeq_rec _ _ _). exact (q C false).
      intros b. etransitivity.
      exact (qq C true false true b).
      exact (qq C true false false b)^.
    - intros C. simple refine (path_cocone _ _).
      + intros i x; destruct i; simpl. exact (qq C true false false x). reflexivity.
      + intros i j φ x; destruct i, j, φ; simpl.
        * hott_simpl.
          match goal with
            | [|- ap (Coeq_rec ?a ?b ?c) _ @ _ = _ ] => rewrite (Coeq_rec_beta_cp a b c)
          end. hott_simpl.
        * reflexivity.
    - intros F. apply path_forall.
      match goal with
        | [|- ?G == _ ] => simple refine (Coeq_ind (fun w => G w = F w) _ _)
      end.
      + simpl. reflexivity.
      + intros b. simpl.
        rewrite transport_paths_FlFr.
        rewrite Coeq_rec_beta_cp. hott_simpl.
  Defined.
End Coequalizer.