Require Import Coq.Lists.List.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.micromega.Psatz.
Require Export Coq.ZArith.ZArith.
Require Export Coq.Strings.String.
Require Export Coq.Logic.Classical.
Require Import Permutation.
Require Import ListDec.
Require Import FL.Mobius_Definition.
Require Import FL.Mobius_Lemmas.

Module Lemma2.
Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).

Import Def.

Import Lemmas.

(* 定理2证明的关键引理， 描述 x sub Y -> x0 sub Y -> PowerSet Y 中有唯一元素 y, 满足 x cup x0 = y *)
Lemma Summ_Test_Union_Eq: forall (x x0 Y: list nat),
In x (PowerSet Y) -> In x0 (PowerSet Y) -> NoDup Y ->
Summ_Of_List (list nat) (test_eq_union_Z x x0) (PowerSet Y) = 1%Z.
Proof.
  intros.
  remember (filter (test_in_union_b x x0) Y) as l.
  assert (subseq l Y). { rewrite Heql. pose proof filter_subseq _ Y (test_in_union_b x x0). tauto. }
  apply inpowerset_subseq_eq in H2 as H3.
  apply Per_add in H3 as H4; destruct H4 as [PY' ?].
  pose proof Permutation_Summ _ _ _ (test_eq_union_Z x x0) H4.
  rewrite <- H5.
  simpl.
  assert (Eq_Union x x0 l).
  {
    unfold Eq_Union; intros.
    split; intros.
    - apply Test_In_Union_b in H6 as H7.
      rewrite Heql.
      apply filter_In; split; [ | tauto].
      destruct H6.
      -- apply inpowerset_subseq_eq in H.
         eapply subseq_in; [apply H| tauto].
      -- apply inpowerset_subseq_eq in H0.
         eapply subseq_in; [apply H0| tauto].
    - rewrite Heql in H6.
      apply filter_In in H6; destruct H6.
      apply Test_In_Union_b in H7; tauto.
  }
  pose proof Test_Eq_Union_Z x x0 l; destruct H7.
  apply H7 in H6 as H9.
  rewrite H9.
  assert (Summ_Of_List (list nat) (test_eq_union_Z x x0) PY' = 0%Z).
  {
    rewrite Summ_f_g with (g:= fun l': list nat => 0%Z).
    apply F_zero_summ_zero.
    intros.
    pose proof Test_Eq_Union_Z x x0 x1; destruct H11.
    destruct (classic (Eq_Union x x0 x1)); [ | apply H12 in H13; tauto].
    unfold Eq_Union in H6, H13.
    assert (forall n:nat, In n x1 <-> In n l).
    {
      intros; split; intros.
      - apply H13 in H14.
        apply H6 in H14; tauto.
      - apply H6 in H14;
        apply H13 in H14; tauto.
    }
    assert (NoDup l). { eapply PowerSet_Element_NoDup. apply H1. tauto. }
    assert (NoDup x1).
    {
      eapply PowerSet_Element_NoDup.
      apply H1.
      eapply Permutation_in; [apply H4 | apply in_cons; tauto].
    }
    assert (In x1 (PowerSet Y)). {eapply Permutation_in; [apply H4 | apply in_cons; tauto]. }
    pose proof NoDup_NoPer Y H1 l x1 H3 H17.
    destruct H18.
    - assert (NoDup (l :: PY')). { eapply Permutation_NoDup. apply Permutation_sym, H4. apply PowerSet_NoDup; tauto. }
      rewrite <- H18 in H10.
      apply NoDup_cons_iff in H19; tauto.
    - pose proof NoDup_Permutation H16 H15 H14.
      apply Permutation_sym in H19; tauto.
  }
  rewrite H10.
  lia.
Qed.

End Lemma2.


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

Monomials and partitions:

- [mpart s] == the multi-monomial whose exponent are [s] if [size s] is smaller
           than the number of variables.
- [partm m] == the partition obtained by sorting the exponent of [m].
- [m \is dominant] == the exponent of [m] are sorted in reverse order.

Antisymmetric polynomials:

- [p \is antisym] == [p] is an antisymmetric polynomial. This is a keyed predicate
           closed by submodule operations [submodPred].

Vandermonde products and determinants:

- [alternpol f] == the alternating sunm of the permuted of f.
- [rho]            == the multi-monomial [[n-1, n-2, ..., 1, 0]]
- [Vanprod n R] == the Vandermonde product in [{mpoly R[n]}], that is the product
                 << \prod_(i < j) ('X_i - 'X_j) >>.

- [antim s]     == the n x n - matrix whose (i, j) coefficient is
                 << 'X_i^(s j - rho j) >>
- [Vanmx]       == the Vandermonde matrix << 'X_i^(n - 1 - j) = 'X_i^(rho j) >>.
- [Vandet]      == the Vandermonde determinant

The main results are the Vandermonde determinant expansion:

- [ Vanprod_alt     : Vanprod = alternpol 'X_[(rho n)] ]
- [ Vandet_VanprodE : Vandet = Vanprod ]

*******************************************************************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq path choice.
From mathcomp Require Import finset fintype finfun tuple bigop ssralg ssrint.
From mathcomp Require Import fingroup perm zmodp binomial order.
From SsrMultinomials Require Import ssrcomplements freeg mpoly.

Require Import tools permcomp presentSn sorted partition.

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

Import LeqGeqOrder.

Local Reserved Notation "''a_' k"
      (at level 8, k at level 2, format "''a_' k").
Local Reserved Notation "m # s"
      (at level 40, left associativity, format "m # s").

Local Notation "''II_' n" := ('I_n * 'I_n)%type (at level 8, n at level 2).

Open Scope group_scope.
Open Scope nat_scope.

(** ** monomials and partitions *)
Section MonomPart.

Variable n : nat.
Implicit Type m : 'X_{1.. n}.

Definition dominant : qualifier 0 'X_{1.. n} :=
  [qualify m : 'X_{1.. n} | sorted geq m].
Definition mpart (s : seq nat) :=
  if size s <= n then [multinom (nth 0 s i)%N | i < n] else mnm0.

Lemma dominant_eq m1 m2 :
  m1 \is dominant -> m2 \is dominant -> perm_eq m1 m2 -> m1 = m2.
Proof.
rewrite !unfold_in => /sorted_eq H{}/H H{}/H Heq.
by apply/val_inj/val_inj; apply Heq.
Qed.

Fact partmP m : is_part (sort geq [seq d <- m | d != 0]).
Proof.
rewrite is_part_sortedE; apply/andP; split.
- exact: sort_sorted.
- by rewrite mem_sort mem_filter eq_refl.
Qed.
Definition partm m := locked (IntPart (partmP m)).
Lemma partmE m : partm m = sort geq [seq d <- m | d != 0] :> seq nat.
Proof. by rewrite /partm; unlock. Qed.

Lemma size_partm m : size (partm m) <= n.
Proof.
rewrite partmE size_sort size_filter -[X in _ <= X](size_tuple m).
exact: count_size.
Qed.

Lemma mpart_is_dominant sh : is_part sh -> mpart sh \is dominant.
Proof.
rewrite /mpart /dominant; case: leqP => [Hsz|_ _].
- rewrite is_part_sortedE => /andP [Hpart _].
  + apply/(sortedP 0) => // i j; rewrite size_tuple => /andP [Hij Hj].
    have Hi := leq_ltn_trans Hij Hj.
    rewrite -[i]/(val (Ordinal Hi)) -[j]/(val (Ordinal Hj)) -!mnm_nth !mnmE /=.
    case: (ssrnat.ltnP j (size sh)) => [Hjsz | /(nth_default _) -> //].
    by apply: (sortedP _ _ _ _ Hpart) => //; rewrite Hij Hjsz.
- apply/(sortedP 0) => // i j; rewrite size_tuple => /andP [Hij Hj] /=.
  by rewrite (nth_map (Ordinal Hj)) // -cardE card_ord.
Qed.

Lemma is_dominant_partm m :
  m \is dominant -> partm m = [seq d <- m | d != 0] :> seq nat.
Proof.
rewrite unfold_in partmE => Hsort.
apply: (sorted_eq (leT := geq)) => //.
- exact: sort_sorted.
- exact: sorted_filter.
- by rewrite perm_sort.
Qed.

Lemma is_dominant_nth_partm m (i : 'I_n) :
  m \is dominant -> nth 0 (partm m) i = m i.
Proof.
move=> Hdom; rewrite (is_dominant_partm Hdom).
case: m Hdom => [[s Hs /=]].
rewrite unfold_in (mnm_nth 0) /=.
case: i => [i /= _] {Hs}; elim: s i => [| s0 s IHs] i // Hsort /=.
case: (altP (s0 =P 0)) Hsort => [->{s0} /= {IHs} Hpath|_].
- have -> : s = nseq (size s) 0.
    elim: s Hpath => [//= | s0 s IHs] /= /andP [].
    by rewrite leqn0 => /eqP -> /IHs {1}->.
  rewrite (eq_in_filter (a2 := pred0)) ?filter_pred0; first last.
    by move=> x /nseqP [-> _].
  by case: i => //= i; rewrite nth_nseq if_same.
- move=> /sorted_consK/IHs {IHs} /= Hrec.
  by case: i.
Qed.

Lemma partmK m : m \is dominant -> mpart (partm m) = m.
Proof.
move=> Hdom; rewrite /mpart size_partm.
by apply/mnmP => i; rewrite mnmE is_dominant_nth_partm.
Qed.

Lemma mpartK sh :
  is_part sh -> size sh <= n -> partm (mpart sh) = sh :> seq nat.
Proof.
move=> Hpart Hsize; apply/eqP/part_eqP => // i.
case: (ssrnat.ltnP i n) => Hi.
- have /is_dominant_nth_partm Hdom := mpart_is_dominant Hpart.
  have:= Hdom (Ordinal Hi) => /= ->.
  by rewrite /mpart Hsize mnmE /=.
- rewrite !nth_default //; apply: leq_trans _ Hi => //.
  exact: size_partm.
Qed.

Lemma mpartE s i : size s <= n -> mpart s i = nth 0 s i.
Proof. by rewrite /mpart => ->; rewrite mnmE. Qed.

Lemma mpart0 : @mpart [::] = 0%MM.
Proof. by apply mnmP => i; rewrite /mpart /= mnmE mnm0E nth_default. Qed.

Lemma perm_mpart s1 s2 : perm_eq s1 s2 -> perm_eq (mpart s1) (mpart s2).
Proof.
move=> Hperm; have Hsz := perm_size Hperm; rewrite /mpart -Hsz.
case: leqP => Hszle; last exact: perm_refl.
apply/seq.permP => P.
have H s : size s <= n ->
           count P [multinom nth 0 s i | i < n] =
           count P s + \sum_(i < n | (P 0) && ~~(i < size s)) 1.
  move=> {}Hsz.
  rewrite -!sum1_count /= big_map enumT -/(index_enum _).
  rewrite (bigID (fun i : 'I_n => i < size s)) /=; congr (_ + _).
  - rewrite (big_nth 0) big_mkord.
    by rewrite (big_ord_widen_cond n (fun i => P (nth 0 s i)) (fun => 1)).
  - apply eq_bigl => i; rewrite [LHS]andbC [RHS]andbC.
    by case: (ssrnat.ltnP i (size s)) => //= H; rewrite nth_default.
by rewrite !{}H -?Hsz // -(seq.permP Hperm).
Qed.

Lemma perm_partm m1 m2 : perm_eq m1 m2 -> partm m1 = partm m2.
Proof.
move=> Hperm; apply val_inj; rewrite /= !partmE; apply/perm_sortP => //.
exact: perm_filter.
Qed.

Lemma partm_permK m : perm_eq m (mpart (partm m)).
Proof.
have Hsm : size (sort geq m) == n by rewrite size_sort size_tuple.
pose sm := [multinom Tuple Hsm].
have Hperm : perm_eq sm m by rewrite /= perm_sort.
rewrite -(perm_partm Hperm) partmK; first last.
  by rewrite unfold_in; apply: sort_sorted.
by rewrite perm_sym.
Qed.

Lemma sumn_mpart sh : size sh <= n -> sumn (mpart sh) = sumn sh.
Proof.
move=> Hsz; rewrite /mpart Hsz !sumnE big_tuple.
under [LHS]eq_bigr do rewrite tnth_mktuple.
rewrite (big_nth 0) big_mkord (big_ord_widen _ _ Hsz).
rewrite (bigID (fun i : 'I_n => i < size sh)) /= addnC big1 ?add0n //.
by move=> i; rewrite -leqNgt; apply: nth_default.
Qed.

Lemma mdeg_mpart sh : size sh <= n -> mdeg (mpart sh) = sumn sh.
Proof. by move/sumn_mpart => <-; rewrite sumnE -/(mdeg _). Qed.

Lemma sumn_partm m : sumn (partm m) = mdeg m.
Proof.
rewrite sumnE.
wlog: m / m \is dominant.
  move=> Hdom; have Hperm := partm_permK m.
  rewrite /mdeg (perm_big _ Hperm) /= -/(mdeg _).
  have /Hdom <- := mpart_is_dominant (intpartP (partm m)).
  by rewrite mpartK // size_partm.
move/is_dominant_partm ->.
symmetry; rewrite big_filter /mdeg.
by rewrite (bigID (fun i => i == 0)) /= big1 ?add0n // => i /eqP.
Qed.

Local Notation "m # s" := [multinom m (s i) | i < n].

Lemma mnm_perm m1 m2 : perm_eq m1 m2 -> {s : 'S_n | m1 == m2 # s}.
Proof.
move=> Hperm; apply sigW; move: Hperm => /tuple_permP [s /val_inj Hs] /=.
by exists s; apply/eqP; apply val_inj => /=.
Qed.

Lemma perm_mpart_partm m : {s : 'S_n | (mpart (partm m)) # s == m}.
Proof.
apply sigW; have [/= s /eqP {2}->] := mnm_perm (partm_permK m).
by exists s.
Qed.

Lemma mpart_partm_perm m : {s : 'S_n | (mpart (partm m)) == m # s}.
Proof.
have [/= s /eqP {2}<-]:= perm_mpart_partm m.
exists (s^-1); apply/eqP/mnmP => i.
by rewrite 2!mnmE permKV.
Qed.

End MonomPart.

Arguments mpart [n] s.
Arguments dominant {n}.

Import GRing.Theory.
Local Open Scope ring_scope.
Local Definition simplexp := (expr0, expr1, scale1r, scaleN1r,
                              mulrN, mulNr, mulrNN).

(** ** Change of scalar in multivariate polynomials *)
Section ScalarChange.

Variables R S : ringType.
Variable mor : {rmorphism R -> S}.
Variable n : nat.

Lemma map_mpolyX (m : 'X_{1..n}) : map_mpoly mor 'X_[m] = 'X_[m].
Proof using.
by rewrite /= /map_mpoly mmapX /= /mmap1 mprodXnE -multinomUE_id.
Qed.

Lemma msym_map_mpoly s (p : {mpoly R[n]}) :
  msym s (map_mpoly mor p) = map_mpoly mor (msym s p).
Proof using.
rewrite (mpolyE p).
rewrite [map_mpoly _ _]raddf_sum [msym s _]raddf_sum.
rewrite [msym s _]raddf_sum [map_mpoly _ _]raddf_sum.
apply eq_bigr => i _ /=; apply/mpolyP => m.
by rewrite mcoeff_map_mpoly /= !mcoeff_sym mcoeff_map_mpoly.
Qed.

End ScalarChange.

(** ** Characteristic of multivariate polynomials *)
Lemma char_mpoly n (R : ringType) : [char R] =i [char {mpoly R[n]}].
Proof using.
move=> p; rewrite !unfold_in /= -mpolyC_nat.
case: (prime.prime p) => //=.
apply/eqP/eqP => [-> //|].
rewrite -(mpolyP) => /(_ 0%MM).
by rewrite mcoeff0 raddfMn /= mcoeffMn mcoeff1 eq_refl /= => ->.
Qed.

(** * Symmetric and Antisymmetric multivariate polynomials *)
Section MPolySym.

Variable n : nat.
Variable R : ringType.

Implicit Types p q r : {mpoly R[n]}.

Lemma issym_tpermP p :
  reflect (forall i j, msym (tperm i j) p = p) (p \is symmetric).
Proof using.
apply/(iffP forallP) => /= [Hsym i j | Htperm s].
- by rewrite (eqP (Hsym (tperm _ _))).
- case: (prod_tpermP s) => ts -> {s} Hall.
  elim: ts Hall => [_ | t0 ts IHts] /=.
    by rewrite !big_nil /= msym1m.
  move=> /andP [_ /IHts{IHts}/eqP Hrec].
  by rewrite !big_cons msymMm Htperm Hrec.
Qed.

Definition antisym : qualifier 0 {mpoly R[n]} :=
  [qualify p | [forall s, msym s p == (-1) ^+ s *: p]].

Fact antisym_key : pred_key antisym. Proof using. by []. Qed.
Canonical antisym_keyed := KeyedQualifier antisym_key.

Lemma isantisymP p :
  reflect (forall s, msym s p = (-1) ^+ s *: p) (p \is antisym).
Proof using. by apply/(iffP forallP) => /= H s; apply/eqP/H. Qed.

Lemma isantisym_tpermP p :
  reflect (forall i j, msym (tperm i j) p = if (i != j) then - p else p)
          (p \is antisym).
Proof using.
apply/(iffP forallP) => /= [Hanti i j | Htperm s].
- rewrite (eqP (Hanti (tperm _ _))) odd_tperm.
  by case: (i != j); rewrite !simplexp.
- case: (prod_tpermP s) => ts -> {s} Hall.
  elim: ts Hall => [_ | t0 ts IHts] /=.
    by rewrite !big_nil odd_perm1 /= msym1m expr0 scale1r.
  move=> /andP [H0 /IHts{IHts}/eqP Hrec].
  rewrite !big_cons msymMm Htperm H0 msymN Hrec.
  rewrite odd_mul_tperm H0 /=.
  by case: (odd_perm _); rewrite !simplexp // opprK.
Qed.

Lemma antisym_char2 : (2 \in [char R]) -> symmetric =i antisym.
Proof using.
move=> Hchar p /=; apply/issymP/isantisymP => H s;
  by rewrite H oppr_char2; first rewrite expr1n scale1r.
Qed.

Lemma perm_smalln : n <= 1 -> forall s : 'S_n, s = 1%g.
Proof using.
by case: n => [|[|//]] _ s; [rewrite (permS0 s) | rewrite (permS1 s)].
Qed.

Lemma sym_smalln : n <= 1 -> (@symmetric n R) =i predT.
Proof using.
move=> Hn p /=; rewrite [RHS]unfold_in /=.
apply/issymP => s.
by rewrite (perm_smalln Hn s) msym1m.
Qed.

Lemma antisym_smalln : n <= 1 -> antisym =i predT.
Proof using.
move=> Hn p /=; rewrite [RHS]unfold_in /=.
apply/isantisymP => s.
by rewrite (perm_smalln Hn s) odd_perm1 msym1m expr0 scale1r.
Qed.

Lemma antisym_zmod : zmod_closed antisym.
Proof using.
split=> [|p q /isantisymP sp /isantisymP sq]; apply/isantisymP=> s.
  by rewrite msym0 scaler0.
by rewrite msymB sp sq scalerBr.
Qed.

Canonical antisym_opprPred := OpprPred antisym_zmod.
Canonical antisym_addrPred := AddrPred antisym_zmod.
Canonical antisym_zmodPred := ZmodPred antisym_zmod.

Lemma antisym_submod_closed : submod_closed antisym.
Proof using.
split=> [|c p q /isantisymP sp /isantisymP sq]; apply/isantisymP=> s.
  by rewrite msym0 scaler0.
rewrite msymD msymZ sp sq.
by rewrite scalerA commr_sign -scalerA scalerDr.
Qed.

Canonical antisym_submodPred := SubmodPred antisym_submod_closed.

Lemma sym_anti p q :
  p \is antisym -> q \is symmetric -> p * q \is antisym.
Proof using.
move=> /isantisymP Hsym /issymP Hanti.
apply/isantisymP => s.
rewrite msymM Hsym Hanti.
by case: (odd_perm _); rewrite !simplexp.
Qed.

Lemma anti_anti p q :
  p \is antisym -> q \is antisym -> p * q \is symmetric.
Proof using.
move=> /isantisymP Hp /isantisymP Hq.
apply/issymP => s; rewrite msymM Hp Hq.
by case: (odd_perm _); rewrite !simplexp // opprK.
Qed.

Local Notation "m # s" := [multinom m (s i) | i < n].

Lemma isantisym_msupp p (s : 'S_n) (m : 'X_{1..n}) : p \is antisym ->
  (m#s \in msupp p) = (m \in msupp p).
Proof using.
rewrite !mcoeff_msupp -mcoeff_sym => /isantisymP ->.
case: (odd_perm s); last by rewrite expr0 scale1r.
rewrite expr1 scaleN1r !mcoeff_eq0.
by rewrite (perm_mem (msuppN _)).
Qed.

Import Order Order.Syntax Order.TotalTheory.

Lemma mlead_antisym_sorted (p : {mpoly R[n]}) : p \is antisym ->
  forall (i j : 'I_n), i <= j -> (mlead p) j <= (mlead p) i.
Proof using.
move=> sym_p i j le_ij; have [->|nz_p] := eqVneq p 0.
  by rewrite mlead0 !mnm0E.
set m := mlead p; case: leqP=> // h.
pose s := tperm i j; pose ms := m#s; have: (m < ms)%O.
  apply/ltmcP; first by rewrite mdeg_mperm.
  exists i=> [k lt_ki|]; last by rewrite mnmE tpermL.
  rewrite mnmE tpermD // neq_ltn orbC ?lt_ki //.
  by move/leq_trans: lt_ki => /(_ _ le_ij) ->.
have: ms \in msupp p by rewrite isantisym_msupp // mlead_supp.
by move/msupp_le_mlead; rewrite leNgt => /negbTE ->.
Qed.

End MPolySym.

Arguments antisym {n R}.

Lemma issym_eltrP n (R : ringType) (p : {mpoly R[n.+1]}) :
  reflect (forall i, i < n -> msym 's_i p = p) (p \is symmetric).
Proof.
apply/(iffP forallP) => /= [Hanti i Hi | Heltr].
- by have /eqP -> := Hanti 's_i.
- elim/eltr_ind => [| S i Hi /eqP IH].
  + by rewrite msym1m.
  + by rewrite msymMm (Heltr i Hi) IH.
Qed.

Lemma isantisym_eltrP n (R : ringType) (p : {mpoly R[n.+1]}) :
  reflect (forall i, i < n -> msym 's_i p = - p) (p \is antisym).
Proof.
apply/(iffP forallP) => [Hanti i Hi | Heltr].
- have /eqP -> := Hanti 's_i.
  by rewrite odd_tperm (inordi_neq_i1 Hi) !simplexp.
- elim/eltr_ind => [| S i Hi /eqP IH].
  + by rewrite odd_perm1 /= msym1m !simplexp.
  + rewrite msymMm (Heltr i Hi).
    rewrite msymN IH odd_mul_tperm (inordi_neq_i1 Hi) addTb.
    by case: (odd_perm _); rewrite !simplexp // opprK.
Qed.

(** * Alternating polynomials *)
Definition alternpol n (R : ringType) (f : {mpoly R[n]}) : {mpoly R[n]} :=
  \sum_(s : 'S_n) (-1) ^+ s *: msym s f.

Section AlternIDomain.

Variable n : nat.
Variable R : idomainType.
Hypothesis Hchar : ~~ (2 \in [char R]).

Local Notation "''a_' k" := (@alternpol n R 'X_[k]).
Local Notation "m # s" := [multinom m (s i) | i < n].

Lemma sym_antisym_char_not2 :
  n >= 2 -> forall p : {mpoly R[n]}, p \is symmetric -> p \is antisym -> p = 0.
Proof using Hchar.
move=>  Hn p /= /issymP Hsym /isantisymP Hanti.
move: Hchar; rewrite (char_mpoly n R) => Hchp.
pose s := tperm (Ordinal (ltnW Hn)) (Ordinal Hn).
have:= Hanti s; rewrite Hsym.
rewrite odd_tperm /= => /eqP; rewrite !simplexp -addr_eq0.
rewrite -mulr2n -mulr_natr mulf_eq0 => /orP [/eqP -> //|] /= /eqP /= H2.
by exfalso; move: Hchp; rewrite negb_and H2 eq_refl.
Qed.

Definition rho := [multinom (n - 1 - i)%N | i < n].

Lemma rho_iota : rho = rev (iota 0 n) :> seq nat.
Proof using.
apply (eq_from_nth (x0 := 0%N)).
  by rewrite size_rev size_iota size_map size_enum_ord.
move=> i; rewrite size_map size_enum_ord => Hi.
rewrite nth_rev size_iota // (nth_map (Ordinal Hi)); last by rewrite size_enum_ord.
rewrite nth_enum_ord // nth_iota; first last.
  by case: n Hi => [// | m] _; rewrite ltnS subSS; apply: leq_subr.
by rewrite add0n; case: n Hi => [// | m] _; rewrite !subSS subn0.
Qed.

Lemma rho_uniq : uniq rho.
Proof using .
suff : perm_eq rho (iota 0 n) by move/perm_uniq ->; exact: iota_uniq.
by rewrite rho_iota perm_sym -perm_rev.
Qed.

Lemma mdeg_rho : mdeg rho = 'C(n, 2).
Proof.
rewrite /mdeg binomial_sumn_iota sumnE.
by apply: perm_big; rewrite rho_iota perm_sym -perm_rev.
Qed.

Lemma alt_homog : 'a_(rho) \is 'C(n, 2).-homog.
Proof using.
apply rpred_sum => s _; rewrite rpredZsign msymX dhomogX /=.
have -> : mdeg (rho#(s^-1)%g) = mdeg rho.
  by rewrite /mdeg; apply/perm_big/tuple_permP; exists (s^-1)%g.
by rewrite mdeg_rho.
Qed.

Lemma alt_anti m : 'a_m \is antisym.
Proof using.
apply/isantisymP => S.
rewrite /alternpol (big_morph (msym S) (@msymD _ _ _) (@msym0 _ _ _)).
rewrite scaler_sumr.
rewrite [RHS](reindex_inj (mulIg S)); apply: eq_big => //= s _.
rewrite msymZ -msymMm scalerA; congr (_ *: _).
by rewrite odd_permM signr_addb [X in (_  = _ * X)]mulrC signrMK.
Qed.

(** ** The leading monomial of an antisymmetric polynomial *)
Section LeadingMonomial.

Variable p : {mpoly R[n]}.

Implicit Types q r : {mpoly R[n]}.

Hypothesis Hpn0 : p != 0.
Hypothesis Hpanti : p \is antisym.

Lemma sym_antiE q : (q \is symmetric) = (p * q \is antisym).
Proof using Hpanti Hpn0.
case: (leqP n 1) => Hn; first by rewrite !(sym_smalln Hn) !(antisym_smalln Hn).
apply/idP/idP; first exact: sym_anti Hpanti.
move: Hpanti => /isantisymP Hsym /isantisymP Hpq.
apply/issymP => s.
have:= Hpq s; rewrite msymM Hsym => H; apply (mulfI Hpn0).
move: H; case: (odd_perm s); rewrite !simplexp //.
by move/oppr_inj.
Qed.

Lemma isantisym_msupp_uniq (m : 'X_{1..n}) : m \in msupp p -> uniq m.
Proof using Hchar Hpanti.
rewrite mcoeff_msupp => Hsupp.
case: (boolP (uniq m)) => // /uniqPn => /(_ 0%N).
move=> [i] [j] []; rewrite size_tuple => Hi Hj Hnth.
move/isantisymP/(_ (tperm (Ordinal (ltn_trans Hi Hj)) (Ordinal Hj))) : Hpanti.
rewrite odd_tperm /eq_op /=.
rewrite (ltn_eqF Hi) expr1 scaleN1r.
move/(congr1 (mcoeff m)); rewrite mcoeffN mcoeff_sym.
have -> : m#tperm (Ordinal (ltn_trans Hi Hj)) (Ordinal Hj) = m.
  rewrite mnmP => k; rewrite mnmE.
  by case: (tpermP _ _ k) => [-> | -> |] //; rewrite !(mnm_nth 0) /= Hnth.
move/eqP; rewrite -addr_eq0.
rewrite -mulr2n -mulr_natr mulf_eq0.
move: Hchar; rewrite negb_and => /negbTE ->.
by move: Hsupp => /negbTE ->.
Qed.

Hypothesis Hphomog : p \is 'C(n , 2).-homog.

Lemma isantisym_mlead_iota : mlead p = rev (iota 0 n) :> seq nat.
Proof using Hchar Hpanti Hphomog Hpn0.
move: Hphomog; rewrite binomial_sumn_iota => /dhomogP Hhomog.
have Huniq := isantisym_msupp_uniq (mlead_supp Hpn0).
rewrite -(revK (mlead p)) -{4}(size_tuple (mlead p)) -size_rev; congr rev.
apply sorted_sumn_iotaE; first last.
  rewrite size_rev size_tuple sumn_rev sumnE -/(mdeg _).
  by rewrite (Hhomog _ (mlead_supp Hpn0)).
rewrite ltn_sorted_uniq_leq rev_uniq Huniq /=.
rewrite {Huniq Hhomog} rev_sorted.
apply/(sortedP 0%N) => // i j; rewrite size_tuple=> /andP [Hij Hj].
have H := mlead_antisym_sorted Hpanti.
have /= := H (Ordinal (leq_ltn_trans Hij Hj)) (Ordinal Hj) Hij.
by rewrite !(mnm_nth 0) /=; apply.
Qed.

Lemma isantisym_mlead_rho : mlead p = rho.
Proof using Hchar Hpanti Hphomog Hpn0.
by apply/val_inj/val_inj; rewrite /= isantisym_mlead_iota rho_iota.
Qed.

End LeadingMonomial.

Lemma isantisym_alt (p : {mpoly R[n]}) :
  p != 0 -> p \is antisym -> p \is ('C(n, 2)).-homog -> p = p@_(rho) *: 'a_rho.
Proof using Hchar.
move=> Hpn0 Hanti Hhom.
apply/eqP; rewrite -subr_eq0; apply contraT => Habs.
have /(isantisym_mlead_rho Habs) H : p - p@_(rho) *: 'a_(rho) \is antisym.
  by apply/(rpredD Hanti)/rpredNr/rpredZ/alt_anti.
move: Habs => /mlead_supp.
have /H{H} ->: p - p@_(rho) *: 'a_(rho) \is ('C(n, 2)).-homog.
  by apply/(rpredD Hhom)/rpredNr/rpredZ/alt_homog.
rewrite mcoeff_msupp linearB /= linearZ linear_sum /=.
rewrite (bigID (xpred1 1%g)) /= big_pred1_eq.
rewrite odd_perm1 /= expr0 scale1r msym1m mcoeffX eq_refl /=.
rewrite big1; first by rewrite addr0 mulr1 subrr eq_refl.
move=> s Hs; apply /eqP; move: Hs; apply contraR.
rewrite linearZ /= msymX mcoeffX.
case: (altP ( _ =P rho)); last by rewrite mulr0 eq_refl.
rewrite mnmP => H _; rewrite -eq_invg1; apply/eqP.
rewrite -permP => i; rewrite perm1.
move/(_ i) : H => /=.
rewrite /rho !mnm_tnth !tnth_mktuple !mnm_tnth !tnth_mktuple !subn1 => H.
rewrite -[LHS]rev_ordK -[RHS]rev_ordK; congr rev_ord.
apply val_inj => /=; rewrite !subnS.
by have:= ltn_ord i => /ltn_predK {1 5}<-; rewrite !subSKn.
Qed.

End AlternIDomain.

(** ** Vandermonde product *)
Definition Vanprod {n} {R : ringType} : {mpoly R[n]} :=
  \prod_(p : 'II_n | p.1 < p.2) ('X_p.1 - 'X_p.2).

Section EltrP.

Variable n i : nat.
Implicit Type (p : 'II_n.+1).

Local Definition eltrp p := ('s_i p.1, 's_i p.2).
Local Definition predi p := (p.1 < p.2) && (p != (inord i, inord i.+1)).

Lemma eltrpK : involutive eltrp.
Proof. by move=> [u v]; rewrite /eltrp !eltrK. Qed.

Lemma predi_eltrp p : i < n -> predi p -> predi (eltrp p).
Proof using.
move=> Hi.
have Hii1 : val (@inord n i.+1) = (@inord n i).+1.
  by do 2 (rewrite /= inordK; last by apply (leq_trans Hi)).
move: p => [u v] /=; rewrite /predi /= /eltrp => /andP [Hlt Hneq] /=.
case: (altP (inord i =P u)) => Hu.
  subst u; rewrite eltrL.
  case: (altP (v =P inord i.+1)) Hneq Hlt => [Hu | Hu _ Hlt].
    by subst v; rewrite /= eq_refl.
  rewrite eltrD; [| by rewrite neq_ltn Hlt | by rewrite eq_sym].
  apply/andP; split.
  - by rewrite ltn_neqAle eq_sym Hu /= Hii1.
  - rewrite /eq_op /= eq_sym; apply/nandP; left.
    by rewrite /eq_op /= Hii1 ieqi1F.
case: (altP (inord i.+1 =P u)) => Hu1.
  subst u; rewrite eltrR /=.
  rewrite eltrD; first last.
  - by move: Hlt; rewrite ltn_neqAle => /andP [].
  - move: Hlt; rewrite Hii1 => /ltnW.
    by rewrite ltn_neqAle => /andP [].
  apply/andP; split.
  - by apply: (ltn_trans _ Hlt); rewrite Hii1.
  - rewrite /eq_op /= eq_refl /= eq_sym.
    by move: Hlt; rewrite ltn_neqAle => /andP [].
rewrite (tpermD Hu Hu1); apply/andP; split; first last.
  by apply/nandP => /=; left; rewrite eq_sym.
case: (altP (inord i =P v)) => Hv.
  subst v; rewrite eltrL Hii1.
  by apply (leq_trans Hlt).
case: (altP (inord i.+1 =P v)) => Hv1.
  subst v; rewrite eltrR.
  by move: Hlt; rewrite Hii1 ltnS ltn_neqAle eq_sym Hu /=.
by rewrite eltrD.
Qed.

Lemma predi_eltrpE p : i < n -> predi p = predi ('s_i p.1, 's_i p.2).
Proof using.
move=> Hi; apply/idP/idP => [|H]; first exact: predi_eltrp.
by rewrite -(eltrpK p) predi_eltrp.
Qed.

End EltrP.

Lemma Vanprod_anti n (R : comRingType) : @Vanprod n R \is antisym.
Proof.
case: n => [| n].
  by apply/isantisymP => s; rewrite (permS0 s) msym1m odd_perm1 simplexp.
apply/isantisym_eltrP => i Hi.
rewrite /Vanprod.
rewrite (bigD1 (inord i, inord i.+1)) /=; first last.
  by rewrite !inordK //=; apply (leq_trans Hi).
rewrite msymM -mulNr; congr (_ * _).
  rewrite msymB opprB.
  by congr (_ - _); rewrite /msym mmapX mmap1U ?eltrL ?eltrR.
rewrite (big_morph _ (msymM 's_i) (msym1 _ 's_i)) /=.
under [LHS]eq_bigr do rewrite msymB /msym !mmapX !mmap1U.
under [LHS]eq_bigl => p do rewrite -/(predi i p) (predi_eltrpE p Hi).
rewrite /= -(big_map _ _ (fun p => ('X_p.1 - 'X_p.2))) /=.
set L := map _ _; suff Hin : perm_eq L (enum {: 'II_ n.+1}).
  by rewrite (perm_big _ Hin) big_enum_cond.
apply: uniq_perm.
- rewrite {}/L map_inj_uniq; first exact: index_enum_uniq.
  exact: (can_inj (eltrpK _)).
- exact: enum_uniq.
- rewrite /L => [[u v]]; rewrite mem_enum inE.
  rewrite -(eltrpK i (u,v)).
  by apply map_f; rewrite mem_index_enum.
Qed.

Lemma sym_VanprodM n (R : comRingType) (p : {mpoly R[n]}) :
  p \is symmetric -> Vanprod * p \is antisym.
Proof. by apply sym_anti; apply Vanprod_anti. Qed.

Section Vanprod.

Variable n : nat.
Variable R : comRingType.

Local Notation Delta := (@Vanprod n R).
Local Notation "'X_ i" := (@mpolyX n R U_(i)). (* Enforce the base ring *)
Local Notation rho := (rho n).
Local Notation "''a_' k" := (alternpol 'X_[k]).

Lemma polyX_inj (i j : 'I_n) : 'X_i = 'X_j -> i = j.
Proof using.
move/(congr1 (mcoeff U_(j))); rewrite !mcoeffX eq_refl /=.
case: (altP (_ =P _)) => [H _ | _ /esym /= /eqP] /=.
- have:= congr1 (fun x : 'X_{1..n} => x j) H.
  by rewrite !mnm1E eq_refl eq_sym; case: eqP.
- by have:= oner_neq0 R => /negbTE ->.
Qed.

Lemma diffX_neq0 (i j : 'I_n) : i != j -> 'X_i - 'X_j != 0.
Proof using. by apply contra; rewrite subr_eq0 => /eqP /polyX_inj ->. Qed.

Lemma msuppX1 i : msupp 'X_i = [:: U_(i)%MM].
Proof using. rewrite msuppE /= unlock /= domU //; exact: oner_neq0. Qed.

Let abound b  : {mpoly R[n]} :=
  \prod_(p : 'II_n | p.1 < p.2 <= b) ('X_p.1 - 'X_p.2).
Let rbound b := [multinom (b - i)%N | i < n].

Lemma mesymlm_rbound b : (mesymlm n b <= rbound b)%MM.
Proof using.
apply/mnm_lepP => i; rewrite !mnmE inE.
case (ssrnat.ltnP i b) => [/= Hb| //].
by rewrite subn_gt0.
Qed.

Lemma coeffXdiff (b : 'I_n) (k : 'X_{1..n}) (i : 'I_n) :
  (k <= rbound b)%MM -> ('X_i - 'X_b)@_k = (k == U_(i)%MM)%:R.
Proof using.
rewrite mcoeffB !mcoeffX => Hk.
suff -> : (U_(b)%MM == k) = false by rewrite subr0 eq_sym.
apply/negP => /eqP; rewrite mnmP => /(_ b).
rewrite mnm1E eq_refl => /esym /= => Hkb.
have {Hkb} : k b != 0%N by rewrite Hkb.
by rewrite -lep1mP => /lepm_trans/(_ Hk); rewrite lep1mP mnmE /= subnn eq_refl.
Qed.

Lemma coeff_prodXdiff (b : 'I_n) (k : 'X_{1..n}) :
  (k <= rbound b)%MM ->
  (\prod_(i < n | i < b) ('X_i - 'X_b))@_k = (k == mesymlm n b)%:R.
Proof using.
case: b => b /=.
elim: {1 5 7}b (leqnn b) k => [| c IHc] Hc k Hb Hk.
  rewrite big1 //.
  suff -> : mesymlm n 0 = 0%MM by rewrite mcoeff1.
  by rewrite mnmP => i; rewrite !mnmE /mesymlmnm inE ltn0.
set ordb := Ordinal Hb.
move/(_ (ltnW Hc)) : IHc => Hrec.
have Hcn := ltn_trans Hc Hb.
pose ordc := Ordinal Hcn.
rewrite (bigID (xpred1 ordc)) /=.
rewrite (eq_bigl (xpred1 ordc)); first last.
  move=> i /=; case: eqP => [->|]; last by rewrite andbF.
  by rewrite /= ltnSn.
rewrite (eq_bigl (fun i : 'I_n => i < c)); first last.
  by move=> i /=; rewrite ltnS ltn_neqAle [RHS]andbC.
rewrite big_pred1_eq.
rewrite (mcoeff_poly_mul_lin _ _ (k := (mdeg k).+2)) //.
case: (boolP (U_(ordc) <= k)%MM) => Hck.
- have ordc_bound : mdeg (U_(ordc))%MM < (mdeg k).+2 by rewrite mdeg1.
  pose mc := BMultinom ordc_bound; rewrite (bigID (xpred1 mc)) /=.
  rewrite (eq_bigl (xpred1 mc)); first last.
    move=> m /=; case eqP => [->|]; last by rewrite andbF.
    by rewrite /= Hck.
  rewrite big_pred1_eq /= coeffXdiff; last exact: lepm_trans Hck Hk.
  rewrite eq_refl mul1r {}Hrec; first last.
    apply: (lepm_trans _ Hk); apply/mnm_lepP => i.
    rewrite mnmBE; exact: leq_subr.
  rewrite big1 ?addr0; first last.
    move=> m /andP [Hmk Hmc1].
    rewrite coeffXdiff; last exact: lepm_trans Hmk Hk.
    by move: Hmc1; rewrite {1}/eq_op /= => /= /negbTE /= ->; rewrite mul0r.
  rewrite -{2}(submK Hck).
  have -> : mesymlm n c.+1 = (mesymlm n c + U_(ordc))%MM.
    rewrite mnmP => i; rewrite !mnmE !inE ltnS leq_eqVlt.
    rewrite orbC eq_sym {2}/eq_op/=.
    case: eqP => [->|_]; first by rewrite ltnn.
    by rewrite orbF addn0.
  congr (nat_of_bool _)%:R; apply/eqP/eqP => [ <- // | Heq].
  by rewrite -[RHS](addmK (U_(ordc))%MM) -[LHS](addmK (U_(ordc))%MM) Heq.
- rewrite big1; first last.
    move=> m /= Hm; rewrite coeffXdiff; last exact: lepm_trans Hm Hk.
    suff -> : m == U_(ordc)%MM :> 'X_{1..n} = false by rewrite mul0r.
    apply/negP => /eqP; rewrite mnmP => /(_ ordc).
    rewrite mnm1E eq_refl /= => Habs; move: Hck.
    have : (U_(ordc) <= m)%MM by rewrite lep1mP {}Habs.
    by move/lepm_trans/(_ Hm) => ->.
  suff -> : (k == mesymlm n c.+1) = false by [].
  apply/negP => /eqP; rewrite mnmP => /(_ ordc).
  move: Hck; rewrite lep1mP negbK => /eqP ->.
  by rewrite /mesymlm /mesymlmnm /mesym1 /= mnmE inE /= ltnSn.
Qed.

Lemma mcoeff_arbound b : b < n -> (abound b)@_(rbound b) = 1.
Proof using.
elim: b => [Hb | b IHb Hb1].
  rewrite /abound {Hb} big1; first last.
    by move=> [i j] /= /andP [/leq_trans H{}/H].
  rewrite mcoeff1 /=.
  suff -> : rbound 0 = 0%MM by rewrite eq_refl.
  by rewrite mnmP => i; rewrite mnmE.
move/(_ (ltnW Hb1)): IHb => Hrec.
rewrite /abound (bigID (fun p : 'II_n => p.2 <= b)) /=.
rewrite (eq_bigl (fun p : 'II_n => p.1 < p.2 <= b)); first last.
  move=> [i j]/=; case: (leqP j b); last by rewrite !andbF.
  by rewrite -ltnS => /ltnW ->; rewrite !andbT.
rewrite mulrC -/(abound _).
pose ordb1 := Ordinal Hb1.
rewrite [X in X * _](_ : _ =
           \prod_(i : 'I_n | i <= b)  ('X_i - 'X_ordb1)); first last.
  rewrite (eq_bigl (fun p : 'II_n => (p.1 <= b) && (p.2 == ordb1))); first last.
    move=> [i j]/=; rewrite -ltnNge -andbA -eqn_leq.
    case: eqP => Hj.
    - have -> : j = ordb1 by apply val_inj.
      by rewrite eq_refl /= ltnS.
    - suff -> : (j == ordb1) = false by rewrite !andbF.
      by apply negbTE; move: Hj => /eqP; apply contra => /eqP ->.
  rewrite (reindex (fun i : 'I_n => (i, ordb1))) /=; first last.
    exists (fun p : 'II_n => p.1) => //.
    by move=> [i j] /=; rewrite inE /= => /andP [_ /eqP <-].
  by apply eq_bigl => i; rewrite eq_refl andbT.
rewrite (mcoeff_poly_mul_lin _ _ (k := (mdeg (rbound b.+1)).+1)) //.
have /= := @coeff_prodXdiff ordb1.
rewrite (eq_bigl (fun i : 'I_(_) => i <= b)); last by move=> i; rewrite ltnS.
move=> Hprod.
have Hmesymlm : mdeg (mesymlm n b.+1) < (mdeg (rbound b.+1)).+1.
  rewrite ltnS /mdeg !big_tuple; apply leq_sum => i _.
  by rewrite -!mnm_tnth; move: (mesymlm_rbound b.+1) => /mnm_lepP; apply.
pose msmb := BMultinom Hmesymlm.
rewrite (bigID (xpred1 msmb)) /=.
rewrite (eq_bigl (xpred1 msmb)); first last.
  move=> m /=; case: eqP => [->|]; last by rewrite andbF.
  by rewrite /= mesymlm_rbound.
rewrite big_pred1_eq /= {}Hprod ?mesymlm_rbound // eq_refl mul1r.
rewrite big1 ?addr0; first last.
  move=> m /andP [Hm Hneq].
  rewrite (eq_bigl (fun i : 'I_(_) => i < b.+1)); first last.
    by move=> i; rewrite ltnS.
  rewrite (@coeff_prodXdiff ordb1) //.
  by move: Hneq; rewrite {1}/eq_op/= => /negbTE -> /=; rewrite mul0r.
rewrite -Hrec; congr mcoeff.
rewrite mnmP => i; rewrite !mnmE inE ltnS.
case: leqP => /= Hi.
- by rewrite subnAC subSS subn0.
- by rewrite subn0; move: Hi (ltnW Hi); rewrite /leq => /eqP -> /eqP ->.
Qed.

Lemma Vanprod_coeff_rho : Delta@_rho = 1.
Proof using.
rewrite /Vanprod.
case: (altP (n =P 0%N)) => [Hn |].
- rewrite big1; last by move=> [[i Hi]]; exfalso; rewrite Hn in Hi.
  suff -> : rho = 0%MM by rewrite mcoeff1 eq_refl.
  by rewrite mnmP => [[i Hi]]; exfalso; rewrite Hn in Hi.
- rewrite -lt0n => /prednK/eqP; rewrite eqn_leq => /andP [].
  move=> /mcoeff_arbound <- _.
  rewrite /rho subn1; congr mcoeff.
  apply eq_bigl => [[i j]] /=.
  case: n i j => [//=| n'] i j /=; first by exfalso; have:= ltn_ord i.
  by rewrite -(ltnS j) ltn_ord andbT.
Qed.

Corollary Vanprod_neq0 : Delta != 0.
Proof using.
apply/negP => /eqP H.
have:= Vanprod_coeff_rho; rewrite {}H mcoeff0 => /esym/eqP.
by rewrite oner_eq0.
Qed.

Lemma Vanprod_dhomog : Delta \is 'C(n, 2).-homog.
Proof using.
have /homogP [d Hd] : Delta \is homog [measure of mdeg].
  rewrite /Vanprod -big_filter -(big_map _ xpredT id).
  apply homog_prod; apply/allP => X /mapP [[i j]] /= _ -> {X}.
  by apply/homogP; exists 1%N; apply rpredB; rewrite dhomogX /= mdeg1.
suff <- : d = 'C(n, 2) by [].
have Hr : rho \in msupp Delta.
  by rewrite mcoeff_msupp Vanprod_coeff_rho oner_neq0.
move: Hd => /dhomogP/(_ _ Hr) /= <-.
exact: mdeg_rho.
Qed.

End Vanprod.

Theorem Vanprod_alt_int n :
  Vanprod = alternpol 'X_[rho n] :> {mpoly int[n]}.
Proof.
rewrite (isantisym_alt _
          (Vanprod_neq0 n _) (Vanprod_anti _ _) (Vanprod_dhomog n _)).
- by rewrite Vanprod_coeff_rho scale1r.
- by apply/negP => /=; rewrite inE /= eqz_nat.
Qed.

Corollary Vanprod_alt n (R : ringType) :
  Vanprod = alternpol 'X_[rho n] :> {mpoly R[n]}.
Proof.
have := Vanprod_alt_int n => /(congr1 (map_mpoly (S := R) intr)).
rewrite /Vanprod raddf_sum rmorph_prod.
under [LHS]eq_bigr => p _ do rewrite raddfB /= !map_mpolyX /=.
by move ->; apply eq_bigr => s _; rewrite raddfZsign !msymX /= map_mpolyX.
Qed.

From mathcomp Require Import matrix.

(** ** Vandermonde matrix and determinant *)
Section VandermondeDet.

Variable n : nat.
Variable R : comRingType.

Local Notation "''a_' k" := (@alternpol n R 'X_[k]).
Local Notation rho := (rho n).

Definition antim (s : seq nat) : 'M[ {mpoly R[n]} ]_n :=
  \matrix_(i, j < n) 'X_i ^+ (nth 0 s j + (n - 1) - j)%N.
Definition Vanmx : 'M[ {mpoly R[n]} ]_n :=
  \matrix_(i, j < n) 'X_i ^+ (n - 1 - j).
Definition Vandet := \det Vanmx.

Local Open Scope ring_scope.

Lemma Vanmx_antimE : Vanmx = antim [::].
Proof using. by apply/matrixP => i j /=; rewrite !mxE nth_default. Qed.

Lemma alt_detE s : 'a_(s + rho) = \det (antim s).
Proof using.
rewrite /alternpol (reindex_inj (inv_inj invgK)) /=; apply eq_bigr => p _.
rewrite odd_permV scaler_sign -mulr_sign; congr (_ * _).
transitivity
  (\prod_(i < n)
    'X_i ^+ (nth 0%N s (p i) + (n - 1) - p i) : {mpoly R[n]}); first last.
  by apply eq_bigr => i _; rewrite mxE.
rewrite msymX mpolyXE_id; apply eq_bigr => i _; congr (_ ^+ _).
rewrite mnmE /= mnmDE invgK mnmE (mnm_nth 0%N) subn1 addnBA //.
by rewrite -ltnS (ltn_predK (ltn_ord i)).
Qed.

Corollary Vandet_VanprodE : Vandet = Vanprod.
Proof using.
rewrite /Vandet Vanmx_antimE.
suff -> : antim [::] = antim (0%MM : 'X_{1..n}).
  by rewrite -alt_detE add0m Vanprod_alt.
by apply/matrixP => i j; rewrite !mxE nth_nil -mnm_nth mnm0E.
Qed.

Lemma mcoeff_alt (m : 'X_{1..n}) : uniq m -> ('a_m)@_m = 1.
Proof.
move=> Huniq.
rewrite /alternpol (reindex_inj invg_inj) /=.
rewrite raddf_sum /= (bigID (pred1 1%g)) /=.
rewrite big_pred1_eq odd_permV odd_perm1 expr0 scale1r invg1 msym1m.
rewrite mcoeffX eq_refl /=.
rewrite big1 ?addr0 // => /= s Hs.
rewrite mcoeffZ msymX mcoeffX invgK.
suff : [multinom m (s i) | i < n] != m by move=> /negbTE ->; rewrite mulr0.
move: Hs; apply contra => /eqP; rewrite mnmP => Heq.
apply/eqP; rewrite -permP => i; rewrite perm1; apply val_inj => /=.
have /eqP := Heq i; rewrite !mnmE !(mnm_nth 0).
rewrite nth_uniq; last exact: Huniq.
- by move=> /eqP ->.
- rewrite size_tuple; exact: ltn_ord.
- rewrite size_tuple; exact: ltn_ord.
Qed.

Lemma alt_uniq_non0 (m : 'X_{1..n}) : uniq m -> 'a_m != 0.
Proof using .
move=> Huniq.
suff : mcoeff m 'a_m == 1.
  apply contraL => /eqP ->; rewrite mcoeff0 eq_sym.
  exact: oner_neq0.
by rewrite mcoeff_alt.
Qed.

Lemma alt_rho_non0 : 'a_rho != 0.
Proof using . exact: alt_uniq_non0 (rho_uniq _). Qed.

Lemma alt_alternate (m : 'X_{1..n}) (i j : 'I_n) :
  i != j -> m i = m j -> 'a_m = 0.
Proof using .
move=> H Heq.
pose t := tperm i j.
have /= oddMt s : (t * s)%g = ~~ s :> bool by rewrite odd_permM odd_tperm H.
rewrite [alternpol _](bigID (@odd_perm _)) /=.
apply: canLR (subrK _) _; rewrite add0r -sumrN.
rewrite (reindex_inj (mulgI t)); apply: eq_big => //= s.
rewrite oddMt => /negPf ->; rewrite scaleN1r scale1r; congr (- _).
rewrite msymMm.
suff -> : msym t 'X_[m] = 'X_[m] :> {mpoly R[n]} by [].
rewrite msymX; congr mpolyX.
rewrite mnmP => k /=.
rewrite !mnmE /= tpermV.
by case: (tpermP i j k) => Hk //; rewrite Hk Heq.
Qed.

Lemma alt_add1_0 (m : 'X_{1..n}) i :
  (nth 0%N m i).+1 = nth 0%N m i.+1 -> 'a_(m + rho) = 0.
Proof using .
move=> Heq.
have Hi1n : i.+1 < n.
  rewrite ltnNge; apply/negP => Hi.
  by move: Heq; rewrite [RHS]nth_default // size_tuple.
have Hi : i < n by rewrite ltnW.
pose i0 := Ordinal Hi; pose i1 := Ordinal Hi1n.
have /alt_alternate : i0 != i1.
  apply/negP => /eqP/(congr1 val)/=/eqP.
  by rewrite ieqi1F.
apply.
rewrite !mnmDE !mnmE !(mnm_nth 0%N) -Heq -(mnm_nth 0%N m i0).
rewrite addSn -addnS subn1 /= subnS prednK //.
have -> : (n.-1 - i = n - i.+1)%N.
  case: n Hi1n Hi {i0 i1} => [//= | n' _] /=.
  by rewrite subSS.
by rewrite subn_gt0.
Qed.

End VandermondeDet.


Require Import UnivalentParametricity.theories.Basics.
Require Import UnivalentParametricity.theories.StdLib.Basics.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.

(*****************************)
(* A library parametrized by the underlying size-aware container type *)
Record Lib (C : Type -> nat -> Type) :=
  { head : forall {A : Type} {n : nat}, C A (S n) -> A;
    map : forall {A B} (f:A -> B) {n}, C A n -> C B n;
    lib_prop : forall n A (B : DType) (f : A -> B) (v : C A (S n)), head (map f v) = f (head v) }.

Arguments map {_} _ {_ _} _ {_} _.
Arguments head {_} _ {_ _} _.
Arguments lib_prop {_} _ {_ _} _ _ _.

(* the proof that Lib is a univalent type constructor requires to
   use an equivalent representation with dependent sums *)

Definition Lib_sig C :=   {hd : forall {A : Type} {n : nat}, C A (S n) -> A  &
                      {map : forall {A B} (f:A -> B) {n},
  C A n -> C B n &
  forall n A (B:DType) (f : A -> B) (v : C A (S n)), hd _ _ (map _ _ f _ v) = f (hd _ _ v) : Type}}.

Instance issig_lib_hd_map C : Lib_sig C ≃ Lib C.
Proof.
  issig (Build_Lib C) (@head C) (@map C) (@lib_prop C).
Defined.

Instance issig_lib_hd_map_inv C : Lib C ≃ Lib_sig C :=
  Equiv_inverse _.

#[export] Hint Extern 0 => progress (unfold Lib_sig) :  typeclass_instances.

(* the proof is automatic using the univ_param_record tactic *)

Definition FP_Lib : Lib ≈ Lib.
  univ_param_record.
Defined.

#[export] Hint Extern 0 (Lib _ ≃ Lib _) => erefine (ur_type FP_Lib _ _ _).(equiv); simpl
:  typeclass_instances.

(* we now define an instance of Lib for vectors *)

Definition lib_vector_prop : forall n A (B:DType) (f : A -> B) (v : t A (S n)),
  Vector.hd (Vector.map f v) = f (Vector.hd v).
Proof.
  intros.
  apply (Vector.caseS (fun _ v => Vector.hd (Vector.map f v) = f (Vector.hd v))).
  intros. reflexivity.
Defined.

Definition libvec : Lib Vector.t :=
  {| head := fun A n x => @Vector.hd A n x;
     map := fun A B f n => Vector.map f;
     lib_prop := lib_vector_prop |}.

(* using the equivalence between vectors and sized lists
   we can automatically infer the Lib structure on sized lists.
*)

Definition lib_list : Lib (fun A n => {l: list A & length l = n}) := ↑ libvec.

Notation vect_to_list := (vector_to_list _ _ (Equiv_id _) _ _ _).
Notation list_to_vect := (list_to_vector _ _ (Equiv_id _) _ _ _).

Transparent vector_to_list list_to_vector.

Notation "[[ ]]" := ([ ]; eq_refl).
Notation "[[ x ]]" := ([x]; eq_refl).
Notation "[[ x ; y ; .. ; z ]]" := ((UR.cons x (UR.cons y .. (UR.cons z UR.nil) ..)) ;eq_refl).

(* the lib_prop theorem has been lifted and can be effectively used *)

Time Eval lazy in (lib_list.(lib_prop) Dnat S [[S O; S (S O)]]).

(* the induced lib_list.(map) function behaves as map on sized lists. *)

Time Eval lazy in lib_list.(map) Datatypes.S [[1;2;3;4;5;6;7;8]].

Definition libvec_
  : {hd : forall {A : Type} {n : nat}, Vector.t A (S n) -> A  &
                      {map : forall {A B} (f:A -> B) {n},
  Vector.t A n -> Vector.t B n &
                  forall n A (B:DType) (f : A -> B) (v : Vector.t A (S n)), hd _ _ (map _ _ f _ v) = f (hd _ _ v) : Type}}
  :=
  ( fun A n x => @Vector.hd A n x;
     ( fun A B f n => Vector.map f;
                        lib_vector_prop)).

Definition sizedList A n := {l: list A & length l = n}.

Opaque vector_to_list.

Definition foo : ({hd : forall (A : Type) (n : nat), t A (S n) -> A &
                {map : forall A B : Type, (A -> B) -> forall n : nat, t A n -> t B n
                &
                forall (n : nat) (A : Type) (B : DType) (f : A -> B) (v : t A (S n)),
                hd B n (map A B f (S n) v) = f (hd A n v) : Type}}
                ≃ {hd : forall (A : Type) (n : nat), sizedList A (S n) -> A &
                  {map
                  : forall A B : Type,
                    (A -> B) -> forall n : nat, sizedList A n -> sizedList B n &
                  forall (n : nat) (A : Type) (B : DType)
                    (f : A -> B) (v : sizedList A (S n)),
                    hd B n (map A B f (S n) v) = f (hd A n v) : Type}}).
  tc.
Defined.
#[export] Hint Extern 0 => apply foo :  typeclass_instances.

Transparent vector_to_list.

Definition liblist : {hd :forall {A : Type} {n : nat}, sizedList A (S n) -> A  &
                      {map : forall {A B} (f:A -> B) {n},
  sizedList A n -> sizedList B n &
                   forall n A (B:DType) (f : A -> B) (v : sizedList A (S n)), hd _ _ (map _ _ f _ v) = f (hd _ _ v) : Type}}
  := ↑ libvec_.

(* Some more tests using the append function *)

Definition app {A} : list A -> list A -> list A :=
  fix app l m :=
  match l with
   | UR.nil => m
   | a :: l1 => a :: app l1 m
  end.

Lemma app_length {A} : forall l l' : list A, length (app l l') = length l + length l'.
Proof.
  induction l; simpl; intros. reflexivity. apply ap. auto.
Defined.

Definition app_list {A:Type} {n n'} `{A ⋈ A} :
  {l: list A & length l = n} -> {l: list A & length l = n'}
  -> {l: list A & length l = n + n'} := ↑ Vector.append.

Definition app_list' {A:Type} {n n'} `{A ⋈ A} :
  {l: list A & length l = n} -> {l: list A & length l = n'}
  -> {l: list A & length l = n + n'}.
   intros l l'. exists (app l.1 l'.1). eapply concat. apply app_length. apply ap2; [exact l.2 | exact l'.2].
Defined.

Eval compute in (app_list [[1;2]] [[1;2]]).

Eval compute in (app_list' [[1;2]] [[1;2]]).

Eval compute in (lib_list.(map) Datatypes.S (app_list [[1;2]] [[5;6]])).

Definition neg : bool -> bool := fun b => match b with
                                          | true => false
                                          | false => true
                                                       end.

Eval compute in (lib_list.(map) neg (app_list [[true;false]] [[true;false]])).

(* Example of lifting structurally a fixpoint on lists to a fixpoint on vectors. *)
(* This example would need some more automation to be nicer *)

Definition fold_left (A B : Type) (f : A -> B -> A)
  := list_rect B (fun _ => A -> A) id (fun x xs IH => fun init => IH (f init x)).

Definition Svect_fold_left_ : forall A B : Type, (A -> B -> A) -> forall l : Svector B, (fun _ : _ => A -> A) l.
  pose fold_left. unfold fold_left in p.
  let X := fresh "X" in
  assert (X : { opt :forall A B : Type, (A -> B -> A) -> forall l : Svector B, (fun _ : _ => A -> A) l  & fold_left ≈ opt}).
  unfold fold_left. cbn.
  eexists (fun A B f v a => Svect_rect B (fun _ => A -> A) _ _ _ _).
  intros. pose (FP_List_vect_rect _ _ H0 (fun _ => x -> x) (fun _ => y -> y) (ltac:(tc))).
  cbn in u; eapply u; tc.
  exact X.1.
Defined.

Definition Svect_fold_left := Eval compute in Svect_fold_left_.


From Cat Require Import Cat.
From Cat.Category Require Import CartesianClosed.
From Cat.Universal Require Import Initial Terminal Product Coproduct.

Set Implicit Arguments.

Class Monoidal : Type :=
{
  cat :> Cat;
  tensor : Bifunctor cat cat cat;
  tensor_unit : Ob cat;
  associator : forall X Y Z : Ob cat, Hom (biob (biob X Y) Z) (biob X (biob Y Z));
  isIso_associator : forall X Y Z : Ob cat, isIso (associator X Y Z);
  left_unitor : forall X : Ob cat, Hom (biob tensor_unit X) X;
  isIso_left_unitor : forall X : Ob cat, isIso (left_unitor X);
  right_unitor : forall X : Ob cat, Hom (biob X tensor_unit) X;
  isIso_right_unitor : forall X : Ob cat, isIso (right_unitor X);
  triangle :
    forall {X Y : Ob cat},
      associator X tensor_unit Y .> bimap (id X) (left_unitor Y) == bimap (right_unitor X) (id Y);
  pentagon :
    forall {W X Y Z : Ob cat},
      bimap (associator W X Y) (id Z) .> associator W (biob X Y) Z .>
        bimap (id W) (associator X Y Z) == associator (biob W X) Y Z .> associator W X (biob Y Z)
}.

Coercion cat : Monoidal >-> Cat.

#[refine]
#[export]
Instance Monoidal_HasTerm_HasProducts
  (C : Cat) (ht : HasTerm C) (hp : HasProducts C) : Monoidal :=
{
  cat := C;
  tensor := @ProductBifunctor C hp;
  tensor_unit := @term C ht;
}.
Proof.
  all: cbn; intros.
  - exact Product.associator.
  - exact Product.isIso_associator.
  - exact (proj1_sig (product_term_l' C ht hp X)).
  - exact (proj2_sig (product_term_l' C ht hp X)).
  - exact (proj1_sig (product_term_r' C X ht hp)).
  - exact (proj2_sig (product_term_r' C X ht hp)).
  - cbn; unfold Product.associator; solve_product.
  - cbn; unfold Product.associator; solve_product.
Defined.

#[refine]
#[export]
Instance Monoidal_HasInit_HasCoproducts
  (C : Cat) (hi : HasInit C) (hp : HasCoproducts C) : Monoidal :=
{
  cat := C;
  tensor := @CoproductBifunctor C hp;
  tensor_unit := @init C hi;
}.
Proof.
  all: cbn; intros.
  - exact Coproduct.associator.
  - exact Coproduct.isIso_associator.
  - exact (proj1_sig (coproduct_init_l' C hi hp X)).
  - exact (proj2_sig (coproduct_init_l' C hi hp X)).
  - exact (proj1_sig (coproduct_init_r' C hi hp X)).
  - exact (proj2_sig (coproduct_init_r' C hi hp X)).
  - cbn; unfold Coproduct.associator; solve_coproduct; apply equiv_initial.
  - cbn; unfold Coproduct.associator; solve_coproduct.
Defined.


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

 Equalizers in the category of strict categories

 ******************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Setcategories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories.
Require Import UniMath.CategoryTheory.limits.equalizers.

Local Open Scope cat.

Definition equalizer_of_setcategory_precategory_ob_mor
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : precategory_ob_mor.
Proof.
  use make_precategory_ob_mor.
  - exact (∑ (x : C₁), F x = G x).
  - exact (λ x y, ∑ (f : pr1 x --> pr1 y),
           # F f · idtoiso (pr2 y)
           =
           idtoiso (pr2 x) · # G f).
Defined.

Definition equalizer_of_setcategory_precategory_data
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : precategory_data.
Proof.
  use make_precategory_data.
  - exact (equalizer_of_setcategory_precategory_ob_mor F G).
  - cbn ; refine (λ x, identity _ ,, _).
    abstract
      (rewrite !functor_id ;
       rewrite id_left, id_right ;
       apply idpath).
  - cbn ; refine (λ x y z f g, pr1 f · pr1 g ,, _).
    abstract
      (rewrite !functor_comp ;
       rewrite !assoc ;
       rewrite <- (pr2 f) ;
       rewrite !assoc' ;
       rewrite <- (pr2 g) ;
       apply idpath).
Defined.

Definition equalizer_of_setcategory_is_precategory
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : is_precategory (equalizer_of_setcategory_precategory_data F G).
Proof.
  use make_is_precategory_one_assoc ;
    intros ;
    (use subtypePath ; [ intro ; apply homset_property | ]) ;
    cbn.
  - apply id_left.
  - apply id_right.
  - apply assoc.
Qed.

Definition equalizer_of_setcategory_precategory
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : precategory.
Proof.
  use make_precategory.
  - exact (equalizer_of_setcategory_precategory_data F G).
  - exact (equalizer_of_setcategory_is_precategory F G).
Defined.

Definition equalizer_of_setcategory_is_setcategory
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : is_setcategory (equalizer_of_setcategory_precategory F G).
Proof.
  split.
  - use isaset_total2.
    + apply C₁.
    + intro.
      apply isasetaprop.
      exact (pr12 C₂ (F x) (G x)).
  - intros x y.
    use isaset_total2.
    + apply homset_property.
    + intro.
      apply isasetaprop.
      apply homset_property.
Qed.

Definition equalizer_of_setcategory
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : setcategory
  := equalizer_of_setcategory_precategory F G ,, equalizer_of_setcategory_is_setcategory F G.

Definition idtoiso_equalizer_of_setcategory
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
           {x y : equalizer_of_setcategory F G}
           (p : x = y)
  : pr11 (idtoiso p) = pr1 (idtoiso (maponpaths pr1 p)).
Proof.
  induction p.
  apply idpath.
Qed.

Definition equalizer_of_setcategory_pr1
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : equalizer_of_setcategory F G ⟶ C₁.
Proof.
  use make_functor.
  - use make_functor_data.
    + exact (λ x, pr1 x).
    + exact (λ x y f, pr1 f).
  - abstract (split ; intro ; intros ; apply idpath).
Defined.

Definition equalizer_of_setcategory_eq
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
  : equalizer_of_setcategory_pr1 F G ∙ F
    =
    equalizer_of_setcategory_pr1 F G ∙ G.
Proof.
  use functor_eq.
  {
    apply homset_property.
  }
  use functor_data_eq ; cbn.
  - exact (λ x, pr2 x).
  - intros x y f.
    cbn.
    rewrite double_transport_idtoiso.
    rewrite !assoc'.
    rewrite (pr2 f).
    rewrite !assoc.
    rewrite z_iso_after_z_iso_inv.
    apply id_left.
Qed.

Definition equalizer_of_setcategory_ump_mor_data
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
           {C₀ : setcategory}
           (H : C₀ ⟶ C₁)
           (p : H ∙ F = H ∙ G)
  : functor_data
      C₀
      (equalizer_of_setcategory F G).
Proof.
  use make_functor_data.
  - refine (λ x, H x ,, _).
    exact (maponpaths (λ z, pr11 z x) p).
  - refine (λ x y f, #H f ,, _).
    abstract
      (pose (from_eq_cat_of_setcategory p f) as q ;
       cbn in q ;
       etrans ;
         [ apply maponpaths_2 ;
           exact q
         | ] ;
       cbn ;
       rewrite !assoc' ;
       apply maponpaths ;
       refine (_ @ id_right _) ;
       apply maponpaths ;
       refine (!_) ;
       refine (_ @ pr1_idtoiso_concat
                 (maponpaths (λ z, pr11 z y) (!p))
                 (maponpaths (λ z, pr11 z y) p)) ;
       refine (!_) ;
       apply setcategory_refl_idtoiso).
Defined.

Definition equalizer_of_setcategory_ump_mor_is_functor
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
           {C₀ : setcategory}
           (H : C₀ ⟶ C₁)
           (p : H ∙ F = H ∙ G)
  : is_functor (equalizer_of_setcategory_ump_mor_data F G H p).
Proof.
  split.
  - intro x.
    use subtypePath.
    {
      intro.
      apply homset_property.
    }
    apply functor_id.
  - intros x y z f g.
    use subtypePath.
    {
      intro.
      apply homset_property.
    }
    apply functor_comp.
Qed.

Definition equalizer_of_setcategory_ump_mor
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
           {C₀ : setcategory}
           (H : C₀ ⟶ C₁)
           (p : H ∙ F = H ∙ G)
  : C₀ ⟶ equalizer_of_setcategory F G.
Proof.
  use make_functor.
  - exact (equalizer_of_setcategory_ump_mor_data F G H p).
  - exact (equalizer_of_setcategory_ump_mor_is_functor F G H p).
Defined.

Definition equalizer_of_setcategory_ump_mor_pr1
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
           {C₀ : setcategory}
           (H : C₀ ⟶ C₁)
           (p : H ∙ F = H ∙ G)
  : equalizer_of_setcategory_ump_mor F G H p ∙ equalizer_of_setcategory_pr1 F G
    =
    H.
Proof.
  use functor_eq.
  {
    apply homset_property.
  }
  use functor_data_eq.
  - exact (λ _, idpath _).
  - exact (λ _ _ _, idpath _).
Qed.

Definition equalizer_of_setcategory_ump_unique
           {C₁ C₂ : setcategory}
           (F G : C₁ ⟶ C₂)
           {C₀ : setcategory}
           (H : C₀ ⟶ C₁)
           (p : H ∙ F = H ∙ G)
           (K : C₀ ⟶ equalizer_of_setcategory F G)
           (K_pr1 : K ∙ equalizer_of_setcategory_pr1 F G = H)
  : K = equalizer_of_setcategory_ump_mor F G H p.
Proof.
  use functor_eq.
  {
    apply homset_property.
  }
  use functor_data_eq.
  - abstract
      (intro x ;
       use subtypePath ;
       [ intro z ;
         exact (pr12 C₂ (F z) (G z))
       | ] ;
       exact (maponpaths (λ z, pr11 z x) K_pr1)).
  - intros x₁ x₂ f.
    rewrite double_transport_idtoiso.
    rewrite !assoc'.
    use z_iso_inv_on_right.
    use subtypePath.
    {
      intro.
      apply homset_property.
    }
    cbn.
    pose (from_eq_cat_of_setcategory K_pr1 f) as q.
    cbn in q.
    etrans.
    {
      apply maponpaths_2.
      exact q.
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          exact (idtoiso_equalizer_of_setcategory
                   F G
                   (equalizer_of_setcategory_ump_unique_subproof C₁ C₂ F G C₀ H p K K_pr1 x₂)).
        }
        refine (!_).
        apply (pr1_idtoiso_concat
                 (maponpaths (λ z, (pr11 z) x₂)
                    (! K_pr1))).
      }
      etrans.
      {
        apply maponpaths.
        apply setcategory_refl_idtoiso.
      }
      apply id_right.
    }
    apply maponpaths_2.
    refine (!_).
    etrans.
    {
      exact (idtoiso_equalizer_of_setcategory
               F G
               (equalizer_of_setcategory_ump_unique_subproof C₁ C₂ F G C₀ H p K K_pr1 x₁)).
    }
    apply setcategory_eq_idtoiso.
Qed.

Definition cat_of_setcategory_equalizers
  : Equalizers cat_of_setcategory.
Proof.
  intros C₁ C₂ F G.
  use make_Equalizer.
  - exact (equalizer_of_setcategory F G).
  - exact (equalizer_of_setcategory_pr1 F G).
  - exact (equalizer_of_setcategory_eq F G).
  - use make_isEqualizer.
    intros C₀ H p.
    simple refine (_ ,, _).
    + refine (equalizer_of_setcategory_ump_mor F G H p ,, _).
      exact (equalizer_of_setcategory_ump_mor_pr1 F G H p).
    + abstract
        (simpl ;
         intro K ;
         use subtypePath ; [ intro ; apply cat_of_setcategory | ] ;
         apply equalizer_of_setcategory_ump_unique ;
         exact (pr2 K)).
Defined.


Require Import RelationClasses.
Require Import Morphisms.
Require Import ClassicalRealizability.ShallowEmbedding.
Require Import ClassicalRealizability.Tactics.
Require Import ClassicalRealizability.BasicResults.

Set Implicit Arguments.

(****************************)
(** *  Subtyping relation  **)
(****************************)

(** **  Definition of the subtype and subtyping equivalence relations  **)

Definition subtype F F' := forall π, π ∈ ‖F'‖ -> π ∈ ‖F‖.
Notation  "A '⊆' B" := (subtype A B) (at level 80, no associativity).
Transparent subtype.

Definition eqtype F F' := forall π, π ∈ ‖F‖ <-> π ∈ ‖F'‖.

Notation "A '≈' B" := (eqtype A B) (at level 80, no associativity).

(** ** Instances for rewriting **)

(** [A ≈ B] is the equivalence associated with the preorder [A ⊆ B] **)
Instance Eqtype_extensional : Proper (eqtype ==> eq ==> iff) Fval.
Proof. intros A B Heq π π' Heqπ. split; intros Hπ; subst; now rewrite (Heq π') || rewrite <- (Heq π'). Qed.

Instance realizes_iff_compat : Proper (eq ==> eqtype ==> iff) realizes.
Proof.
intros t t' Heqt A B Heq.
split; intros Ht π Hπ; subst; apply Ht; now apply (Eqtype_extensional Heq eq_refl).
Qed.

Instance realizes_impl_compat : Proper (eq ==> subtype ==> Basics.impl) realizes.
Proof. intros t t' Heqt A B Hsub Ht. intros π Hπ. subst. apply Ht. now apply Hsub. Qed.

Instance Subtype_PreOrder : PreOrder subtype.
Proof. repeat split. now intros ? ? ?. intros A B C HAB HBC π Hπ. apply HAB. now apply HBC. Qed.

Instance Eqtype_equiv : Equivalence eqtype.
Proof.
split.
  intros F s. reflexivity.
  intros A B Heq s. now rewrite Heq.
  intros A B C HAB HBC s. rewrite HAB. now rewrite HBC.
Qed.

Instance Subtype_PO : PartialOrder eqtype subtype.
Proof.
intros x y; split; intro Heq.
  split; intros π Hπ. now rewrite Heq. now rewrite <- Heq.
  destruct Heq as [H₁ H₂]. split; now apply H₁ || apply H₂.
Qed.

Lemma eqtype_subtype : forall A B, A ≈ B -> A ⊆ B.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma subtype_eqtype : forall A B, A ⊆ B -> B ⊆ A -> A ≈ B.
Proof. intros A B HAB HBA s. split; intro Hπ; now (apply HAB || apply HBA). Qed.

(*
(** The connectives respects subtyping. **)
Instance Forall_proper (T : Type) : Proper (pointwise_relation T subtype ==> subtype) (Forall T).
Proof. intros A B HAB π [t Hπ]. exists t. now apply (HAB t). Qed.

Instance mapsto_Proper : Proper (Impl ==> subtype ==> subtype) mapsto.
Proof. intros c₁ c₂ Hcs A B HAB π [Hc Hπ]. split. now rewrite Hcs. now apply HAB. Qed.

Lemma eqtype_subtype : forall A B, A ≈ B -> A ⊆ B.
Proof. intros. rewrite H. reflexivity. Qed.
*)

(** ** Usual properties of a subtyping relation **)

(** Propositional constants **)
Lemma sub_bot : forall F, ⊥ ⊆ F.
Proof. Ksolve. Qed.

Lemma sub_top : forall F, F ⊆ ⊤.
Proof. Ksolve. Qed.

Lemma top_bot_sub_one : (⊤ → ⊥) ⊆ one.
Proof. unfold one. Ksolve. Qed.

(** Implication **)
Lemma sub_Impl : forall A A' B B', A ⊆ A' -> B ⊆ B' -> A' → B ⊆ A → B'.
Proof. intros A A' B B' HA HB. start. split. start. apply Ht. now apply HA. now apply HB. Qed.

(** Universal quantification **)
Lemma sub_Forall : forall T A (t : T), (∀x, A x) ⊆ A t.
Proof. Ksolve. Qed.

Lemma Forall_sub_compat : forall T A B, (forall x : T, A x ⊆ B x) -> (∀x, A x) ⊆ ∀x, B x.
Proof. intros T A B Hsub π [n Hn]. exists n. now apply Hsub. Qed.

Lemma sub_Forall_add : forall T A (B : T -> formula), (forall t, A ⊆ B t) -> A ⊆ ∀t, B t.
Proof. intros T A B HAB π [t Hπ]. now apply (HAB t). Qed.

Lemma sub_Forall_cross : forall T A (B : T -> formula), (∀t, A → B t) ≈ A → ∀t, B t.
Proof. intros; split; Ksolve. Qed.

Lemma Forall_comm : forall T₁ T₂ (A : T₁ -> T₂ -> formula), (∀t, ∀u, A t u) ≈ ∀u, ∀t, A t u.
Proof. intros ? ? ? π; split; intro; dec π; find. Qed.

Lemma Forall_cancel : forall T A, inhabited T -> (∀t : T, A) ≈ A.
Proof. intros T A [] π; split; intro; dec π; find; ok. Qed.

(** Semantic implication **)
Lemma sub_mapsto : forall A c, A ⊆ c ↦ A.
Proof. now intros ? ? ? []. Qed.

Lemma mapsto_sub_compat : forall (c c' : Prop) A B, (c' -> c) -> A ⊆ B -> c ↦ A ⊆ c' ↦ B.
Proof. intros c c' A B Hcs HAB π [Hc Hπ]. split. now apply Hcs. now apply HAB. Qed.

Lemma mapsto_cancel : forall c A, (c ↦ A) ∩ (~c ↦ A) ≈ A.
Proof.
intros c A π. split; intro Hπ.
  now destruct Hπ as [[]|[]].
  elim (Classical_Prop.classic c); intro Hc; (now left; split) || (now right; split).
Qed.

Lemma mapsto_idempotent : forall c A, c ↦ c ↦ A ≈ c ↦ A.
Proof. intros. apply subtype_eqtype. now intros ? []; repeat split. apply sub_mapsto. Qed.

Instance mapsto_eqtype_compat : Proper (iff ==> eqtype ==> eqtype) mapsto.
Proof.
intros c c' Hc A B HAB π.
split; (apply mapsto_sub_compat; [now intuition | apply eqtype_subtype]); assumption || now symmetry.
Qed.

Instance mapsto_subtype_compat : Proper (Basics.flip Basics.impl ==> subtype ==> subtype) mapsto.
Proof. intros c c' Hc A B HAB. now apply mapsto_sub_compat. Qed.

(** Intersection type **)
Lemma sub_inter_l : forall A B, A ∩ B ⊆ A.
Proof. intros. now left. Qed.

Lemma sub_inter_r : forall A B, A ∩ B ⊆ B.
Proof. intros. now right. Qed.

Lemma sub_inter : forall A B C, C ⊆ A -> C ⊆ B -> C ⊆ A ∩ B.
Proof. intros A B C HA HB ? [? | ?]. now apply HA. now apply HB. Qed.

Lemma inter_sub_compat : forall A A' B B', A ⊆ A' -> B ⊆ B' -> A ∩ B ⊆ A' ∩ B'.
Proof. intros A A' B B' HA HB ? [? | ?]. now left; apply HA. now right; apply HB. Qed.

Lemma inter_mapsto_distr : forall c A B, c ↦ (A ∩ B) ≈ (c ↦ A) ∩ (c ↦ B).
Proof.
intros c A B s. split; intro Hπ.
  destruct Hπ as [Hc [Hπ | Hπ]]. now left; split. now right; split.
  destruct Hπ as [[Hc Hπ] | [Hc Hπ]]. now split; try left. now split; try right.
Qed.

(** Interactions between subtpying and realizability **)
Theorem sub_stack : forall A B π, π ∈ ‖B‖ -> A ⊆ B -> π ∈ ‖A‖.
Proof. auto. Qed.
Arguments sub_stack [A] [B] [π] Hπ HAB.

Theorem sub_term : forall A B t, t ⊩ A -> A ⊆ B -> t ⊩ B.
Proof. intros A B t Ht HAB. start. apply Ht. now apply HAB. Qed.

Theorem sub_id : forall A B, A ⊆ B -> forall e, Id↓e ⊩ A → B.
Proof. intros ? ? H. Ksolve. now apply H. Qed.

(** ** Automatization **)

(* FIXME(speedup): use Hint Extern to speclialize the patterns on which each case is used
   BUG 3199 !! *)
Create HintDb Ksubtype.
Hint Opaque subtype eqtype : Ksubtype.
Hint Immediate (@reflexivity _ subtype _) (@reflexivity _ eqtype _) sub_Forall sub_bot sub_mapsto : Ksubtype.
Hint Immediate mapsto_cancel mapsto_idempotent inter_mapsto_distr : Ksubtype.

Hint Resolve sub_Impl sub_inter_l sub_inter_r sub_inter sub_Forall_add sub_Forall_cross : Ksubtype.
Hint Resolve Forall_sub_compat mapsto_sub_compat inter_sub_compat : Ksubtype.
(*
Check sub_Impl.
Hint Extern 2 ((_ → _) ⊆ (_ → _)) => eapply sub_Impl : Ksubtype.
Hint Extern 0 ((_ ∩ _) ⊆ _) => apply sub_inter_l : Ksubtype.
Hint Extern 0 ((_ ∩ _) ⊆ _) => apply sub_inter_r : Ksubtype.
Hint Extern 2 (_ ⊆ (_ ∩ _)) => apply sub_inter : Ksubtype.
Hint Extern 1 (_ ⊆ (∀_, _)) => apply sub_Forall_add : Ksubtype.
Hint Resolve sub_Forall_cross : Ksubtype.
Hint Extern 1 ((∀_, _) ⊆ (∀_, _)) => apply Forall_sub_proper : Ksubtype.
Hint Extern 2 ((_ ↦ _) ⊆ (_ ↦ _)) => apply mapsto_sub_proper : Ksubtype.
Hint Extern 2 ((_ ∩ _) ⊆ (_ ∩ _)) => apply inter_sub_proper : Ksubtype.
*)
Hint Resolve sub_term sub_stack (@transitivity _ subtype _) : Ksubtype.
Hint Extern 1 (_ ⊆ _) => apply top_bot_sub_one; trivial : Ksubtype. (* avoid unfolding of ⊆ *)
Hint Extern 5 (_ ⊆ _) => apply eqtype_subtype : Ksubtype.
Hint Extern 6 (_ ≈ _) => apply subtype_eqtype : Ksubtype.
Hint Extern 7 (_ ≈ _) => apply (@symmetry _ eqtype _) : Ksubtype.   (* high cost to avoid excessive use *)
(* Currently useless because of bug 3199 *)

(** The tactic solving subtyping goals **)
Ltac subtyping := progress eauto 6 with Ksubtype.

(** Same as [subtyping] but displays proof search information **)
Ltac info_subtyping := progress info_eauto 6 with Ksubtype.

(** **  Some examples  **)

Example inter_idempotent : forall A, A ∩ A ≈ A.
Proof. subtyping. Qed. (* BUG 3199: symmetry used twice for nothing *)

Example callcc_realizes_NNPP : forall e, callcc↓e ⊩ ∀P, (¬¬P) → P.
Proof. intro e. apply (sub_term (callcc_realizes_Peirce e)). subtyping. Qed.

Lemma inter_realizer : forall A B t e, t↓e ⊩ A∩B <-> t↓e ⊩ A /\ t↓e ⊩ B.
Proof.
intros A B t e. split; intro Ht.
  split; subtyping.
  destruct Ht as [Ht₁ Ht₂]. start; (now apply Ht₁) || (now apply Ht₂).
Qed.