(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path.
From mathcomp Require Import div choice fintype tuple finfun bigop prime.
From mathcomp Require Import ssralg poly finset fingroup morphism perm.
From mathcomp Require Import automorphism quotient action finalg zmodp.
From mathcomp Require Import commutator cyclic center pgroup sylow gseries.
From mathcomp Require Import nilpotent abelian ssrnum ssrint polydiv rat.
From mathcomp Require Import matrix mxalgebra intdiv mxpoly vector falgebra.
From mathcomp Require Import fieldext separable galois algC cyclotomic algnum.
From mathcomp Require Import mxrepresentation classfun character.

(******************************************************************************)
(* This file provides some standard results based on integrality properties   *)
(* of characters, such as theorem asserting that the degree of an irreducible *)
(* character of G divides the order of G (Isaacs 3.11), or the famous p^a.q^b *)
(* solvability theorem of Burnside.                                           *)
(*   Defined here:                                                            *)
(*    'K_k == the kth class sum in gring F G, where k : 'I_#|classes G|, and  *)
(*            F is inferred from the context.                                 *)
(*            := gset_mx F G (enum_val k) (see mxrepresentation.v).           *)
(* --> The 'K_k form a basis of 'Z(group_ring F G)%MS.                        *)
(*   gring_classM_coef i j k == the coordinate of 'K_i *m 'K_j on 'K_k; this  *)
(*            is usually abbreviated as a i j k.                              *)
(*   gring_classM_coef_set A B z == the set of all (x, y) in setX A B such    *)
(*            that x * y = z; if A and B are respectively the ith and jth     *)
(*            conjugacy class of G, and z is in the kth conjugacy class, then *)
(*            gring_classM_coef i j k is exactly the cardinal of this set.    *)
(*  'omega_i[A] == the mode of 'chi[G]_i on (A \in 'Z(group_ring algC G))%MS, *)
(*            i.e., the z such that gring_op 'Chi_i A  = z%:M.                *)
(******************************************************************************)

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

Import GroupScope GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Lemma group_num_field_exists (gT : finGroupType) (G : {group gT}) :
  {Qn : splittingFieldType rat & galois 1 {:Qn} &
    {QnC : {rmorphism Qn -> algC}
         & forall nuQn : argumentType (mem ('Gal({:Qn}%VS / 1%VS))),
              {nu : {rmorphism algC -> algC} |
                 {morph QnC: a / nuQn a >-> nu a}}
         & {w : Qn & #|G|.-primitive_root w /\ <<1; w>>%VS = fullv
              & forall (hT : finGroupType) (H : {group hT}) (phi : 'CF(H)),
                       phi \is a character ->
                       forall x, (#[x] %| #|G|)%N -> {a | QnC a = phi x}}}}.
Proof.
have [z prim_z] := C_prim_root_exists (cardG_gt0 G); set n := #|G| in prim_z *.
have [Qn [QnC [[|w []] // [Dz] genQn]]] := num_field_exists [:: z].
have prim_w: n.-primitive_root w by rewrite -Dz fmorph_primitive_root in prim_z.
have Q_Xn1: ('X^n - 1 : {poly Qn}) \is a polyOver 1%AS.
  by rewrite rpredB ?rpred1 ?rpredX //= polyOverX.
have splitXn1: splittingFieldFor 1 ('X^n - 1) {:Qn}.
  pose r := codom (fun i : 'I_n => w ^+ i).
  have Dr: 'X^n - 1 = \prod_(y <- r) ('X - y%:P).
    by rewrite -(factor_Xn_sub_1 prim_w) big_mkord big_image.
  exists r; first by rewrite -Dr eqpxx.
  apply/eqP; rewrite eqEsubv subvf -genQn adjoin_seqSr //; apply/allP=> /=.
  by rewrite andbT -root_prod_XsubC -Dr; apply/unity_rootP/prim_expr_order.
have Qn_ax : SplittingField.axiom Qn by exists ('X^n - 1).
exists (SplittingFieldType _ _ Qn_ax).
  apply/splitting_galoisField.
  exists ('X^n - 1); split => //.
  apply: separable_Xn_sub_1; rewrite -(fmorph_eq0 QnC) rmorph_nat.
  by rewrite pnatr_eq0 -lt0n cardG_gt0.
exists QnC => [// nuQn|].
  by apply: (extend_algC_subfield_aut QnC [rmorphism of nuQn]).
rewrite span_seq1 in genQn.
exists w => // hT H phi Nphi x x_dv_n.
apply: sig_eqW; have [rH ->] := char_reprP Nphi.
have [Hx | /cfun0->] := boolP (x \in H); last by exists 0; rewrite rmorph0.
have [e [_ [enx1 _] [-> _] _]] := repr_rsim_diag rH Hx.
have /fin_all_exists[k Dk] i: exists k, e 0 i = z ^+ k.
  have [|k ->] := (prim_rootP prim_z) (e 0 i); last by exists k.
  by have /dvdnP[q ->] := x_dv_n; rewrite mulnC exprM enx1 expr1n.
exists (\sum_i w ^+ k i); rewrite rmorph_sum; apply/eq_bigr => i _.
by rewrite rmorphX Dz Dk.
Qed.

Section GenericClassSums.

(* This is Isaacs, Theorem (2.4), generalized to an arbitrary field, and with *)
(* the combinatorial definition of the coeficients exposed.                   *)
(* This part could move to mxrepresentation.*)

Variable (gT : finGroupType) (G : {group gT}) (F : fieldType).

Definition gring_classM_coef_set (Ki Kj : {set gT}) g :=
  [set xy in [predX Ki & Kj] | let: (x, y) := xy in x * y == g]%g.

Definition gring_classM_coef (i j k : 'I_#|classes G|) :=
  #|gring_classM_coef_set (enum_val i) (enum_val j) (repr (enum_val k))|.

Definition gring_class_sum (i : 'I_#|classes G|) := gset_mx F G (enum_val i).

Local Notation "''K_' i" := (gring_class_sum i)
  (at level 8, i at level 2, format "''K_' i") : ring_scope.
Local Notation a := gring_classM_coef.

Lemma gring_class_sum_central i : ('K_i \in 'Z(group_ring F G))%MS.
Proof. by rewrite -classg_base_center (eq_row_sub i) // rowK. Qed.

Lemma set_gring_classM_coef (i j k : 'I_#|classes G|) g :
    g \in enum_val k ->
  a i j k = #|gring_classM_coef_set (enum_val i) (enum_val j) g|.
Proof.
rewrite /a; have /repr_classesP[] := enum_valP k; move: (repr _) => g1 Gg1 ->.
have [/imsetP[zi Gzi ->] /imsetP[zj Gzj ->]] := (enum_valP i, enum_valP j).
move=> g1Gg; have Gg := subsetP (class_subG Gg1 (subxx _)) _ g1Gg.
set Aij := gring_classM_coef_set _ _.
without loss suffices IH: g g1 Gg Gg1 g1Gg / (#|Aij g1| <= #|Aij g|)%N.
  by apply/eqP; rewrite eqn_leq !IH // class_sym.
have [w Gw Dg] := imsetP g1Gg; pose J2 (v : gT) xy := (xy.1 ^ v, xy.2 ^ v)%g.
have J2inj: injective (J2 w).
  by apply: can_inj (J2 w^-1)%g _ => [[x y]]; rewrite /J2 /= !conjgK.
rewrite -(card_imset _ J2inj) subset_leq_card //; apply/subsetP.
move=> _ /imsetP[[x y] /setIdP[/andP[/= x1Gx y1Gy] Dxy1] ->]; rewrite !inE /=.
rewrite !(class_sym _ (_ ^ _)) !classGidl // class_sym x1Gx class_sym y1Gy.
by rewrite -conjMg (eqP Dxy1) /= -Dg.
Qed.

Theorem gring_classM_expansion i j : 'K_i *m 'K_j = \sum_k (a i j k)%:R *: 'K_k.
Proof.
have [/imsetP[zi Gzi dKi] /imsetP[zj Gzj dKj]] := (enum_valP i, enum_valP j).
pose aG := regular_repr F G; have sKG := subsetP (class_subG _ (subxx G)).
transitivity (\sum_(x in zi ^: G) \sum_(y in zj ^: G) aG (x * y)%g).
  rewrite mulmx_suml -/aG dKi; apply: eq_bigr => x /sKG Gx.
  rewrite mulmx_sumr -/aG dKj; apply: eq_bigr => y /sKG Gy.
  by rewrite repr_mxM ?Gx ?Gy.
pose h2 xy : gT := (xy.1 * xy.2)%g.
pose h1 xy := enum_rank_in (classes1 G) (h2 xy ^: G).
rewrite pair_big (partition_big h1 xpredT) //=; apply: eq_bigr => k _.
rewrite (partition_big h2 (mem (enum_val k))) /= => [|[x y]]; last first.
  case/andP=> /andP[/= /sKG Gx /sKG Gy] /eqP <-.
  by rewrite enum_rankK_in ?class_refl ?mem_classes ?groupM ?Gx ?Gy.
rewrite scaler_sumr; apply: eq_bigr => g Kk_g; rewrite scaler_nat.
rewrite (set_gring_classM_coef _ _ Kk_g) -sumr_const; apply: eq_big => [] [x y].
  rewrite !inE /= dKi dKj /h1 /h2 /=; apply: andb_id2r => /eqP ->.
  have /imsetP[zk Gzk dKk] := enum_valP k; rewrite dKk in Kk_g.
  by rewrite (class_eqP Kk_g) -dKk enum_valK_in eqxx andbT.
by rewrite /h2 /= => /andP[_ /eqP->].
Qed.

Fact gring_irr_mode_key : unit. Proof. by []. Qed.
Definition gring_irr_mode_def (i : Iirr G) := ('chi_i 1%g)^-1 *: 'chi_i.
Definition gring_irr_mode := locked_with gring_irr_mode_key gring_irr_mode_def.
Canonical gring_irr_mode_unlockable := [unlockable fun gring_irr_mode].

End GenericClassSums.

Arguments gring_irr_mode {gT G%G} i%R _%g : extra scopes.

Notation "''K_' i" := (gring_class_sum _ i)
  (at level 8, i at level 2, format "''K_' i") : ring_scope.

Notation "''omega_' i [ A ]" := (xcfun (gring_irr_mode i) A)
   (at level 8, i at level 2, format "''omega_' i [ A ]") : ring_scope.

Section IntegralChar.

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

(* This is Isaacs, Corollary (3.6). *)
Lemma Aint_char (chi : 'CF(G)) x : chi \is a character -> chi x \in Aint.
Proof.
have [Gx /char_reprP[rG ->] {chi} | /cfun0->//] := boolP (x \in G).
have [e [_ [unit_e _] [-> _] _]] := repr_rsim_diag rG Gx.
rewrite rpred_sum // => i _; apply: (@Aint_unity_root #[x]) => //.
exact/unity_rootP.
Qed.

Lemma Aint_irr i x : 'chi[G]_i x \in Aint.
Proof. exact/Aint_char/irr_char. Qed.

Local Notation R_G := (group_ring algCfield G).
Local Notation a := gring_classM_coef.

(* This is Isaacs (2.25). *)
Lemma mx_irr_gring_op_center_scalar n (rG : mx_representation algCfield G n) A :
  mx_irreducible rG -> (A \in 'Z(R_G))%MS -> is_scalar_mx (gring_op rG A).
Proof.
move/groupC=> irrG /center_mxP[R_A cGA].
apply: mx_abs_irr_cent_scalar irrG _ _; apply/centgmxP => x Gx.
by rewrite -(gring_opG rG Gx) -!gring_opM ?cGA // envelop_mx_id.
Qed.

Section GringIrrMode.

Variable i : Iirr G.

Let n := irr_degree (socle_of_Iirr i).
Let mxZn_inj: injective (@scalar_mx algCfield n).
Proof. by rewrite -[n]prednK ?irr_degree_gt0 //; apply: fmorph_inj. Qed.

Lemma cfRepr_gring_center n1 (rG : mx_representation algCfield G n1) A :
  cfRepr rG = 'chi_i -> (A \in 'Z(R_G))%MS -> gring_op rG A = 'omega_i[A]%:M.
Proof.
move=> def_rG Z_A; rewrite unlock xcfunZl -{2}def_rG xcfun_repr.
have irr_rG: mx_irreducible rG.
  have sim_rG: mx_rsim 'Chi_i rG by apply: cfRepr_inj; rewrite irrRepr.
  exact: mx_rsim_irr sim_rG (socle_irr _).
have /is_scalar_mxP[e ->] := mx_irr_gring_op_center_scalar irr_rG Z_A.
congr _%:M; apply: (canRL (mulKf (irr1_neq0 i))).
by rewrite mulrC -def_rG cfunE repr_mx1 group1 -mxtraceZ scalemx1.
Qed.

Lemma irr_gring_center A :
  (A \in 'Z(R_G))%MS -> gring_op 'Chi_i A = 'omega_i[A]%:M.
Proof. exact: cfRepr_gring_center (irrRepr i). Qed.

Lemma gring_irr_modeM A B :
    (A \in 'Z(R_G))%MS -> (B \in 'Z(R_G))%MS ->
  'omega_i[A *m B] = 'omega_i[A] * 'omega_i[B].
Proof.
move=> Z_A Z_B; have [[R_A cRA] [R_B cRB]] := (center_mxP Z_A, center_mxP Z_B).
apply: mxZn_inj; rewrite scalar_mxM -!irr_gring_center ?gring_opM //.
apply/center_mxP; split=> [|C R_C]; first exact: envelop_mxM.
by rewrite mulmxA cRA // -!mulmxA cRB.
Qed.

Lemma gring_mode_class_sum_eq (k : 'I_#|classes G|) g :
  g \in enum_val k -> 'omega_i['K_k] = #|g ^: G|%:R * 'chi_i g / 'chi_i 1%g.
Proof.
have /imsetP[x Gx DxG] := enum_valP k; rewrite DxG => /imsetP[u Gu ->{g}].
rewrite unlock classGidl ?cfunJ {u Gu}// mulrC mulr_natl.
rewrite xcfunZl raddf_sum DxG -sumr_const /=; congr (_ * _).
by apply: eq_bigr => _ /imsetP[u Gu ->]; rewrite xcfunG ?groupJ ?cfunJ.
Qed.

(* This is Isaacs, Theorem (3.7). *)
Lemma Aint_gring_mode_class_sum k : 'omega_i['K_k] \in Aint.
Proof.
move: k; pose X := [tuple 'omega_i['K_k] | k < #|classes G| ].
have memX k: 'omega_i['K_k] \in X by apply: image_f.
have S_P := Cint_spanP X; set S := Cint_span X in S_P.
have S_X: {subset X <= S} by apply: mem_Cint_span.
have S_1: 1 \in S.
  apply: S_X; apply/codomP; exists (enum_rank_in (classes1 G) 1%g).
  rewrite (@gring_mode_class_sum_eq _ 1%g) ?enum_rankK_in ?classes1 //.
  by rewrite mulfK ?irr1_neq0 // class1G cards1.
suffices Smul: mulr_closed S.
  by move=> k; apply: fin_Csubring_Aint S_P _ _; rewrite ?S_X.
split=> // _ _ /S_P[x ->] /S_P[y ->].
rewrite mulr_sumr rpred_sum // => j _.
rewrite mulrzAr mulr_suml rpredMz ?rpred_sum // => k _.
rewrite mulrzAl rpredMz {x y}// !nth_mktuple.
rewrite -gring_irr_modeM ?gring_class_sum_central //.
rewrite gring_classM_expansion raddf_sum rpred_sum // => jk _.
by rewrite scaler_nat raddfMn rpredMn ?S_X ?memX.
Qed.

(* A more usable reformulation that does not involve the class sums. *)
Corollary Aint_class_div_irr1 x :
  x \in G -> #|x ^: G|%:R * 'chi_i x / 'chi_i 1%g \in Aint.
Proof.
move=> Gx; have clGxG := mem_classes Gx; pose k := enum_rank_in clGxG (x ^: G).
have k_x: x \in enum_val k by rewrite enum_rankK_in // class_refl.
by rewrite -(gring_mode_class_sum_eq k_x) Aint_gring_mode_class_sum.
Qed.

(* This is Isaacs, Theorem (3.8). *)
Theorem coprime_degree_support_cfcenter g :
    coprime (truncC ('chi_i 1%g)) #|g ^: G| -> g \notin ('Z('chi_i))%CF ->
  'chi_i g = 0.
Proof.
set m := truncC _ => co_m_gG notZg.
have [Gg | /cfun0-> //] := boolP (g \in G).
have Dm: 'chi_i 1%g = m%:R by rewrite truncCK ?Cnat_irr1.
have m_gt0: (0 < m)%N by rewrite -ltC_nat -Dm irr1_gt0.
have nz_m: m%:R != 0 :> algC by rewrite pnatr_eq0 -lt0n.
pose alpha := 'chi_i g / m%:R.
have a_lt1: `|alpha| < 1.
  rewrite normrM normfV normr_nat -{2}(divff nz_m).
  rewrite ltr_def (can_eq (mulfVK nz_m)) eq_sym -{1}Dm -irr_cfcenterE // notZg.
  by rewrite ler_pmul2r ?invr_gt0 ?ltr0n // -Dm char1_ge_norm ?irr_char.
have Za: alpha \in Aint.
  have [u _ /dvdnP[v eq_uv]] := Bezoutl #|g ^: G| m_gt0.
  suffices ->: alpha = v%:R * 'chi_i g - u%:R * (alpha * #|g ^: G|%:R).
    rewrite rpredB // rpredM ?rpred_nat ?Aint_irr //.
    by rewrite mulrC mulrA -Dm Aint_class_div_irr1.
  rewrite -mulrCA -[v%:R](mulfK nz_m) -!natrM -eq_uv (eqnP co_m_gG).
  by rewrite mulrAC -mulrA -/alpha mulr_natl mulr_natr mulrS addrK.
have [Qn galQn [QnC gQnC [_ _ Qn_g]]] := group_num_field_exists <[g]>.
have{Qn_g} [a Da]: exists a, QnC a = alpha.
  rewrite /alpha; have [a <-] := Qn_g _ G _ (irr_char i) g (dvdnn _).
  by exists (a / m%:R); rewrite fmorph_div rmorph_nat.
have Za_nu nu: sval (gQnC nu) alpha \in Aint by rewrite Aint_aut.
have norm_a_nu nu: `|sval (gQnC nu) alpha| <= 1.
  move: {nu}(sval _) => nu; rewrite fmorph_div rmorph_nat normrM normfV.
  rewrite normr_nat -Dm -(ler_pmul2r (irr1_gt0 (aut_Iirr nu i))) mul1r.
  congr (_ <= _): (char1_ge_norm g (irr_char (aut_Iirr nu i))).
  by rewrite !aut_IirrE !cfunE Dm rmorph_nat divfK.
pose beta := QnC (galNorm 1 {:Qn} a).
have Dbeta: beta = \prod_(nu in 'Gal({:Qn} / 1)) sval (gQnC nu) alpha.
  rewrite /beta rmorph_prod. apply: eq_bigr => nu _.
  by case: (gQnC nu) => f /= ->; rewrite Da.
have Zbeta: beta \in Cint.
  apply: Cint_rat_Aint; last by rewrite Dbeta rpred_prod.
  rewrite /beta; have /vlineP[/= c ->] := mem_galNorm galQn (memvf a).
  by rewrite alg_num_field fmorph_rat rpred_rat.
have [|nz_a] := boolP (alpha == 0).
  by rewrite (can2_eq (divfK _) (mulfK _)) // mul0r => /eqP.
have: beta != 0 by rewrite Dbeta; apply/prodf_neq0 => nu _; rewrite fmorph_eq0.
move/(norm_Cint_ge1 Zbeta); rewrite ltr_geF //; apply: ler_lt_trans a_lt1.
rewrite -[`|alpha|]mulr1 Dbeta (bigD1 1%g) ?group1 //= -Da.
case: (gQnC _) => /= _ <-; rewrite gal_id normrM.
rewrite -subr_ge0 -mulrBr mulr_ge0 ?normr_ge0 // Da subr_ge0.
elim/big_rec: _ => [|nu c _]; first by rewrite normr1 lerr.
apply: ler_trans; rewrite -subr_ge0 -{1}[`|c|]mul1r normrM -mulrBl.
by rewrite mulr_ge0 ?normr_ge0 // subr_ge0 norm_a_nu.
Qed.

End GringIrrMode.

(* This is Isaacs, Theorem (3.9). *)
Theorem primes_class_simple_gt1 C :
  simple G -> ~~ abelian G -> C \in (classes G)^# -> (size (primes #|C|) > 1)%N.
Proof.
move=> simpleG not_cGG /setD1P[ntC /imsetP[g Gg defC]].
have{ntC} nt_g: g != 1%g by rewrite defC classG_eq1 in ntC.
rewrite ltnNge {C}defC; set m := #|_|; apply/negP=> p_natC.
have{p_natC} [p p_pr [a Dm]]: {p : nat & prime p & {a | m = p ^ a}%N}.
  have /prod_prime_decomp->: (0 < m)%N by rewrite /m -index_cent1.
  rewrite prime_decompE; case Dpr: (primes _) p_natC => [|p []] // _.
    by exists 2 => //; rewrite big_nil; exists 0%N.
  rewrite big_seq1; exists p; last by exists (logn p m).
  by have:= mem_primes p m; rewrite Dpr mem_head => /esym/and3P[].
have{simpleG} [ntG minG] := simpleP _ simpleG.
pose p_dv1 i := (p %| 'chi[G]_i 1%g)%C.
have p_dvd_supp_g i: ~~ p_dv1 i && (i != 0) -> 'chi_i g = 0.
  rewrite /p_dv1 irr1_degree dvdC_nat -prime_coprime // => /andP[co_p_i1 nz_i].
  have fful_i: cfker 'chi_i = [1].
    have /minG[//|/eqP] := cfker_normal 'chi_i.
    by rewrite eqEsubset subGcfker (negPf nz_i) andbF.
  have trivZ: 'Z(G) = [1] by have /minG[|/center_idP/idPn] := center_normal G.
  have trivZi: ('Z('chi_i))%CF = [1].
    apply/trivgP; rewrite -quotient_sub1 ?norms1 //= -fful_i cfcenter_eq_center.
    rewrite fful_i subG1 -(isog_eq1 (isog_center (quotient1_isog G))) /=.
    by rewrite trivZ.
  rewrite coprime_degree_support_cfcenter ?trivZi ?inE //.
  by rewrite -/m Dm irr1_degree natCK coprime_sym coprime_expl.
pose alpha := \sum_(i | p_dv1 i && (i != 0)) 'chi_i 1%g / p%:R * 'chi_i g.
have nz_p: p%:R != 0 :> algC by rewrite pnatr_eq0 -lt0n prime_gt0.
have Dalpha: alpha = - 1 / p%:R.
  apply/(canRL (mulfK nz_p))/eqP; rewrite -addr_eq0 addrC; apply/eqP/esym.
  transitivity (cfReg G g); first by rewrite cfRegE (negPf nt_g).
  rewrite cfReg_sum sum_cfunE (bigD1 0) //= irr0 !cfunE cfun11 cfun1E Gg.
  rewrite mulr1; congr (1 + _); rewrite (bigID p_dv1) /= addrC big_andbC.
  rewrite big1 => [|i /p_dvd_supp_g chig0]; last by rewrite cfunE chig0 mulr0.
  rewrite add0r big_andbC mulr_suml; apply: eq_bigr => i _.
  by rewrite mulrAC divfK // cfunE.
suffices: (p %| 1)%C by rewrite (dvdC_nat p 1) dvdn1 -(subnKC (prime_gt1 p_pr)).
rewrite unfold_in (negPf nz_p).
rewrite Cint_rat_Aint ?rpred_div ?rpred1 ?rpred_nat //.
rewrite -rpredN // -mulNr -Dalpha rpred_sum // => i /andP[/dvdCP[c Zc ->] _].
by rewrite mulfK // rpredM ?Aint_irr ?Aint_Cint.
Qed.

End IntegralChar.

Section MoreIntegralChar.

Implicit Type gT : finGroupType.

(* This is Burnside's famous p^a.q^b theorem (Isaacs, Theorem (3.10)). *)
Theorem Burnside_p_a_q_b gT (G : {group gT}) :
  (size (primes #|G|) <= 2)%N -> solvable G.
Proof.
move: {2}_.+1 (ltnSn #|G|) => n; elim: n => // n IHn in gT G *.
rewrite ltnS => leGn piGle2; have [simpleG | ] := boolP (simple G); last first.
  rewrite negb_forall_in => /exists_inP[N sNG]; rewrite eq_sym.
  have [-> | ] := altP (N =P G).
    rewrite groupP /= genGid normG andbT eqb_id negbK => /eqP->.
    exact: solvable1.
  rewrite [N == G]eqEproper sNG eqbF_neg !negbK => ltNG /and3P[grN].
  case/isgroupP: grN => {N}N -> in sNG ltNG *; rewrite /= genGid => ntN nNG.
  have nsNG: N <| G by apply/andP.
  have dv_le_pi m: (m %| #|G| -> size (primes m) <= 2)%N.
    move=> m_dv_G; apply: leq_trans piGle2.
    by rewrite uniq_leq_size ?primes_uniq //; apply: pi_of_dvd.
  rewrite (series_sol nsNG) !IHn ?dv_le_pi ?cardSg ?dvdn_quotient //.
    by apply: leq_trans leGn; apply: ltn_quotient.
  by apply: leq_trans leGn; apply: proper_card.
have [->|[p p_pr p_dv_G]] := trivgVpdiv G; first exact: solvable1.
have piGp: p \in \pi(G) by rewrite mem_primes p_pr cardG_gt0.
have [P sylP] := Sylow_exists p G; have [sPG pP p'GP] := and3P sylP.
have ntP: P :!=: 1%g by rewrite -rank_gt0 (rank_Sylow sylP) p_rank_gt0.
have /trivgPn[g /setIP[Pg cPg] nt_g]: 'Z(P) != 1%g.
  by rewrite center_nil_eq1 // (pgroup_nil pP).
apply: abelian_sol; have: (size (primes #|g ^: G|) <= 1)%N.
  rewrite -ltnS -[_.+1]/(size (p :: _)) (leq_trans _ piGle2) //.
  rewrite -index_cent1 uniq_leq_size // => [/= | q].
    rewrite primes_uniq -p'natEpi ?(pnat_dvd _ p'GP) ?indexgS //.
    by rewrite subsetI sPG sub_cent1.
  by rewrite inE => /predU1P[-> // |]; apply: pi_of_dvd; rewrite ?dvdn_indexg.
rewrite leqNgt; apply: contraR => /primes_class_simple_gt1-> //.
by rewrite !inE classG_eq1 nt_g mem_classes // (subsetP sPG).
Qed.

(* This is Isaacs, Theorem (3.11). *)
Theorem dvd_irr1_cardG gT (G : {group gT}) i : ('chi[G]_i 1%g %| #|G|)%C.
Proof.
rewrite unfold_in -if_neg irr1_neq0 Cint_rat_Aint //=.
  by rewrite rpred_div ?rpred_nat // rpred_Cnat ?Cnat_irr1.
rewrite -[n in n / _]/(_ *+ true) -(eqxx i) -mulr_natr.
rewrite -first_orthogonality_relation mulVKf ?neq0CG //.
rewrite sum_by_classes => [|x y Gx Gy]; rewrite -?conjVg ?cfunJ //.
rewrite mulr_suml rpred_sum // => K /repr_classesP[Gx {1}->].
by rewrite !mulrA mulrAC rpredM ?Aint_irr ?Aint_class_div_irr1.
Qed.

(* This is Isaacs, Theorem (3.12). *)
Theorem dvd_irr1_index_center gT (G : {group gT}) i :
  ('chi[G]_i 1%g %| #|G : 'Z('chi_i)%CF|)%C.
Proof.
without loss fful: gT G i / cfaithful 'chi_i.
  rewrite -{2}[i](quo_IirrK _ (subxx _)) 1?mod_IirrE ?cfModE ?cfker_normal //.
  rewrite morph1; set i1 := quo_Iirr _ i => /(_ _ _ i1) IH.
  have fful_i1: cfaithful 'chi_i1.
    by rewrite quo_IirrE ?cfker_normal ?cfaithful_quo.
  have:= IH fful_i1; rewrite cfcenter_fful_irr // -cfcenter_eq_center.
  rewrite index_quotient_eq ?cfcenter_sub ?cfker_norm //.
  by rewrite setIC subIset // normal_sub ?cfker_center_normal.
have [lambda lin_lambda Dlambda] := cfcenter_Res 'chi_i.
have DchiZ: {in G & 'Z(G), forall x y, 'chi_i (x * y)%g = 'chi_i x * lambda y}.
  rewrite -(cfcenter_fful_irr fful) => x y Gx Zy.
  apply: (mulfI (irr1_neq0 i)); rewrite mulrCA.
  transitivity ('chi_i x * ('chi_i 1%g *: lambda) y); last by rewrite !cfunE.
  rewrite -Dlambda cfResE ?cfcenter_sub //.
  rewrite -irrRepr cfcenter_repr !cfunE in Zy *.
  case/setIdP: Zy => Gy /is_scalar_mxP[e De].
  rewrite repr_mx1 group1 (groupM Gx Gy) (repr_mxM _ Gx Gy) Gx Gy De.
  by rewrite mul_mx_scalar mxtraceZ mulrCA mulrA mulrC -mxtraceZ scalemx1.
have inj_lambda: {in 'Z(G) &, injective lambda}.
  rewrite -(cfcenter_fful_irr fful) => x y Zx Zy eq_xy.
  apply/eqP; rewrite eq_mulVg1 -in_set1 (subsetP fful) // cfkerEirr inE.
  apply/eqP; transitivity ('Res['Z('chi_i)%CF] 'chi_i (x^-1 * y)%g).
    by rewrite cfResE ?cfcenter_sub // groupM ?groupV.
  rewrite Dlambda !cfunE lin_charM ?groupV // -eq_xy -lin_charM ?groupV //.
  by rewrite mulrC mulVg lin_char1 ?mul1r.
rewrite unfold_in -if_neg irr1_neq0 Cint_rat_Aint //.
  by rewrite rpred_div ?rpred_nat // rpred_Cnat ?Cnat_irr1.
rewrite (cfcenter_fful_irr fful) nCdivE natf_indexg ?center_sub //=.
have ->: #|G|%:R = \sum_(x in G) 'chi_i x * 'chi_i (x^-1)%g.
  rewrite -[_%:R]mulr1; apply: canLR (mulVKf (neq0CG G)) _.
  by rewrite first_orthogonality_relation eqxx.
rewrite (big_setID [set x | 'chi_i x == 0]) /= -setIdE.
rewrite big1 ?add0r => [| x /setIdP[_ /eqP->]]; last by rewrite mul0r.
pose h x := (x ^: G * 'Z(G))%g; rewrite (partition_big_imset h).
rewrite !mulr_suml rpred_sum //= => _ /imsetP[x /setDP[Gx nz_chi_x] ->].
have: #|x ^: G|%:R * ('chi_i x * 'chi_i x^-1%g) / 'chi_i 1%g \in Aint.
  by rewrite !mulrA mulrAC rpredM ?Aint_irr ?Aint_class_div_irr1.
congr 2 (_ * _ \in Aint); apply: canRL (mulfK (neq0CG _)) _.
rewrite inE in nz_chi_x.
transitivity ('chi_i x * 'chi_i (x^-1)%g *+ #|h x|); last first.
  rewrite -sumr_const.
  apply: eq_big => [y | _ /mulsgP[_ z /imsetP[u Gu ->] Zz] ->].
    rewrite !inE -andbA; apply/idP/and3P=> [|[_ _ /eqP <-]]; last first.
      by rewrite -{1}[y]mulg1 mem_mulg ?class_refl.
    case/mulsgP=> _ z /imsetP[u Gu ->] Zz ->; have /centerP[Gz cGz] := Zz.
    rewrite groupM 1?DchiZ ?groupJ ?cfunJ //; split=> //.
      by rewrite mulf_neq0 // lin_char_neq0 /= ?cfcenter_fful_irr.
    rewrite -[z](mulKg u) -cGz // -conjMg /h classGidl {u Gu}//.
    apply/eqP/setP=> w; apply/mulsgP/mulsgP=> [][_ z1 /imsetP[v Gv ->] Zz1 ->].
      exists (x ^ v)%g (z * z1)%g; rewrite ?mem_imset ?groupM //.
      by rewrite conjMg -mulgA /(z ^ v)%g cGz // mulKg.
    exists ((x * z) ^ v)%g (z^-1 * z1)%g; rewrite ?mem_imset ?groupM ?groupV //.
    by rewrite conjMg -mulgA /(z ^ v)%g cGz // mulKg mulKVg.
  rewrite !irr_inv DchiZ ?groupJ ?cfunJ // rmorphM mulrACA -!normCK -exprMn.
  by rewrite (normC_lin_char lin_lambda) ?mulr1 //= cfcenter_fful_irr.
rewrite mulrAC -natrM mulr_natl; congr (_ *+ _).
symmetry; rewrite /h /mulg /= /set_mulg [in _ @2: (_, _)]unlock cardsE.
rewrite -cardX card_in_image // => [] [y1 z1] [y2 z2] /=.
move=> /andP[/=/imsetP[u1 Gu1 ->] Zz1] /andP[/=/imsetP[u2 Gu2 ->] Zz2] {y1 y2}.
move=> eq12; have /eqP := congr1 'chi_i eq12.
rewrite !(cfunJ, DchiZ) ?groupJ // (can_eq (mulKf nz_chi_x)).
rewrite (inj_in_eq inj_lambda) // => /eqP eq_z12; rewrite eq_z12 in eq12 *.
by rewrite (mulIg _ _ _ eq12).
Qed.

(* This is Isaacs, Problem (3.7). *)
Lemma gring_classM_coef_sum_eq gT (G : {group gT}) j1 j2 k g1 g2 g :
   let a := @gring_classM_coef gT G j1 j2 in let a_k := a k in
   g1 \in enum_val j1 -> g2 \in enum_val j2 -> g \in enum_val k ->
   let sum12g := \sum_i 'chi[G]_i g1 * 'chi_i g2 * ('chi_i g)^* / 'chi_i 1%g in
  a_k%:R = (#|enum_val j1| * #|enum_val j2|)%:R / #|G|%:R * sum12g.
Proof.
move=> a /= Kg1 Kg2 Kg; rewrite mulrAC; apply: canRL (mulfK (neq0CG G)) _.
transitivity (\sum_j (#|G| * a j)%:R *+ (j == k) : algC).
  by rewrite (bigD1 k) //= eqxx -natrM mulnC big1 ?addr0 // => j /negPf->.
have defK (j : 'I_#|classes G|) x: x \in enum_val j -> enum_val j = x ^: G.
  by have /imsetP[y Gy ->] := enum_valP j => /class_eqP.
have Gg: g \in G.
  by case/imsetP: (enum_valP k) Kg => x Gx -> /imsetP[y Gy ->]; apply: groupJ.
transitivity (\sum_j \sum_i 'omega_i['K_j] * 'chi_i 1%g * ('chi_i g)^* *+ a j).
  apply: eq_bigr => j _; have /imsetP[z Gz Dj] := enum_valP j.
  have Kz: z \in enum_val j by rewrite Dj class_refl.
  rewrite -(Lagrange (subsetIl G 'C[z])) index_cent1 -mulnA natrM -mulrnAl.
  have ->: (j == k) = (z \in enum_val k).
    by rewrite -(inj_eq enum_val_inj); apply/eqP/idP=> [<-|/defK->].
  rewrite (defK _ g) // -second_orthogonality_relation // mulr_suml.
  apply: eq_bigr=> i _; rewrite natrM mulrA mulr_natr mulrC mulrA.
  by rewrite (gring_mode_class_sum_eq i Kz) divfK ?irr1_neq0.
rewrite exchange_big /= mulr_sumr; apply: eq_bigr => i _.
transitivity ('omega_i['K_j1 *m 'K_j2] * 'chi_i 1%g * ('chi_i g)^*).
  rewrite gring_classM_expansion -/a raddf_sum !mulr_suml /=.
  by apply: eq_bigr => j _; rewrite xcfunZr -!mulrA mulr_natl.
rewrite !mulrA 2![_ / _]mulrAC (defK _ _ Kg1) (defK _ _ Kg2); congr (_ * _).
rewrite gring_irr_modeM ?gring_class_sum_central // mulnC natrM.
rewrite (gring_mode_class_sum_eq i Kg2) !mulrA divfK ?irr1_neq0 //.
by congr (_ * _); rewrite [_ * _]mulrC (gring_mode_class_sum_eq i Kg1) !mulrA.
Qed.

(* This is Isaacs, Problem (2.16). *)
Lemma index_support_dvd_degree gT (G H : {group gT}) chi :
    H \subset G -> chi \is a character -> chi \in 'CF(G, H) ->
    (H :==: 1%g) || abelian G ->
  (#|G : H| %| chi 1%g)%C.
Proof.
move=> sHG Nchi Hchi ZHG.
suffices: (#|G : H| %| 'Res[H] chi 1%g)%C by rewrite cfResE ?group1.
rewrite ['Res _]cfun_sum_cfdot sum_cfunE rpred_sum // => i _.
rewrite cfunE dvdC_mulr ?Cint_Cnat ?Cnat_irr1 //.
have [j ->]: exists j, 'chi_i = 'Res 'chi[G]_j.
  case/predU1P: ZHG => [-> | cGG] in i *.
    suffices ->: i = 0 by exists 0; rewrite !irr0 cfRes_cfun1 ?sub1G.
    apply/val_inj; case: i => [[|i] //=]; rewrite ltnNge NirrE.
    by rewrite (@leq_trans 1) // leqNgt classes_gt1 eqxx.
  have linG := char_abelianP G cGG; have linG1 j := eqP (proj2 (andP (linG j))).
  have /fin_all_exists[rH DrH] j: exists k, 'Res[H, G] 'chi_j = 'chi_k.
    apply/irrP/lin_char_irr/andP.
    by rewrite cfRes_char ?irr_char // cfRes1 ?linG1.
  suffices{i} all_rH: codom rH =i Iirr H.
    by exists (iinv (all_rH i)); rewrite DrH f_iinv.
  apply/subset_cardP; last exact/subsetP; apply/esym/eqP.
  rewrite card_Iirr_abelian ?(abelianS sHG) //.
  rewrite -(eqn_pmul2r (indexg_gt0 G H)) Lagrange //; apply/eqP.
  rewrite -sum_nat_const -card_Iirr_abelian // -sum1_card.
  rewrite (partition_big rH (mem (codom rH))) /=; last exact: image_f.
  have nsHG: H <| G by rewrite -sub_abelian_normal.
  apply: eq_bigr => _ /codomP[i ->]; rewrite -card_quotient ?normal_norm //.
  rewrite -card_Iirr_abelian ?quotient_abelian //.
  have Mlin j1 j2: exists k, 'chi_j1 * 'chi_j2 = 'chi[G]_k.
    exact/irrP/lin_char_irr/rpredM.
  have /fin_all_exists[rQ DrQ] (j : Iirr (G / H)) := Mlin i (mod_Iirr j).
  have mulJi: ('chi[G]_i)^*%CF * 'chi_i = 1.
    apply/cfun_inP=> x Gx; rewrite !cfunE -lin_charV_conj ?linG // cfun1E Gx.
    by rewrite lin_charV ?mulVf ?lin_char_neq0 ?linG.
  have inj_rQ: injective rQ.
    move=> j1 j2 /(congr1 (fun k => (('chi_i)^*%CF * 'chi_k) / H)%CF).
    by rewrite -!DrQ !mulrA mulJi !mul1r !mod_IirrE ?cfModK // => /irr_inj.
  rewrite -(card_imset _ inj_rQ) -sum1_card; apply: eq_bigl => j.
  rewrite -(inj_eq irr_inj) -!DrH; apply/eqP/imsetP=> [eq_ij | [k _ ->]].
    have [k Dk] := Mlin (conjC_Iirr i) j; exists (quo_Iirr H k) => //.
    apply/irr_inj; rewrite -DrQ quo_IirrK //.
      by rewrite -Dk conjC_IirrE mulrCA mulrA mulJi mul1r.
    apply/subsetP=> x Hx; have Gx := subsetP sHG x Hx.
    rewrite cfkerEirr inE linG1 -Dk conjC_IirrE; apply/eqP.
    transitivity ((1 : 'CF(G)) x); last by rewrite cfun1E Gx.
    by rewrite -mulJi !cfunE -!(cfResE _ sHG Hx) eq_ij.
  rewrite -DrQ; apply/cfun_inP=> x Hx; rewrite !cfResE // cfunE mulrC.
  by rewrite cfker1 ?linG1 ?mul1r ?(subsetP _ x Hx) // mod_IirrE ?cfker_mod.
have: (#|G : H| %| #|G : H|%:R * '[chi, 'chi_j])%C.
  by rewrite dvdC_mulr ?Cint_Cnat ?Cnat_cfdot_char_irr.
congr (_ %| _)%C; rewrite (cfdotEl _ Hchi) -(Lagrange sHG) mulnC natrM.
rewrite invfM -mulrA mulVKf ?neq0CiG //; congr (_ * _).
by apply: eq_bigr => x Hx; rewrite !cfResE.
Qed.

(* This is Isaacs, Theorem (3.13). *)
Theorem faithful_degree_p_part gT (p : nat) (G P : {group gT}) i :
    cfaithful 'chi[G]_i -> p.-nat (truncC ('chi_i 1%g)) ->
    p.-Sylow(G) P -> abelian P ->
  'chi_i 1%g = (#|G : 'Z(G)|`_p)%:R.
Proof.
have [p_pr | pr'p] := boolP (prime p); last first.
  have p'n n: (n > 0)%N -> p^'.-nat n.
    by move/p'natEpi->; rewrite mem_primes (negPf pr'p).
  rewrite irr1_degree natCK => _ /pnat_1-> => [_ _|].
    by rewrite part_p'nat ?p'n.
  by rewrite p'n ?irr_degree_gt0.
move=> fful_i /p_natP[a Dchi1] sylP cPP.
have Dchi1C: 'chi_i 1%g = (p ^ a)%:R by rewrite -Dchi1 irr1_degree natCK.
have pa_dv_ZiG: (p ^ a %| #|G : 'Z(G)|)%N.
  rewrite -dvdC_nat -[pa in (pa %| _)%C]Dchi1C -(cfcenter_fful_irr fful_i).
  exact: dvd_irr1_index_center.
have [sPG pP p'PiG] := and3P sylP.
have ZchiP: 'Res[P] 'chi_i \in 'CF(P, P :&: 'Z(G)).
  apply/cfun_onP=> x; rewrite inE; have [Px | /cfun0->//] := boolP (x \in P).
  rewrite /= -(cfcenter_fful_irr fful_i) cfResE //.
  apply: coprime_degree_support_cfcenter.
  rewrite Dchi1 coprime_expl // prime_coprime // -p'natE //.
  apply: pnat_dvd p'PiG; rewrite -index_cent1 indexgS // subsetI sPG.
  by rewrite sub_cent1 (subsetP cPP).
have /andP[_ nZG] := center_normal G; have nZP := subset_trans sPG nZG.
apply/eqP; rewrite Dchi1C eqr_nat eqn_dvd -{1}(pfactorK a p_pr) -p_part.
rewrite partn_dvd //= -dvdC_nat -[pa in (_ %| pa)%C]Dchi1C -card_quotient //=.
rewrite -(card_Hall (quotient_pHall nZP sylP)) card_quotient // -indexgI.
rewrite -(cfResE _ sPG) // index_support_dvd_degree ?subsetIl ?cPP ?orbT //.
by rewrite cfRes_char ?irr_char.
Qed.

(* This is Isaacs, Lemma (3.14). *)
(* Note that the assumption that G be cyclic is unnecessary, as S will be     *)
(* empty if this is not the case.                                             *)
Lemma sum_norm2_char_generators gT (G : {group gT}) (chi : 'CF(G)) :
    let S := [pred s | generator G s] in
    chi \is a character -> {in S, forall s, chi s != 0} ->
  \sum_(s in S) `|chi s| ^+ 2 >= #|S|%:R.
Proof.
move=> S Nchi nz_chi_S; pose n := #|G|.
have [g Sg | S_0] := pickP (generator G); last first.
  by rewrite eq_card0 // big_pred0 ?lerr.
have defG: <[g]> = G by apply/esym/eqP.
have [cycG Gg]: cyclic G /\ g \in G by rewrite -defG cycle_cyclic cycle_id.
pose I := {k : 'I_n | coprime n k}; pose ItoS (k : I) := (g ^+ sval k)%g.
have imItoS: codom ItoS =i S.
  move=> s; rewrite inE /= /ItoS /I /n /S -defG -orderE.
  apply/codomP/idP=> [[[i cogi] ->] | Ss]; first by rewrite generator_coprime.
  have [m ltmg Ds] := cyclePmin (cycle_generator Ss).
  by rewrite Ds generator_coprime in Ss; apply: ex_intro (Sub (Sub m _) _) _.
have /injectiveP injItoS: injective ItoS.
  move=> k1 k2 /eqP; apply: contraTeq.
  by rewrite eq_expg_mod_order orderE defG -/n !modn_small.
have [Qn galQn [QnC gQnC [eps [pr_eps defQn] QnG]]] := group_num_field_exists G.
have{QnG} QnGg := QnG _ G _ _ g (order_dvdG Gg).
pose calG := 'Gal({:Qn} / 1).
have /fin_all_exists2[ItoQ inItoQ defItoQ] (k : I):
  exists2 nu, nu \in calG & nu eps = eps ^+ val k.
- case: k => [[m _] /=]; rewrite coprime_sym => /Qn_aut_exists[nuC DnuC].
  have [nuQ DnuQ] := restrict_aut_to_normal_num_field QnC nuC.
  have hom_nu: kHom 1 {:Qn} (linfun nuQ).
    rewrite k1HomE; apply/ahom_inP.
    by split=> [u v | ]; rewrite !lfunE ?rmorphM ?rmorph1.
  have [|nu cGnu Dnu] := kHom_to_gal _ (normalFieldf 1) hom_nu.
    by rewrite !subvf.
  exists nu => //; apply: (fmorph_inj QnC).
  rewrite -Dnu ?memvf // lfunE DnuQ rmorphX DnuC //.
  by rewrite prim_expr_order // fmorph_primitive_root.
have{defQn} imItoQ: calG = ItoQ @: {:I}.
  apply/setP=> nu; apply/idP/imsetP=> [cGnu | [k _ ->] //].
  have pr_nu_e: n.-primitive_root (nu eps) by rewrite fmorph_primitive_root.
  have [i Dnue] := prim_rootP pr_eps (prim_expr_order pr_nu_e).
  rewrite Dnue prim_root_exp_coprime // coprime_sym in pr_nu_e.
  apply: ex_intro2 (Sub i _) _ _ => //; apply/eqP.
  rewrite /calG /= -defQn in ItoQ inItoQ defItoQ nu cGnu Dnue *.
  by rewrite gal_adjoin_eq // defItoQ -Dnue.
have injItoQ: {in {:I} &, injective ItoQ}.
  move=> k1 k2 _ _ /(congr1 (fun nu : gal_of _ => nu eps))/eqP.
  by apply: contraTeq; rewrite !defItoQ (eq_prim_root_expr pr_eps) !modn_small.
pose pi1 := \prod_(s in S) chi s; pose pi2 := \prod_(s in S) `|chi s| ^+ 2.
have Qpi1: pi1 \in Crat.
  have [a Da] := QnGg _ Nchi; suffices ->: pi1 = QnC (galNorm 1 {:Qn} a).
    have /vlineP[q ->] := mem_galNorm galQn (memvf a).
    by rewrite rmorphZ_num rmorph1 mulr1 Crat_rat.
  rewrite /galNorm rmorph_prod -/calG imItoQ big_imset //=.
  rewrite /pi1 -(eq_bigl _ _ imItoS) -big_uniq // big_image /=.
  apply: eq_bigr => k _; have [nuC DnuC] := gQnC (ItoQ k); rewrite DnuC Da.
  have [r ->] := char_sum_irr Nchi; rewrite !sum_cfunE rmorph_sum.
  apply: eq_bigr => i _; have /QnGg[b Db] := irr_char i.
  have Lchi_i: 'chi_i \is a linear_char by rewrite irr_cyclic_lin.
  have /(prim_rootP pr_eps)[m Dem]: b ^+ n = 1.
    apply/eqP; rewrite -(fmorph_eq1 QnC) rmorphX Db -lin_charX //.
    by rewrite -expg_mod_order orderE defG modnn lin_char1.
  rewrite -Db -DnuC Dem rmorphX /= defItoQ exprAC -{m}Dem rmorphX {b}Db.
  by rewrite lin_charX.
clear I ItoS imItoS injItoS ItoQ inItoQ defItoQ imItoQ injItoQ.
clear Qn galQn QnC gQnC eps pr_eps QnGg calG.
have{Qpi1} Zpi1: pi1 \in Cint.
  by rewrite Cint_rat_Aint // rpred_prod // => s _; apply: Aint_char.
have{pi1 Zpi1} pi2_ge1: 1 <= pi2.
  have ->: pi2 = `|pi1| ^+ 2.
    by rewrite (big_morph Num.norm (@normrM _) (@normr1 _)) -prodrXl.
  by rewrite Cint_normK // sqr_Cint_ge1 //; apply/prodf_neq0.
have Sgt0: (#|S| > 0)%N by rewrite (cardD1 g) [g \in S]Sg.
rewrite -mulr_natr -ler_pdivl_mulr ?ltr0n //.
have n2chi_ge0 s: s \in S -> 0 <= `|chi s| ^+ 2 by rewrite exprn_ge0 ?normr_ge0.
rewrite -(expr_ge1 Sgt0); last by rewrite divr_ge0 ?ler0n ?sumr_ge0.
by rewrite (ler_trans pi2_ge1) // lerif_AGM.
Qed.

(* This is Burnside's vanishing theorem (Isaacs, Theorem (3.15)). *)
Theorem nonlinear_irr_vanish gT (G : {group gT}) i :
  'chi[G]_i 1%g > 1 -> exists2 x, x \in G & 'chi_i x = 0.
Proof.
move=> chi1gt1; apply/exists_eq_inP; apply: contraFT (ltr_geF chi1gt1).
move/exists_inPn => -nz_chi.
rewrite -(norm_Cnat (Cnat_irr1 i)) -(@expr_le1 _ 2) ?normr_ge0 //.
rewrite -(ler_add2r (#|G|%:R * '['chi_i])) {1}cfnorm_irr mulr1.
rewrite (cfnormE (cfun_onG _)) mulVKf ?neq0CG // (big_setD1 1%g) //=.
rewrite addrCA ler_add2l (cardsD1 1%g) group1 mulrS ler_add2l.
rewrite -sumr_const !(partition_big_imset (fun s => <[s]>)) /=.
apply: ler_sum => _ /imsetP[g /setD1P[ntg Gg] ->].
have sgG: <[g]> \subset G by rewrite cycle_subG.
pose S := [pred s | generator <[g]> s]; pose chi := 'Res[<[g]>] 'chi_i.
have defS: [pred s in G^# | <[s]> == <[g]>] =i S.
  move=> s; rewrite inE /= eq_sym andb_idl // !inE -cycle_eq1 -cycle_subG.
  by move/eqP <-; rewrite cycle_eq1 ntg.
have resS: {in S, 'chi_i =1 chi}.
  by move=> s /cycle_generator=> g_s; rewrite cfResE ?cycle_subG.
rewrite !(eq_bigl _ _ defS) sumr_const.
rewrite (eq_bigr (fun s => `|chi s| ^+ 2)) => [|s /resS-> //].
apply: sum_norm2_char_generators => [|s Ss].
  by rewrite cfRes_char ?irr_char.
by rewrite -resS // nz_chi ?(subsetP sgG) ?cycle_generator.
Qed.

End MoreIntegralChar.


(** * Injectivity *)

From DEZ Require Export
  Init.

(** ** Injective Unary Function *)
(** ** Monomorphism *)

Class IsInjUnFn (A B : Type) (X : A -> A -> Prop) (Y : B -> B -> Prop)
  (f : A -> B) : Prop :=
  inj_un_fn (x y : A) (a : Y (f x) (f y)) : X x y.

(** ** Cancellative Unary Operation *)
(** ** Injective Unary Operation *)

Class IsInj (A : Type) (X : A -> A -> Prop)
  (f : A -> A) : Prop :=
  inj (x y : A) (a : X (f x) (f y)) : X x y.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (f : A -> A).

(** Injectivity of a unary operation is a special case
    of its injectivity as a unary function. *)

#[export] Instance inj_is_inj_un_fn
  `{!IsInj X f} : IsInjUnFn X X f.
Proof. auto. Qed.

#[local] Instance inj_un_fn_is_inj
  `{!IsInjUnFn X X f} : IsInj X f.
Proof. auto. Qed.

End Context.


Require Import Metalib.Metatheory.
Require Import SystemF_inf.

(* ********************************************************************** *)
(** * Monotype predicate *)

Inductive mono : sty -> Prop :=
| mono_nat : mono sty_nat
| mono_top : mono sty_top
| mono_bot : mono sty_bot
| mono_var_f : forall (X:typvar),
    (mono (sty_var_f X))
| mono_arrow : forall (A B:sty),
    (mono A) ->
    (mono B) ->
    (mono (sty_arrow A B))
| mono_and : forall (A B:sty),
    (mono A) ->
    (mono B) ->
    (mono (sty_and A B))
| mono_rcd : forall (l:nat) (A:sty),
    (mono A) ->
    (mono (sty_rcd l A)).

Inductive poly : sty -> Prop :=
| poly_p : forall A B,
    lc_sty (sty_all A B) ->
    poly (sty_all A B)
| poly_and1 : forall A B,
    poly A ->
    mono B ->
    poly (sty_and A B)
| poly_and2 : forall A B,
    poly B ->
    mono A ->
    poly (sty_and A B)
| poly_and3 : forall A B,
    poly A ->
    poly B ->
    poly (sty_and A B)
| poly_arr1 : forall (A B:sty),
    poly A ->
    mono B ->
    poly (sty_arrow A B)
| poly_arr2 : forall (A B:sty),
    poly B ->
    mono A ->
    poly (sty_arrow A B)
| poly_arr3 : forall (A B:sty),
    poly A ->
    poly B ->
    poly (sty_arrow A B)
| poly_rcd : forall (l:nat) (A:sty),
    poly A ->
    poly (sty_rcd l A).

(* ********************************************************************** *)
(** * Type translation *)

Fixpoint sty2ty (A : sty) : ty :=
  match A with
  | sty_nat => ty_nat
  | sty_arrow A1 A2  => ty_arrow (sty2ty A1) (sty2ty A2)
  | sty_and A1 A2 => ty_prod (sty2ty A1) (sty2ty A2)
  | sty_top => ty_unit
  | sty_bot => ty_all (ty_var_b 0)
  | sty_all _ A => ty_all (sty2ty A)
  | sty_rcd _ A => sty2ty A
  | sty_var_b n => ty_var_b n
  | sty_var_f n => ty_var_f n
  end.

(* ********************************************************************** *)
(** * Fco well-formedness of types *)

Inductive wft : tctx -> ty -> Prop :=    (* defn wft *)
 | wft_unit : forall (dd:tctx),
     wft dd ty_unit
 | wft_nat : forall (dd:tctx),
     wft dd ty_nat
 | wft_var : forall (dd:tctx) (X:typvar),
      binds  X  tt  dd  ->
     wft dd (ty_var_f X)
 | wft_arrow : forall (dd:tctx) (T1 T2:ty),
     wft dd T1 ->
     wft dd T2 ->
     wft dd (ty_arrow T1 T2)
 | wft_prod : forall (dd:tctx) (T1 T2:ty),
     wft dd T1 ->
     wft dd T2 ->
     wft dd (ty_prod T1 T2)
 | wft_all : forall (L:vars) (dd:tctx) (T2:ty),
      ( forall X , X \notin  L  -> wft  (( X ~tt)++ dd )   ( open_ty_wrt_ty T2 (ty_var_f X) )  )  ->
     wft dd (ty_all T2).

(* ********************************************************************** *)
(** * Fco well-formedness of term contexts *)

Inductive wfe : tctx -> ctx -> Prop :=    (* defn wfe *)
 | wfe_empty : forall (dd:tctx),
      uniq  dd  ->
     wfe dd  nil
 | wfe_var : forall (dd:tctx) (gg:ctx) (x:expvar) (T:ty),
     wft dd T ->
     wfe dd gg ->
      ( x  `notin` dom ( gg ))  ->
      ( x  `notin` dom ( dd ))  ->
     wfe dd  (( x ~ T )++ gg ) .

(* ********************************************************************** *)
(** * Coercion typing *)

Inductive ctyp : tctx -> co -> ty -> ty -> Prop :=    (* defn ctyp *)
 | ctyp_id : forall (dd:tctx) (T:ty),
     wft dd T ->
     ctyp dd co_id T T
 | ctyp_trans : forall (dd:tctx) (c1 c2:co) (T1 T3 T2:ty),
     ctyp dd c1 T2 T3 ->
     ctyp dd c2 T1 T2 ->
     ctyp dd (co_trans c1 c2) T1 T3
 | ctyp_top : forall (dd:tctx) (T:ty),
     wft dd T ->
     ctyp dd co_top T ty_unit
 | ctyp_bot : forall (dd:tctx) (T:ty),
     wft dd T ->
     ctyp dd co_bot (ty_all (ty_var_b 0)) T
 | ctyp_arr : forall (dd:tctx) (c1 c2:co) (T1 T2 T1' T2':ty),
     ctyp dd c1 T1' T1 ->
     ctyp dd c2 T2 T2' ->
     ctyp dd (co_arr c1 c2) (ty_arrow T1 T2) (ty_arrow T1' T2')
 | ctyp_pair : forall (dd:tctx) (c1 c2:co) (T1 T2 T3:ty),
     ctyp dd c1 T1 T2 ->
     ctyp dd c2 T1 T3 ->
     ctyp dd (co_pair c1 c2) T1 (ty_prod T2 T3)
 | ctyp_projl : forall (dd:tctx) (T1 T2:ty),
     wft dd T1 ->
     wft dd T2 ->
     ctyp dd co_proj1 (ty_prod T1 T2) T1
 | ctyp_projr : forall (dd:tctx) (T1 T2:ty),
     wft dd T1 ->
     wft dd T2 ->
     ctyp dd co_proj2 (ty_prod T1 T2) T2
 | ctyp_forall : forall (L:vars) (dd:tctx) (c:co) (T1 T2:ty),
      ( forall X , X \notin  L  -> ctyp  (( X ~tt)++ dd )  c  ( open_ty_wrt_ty T1 (ty_var_f X) )   ( open_ty_wrt_ty T2 (ty_var_f X) )  )  ->
     ctyp dd (co_forall c) (ty_all T1) (ty_all T2)
 | ctyp_distArr : forall (dd:tctx) (T1 T2 T3:ty),
     wft dd T1 ->
     wft dd T2 ->
     wft dd T3 ->
     ctyp dd co_distArr (ty_prod  ( (ty_arrow T1 T2) )   ( (ty_arrow T1 T3) ) ) (ty_arrow T1 (ty_prod T2 T3))
 | ctyp_topArr : forall (dd:tctx),
     ctyp dd co_topArr ty_unit (ty_arrow ty_unit ty_unit)
 | ctyp_topAll : forall (dd:tctx),
     ctyp dd co_topAll ty_unit (ty_all ty_unit)
 | ctyp_distPoly : forall (dd:tctx) (T1 T2:ty),
     wft dd (ty_all T1) ->
     wft dd (ty_all T2) ->
     ctyp dd co_distPoly (ty_prod  ( (ty_all T1) )   ( (ty_all T2) ) ) (ty_all (ty_prod T1 T2)).

(* ********************************************************************** *)
(** * Fco typing *)

Inductive typ : tctx -> ctx -> exp -> ty -> Prop :=    (* defn typ *)
 | typ_unit : forall (dd:tctx) (gg:ctx),
     wfe dd gg ->
     typ dd gg exp_unit ty_unit
 | typ_nat : forall (dd:tctx) (gg:ctx) (i:nat),
     wfe dd gg ->
     typ dd gg (exp_lit i) ty_nat
 | typ_var : forall (dd:tctx) (gg:ctx) (x:expvar) (T:ty),
     wfe dd gg ->
      binds  x   T   gg  ->
     typ dd gg (exp_var_f x) T
 | typ_abs : forall (L:vars) (dd:tctx) (gg:ctx) (e:exp) (T1 T2:ty),
      ( forall x , x \notin  L  -> typ dd  (( x ~ T1 )++ gg )   ( open_exp_wrt_exp e (exp_var_f x) )  T2 )  ->
     wft dd T1 ->
     typ dd gg (exp_abs e) (ty_arrow T1 T2)
 | typ_app : forall (dd:tctx) (gg:ctx) (e1 e2:exp) (T2 T1:ty),
     typ dd gg e1 (ty_arrow T1 T2) ->
     typ dd gg e2 T1 ->
     typ dd gg (exp_app e1 e2) T2
 | typ_pair : forall (dd:tctx) (gg:ctx) (e1 e2:exp) (T1 T2:ty),
     typ dd gg e1 T1 ->
     typ dd gg e2 T2 ->
     typ dd gg (exp_pair e1 e2) (ty_prod T1 T2)
 | typ_tabs : forall (L:vars) (dd:tctx) (gg:ctx) (e:exp) (T:ty),
      ( forall X , X \notin  L  -> typ  (( X ~tt)++ dd )  gg  ( open_exp_wrt_ty e (ty_var_f X) )   ( open_ty_wrt_ty T (ty_var_f X) )  )  ->
     wfe dd gg ->
     typ dd gg (exp_tabs e) (ty_all T)
 | typ_tapp : forall (dd:tctx) (gg:ctx) (e:exp) (T T':ty),
     typ dd gg e (ty_all T') ->
     wft dd T ->
     typ dd gg (exp_tapp e T)  (open_ty_wrt_ty  T'   T )
 | typ_capp : forall (dd:tctx) (gg:ctx) (c:co) (e:exp) (T' T:ty),
     typ dd gg e T ->
     ctyp dd c T T' ->
     wft dd T' ->
     typ dd gg (exp_capp c e) T'.

(* ********************************************************************** *)
(** * Value predicate *)

Inductive value : exp -> Prop :=    (* defn value *)
 | value_unit :
     value exp_unit
 | value_lit : forall (i:nat),
     value (exp_lit i)
 | value_abs : forall (e:exp),
     lc_exp (exp_abs e) ->
     value (exp_abs e)
 | value_tabs : forall (e:exp),
     lc_exp (exp_tabs e) ->
     value (exp_tabs e)
 | value_pair : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     value (exp_pair v1 v2)
 | value_arr : forall (c1 c2:co) (v:exp),
     value v ->
     value (exp_capp  ( (co_arr c1 c2) )  v)
 | value_forall : forall (c:co) (v:exp),
     value v ->
     value (exp_capp  ( (co_forall c) )  v)
 | value_distArr : forall (v:exp),
     value v ->
     value (exp_capp co_distArr v)
 | value_topArr : forall (v:exp),
     value v ->
     value (exp_capp co_topArr v)
 | value_topAll : forall (v:exp),
     value v ->
     value (exp_capp co_topAll v)
 | value_distPoly : forall (v:exp),
     value v ->
     value (exp_capp co_distPoly v).

(* ********************************************************************** *)
(** * Single-step reduction *)

Inductive step : exp -> exp -> Prop :=
 | step_topArr :
     step (exp_app  ( (exp_capp co_topArr exp_unit) )  exp_unit) exp_unit
 | step_topAll : forall (T:ty),
     lc_ty T ->
     step (exp_tapp  ( (exp_capp co_topAll exp_unit) )  T) exp_unit
 | step_distArr : forall (v1 v2 v3:exp),
     value v1 ->
     value v2 ->
     value v3 ->
     step (exp_app  ( (exp_capp co_distArr (exp_pair v1 v2)) )  v3) (exp_pair (exp_app v1 v3) (exp_app v2 v3))
 | step_distPoly : forall (v1 v2:exp) (T:ty),
     lc_ty T ->
     value v1 ->
     value v2 ->
     step (exp_tapp  ( (exp_capp co_distPoly (exp_pair v1 v2)) )  T) (exp_pair (exp_tapp v1 T) (exp_tapp v2 T))
 | step_id : forall (v:exp),
     value v ->
     step (exp_capp co_id v) v
 | step_trans : forall (c1 c2:co) (v:exp),
     value v ->
     step (exp_capp  ( (co_trans c1 c2) )  v) (exp_capp c1  ( (exp_capp c2 v) ) )
 | step_top : forall (v:exp),
     value v ->
     step (exp_capp co_top v) exp_unit
 | step_arr : forall (c1 c2:co) (v1 v2:exp),
     value v1 ->
     value v2 ->
     step (exp_app  ( (exp_capp  ( (co_arr c1 c2) )  v1) )  v2) (exp_capp c2  ( (exp_app v1  ( (exp_capp c1 v2) ) ) ) )
 | step_pair : forall (c1 c2:co) (v:exp),
     value v ->
     step (exp_capp (co_pair c1 c2) v) (exp_pair (exp_capp c1 v) (exp_capp c2 v))
 | step_projl : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     step (exp_capp co_proj1 (exp_pair v1 v2)) v1
 | step_projr : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     step (exp_capp co_proj2 (exp_pair v1 v2)) v2
 | step_forall : forall (c:co) (v:exp) (T:ty),
     lc_ty T ->
     value v ->
     step (exp_tapp  ( (exp_capp (co_forall c) v) )  T) (exp_capp c  ( (exp_tapp v T) ) )
 | step_beta : forall (e v:exp),
     lc_exp (exp_abs e) ->
     value v ->
     step (exp_app  ( (exp_abs e) )  v)  (open_exp_wrt_exp  e v )
 | step_tbeta : forall (e:exp) (T:ty),
     lc_exp (exp_tabs e) ->
     lc_ty T ->
     step (exp_tapp  ( (exp_tabs e) )  T)  (open_exp_wrt_ty  e   T )
 | step_app1 : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (exp_app e1 e2) (exp_app e1' e2)
 | step_app2 : forall (v1 e2 e2':exp),
     step e2 e2' ->
     value v1 ->
     step (exp_app v1 e2) (exp_app v1 e2')
 | step_pairl : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (exp_pair e1 e2) (exp_pair e1' e2)
 | step_pairr : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (exp_pair v1 e2) (exp_pair v1 e2')
 | step_tapp : forall (e:exp) (T:ty) (e':exp),
     lc_ty T ->
     step e e' ->
     step (exp_tapp e T) (exp_tapp e' T)
 | step_capp : forall (c:co) (e e':exp),
     step e e' ->
     step (exp_capp c e) (exp_capp c e').

(* ********************************************************************** *)
(** * Fi+ well-formedness of types *)

Inductive swft : stctx -> sty -> Prop :=    (* defn swft *)
 | swft_top : forall (DD:stctx),
     swft DD sty_top
 | swft_bot : forall (DD:stctx),
     swft DD sty_bot
 | swft_nat : forall (DD:stctx),
     swft DD sty_nat
 | swft_var : forall (DD:stctx) (X:typvar) (A:sty),
      binds ( X ) ( A ) ( DD )  ->
     swft DD (sty_var_f X)
 | swft_arrow : forall (DD:stctx) (A B:sty),
     swft DD A ->
     swft DD B ->
     swft DD (sty_arrow A B)
 | swft_all : forall (L:vars) (DD:stctx) (A B:sty),
     swft DD A ->
      ( forall X , X \notin  L  -> swft  (( X ~ A )++ DD )   ( open_sty_wrt_sty B (sty_var_f X) )  )  ->
     swft DD (sty_all A B)
 | swft_and : forall (DD:stctx) (A B:sty),
     swft DD A ->
     swft DD B ->
     swft DD (sty_and A B)
 | swft_rcd : forall (DD:stctx) (l:nat) (A:sty),
     swft DD A ->
     swft DD (sty_rcd l A).

(* ********************************************************************** *)
(** * Fi+ well-formedness of term contexts *)

Inductive swfe : stctx -> sctx -> Prop :=    (* defn swfe *)
 | swfe_empty : forall (DD:stctx),
     swfe DD  nil
 | swfe_var : forall (DD:stctx) (GG:sctx) (x:expvar) (A:sty),
     swfe DD GG ->
     swft DD A ->
      ( x  `notin` dom ( GG ))  ->
      ( x  `notin` dom ( DD ))  ->
     swfe DD  (( x ~ A )++ GG ) .

(* ********************************************************************** *)
(** * Fi+ well-formedness of type contexts *)

Inductive swfte : stctx -> Prop :=    (* defn swfte *)
 | swfte_empty :
     swfte  nil
 | swfte_var : forall (DD:stctx) (X:typvar) (A:sty),
     swfte DD ->
     swft DD A ->
      ( X  `notin` dom ( DD ))  ->
     swfte  (( X ~ A )++ DD ) .

(* ********************************************************************** *)
(** * Coercive subtyping *)

Inductive sub : stctx -> sty -> sty -> co -> Prop :=    (* defn sub *)
 | S_refl : forall (DD:stctx) (A:sty),
     swft DD A ->
     sub DD A A co_id
 | S_trans : forall (DD:stctx) (A1 A3:sty) (c1 c2:co) (A2:sty),
     sub DD A2 A3 c1 ->
     sub DD A1 A2 c2 ->
     sub DD A1 A3 (co_trans c1 c2)
 | S_top : forall (DD:stctx) (A:sty),
     swft DD A ->
     sub DD A sty_top co_top
 | S_bot : forall (DD:stctx) (A:sty),
     swft DD A ->
     sub DD sty_bot A co_bot
 | S_topArr : forall (DD:stctx),
     sub DD sty_top (sty_arrow sty_top sty_top) co_topArr
 | S_topRcd : forall (DD:stctx) (l:nat),
     sub DD sty_top (sty_rcd l sty_top) co_id
 | S_topAll : forall (DD:stctx),
     sub DD sty_top (sty_all sty_top sty_top) co_topAll
 | S_arr : forall (DD:stctx) (A1 A2 B1 B2:sty) (c1 c2:co),
     sub DD B1 A1 c1 ->
     sub DD A2 B2 c2 ->
     sub DD (sty_arrow A1 A2) (sty_arrow B1 B2) (co_arr c1 c2)
 | S_and : forall (DD:stctx) (A1 A2 A3:sty) (c1 c2:co),
     sub DD A1 A2 c1 ->
     sub DD A1 A3 c2 ->
     sub DD A1 (sty_and A2 A3) (co_pair c1 c2)
 | S_andl : forall (DD:stctx) (A1 A2:sty),
     swft DD A1 ->
     swft DD A2 ->
     sub DD (sty_and A1 A2) A1 co_proj1
 | S_andr : forall (DD:stctx) (A1 A2:sty),
     swft DD A1 ->
     swft DD A2 ->
     sub DD (sty_and A1 A2) A2 co_proj2
 | S_forall : forall (L:vars) (DD:stctx) (A1 B1 A2 B2:sty) (c c':co),
      ( forall X , X \notin  L  -> sub  (( X ~ A2 )++ DD )   ( open_sty_wrt_sty B1 (sty_var_f X) )   ( open_sty_wrt_sty B2 (sty_var_f X) )  c )  ->
     sub DD A2 A1 c' ->
     sub DD (sty_all A1 B1) (sty_all A2 B2) (co_forall c)
 | S_rcd : forall (DD:stctx) (l:nat) (A B:sty) (c:co),
     sub DD A B c ->
     sub DD (sty_rcd l A) (sty_rcd l B) c
 | S_distArr : forall (DD:stctx) (A1 A2 A3:sty),
     swft DD A1 ->
     swft DD A2 ->
     swft DD A3 ->
     sub DD (sty_and  ( (sty_arrow A1 A2) )   ( (sty_arrow A1 A3) ) ) (sty_arrow A1 (sty_and A2 A3)) co_distArr
 | S_distRcd : forall (DD:stctx) (l:nat) (A B:sty),
     swft DD A ->
     swft DD B ->
     sub DD (sty_and (sty_rcd l A) (sty_rcd l B)) (sty_rcd l (sty_and A B)) co_id
 | S_distPoly : forall (L:vars) (DD:stctx) (A B1 B2:sty),
     swft DD A ->
      ( forall X , X \notin  L  -> swft  (( X ~ A )++ DD )   ( open_sty_wrt_sty B1 (sty_var_f X) )  )  ->
      ( forall X , X \notin  L  -> swft  (( X ~ A )++ DD )   ( open_sty_wrt_sty B2 (sty_var_f X) )  )  ->
     sub DD (sty_and  ( (sty_all A B1) )   ( (sty_all A B2) ) ) (sty_all A (sty_and B1 B2)) co_distPoly.

(* ********************************************************************** *)
(** * Subtyping minus contexts and coercions *)

Inductive csub : sty -> sty -> co -> Prop :=
 | CS_refl : forall (A:sty),
     lc_sty A ->
     csub A A co_id
 | CS_trans : forall (A1 A3:sty) (c1 c2:co) (A2:sty),
     csub A2 A3 c1 ->
     csub A1 A2 c2 ->
     csub A1 A3 (co_trans c1 c2)
 | CS_top : forall (A:sty),
     lc_sty A ->
     csub A sty_top co_top
 | CS_bot : forall (A:sty),
     lc_sty A ->
     csub sty_bot A co_bot
 | CS_topArr :
     csub sty_top (sty_arrow sty_top sty_top) co_topArr
 | CS_topRcd : forall (l:nat),
     csub sty_top (sty_rcd l sty_top) co_id
 | CS_topAll :
     csub sty_top (sty_all sty_top sty_top) co_topAll
 | CS_arr : forall (A1 A2 B1 B2:sty) (c1 c2:co),
     csub B1 A1 c1 ->
     csub A2 B2 c2 ->
     csub (sty_arrow A1 A2) (sty_arrow B1 B2) (co_arr c1 c2)
 | CS_and : forall (A1 A2 A3:sty) (c1 c2:co),
     csub A1 A2 c1 ->
     csub A1 A3 c2 ->
     csub A1 (sty_and A2 A3) (co_pair c1 c2)
 | CS_andl : forall (A1 A2:sty),
     lc_sty A2 ->
     lc_sty A1 ->
     csub (sty_and A1 A2) A1 co_proj1
 | CS_andr : forall (A1 A2:sty),
     lc_sty A1 ->
     lc_sty A2 ->
     csub (sty_and A1 A2) A2 co_proj2
 | CS_forall : forall (L:vars) (A1 B1 A2 B2:sty) (c c':co),
      ( forall X , X \notin  L  -> csub  ( open_sty_wrt_sty B1 (sty_var_f X) )   ( open_sty_wrt_sty B2 (sty_var_f X) )  c )  ->
     csub A2 A1 c' ->
     csub (sty_all A1 B1) (sty_all A2 B2) (co_forall c)
 | CS_rcd : forall (l:nat) (A B:sty) (c:co),
     csub A B c ->
     csub (sty_rcd l A) (sty_rcd l B) c
 | CS_distArr : forall (A1 A2 A3:sty),
     lc_sty A1 ->
     lc_sty A2 ->
     lc_sty A3 ->
     csub (sty_and  ( (sty_arrow A1 A2) )   ( (sty_arrow A1 A3) ) ) (sty_arrow A1 (sty_and A2 A3)) co_distArr
 | CS_distRcd : forall (l:nat) (A B:sty),
     lc_sty A ->
     lc_sty B ->
     csub (sty_and (sty_rcd l A) (sty_rcd l B)) (sty_rcd l (sty_and A B)) co_id
 | CS_distPoly : forall (A B1 B2:sty),
     lc_sty (sty_all A B1) ->
     lc_sty (sty_all A B2) ->
     lc_sty A ->
     csub (sty_and  ( (sty_all A B1) )   ( (sty_all A B2) ) ) (sty_all A (sty_and B1 B2)) co_distPoly.

(* ********************************************************************** *)
(** * Top-like predicate *)

Inductive TopLike : sty -> Prop :=
| tl_top : TopLike sty_top
| tl_and : forall A B,
    TopLike A ->
    TopLike B ->
    TopLike (sty_and A B)
| tl_arr : forall A B,
    TopLike B ->
    TopLike (sty_arrow A B)
| tl_all : forall L A B,
    (forall X, X `notin` L -> TopLike (open_sty_wrt_sty B (sty_var_f X))) ->
    TopLike (sty_all A B)
| tl_rcd : forall A l,
    TopLike A ->
    TopLike (sty_rcd l A).

(* ********************************************************************** *)
(** * Disjointness relation *)

Inductive disjoint : stctx -> sty -> sty -> Prop :=
 | D_topL : forall (DD:stctx) (A:sty) B,
     swft DD A ->
     swft DD B ->
     TopLike B ->
     disjoint DD B A
 | D_topR : forall (DD:stctx) (A:sty) B,
     swft DD A ->
     swft DD B ->
     TopLike B ->
     disjoint DD A B
 | D_arr : forall (DD:stctx) (A1 A2 B1 B2:sty),
     disjoint DD A2 B2 ->
     swft DD A1 ->
     swft DD B1 ->
     disjoint DD (sty_arrow A1 A2) (sty_arrow B1 B2)
 | D_andL : forall (DD:stctx) (A1 A2 B:sty),
     disjoint DD A1 B ->
     disjoint DD A2 B ->
     disjoint DD (sty_and A1 A2) B
 | D_andR : forall (DD:stctx) (A B1 B2:sty),
     disjoint DD A B1 ->
     disjoint DD A B2 ->
     disjoint DD A (sty_and B1 B2)
 | D_rcdEq : forall (DD:stctx) (l:nat) (A B:sty),
     disjoint DD A B ->
     disjoint DD (sty_rcd l A) (sty_rcd l B)
 | D_rcdNeq : forall (DD:stctx) (l1:nat) (A:sty) (l2:nat) (B:sty),
      l1  <>  l2  ->
     swft DD A ->
     swft DD B ->
     disjoint DD (sty_rcd l1 A) (sty_rcd l2 B)
 | D_axNatArr : forall (DD:stctx) (A1 A2:sty),
     swft DD A1 ->
     swft DD A2 ->
     disjoint DD sty_nat (sty_arrow A1 A2)
 | D_axArrNat : forall (DD:stctx) (A1 A2:sty),
     swft DD A1 ->
     swft DD A2 ->
     disjoint DD (sty_arrow A1 A2) sty_nat
 | D_axNatRcd : forall (DD:stctx) (l:nat) (A:sty),
     swft DD A ->
     disjoint DD sty_nat (sty_rcd l A)
 | D_axRcdNat : forall (DD:stctx) (l:nat) (A:sty),
     swft DD A ->
     disjoint DD (sty_rcd l A) sty_nat
 | D_axArrRcd : forall (DD:stctx) (A1 A2:sty) (l:nat) (A:sty),
     swft DD A1 ->
     swft DD A2 ->
     swft DD A ->
     disjoint DD (sty_arrow A1 A2) (sty_rcd l A)
 | D_axRcdArr : forall (DD:stctx) (l:nat) (A A1 A2:sty),
     swft DD A1 ->
     swft DD A2 ->
     swft DD A ->
     disjoint DD (sty_rcd l A) (sty_arrow A1 A2)
 | D_axRcdAll : forall (DD:stctx) (l:nat) (A A1 B1:sty),
     swft DD (sty_all A1 B1) ->
     swft DD A ->
     disjoint DD (sty_rcd l A) (sty_all A1 B1)
 | D_axAllRcd : forall (DD:stctx) (A1 B1:sty) (l:nat) (A:sty),
     swft DD (sty_all A1 B1) ->
     swft DD A ->
     disjoint DD (sty_all A1 B1) (sty_rcd l A)
 | D_axAllNat : forall (DD:stctx) (A1 B1:sty),
     swft DD (sty_all A1 B1) ->
     disjoint DD (sty_all A1 B1) sty_nat
 | D_axNatAll : forall (DD:stctx) (A1 B1:sty),
     swft DD (sty_all A1 B1) ->
     disjoint DD sty_nat (sty_all A1 B1)
 | D_axArrAll : forall (DD:stctx) (A B A1 B1:sty),
     swft DD (sty_all A1 B1) ->
     swft DD A ->
     swft DD B ->
     disjoint DD (sty_arrow A B) (sty_all A1 B1)
 | D_axAllArr : forall (DD:stctx) (A1 B1 A B:sty),
     swft DD (sty_all A1 B1) ->
     swft DD A ->
     swft DD B ->
     disjoint DD (sty_all A1 B1) (sty_arrow A B)
 | D_tvarL : forall (DD:stctx) (X:typvar) (B A:sty) (c:co),
      binds ( X ) ( A ) ( DD )  ->
     sub DD A B c ->
     disjoint DD (sty_var_f X) B
 | D_tvarR : forall (DD:stctx) (B:sty) (X:typvar) (A:sty) (c:co),
      binds ( X ) ( A ) ( DD )  ->
     sub DD A B c ->
     disjoint DD B (sty_var_f X)
 | D_forall : forall (L:vars) (DD:stctx) (A1 B1 A2 B2:sty),
      ( forall X , X \notin  L  -> disjoint  (( X ~ (sty_and A1 A2) )++ DD )   ( open_sty_wrt_sty B1 (sty_var_f X) )   ( open_sty_wrt_sty B2 (sty_var_f X) )  )  ->
     swft DD A1 ->
     swft DD A2 ->
     disjoint DD (sty_all A1 B1) (sty_all A2 B2).

(* ********************************************************************** *)
(** * Fi+ elaboration typing *)

Inductive has_type : stctx -> sctx -> sexp -> dirflag -> sty -> exp -> Prop :=    (* defn has_type *)
 | T_top : forall (DD:stctx) (GG:sctx),
     swfe DD GG ->
     swfte DD ->
     has_type DD GG sexp_top Inf sty_top exp_unit
 | T_nat : forall (DD:stctx) (GG:sctx) (i:nat),
     swfe DD GG ->
     swfte DD ->
     has_type DD GG (sexp_lit i) Inf sty_nat (exp_lit i)
 | T_var : forall (DD:stctx) (GG:sctx) (x:expvar) (A:sty),
     swfte DD ->
     swfe DD GG ->
      binds ( x ) ( A ) ( GG )  ->
     has_type DD GG (sexp_var_f x) Inf A (exp_var_f x)
 | T_app : forall (DD:stctx) (GG:sctx) (ee1 ee2:sexp) (A2:sty) (e1 e2:exp) (A1:sty),
     has_type DD GG ee1 Inf (sty_arrow A1 A2) e1 ->
     has_type DD GG ee2 Chk A1 e2 ->
     has_type DD GG (sexp_app ee1 ee2) Inf A2 (exp_app e1 e2)
 | T_merge : forall (DD:stctx) (GG:sctx) (ee1 ee2:sexp) (A1 A2:sty) (e1 e2:exp),
     has_type DD GG ee1 Inf A1 e1 ->
     has_type DD GG ee2 Inf A2 e2 ->
     disjoint DD A1 A2 ->
     has_type DD GG (sexp_merge ee1 ee2) Inf (sty_and A1 A2) (exp_pair e1 e2)
 | T_anno : forall (DD:stctx) (GG:sctx) (ee:sexp) (A:sty) (e:exp),
     has_type DD GG ee Chk A e ->
     has_type DD GG (sexp_anno ee A) Inf A e
 | T_tabs : forall (L:vars) (DD:stctx) (GG:sctx) (A:sty) (ee:sexp) (B:sty) (e:exp),
     swft DD A ->
      ( forall X , X \notin  L  -> has_type  (( X ~ A )++ DD )  GG  ( open_sexp_wrt_sty ee (sty_var_f X) )  Inf  ( open_sty_wrt_sty B (sty_var_f X) )   ( open_exp_wrt_ty e (ty_var_f X) )  )  ->
     swfe DD GG ->
     has_type DD GG (sexp_tabs A ee) Inf (sty_all A B) (exp_tabs e)
 | T_tapp : forall (DD:stctx) (GG:sctx) (ee:sexp) (t C:sty) (e:exp) (B:sty),
     has_type DD GG ee Inf (sty_all B C) e ->
      mono  t  ->
     disjoint DD t B ->
     has_type DD GG (sexp_tapp ee t) Inf  (open_sty_wrt_sty  C   t )  (exp_tapp e  (sty2ty  t ) )
 | T_rcd : forall (DD:stctx) (GG:sctx) (l:nat) (ee:sexp) (A:sty) (e:exp),
     has_type DD GG ee Inf A e ->
     has_type DD GG (sexp_rcd l ee) Inf (sty_rcd l A) e
 | T_proj : forall (DD:stctx) (GG:sctx) (ee:sexp) (l:nat) (A:sty) (e:exp),
     has_type DD GG ee Inf (sty_rcd l A) e ->
     has_type DD GG (sexp_proj ee l) Inf A e
 | T_abs : forall (L:vars) (DD:stctx) (GG:sctx) (ee:sexp) (A B:sty) (e:exp),
     swft DD A ->
      ( forall x , x \notin  L  -> has_type DD  (( x ~ A )++ GG )   ( open_sexp_wrt_sexp ee (sexp_var_f x) )  Chk B  ( open_exp_wrt_exp e (exp_var_f x) )  )  ->
     has_type DD GG (sexp_abs ee) Chk (sty_arrow A B) (exp_abs e)
 | T_sub : forall (DD:stctx) (GG:sctx) (ee:sexp) (A:sty) (c:co) (e:exp) (B:sty),
     has_type DD GG ee Inf B e ->
     swft DD A ->
     sub DD B A c ->
     has_type DD GG ee Chk A (exp_capp c e).

(* ********************************************************************** *)
(** * Typing of Fi+ expression contexts *)

Inductive CTyp : CC -> stctx -> sctx -> dirflag -> sty -> stctx -> sctx -> dirflag -> sty -> cc -> Prop :=    (* defn CTyp *)
 | CTyp_empty1 : forall (DD:stctx) (GG:sctx) (A:sty),
     lc_sty A ->
     CTyp C_Empty DD GG Inf A DD GG Inf A cc_empty
 | CTyp_empty2 : forall (DD:stctx) (GG:sctx) (A:sty),
     lc_sty A ->
     CTyp C_Empty DD GG Chk A DD GG Chk A cc_empty
 | CTyp_appL1 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (e:exp) (A1:sty),
     CTyp CC5 DD GG Inf A DD' GG' Inf (sty_arrow A1 A2) cc5 ->
     has_type DD' GG' ee2 Chk A1 e ->
     CTyp (C_AppL CC5 ee2) DD GG Inf A DD' GG' Inf A2 (cc_appL cc5 e)
 | CTyp_appL2 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (e:exp) (A1:sty),
     CTyp CC5 DD GG Chk A DD' GG' Inf (sty_arrow A1 A2) cc5 ->
     has_type DD' GG' ee2 Chk A1 e ->
     CTyp (C_AppL CC5 ee2) DD GG Chk A DD' GG' Inf A2 (cc_appL cc5 e)
 | CTyp_appR1 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (e:exp) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Inf A DD' GG' Chk A1 cc5 ->
     has_type DD' GG' ee1 Inf (sty_arrow A1 A2) e ->
     CTyp (C_AppRd ee1 CC5) DD GG Inf A DD' GG' Inf A2 (cc_appR e cc5)
 | CTyp_appR2 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (e:exp) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Chk A DD' GG' Chk A1 cc5 ->
     has_type DD' GG' ee1 Inf (sty_arrow A1 A2) e ->
     CTyp (C_AppRd ee1 CC5) DD GG Chk A DD' GG' Inf A2 (cc_appR e cc5)
 | CTyp_mergeL1 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc) (e:exp),
     CTyp CC5 DD GG Inf A DD' GG' Inf A1 cc5 ->
     has_type DD' GG' ee2 Inf A2 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeL CC5 ee2) DD GG Inf A DD' GG' Inf (sty_and A1 A2) (cc_pairL cc5 e)
 | CTyp_mergeL2 : forall (CC5:CC) (ee2:sexp) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc) (e:exp),
     CTyp CC5 DD GG Chk A DD' GG' Inf A1 cc5 ->
     has_type DD' GG' ee2 Inf A2 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeL CC5 ee2) DD GG Chk A DD' GG' Inf (sty_and A1 A2) (cc_pairL cc5 e)
 | CTyp_mergeR1 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (e:exp) (cc5:cc),
     CTyp CC5 DD GG Inf A DD' GG' Inf A2 cc5 ->
     has_type DD' GG' ee1 Inf A1 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeR ee1 CC5) DD GG Inf A DD' GG' Inf (sty_and A1 A2) (cc_pairR e cc5)
 | CTyp_mergeR2 : forall (ee1:sexp) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (e:exp) (cc5:cc),
     CTyp CC5 DD GG Chk A DD' GG' Inf A2 cc5 ->
     has_type DD' GG' ee1 Inf A1 e ->
     disjoint DD' A1 A2 ->
     CTyp (C_MergeR ee1 CC5) DD GG Chk A DD' GG' Inf (sty_and A1 A2) (cc_pairR e cc5)
 | CTyp_rcd1 : forall (l:nat) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Inf A DD' GG' Inf B cc5 ->
     CTyp (C_Rcd l CC5) DD GG Inf A DD' GG' Inf (sty_rcd l B) cc5
 | CTyp_rcd2 : forall (l:nat) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Chk A DD' GG' Inf B cc5 ->
     CTyp (C_Rcd l CC5) DD GG Chk A DD' GG' Inf (sty_rcd l B) cc5
 | CTyp_proj1 : forall (CC5:CC) (l:nat) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Inf A DD' GG' Inf (sty_rcd l B) cc5 ->
     CTyp (C_Proj CC5 l) DD GG Inf A DD' GG' Inf B cc5
 | CTyp_proj2 : forall (CC5:CC) (l:nat) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B:sty) (cc5:cc),
     CTyp CC5 DD GG Chk A DD' GG' Inf (sty_rcd l B) cc5 ->
     CTyp (C_Proj CC5 l) DD GG Chk A DD' GG' Inf B cc5
 | CTyp_anno1 : forall (CC5:CC) (A:sty) (DD:stctx) (GG:sctx) (B:sty) (DD':stctx) (GG':sctx) (cc5:cc),
     CTyp CC5 DD GG Inf B DD' GG' Chk A cc5 ->
     CTyp (C_Anno CC5 A) DD GG Inf B DD' GG' Inf A cc5
 | CTyp_anno2 : forall (CC5:CC) (A:sty) (DD:stctx) (GG:sctx) (B:sty) (DD':stctx) (GG':sctx) (cc5:cc),
     CTyp CC5 DD GG Chk B DD' GG' Chk A cc5 ->
     CTyp (C_Anno CC5 A) DD GG Chk B DD' GG' Inf A cc5
 | CTyp_abs1 : forall (x:expvar) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc),
     CTyp CC5 DD GG Inf A DD'  (( x ~ A1 )++ GG' )  Chk A2 cc5 ->
     swft DD' A1 ->
     swfte DD' ->
     x `notin` dom GG' ->
     x `notin` dom DD' ->
     CTyp (C_Lam x CC5) DD GG Inf A DD' GG' Chk (sty_arrow A1 A2) (cc_lam x cc5)
 | CTyp_abs2 : forall (x:expvar) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A1 A2:sty) (cc5:cc),
     CTyp CC5 DD GG Chk A DD'  (( x ~ A1 )++ GG' )  Chk A2 cc5 ->
     swft DD' A1 ->
     swfte DD' ->
     x `notin` dom GG' ->
     x `notin` dom DD' ->
     CTyp (C_Lam x CC5) DD GG Chk A DD' GG' Chk (sty_arrow A1 A2) (cc_lam x cc5)
 | CTyp_tabs1 : forall X (L:vars) (B:sty) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B':sty) (cc5:cc),
     CTyp CC5 DD GG Inf A  (( X ~ B )++ DD' )  GG' Inf  ( open_sty_wrt_sty B' (sty_var_f X) )  cc5   ->
     swft DD' B ->
     swfe DD' GG' ->
     swfte DD' ->
     X `notin` dom GG' ->
     X `notin` dom DD' ->
     X `notin` fv_sty_in_sty B' ->
     X `notin` fv_sty_in_sty B' ->
     CTyp (C_tabs X B CC5) DD GG Inf A DD' GG' Inf (sty_all B B') (cc_tabs X cc5)
 | CTyp_tabs2 : forall X (L:vars) (B:sty) (CC5:CC) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (B':sty) (cc5:cc),
     CTyp CC5 DD GG Chk A  (( X ~ B )++ DD' )  GG' Inf  ( open_sty_wrt_sty B' (sty_var_f X) )  cc5   ->
     swft DD' B ->
     swfe DD' GG' ->
     swfte DD' ->
     X `notin` dom GG' ->
     X `notin` dom DD' ->
     X `notin` fv_sty_in_sty B' ->
     X `notin` fv_sty_in_sty B' ->
     CTyp (C_tabs X B CC5) DD GG Chk A DD' GG' Inf (sty_all B B') (cc_tabs X cc5)
 | CTyp_tapp1 : forall (CC5:CC) (B:sty) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Inf A DD' GG' Inf (sty_all A1 A2) cc5 ->
     swfte DD' ->
     swft DD' B ->
     disjoint DD' B A1 ->
     mono  B  ->
     CTyp (C_tapp CC5 B) DD GG Inf A DD' GG' Inf  (open_sty_wrt_sty  A2   B )  (cc_tapp cc5  (sty2ty  B ) )
 | CTyp_tapp2 : forall (CC5:CC) (B:sty) (DD:stctx) (GG:sctx) (A:sty) (DD':stctx) (GG':sctx) (A2:sty) (cc5:cc) (A1:sty),
     CTyp CC5 DD GG Chk A DD' GG' Inf (sty_all A1 A2) cc5 ->
     swfte DD' ->
     swft DD' B ->
     disjoint DD' B A1 ->
     mono  B  ->
     CTyp (C_tapp CC5 B) DD GG Chk A DD' GG' Inf  (open_sty_wrt_sty  A2   B )  (cc_tapp cc5  (sty2ty  B ) ).

(** ** Context replacement *)

Fixpoint appctx (ctx : cc) (t : exp) : exp :=
  match ctx with
  | cc_empty => t
  | cc_lam x c => exp_abs (close_exp_wrt_exp x (appctx c t))
  | cc_tabs X c => exp_tabs (close_exp_wrt_ty X (appctx c t))
  | cc_tapp c T => exp_tapp (appctx c t) T
  | cc_appL c t2 => exp_app (appctx c t) t2
  | cc_appR t1 c => exp_app t1 (appctx c t)
  | cc_pairL c t2 => exp_pair (appctx c t) t2
  | cc_pairR t1 c => exp_pair t1 (appctx c t)
  | cc_co co c => exp_capp co (appctx c t)
  end.

Section Star.

  Variable A : Type.

  Definition relation := A -> A -> Prop.

  Variable R : relation.

  Inductive star : relation :=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

  Lemma star_one:
    forall a b, R a b -> star a b.
  Proof.
    eauto using star.
  Qed.

  Lemma star_trans:
    forall a b, star a b -> forall c, star b c -> star a c.
  Proof.
    induction 1; eauto using star.
  Qed.

  Hypothesis R_functional:
    forall a b c, R a b -> R a c -> b = c.

  Lemma star_star_inv:
    forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
  Proof.
    induction 1; intros.
    - auto.
    - inversion H1; subst.
      + right. eauto using star.
      + assert (b = b0) by (eapply R_functional; eauto). subst b0.
        apply IHstar; auto.
  Qed.

  Definition irred a : Prop := forall b, ~(R a b).

  Lemma finseq_unique:
    forall a b b',
      star a b -> irred b ->
      star a b' -> irred b' ->
      b = b'.
  Proof.
    intros. destruct (star_star_inv _ _ H _ H1).
    - inversion H3; subst. auto. elim (H0 _ H4).
    - inversion H3; subst. auto. elim (H2 _ H4).
  Qed.

End Star.

Arguments star : default implicits.
Arguments irred : default implicits.

Notation "t ->* t'" := (star step t t') (at level 68).

Hint Constructors wft wfe ctyp typ value step swft swfe swfte sub csub disjoint has_type TopLike star mono poly CTyp.


(** * Initial Object **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import COC.Base.Main.

Class IsInitial (C: Category)
      (obj: C)
      (univ: forall X: C, C obj X) :=
  {
    initial_uniqueness:
      forall (X: C)(f: C obj X),
        f == univ X
  }.

Structure Initial (C: Category) :=
  {
    initial_obj:> C;
    initial_univ: forall X: C, C initial_obj X;

    initial_prf:> IsInitial initial_univ
  }.
Existing Instance initial_prf.

Notation "[ 'Initial' i 'by' univ ]" := (@Build_Initial _ i univ _).
Notation "[ 'Initial' 'by' univ ]" := [Initial _ by univ].

Lemma initial_isomorphic:
  forall (C: Category)(i i': Initial C),
    i === i' in C.
Proof.
  intros C i i'; simpl; unfold isomorphic.
  exists (initial_univ i i'), (initial_univ i' i); split.
  - rewrite (initial_uniqueness (Id i)).
    now apply initial_uniqueness.
  - rewrite (initial_uniqueness (Id i')).
    now apply initial_uniqueness.
Qed.

(** Examples **)
Program Definition initial_of_Types: Initial Types :=
  [Initial empty by (fun (X: Type)(e: empty) => match e with end)].

Program Definition initial_of_Setoids: Initial Setoids :=
  [Initial empty_setoid
    by (fun (X: Setoid) => [e in empty :-> match e with end])].

Program Definition Zero: Category :=
  [Category by (fun (e e': empty) => match e, e' with end)
   with (fun X Y Z f g => match X with end),
        (fun X => match X with end)].

Program Definition FromZero (C: Category): Zero --> C :=
  [Functor by (fun X Y f => match X with end)
   with (fun (X: empty) => match X with end)].

Program Definition initial_of_Cat: Initial Cat :=
  [Initial Zero by @FromZero].


From CP Require Export comparators.
From Coq Require Import Lists.List.
Import ListNotations.

(*terms*)
Fixpoint AddItemOrdered {X: Type} (x1: X) (b1: bag X) (less_than: X->X->bool) : bag X :=
  match b1 with
  | h1 :: t1 =>
    if less_than x1 h1 then x1 :: b1
    else h1 :: (AddItemOrdered x1 t1 less_than)
  | _ => [x1]
  end.

Fixpoint AddItemsOrdered {X: Type} (b1 b2: bag X) (less_than: X->X->bool) : bag X :=
  match b1 with
  | h1 :: t1 =>
    AddItemsOrdered t1 (AddItemOrdered h1 b2 less_than) less_than
  | _ => b2
  end.

(*add a subterm to a compound term*)
Definition AddTerm (t1: g_term) (t2: g_term) : g_term :=
  match t1 with
  | Term x1 x2 => Term x1 (AddItemOrdered t2 x2 LessThanTermB) (*add subterm to a compound term*)
  | _ => t1 (*simple terms do not have subterms*)
  end.

(*add a bag of subterms to a compound term*)
Definition AddTerms (t1: g_term) (m1: g_multiset) : g_term :=
  match t1 with
  | Term x1 x2 => Term x1 (AddItemsOrdered m1 x2 LessThanTermB)
  | _ => t1
  end.

Definition Subterms (t1: g_term) : g_multiset :=
  match t1 with
  | Term _ x2 => x2
  | _ => nil
  end.

(*bags*)
Fixpoint TermInBagB (t1: g_term) (m1: g_multiset) : bool :=
  match m1 with
  | h2 :: t2 =>
    if EqualTermB t1 h2 then true
    else TermInBagB t1 t2
  | _ => false
  end.

Fixpoint RemoveATerm (t1: g_term) (m1: g_multiset): g_multiset :=
  match m1 with
  | nil => nil
  | h2 :: t2 =>
    if EqualTermB t1 h2 then t2
    else h2 :: (RemoveATerm t1 t2)
  end.

Fixpoint RemoveTerms (m1 m2: g_multiset): g_multiset :=
  match m1 with
  | nil => m2
  | h1 :: t1 => RemoveTerms t1 (RemoveATerm h1 m2)
  end.

(*these two functions are built for our cP verifier*)
Fixpoint AtomCountInMultiset (a1: atom) (m1: g_multiset): nat :=
  match m1 with
  | h1 :: t1 =>
    match h1 with
    | Atom a2 =>
      if EqualAtomB a2 a1 then S (AtomCountInMultiset a1 t1)
      else AtomCountInMultiset a1 t1
    | _ => AtomCountInMultiset a1 t1
    end
  | nil => O
  end.

Fixpoint AtomBagIn (m1 m2: g_multiset): bool :=
  match m1 with
  | h1 :: t1 =>
    match h1 with
    | Atom a1 =>
      if AtomCountInMultiset a1 m1 <=? AtomCountInMultiset a1 m2 then AtomBagIn t1 m2
      else false
    | _ => false
    end
  | nil => true
  end.

(*cP systems*)
Definition SystemState (sys: cPsystem_conf): state :=
  match sys with
  | cP_sys x1 _ => x1
  end.

Definition ChangeState (s1: state) (sys: cPsystem_conf) : cPsystem_conf :=
  match sys with
  | cP_sys _ y1 => cP_sys s1 y1
  end.

Definition SystemTerms (sys: cPsystem_conf): g_multiset :=
  match sys with
  | cP_sys _ y1 => y1
  end.

Definition SystemMemory (sys: cPsystem_conf): nat :=
  match sys with
  | cP_sys _ y1 => length y1
  end.

Definition SystemTermCount:= SystemMemory.

Definition TermInSystemB (t1: g_term) (sys: cPsystem_conf): bool :=
  match sys with
  |cP_sys _ y1 => TermInBagB t1 y1
  end.

Definition ProduceATerm (t1: g_term) (sys: cPsystem_conf) : cPsystem_conf :=
  match sys with
  | cP_sys x1 y1 => cP_sys x1 (AddItemOrdered t1 y1 LessThanTermB)
  end.

Definition ProduceTerms (m1: g_multiset) (sys: cPsystem_conf): cPsystem_conf :=
  match sys with
  | cP_sys x1 y1 => cP_sys x1 (AddItemsOrdered m1 y1 LessThanTermB)
  end.

Definition ConsumeATerm (t1: g_term) (sys: cPsystem_conf): cPsystem_conf :=
  match sys with
  | cP_sys x1 y1 => cP_sys x1 (RemoveATerm t1 y1)
  end.

Definition ConsumeTerms (m1: g_multiset) (sys: cPsystem_conf): cPsystem_conf :=
  match sys with
  | cP_sys x1 y1 => cP_sys x1 (RemoveTerms m1 y1)
  end.

Definition ConsumeAllTerms (sys: cPsystem_conf): cPsystem_conf :=
  match sys with
  |cP_sys x1 _ => cP_sys x1 nil
  end.

Definition NewConf := cP_sys.

Definition NewConfSorted (s1: state) (m1 m2: g_multiset) (sys: cPsystem_conf) :=
  ChangeState s1 (ProduceTerms m1 (ConsumeTerms m2 sys)).

(*for consistency, not very useful*)
Definition ApplyARule (sys: cPsystem_conf) (r1: cP_rule) : cPsystem_conf :=
  r1 sys.

Fixpoint ApplyARuleset (sys: cPsystem_conf) (rs: cP_ruleset) : cPsystem_conf :=
  match rs with
  | h1 :: t1 => ApplyARuleset (h1 sys) t1
  | _ => sys
  end.

(*system properties*)
(*terminated without checking self-looping rules*)
Definition SystemIsTerminatedRSB (sys: cPsystem_conf) (rs: cP_ruleset) : bool :=
  EqualCPSystemConfigurationB sys (ApplyARuleset sys rs).
Definition SystemIsTerminatedRS (sys: cPsystem_conf) (rs: cP_ruleset) : Prop :=
  sys = ApplyARuleset sys rs.
Definition SystemIsTerminatedRB (sys: cPsystem_conf) (r1: cP_rule) : bool :=
  EqualCPSystemConfigurationB sys (r1 sys).
Definition SystemIsTerminatedR (sys: cPsystem_conf) (r1: cP_rule) : Prop :=
  sys = r1 sys.

Definition RuleApplicableB (sys: cPsystem_conf) (r1: cP_rule) : bool :=
  negb (EqualCPSystemConfigurationB sys (r1 sys)).
Definition RuleApplicable (sys: cPsystem_conf) (r1: cP_rule) : Prop :=
  sys <> r1 sys.
Definition RulesetApplicableB (sys: cPsystem_conf) (rs: cP_ruleset) : bool :=
  negb (EqualCPSystemConfigurationB sys (ApplyARuleset sys rs)).
Definition RulesetApplicable (sys: cPsystem_conf) (rs: cP_ruleset) : Prop :=
  sys <> ApplyARuleset sys rs.

Definition RulesetNotApplicableB := SystemIsTerminatedRSB.
Definition RulesetNotApplicable := SystemIsTerminatedRS.
Definition RuleNotApplicableB := SystemIsTerminatedRB.
Definition RuleNotApplicable := SystemIsTerminatedR.

Fixpoint SystemConfigurationInBagB (sys: cPsystem_conf) (bs1: bag cPsystem_conf): bool :=
  match bs1 with
  | h1 :: t1 =>
    if EqualCPSystemConfigurationB sys h1 then true
    else SystemConfigurationInBagB sys t1
  | _ => false
  end.

Fixpoint LoopingCheckWithLimit (sys: cPsystem_conf) (rs: cP_ruleset) (bs1: bag cPsystem_conf) (limit1: nat): bool :=
  match limit1 with
  | S n' =>
    if SystemConfigurationInBagB sys bs1 then true
    else LoopingCheckWithLimit (ApplyARuleset sys rs) rs ([sys] ++ bs1) n'
  | O => false (*no loop*)
  end.

Definition LoopingCheckB (sys: cPsystem_conf) (rs: cP_ruleset)  (limit1: nat):=
  LoopingCheckWithLimit sys rs nil limit1.

Fixpoint DeadlockCheckB (sys: cPsystem_conf) (rs: cP_ruleset) (limit1: nat): bool :=
  match limit1 with
  | S n' =>
    if EqualCPSystemConfigurationB (ApplyARuleset sys rs) sys then true
    else DeadlockCheckB (ApplyARuleset sys rs) rs n'
  | O => false (*no deadlock*)
  end.

Fixpoint RunNSteps (sys: cPsystem_conf) (rs: cP_ruleset) (n1: nat) : cPsystem_conf :=
  match n1 with
  | O => sys
  | S n' => RunNSteps (ApplyARuleset sys rs) rs n'
  end.

(*
(*Cannot guess decreasing argument of fix - Coq hates to run a system forever,
while cP system is Turing complete, which can run forever*)
Fixpoint RunUntilTerminated (sys: cPsystem_conf) (rs: cP_ruleset) : cPsystem_conf :=
  if IsTerminatedRSB sys rs then sys else RunUntilTerminated (ApplyARuleset sys rs) rs.
*)

Fixpoint RunUntilTerminated (sys: cPsystem_conf) (rs: cP_ruleset) (limit1: nat) : cPsystem_conf :=
  match limit1, SystemIsTerminatedRSB sys rs with
  | O, _ => sys
  | _, true => sys
  | S n', false => RunUntilTerminated (ApplyARuleset sys rs) rs n'
  end.


(* Full safety for STLC *)
(* values well-typed with respect to runtime environment *)
(* inversion lemma structure *)
(* subtyping (in addition to nano2.v) *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
| vbool : bool -> vl
| vabs  : list vl -> tm -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint length {X: Type} (l : list X): nat :=
  match l with
    | [] => 0
    | _::l' => 1 + length l'
  end.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
           has_type env ttrue TBool
| t_false: forall env,
           has_type env tfalse TBool
| t_var: forall x env T1,
           index x env = Some T1 ->
           has_type env (tvar x) T1
| t_app: forall env f x T1 T2,
           has_type env f (TFun T1 T2) ->
           has_type env x T1 ->
           has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
           has_type (T1::(TFun T1 T2)::env) y T2 ->
           has_type env (tabs y) (TFun T1 T2)
.

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : wf_env nil nil
| wfe_cons : forall v t vs ts,
    val_type (v::vs) v t ->
    wf_env vs ts ->
    wf_env (cons v vs) (cons t ts)

with val_type : venv -> vl -> ty -> Prop :=
| v_bool: forall venv b,
    val_type venv (vbool b) TBool
| v_abs: forall env venv tenv y T1 T2,
    wf_env venv tenv ->
    has_type (T1::(TFun T1 T2)::tenv) y T2 ->
    val_type env (vabs venv y) (TFun T1 T2)
.

Inductive stp: venv -> ty -> venv -> ty -> Prop :=
| stp_bool: forall G1 G2,
    stp G1 TBool G2 TBool
| stp_fun: forall G1 G2 T1 T2 T3 T4,
    stp G2 T3 G1 T1 ->
    stp G1 T2 G2 T4 ->
    stp G1 (TFun T1 T2) G2 (TFun T3 T4)
.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v

Could use do-notation to clean up syntax.
 *)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs y     => Some (Some (vabs env y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vbool _)) => Some None
                | Some (Some (vabs env2 ey)) =>
                  teval n (vx::(vabs env2 ey)::env2) ey
              end
          end
      end
  end.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
Hint Constructors val_type.
Hint Constructors wf_env.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

Lemma wf_length : forall vs ts,
                    wf_env vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_env in H1. auto.
Qed.

Hint Immediate wf_length.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Lemma valtp_extend : forall vs v v1 T,
                       val_type vs v T ->
                       val_type (v1::vs) v T.
Proof. intros. induction H; eauto. Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type vs v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto. eapply valtp_extend; eauto.
Qed.

Inductive res_type: venv -> option vl -> ty -> Prop :=
| not_stuck: forall venv v T,
      val_type venv v T ->
      res_type venv (Some v) T.

Hint Constructors res_type.
Hint Resolve not_stuck.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stp H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros. inversion H; inversion H0; subst T2; subst; eauto. inversion H9. inversion H9.
  admit.
Qed.

Lemma invert_abs: forall venv vf vx T1 T2,
  val_type venv vf (TFun T1 T2) ->
  exists env tenv y T3 T4,
    vf = (vabs env y) /\
    wf_env env tenv /\
    has_type (T3::(TFun T3 T4)::tenv) y T4 /\
    stp venv T1 (vx::vf::env) T3 /\
    stp (vx::vf::env) T4 venv T2.
Proof.
  intros. inversion H. repeat eexists; repeat eauto. admit. admit.
Qed.

(* if not a timeout, then result not stuck and well-typed *)

Theorem full_safety : forall n e tenv venv res T,
  teval n venv e = Some res -> has_type tenv e T -> wf_env venv tenv ->
  res_type venv res T.

Proof.
  intros n. induction n.
  (* 0 *)   intros. inversion H.
  (* S n *) intros. destruct e; inversion H; inversion H0.

  Case "True".  eapply not_stuck. eapply v_bool.
  Case "False". eapply not_stuck. eapply v_bool.

  Case "Var".
    destruct (index_safe_ex venv0 tenv0 T i) as [v [I V]]; eauto.

    rewrite I. eapply not_stuck. eapply V.

  Case "App".
    remember (teval n venv0 e1) as tf.
    remember (teval n venv0 e2) as tx.
    subst T.

    destruct tx as [rx|]; try solve by inversion.
    assert (res_type venv0 rx T1) as HRX. SCase "HRX". subst. eapply IHn; eauto.
    inversion HRX as [? vx].

    destruct tf as [rf|]; subst rx; try solve by inversion.
    assert (res_type venv0 rf (TFun T1 T2)) as HRF. SCase "HRF". subst. eapply IHn; eauto.
    inversion HRF as [? vf].

    destruct (invert_abs venv0 vf vx T1 T2) as
        [env1 [tenv [y0 [T3 [T4 [EF [WF [HTY [STX STY]]]]]]]]]. eauto.
    (* now we know it's a closure, and we have has_type evidence *)

    assert (res_type (vx::vf::env1) res T4) as HRY.
      SCase "HRY".
        subst. eapply IHn. eauto. eauto.
        (* wf_env f x *) econstructor. eapply valtp_widen; eauto.
        (* wf_env f   *) econstructor. eapply v_abs; eauto.
        eauto.

    inversion HRY as [? vy].

    eapply not_stuck. eapply valtp_widen; eauto.

  Case "Abs". intros. inversion H. inversion H0.
    eapply not_stuck. eapply v_abs; eauto.
Qed.

End STLC.


From Undecidability.LambdaCalculus Require Import wCBN Util.term_facts.
Import L.L (term, var, app, lam).
Require Import Undecidability.L.Util.L_facts.
Import wCBN (subst, step, stepApp, stepLam).
Require Import Relations Lia.
Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Inductive stepLam_spec s t : term -> Prop :=
  | stepLam_spec_intro : stepLam_spec s t (subst (scons t var) s).
Inductive stepApp_spec s t : term -> Prop :=
  | stepApp_spec_intro : forall s', step s s' -> stepApp_spec s t (app s' t).

Lemma stepE {s t} : step s t ->
  match s with
  | app (lam s') t' => stepLam_spec s' t' t
  | app s' t' => stepApp_spec s' t' t
  | _ => False
  end.
Proof. by elim; [|case]. Qed.

Lemma step_fun s t1 t2 : step s t1 -> step s t2 -> t1 = t2.
Proof.
  move=> H. elim: H t2.
  - by move=> > /stepE [].
  - case.
    + by move=> > /stepE.
    + by move=> > ? IH ? /stepE [] ? /IH ->.
    + by move=> > /stepE.
Qed.

Lemma step_bound s k t : step s t -> bound k s -> bound k t.
Proof.
  elim.
  - move=> > /boundE [/boundE /bound_subst +] ?. apply.
    move=> [|n] /=; first done.
    move=> ?. constructor. lia.
  - move=> > ? ? /boundE [? ?].
    constructor; by auto with nocore.
Qed.

Lemma stepLam' s t t' : t' = (subst (scons t var) s) -> step (app (lam s) t) t'.
Proof. move=> ->. by apply: stepLam. Qed.

Lemma step_closed s t : step s t -> closed s -> closed t.
Proof. by move=> /step_bound + /closed_dcl => /[apply] /closed_dcl. Qed.

Lemma steps_bound k {s t} : clos_refl_trans term step s t -> bound k s -> bound k t.
Proof. elim; by eauto using step_bound. Qed.

Lemma closed_halt_iff {t} : closed t -> ((exists t', t = lam t') <-> (forall u, not (step t u))).
Proof.
  intros Ht. split. { by move=> [? ->] ? /stepE. }
  suff: (forall s t, closed s -> closed t -> exists u, step (app s t) u).
  { case: t Ht.
    - by move=> ? /not_closed_var.
    - move=> s t /closed_app [++] H => /H /[apply].
      by move=> [u] Hu /(_ u Hu).
    - move=> *. by eexists. }
  elim.
  - by move=> > /not_closed_var.
  - move=> ? IH1 ? IH2 ? /closed_app [/IH1] /[apply].
    move=> [u Hu] ?. eexists. apply: stepApp. by eassumption.
  - move=> *. eexists. by apply: stepLam.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal70.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq natural (count (insort (Nil) (Zero)) (Zero)) (Succ (count (Nil) (Zero)))).
Admitted.
QuickChick lfind_hyp_test.


Require Import
  Pact.Lib
  Pact.Ty.

Open Scope Ty_scope.

Inductive Builtin : Ty → Set :=
  | AddInt : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | SubInt : Builtin (ℤ ⟶ ℤ ⟶ ℤ).

Derive Signature NoConfusion NoConfusionHom Subterm EqDec for Builtin.

(*

Inductive Builtin : Ty → Set :=
  (* IntOps *)
  (* Integer Add *)
  | AddInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Int Num functions *)
  | SubInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | DivInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | MulInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NegateInt        : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | AbsInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Int fractional *)
  | ExpInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LnInt            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | SqrtInt          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LogBaseInt       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* General int ops *)
  | ModInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | BitAndInt        : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | BitOrInt         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | BitXorInt        : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | BitShiftInt      : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | BitComplementInt : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Int show instance *)
  | ShowInt          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Int Equality *)
  | EqInt            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NeqInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | GTInt            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | GEQInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LTInt            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LEQInt           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* If *)
  | IfElse           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Decimal ops *)
  (* Decimal add *)
  | AddDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Decimal num *)
  | SubDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | DivDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | MulDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NegateDec        : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | AbsDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Decimal rounding ops *)
  | RoundDec         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | CeilingDec       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | FloorDec         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Decimal rounding ops *)
  | ExpDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LnDec            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LogBaseDec       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | SqrtDec          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Decimal Show *)
  | ShowDec          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Decimal Equality *)
  | EqDec            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NeqDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Decimal ord *)
  | GTDec            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | GEQDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LTDec            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LEQDec           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Bool Comparisons *)
  | AndBool          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | OrBool           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NotBool          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* other bool ops *)
  | EqBool           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NeqBool          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | ShowBool         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* String Equality *)
  | EqStr            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NeqStr           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* String Ord *)
  | GTStr            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | GEQStr           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LTStr            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LEQStr           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
   (* String Add *)
  | AddStr           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* String ListLike *)
  | ConcatStr        : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | DropStr          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | TakeStr          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LengthStr        : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | ReverseStr       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* String Show *)
  | ShowStr          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Object equality *)
  | EqObj            : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NeqObj           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* List Equality *)
  | EqList           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NeqList          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* List Ord *)
  | GTList           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | GEQList          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LTList           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LEQList          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* List Show *)
  | ShowList         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* List Add *)
  | AddList          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* ListLike List *)
  | TakeList         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | DropList         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | LengthList       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | ConcatList       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | ReverseList      : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Misc list ops *)
  | FilterList       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | DistinctList     : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | MapList          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | ZipList          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | FoldList         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Unit ops *)
  | EqUnit           : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | NeqUnit          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | ShowUnit         : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  (* Others *)
  | Enforce          : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | EnforceOne       : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | Enumerate        : Builtin (ℤ ⟶ ℤ ⟶ ℤ)
  | EnumerateStepN   : Builtin (ℤ ⟶ ℤ ⟶ ℤ).

*)