Require Import Coq.Lists.List.
Require Import ExtLib.Core.EquivDec.
Require Import ExtLib.Tactics.Consider.
Require Import MirrorShard.Expr.

Set Implicit Arguments.
Set Strict Implicit.

Module Type Subst.
  (** An environment that maintains a mapping from variables to their meaning **)
  Parameter Subst : list type -> Type.

  Section typed.
    Variable types : list type.

    (** Predicates **)
    Parameter Subst_WellTyped : tfunctions -> tenv -> tenv -> Subst types -> Prop.

    (** Relations **)
    Parameter Subst_Equal : Subst types -> Subst types -> Prop.
    Parameter Equiv_Subst_Equal : RelationClasses.Equivalence Subst_Equal.

    Parameter Subst_Extends : Subst types -> Subst types -> Prop.

    Parameter Refl_Subst_Extends : RelationClasses.Reflexive Subst_Extends.
    Parameter Antisym_Subst_Extends : @RelationClasses.Antisymmetric _ _ Equiv_Subst_Equal Subst_Extends.
    Parameter Trans_Subst_Extends : RelationClasses.Transitive Subst_Extends.

    (** Operations **)
    Parameter Subst_empty : Subst types.

    Axiom Subst_empty_WellTyped : forall funcs U G,
      Subst_WellTyped funcs U G Subst_empty.

    Parameter Subst_lookup : uvar -> Subst types -> option (expr types).
    Parameter Subst_set : uvar -> expr types -> Subst types -> option (Subst types).

    Parameter Subst_size : Subst types -> nat.
    Parameter Subst_domain : Subst types -> list uvar.

    (** Substitute meta variables **)
    Parameter exprInstantiate : Subst types -> expr types -> expr types.

    Axiom exprInstantiate_WellTyped : forall funcs U G sub,
      Subst_WellTyped funcs U G sub ->
      forall e t,
        is_well_typed funcs U G e t = is_well_typed funcs U G (exprInstantiate sub e) t.

    Axiom exprInstantiate_Extends : forall x y,
      Subst_Extends x y ->
      forall t, exprInstantiate x (exprInstantiate y t) = exprInstantiate x t.

    Axiom exprInstantiate_extends : forall sub sub' l r,
      exprInstantiate sub l = exprInstantiate sub r ->
      Subst_Extends sub' sub ->
      exprInstantiate sub' l = exprInstantiate sub' r.

    Axiom exprInstantiate_instantiated : forall k sub e,
      Subst_lookup k sub = Some e ->
      exprInstantiate sub e = e.

    Axiom exprInstantiate_Removes : forall k sub e e' e'',
      Subst_lookup k sub = Some e ->
      exprInstantiate sub e' = e'' ->
      mentionsU k e'' = false.

    (** The meaning of size **)
    Axiom Subst_domain_iff : forall s k,
      (exists e, Subst_lookup k s = Some e) <-> In k (Subst_domain s).

    Axiom Subst_size_cardinal : forall sub,
      Subst_size sub = length (Subst_domain sub).

    (** Axiomatization of exprInstantiate **)
    Axiom exprInstantiate_Func : forall a b c,
      exprInstantiate a (Func b c) = Func b (map (exprInstantiate a) c).

    Axiom exprInstantiate_Equal : forall a b c d,
      exprInstantiate a (Equal b c d) = Equal b (exprInstantiate a c) (exprInstantiate a d).

    Axiom exprInstantiate_Not : forall a b,
      exprInstantiate a (Not b) = Not (exprInstantiate a b).

    Axiom exprInstantiate_UVar : forall a x,
      exprInstantiate a (UVar x) = match Subst_lookup x a with
                                     | None => UVar x
                                     | Some v => v
                                   end.

    Axiom exprInstantiate_Var : forall a x,
      exprInstantiate a (Var x) = Var x.

    Axiom exprInstantiate_Const : forall a t v,
      exprInstantiate a (@Const types t v) = (@Const types t v).

    (** Subst_set & Subst_lookup **)
    Axiom Subst_set_Subst_lookup : forall k v sub sub',
      Subst_set k v sub = Some sub' ->
      Subst_lookup k sub' = Some (exprInstantiate sub v).

    Axiom Subst_set_Extends : forall k v sub sub',
      Subst_set k v sub = Some sub' ->
      Subst_lookup k sub = None ->
      Subst_Extends sub' sub.

    Axiom Subst_lookup_Extends : forall sub sub' k v,
      Subst_lookup k sub = Some v ->
      Subst_Extends sub' sub ->
      Subst_lookup k sub' = Some (exprInstantiate sub' v).

    Axiom Subst_set_exprInstantiate : forall x e sub sub',
      Subst_set x e sub = Some sub' ->
      Subst_lookup x sub = None ->
      exprInstantiate sub' (UVar x) = exprInstantiate sub' e.

    Axiom Subst_set_WellTyped : forall funcs U G u E t sub sub',
      Subst_set u E sub = Some sub' ->
      nth_error U u = Some t ->
      is_well_typed funcs U G E t = true ->
      Subst_WellTyped funcs U G sub ->
      Subst_WellTyped funcs U G sub'.

    (** Well-typedness **)
    Axiom WellTyped_lookup : forall funcs U G sub,
      Subst_WellTyped funcs U G sub ->
      forall u e,
      Subst_lookup u sub = Some e ->
      exists t, nth_error U u = Some t /\
      is_well_typed funcs U G e t = true.

    (** Semantics interpretation of substitutions **)
    Parameter Subst_equations :
      forall (funcs : functions types) (U G : env types), Subst types -> Prop.

    Axiom Subst_equations_empty : forall funcs U G,
      Subst_equations funcs U G Subst_empty.

    Axiom Subst_equations_weaken : forall funcs U G s U' G',
      Subst_equations funcs U G s ->
      Subst_equations funcs (U ++ U') (G ++ G') s.

    Axiom Subst_equations_exprInstantiate : forall funcs U G e t sub,
      Subst_equations funcs U G sub ->
      exprD funcs U G (exprInstantiate sub e) t = exprD funcs U G e t.

    Axiom Subst_equations_Extends : forall funcs G sub sub' U,
      Subst_Extends sub' sub ->
      Subst_equations funcs U G sub' ->
      Subst_equations funcs U G sub.

    Axiom Subst_equations_WellTyped : forall funcs G U sub,
      Subst_equations funcs U G sub ->
      Subst_WellTyped (typeof_funcs funcs) (typeof_env U) (typeof_env G) sub.

    (** An incremental version of Subst_equations **)
    Section Subst_equations_to.
      Variable funcs : functions types.
      Variables uenv venv : env types.
      Variable subst : Subst types.

      Fixpoint Subst_equations_to (from : nat) (ls : Expr.env types) : Prop :=
        match ls with
          | nil => True
          | l :: ls =>
            match Subst_lookup from subst with
              | None => True
              | Some e => match exprD funcs uenv venv e (projT1 l) with
                            | None => False
                            | Some v => projT2 l = v
                          end
            end /\ Subst_equations_to (S from) ls
        end.

      Axiom Subst_equations_to_Subst_equations :
        Subst_WellTyped (typeof_funcs funcs) (typeof_env uenv) (typeof_env venv) subst ->
        Subst_equations_to 0 uenv ->
        Subst_equations funcs uenv venv subst.

    End Subst_equations_to.

  End typed.

End Subst.

Module SubstFacts (S : Subst).

  Section typed.
    Variable types : list type.
    Variable funcs : functions types.

    Theorem Subst_equations_to_app : forall m v s vs from vs',
      S.Subst_equations_to funcs m v s from (vs ++ vs') <->
      (S.Subst_equations_to funcs m v s from vs /\
        S.Subst_equations_to funcs m v s (from + length vs) vs').
    Proof.
      clear. induction vs; simpl; intros.
      { rewrite Plus.plus_0_r. intuition. }
      { rewrite IHvs. rewrite <- Plus.plus_Snm_nSm. simpl.
        intuition. }
    Qed.

    Theorem Subst_equations_to_weaken : forall m v s vs from,
      S.Subst_equations_to funcs m v s from vs ->
      forall m' v',
        S.Subst_equations_to funcs (m ++ m') (v ++ v') s from vs.
    Proof.
      clear. induction vs; simpl in *; intros; auto.
      { intuition. destruct (S.Subst_lookup from s); auto.
        consider (exprD funcs m v e (projT1 a)); intros.
        erewrite exprD_weaken; eauto. contradiction. }
    Qed.
  End typed.

End SubstFacts.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Instance.Cones.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Theorem Cones_to_Comma `(F : J ⟶ C) :
  Cones F ⟶ (Diagonal J ↓ @Const Fun F).
Proof.
  functor; simpl; intros.
  - exists (vertex_obj, ()).
    transform; simpl; intros.
    + apply vertex_map.
    + abstract (rewrite id_right; apply ump_cones).
    + abstract (rewrite id_right; symmetry; apply ump_cones).
  - exists (`1 f, ()); abstract (simpl; intros; cat).
  - abstract proper.
  - abstract cat.
  - abstract cat.
Defined.

Theorem Cones_from_Comma `(F : J ⟶ C) :
  (Diagonal J ↓ @Const Fun F) ⟶ Cones F.
Proof.
  functor; simpl; intros.
  - construct; simpl; intros.
    + exact (fst ``X).
    + exact (transform[`2 X] _).
    + abstract (rewrite (naturality[`2 X]); cat).
  - destruct f; simpl in *.
    exists (fst x0); abstract (intros; rewrite e; cat).
  - abstract proper.
  - abstract cat.
  - abstract cat.
Defined.

(* Wikipedia: "We can define the category of cones to F as the comma category
  (Δ ↓ F). Morphisms of cones are then just morphisms in this category. This
  equivalence is rooted in the observation that a natural map between constant
  functors Δ(N), Δ(M) corresponds to a morphism between N and M. In this
  sense, the diagonal functor acts trivially on arrows. In similar vein,
  writing down the definition of a natural map from a constant functor Δ(N) to
  F yields the same diagram as the above. As one might expect, a morphism from
  a cone (N, ψ) to a cone (L, φ) is just a morphism N → L such that all the
  "obvious" diagrams commute." *)

Theorem Cones_Comma `(F : J ⟶ C) :
  Cones F ≅[Cat] (Diagonal J ↓ @Const Fun F).
Proof.
  isomorphism; simpl; intros.
  - apply Cones_to_Comma.
  - apply Cones_from_Comma.
  - constructive.
    + exists (id, ()); abstract cat.
    + exists (id, ()); abstract cat.
    + abstract (simpl; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
  - constructive.
    + exists id; abstract (intros; cat).
    + exists id; abstract (intros; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
Qed.


Require Import Arith Bedrock Locals List PreAutoSep.

Lemma wordToNat_wminus : forall sz (w u : word sz),
  u <= w
  -> wordToNat (w ^- u) = wordToNat w - wordToNat u.
  intros.
  eapply natToWord_inj; try eapply wordToNat_bound.
  2: generalize (wordToNat_bound w); omega.
  rewrite natToWord_wordToNat.
  unfold wminus.
  rewrite wneg_alt.
  unfold wnegN.
  pattern w at 1.
  rewrite <- (natToWord_wordToNat w).
  rewrite <- natToWord_plus.
  specialize (wordToNat_bound u); intro.
  destruct (le_lt_dec (wordToNat u) (wordToNat w)).
  replace (wordToNat w + (pow2 sz - wordToNat u))
    with (pow2 sz + (wordToNat w - wordToNat u)) by omega.
  rewrite natToWord_plus.
  rewrite natToWord_pow2.
  apply wplus_unit.
  elimtype False; apply H.
  nomega.
Qed.

Hint Rewrite wordToNat_wminus using assumption : sepFormula.

Lemma Nle_out : forall n m, (n <= m)%N -> (N.to_nat n <= N.to_nat m)%nat.
  intros; apply N.lt_eq_cases in H; intuition.
  apply Nlt_out in H0; auto.
Qed.

Lemma wordToNat_wplus : forall (w u : W),
  goodSize (wordToNat w + wordToNat u)
  -> wordToNat (w ^+ u) = wordToNat w + wordToNat u.
  intros.
  rewrite wplus_alt; unfold wplusN, wordBinN.
  apply wordToNat_natToWord_idempotent; auto.
Qed.

Lemma wordToNat_wmult : forall (w u : W),
  goodSize (wordToNat w * wordToNat u)
  -> wordToNat (w ^* u) = wordToNat w * wordToNat u.
  intros.
  rewrite wmult_alt; unfold wmultN, wordBinN.
  apply wordToNat_natToWord_idempotent; auto.
Qed.

Lemma wle_le : forall (n sz : W),
  n <= sz
  -> (wordToNat n <= wordToNat sz)%nat.
  intros; destruct (le_lt_dec (wordToNat n) (wordToNat sz)); auto.
  elimtype False; apply H.
  nomega.
Qed.

Local Hint Resolve simplify_fwd.

Lemma subst_qspecOut_fwd' : forall pc state (specs : codeSpec pc state) A B v v' qs (k : _ -> propX _ _ (A :: B :: nil)),
  interp specs (subst (subst (qspecOut qs k) v) v' ---> qspecOut qs (fun x => subst (subst (k x) v) v')).
  induction qs; simpl; intros.
  apply Imply_refl.
  apply Imply_I.
  eapply Exists_E.
  apply Env; simpl; eauto.
  simpl; intros.
  eapply Exists_I.
  eapply Imply_E.
  apply interp_weaken; eauto.
  eapply Env; simpl; eauto.
Qed.

Lemma subst_qspecOut_fwd : forall pc state (specs : codeSpec pc state) A v qs (k : _ -> propX _ _ (A :: nil)),
  interp specs (subst (qspecOut qs k) v)
  -> interp specs (qspecOut qs (fun x => subst (k x) v)).
  induction qs; propxFo; eauto.
Qed.

Lemma subst_qspecOut_bwd' : forall pc state (specs : codeSpec pc state) A B v v' qs (k : _ -> propX _ _ (A :: B :: nil)),
  interp specs (qspecOut qs (fun x => subst (subst (k x) v) v') ---> subst (subst (qspecOut qs k) v) v').
  induction qs; simpl; intros.
  apply Imply_refl.
  apply Imply_I.
  eapply Exists_E.
  apply Env; simpl; eauto.
  simpl; intros.
  eapply Exists_I.
  eapply Imply_E.
  apply interp_weaken; eauto.
  eapply Env; simpl; eauto.
Qed.

Lemma subst_qspecOut_bwd : forall pc state (specs : codeSpec pc state) A v qs (k : _ -> propX _ _ (A :: nil)),
  interp specs (qspecOut qs (fun x => subst (k x) v))
  -> interp specs (subst (qspecOut qs k) v).
  induction qs; propxFo; eauto.
Qed.

Fixpoint domain (qs : qspec) : Type :=
  match qs with
    | Programming.Body _ => unit
    | Quant _ f => sigT (fun x => domain (f x))
  end.

Fixpoint qspecOut' (qs : qspec) : domain qs -> HProp :=
  match qs with
    | Programming.Body P => fun _ => P
    | Quant _ f => fun d => qspecOut' (f (projT1 d)) (projT2 d)
  end.

Lemma qspecOut_fwd' : forall (specs : codeSpec W (settings * state)) qs k,
  interp specs (qspecOut qs k ---> Ex v : domain qs, k (qspecOut' qs v))%PropX.
  induction qs; simpl; intros.
  apply Imply_I; apply Exists_I with tt; apply Env; simpl; tauto.
  apply Imply_I; eapply Exists_E; [ apply Env; simpl; tauto | ].
  simpl; intros.
  eapply Exists_E.
  eapply Imply_E.
  apply interp_weaken; apply H.
  apply Env; simpl; eauto.
  simpl; intros.
  apply Exists_I with (existT _ B B0).
  apply Env; simpl; eauto.
Qed.

Lemma qspecOut_fwd : forall (specs : codeSpec W (settings * state)) qs k,
  interp specs (qspecOut qs k)
  -> exists v : domain qs, interp specs (k (qspecOut' qs v)).
  intros; apply (Imply_sound (qspecOut_fwd' _ _ _)) in H; propxFo; eauto.
Qed.

Lemma qspecOut_bwd' : forall (specs : codeSpec W (settings * state)) qs k v,
  interp specs (k (qspecOut' qs v) ---> qspecOut qs k).
  induction qs; simpl; intros.
  apply Imply_refl.
  destruct v; simpl.
  eapply Imply_trans; eauto.
  apply Imply_I; eapply Exists_I; apply Env; simpl; eauto.
Qed.

Lemma qspecOut_bwd : forall (specs : codeSpec W (settings * state)) qs k v,
  interp specs (k (qspecOut' qs v))
  -> interp specs (qspecOut qs k).
  intros; eapply (Imply_sound (qspecOut_bwd' _ _ _ _)); eauto.
Qed.

Lemma qspecOut_bwd'' : forall (specs : codeSpec W (settings * state)) qs k,
  interp specs ((Ex v, k (qspecOut' qs v)) ---> qspecOut qs k)%PropX.
  intros.
  apply Imply_I.
  eapply Exists_E; [ apply Env; simpl; eauto | ].
  simpl; intros.
  eapply Imply_E.
  apply interp_weaken; apply qspecOut_bwd'.
  apply Env; simpl; eauto.
Qed.

Theorem localsInvariant_in : forall ns' pre post ns res ns'' res' stn_st specs,
  interp specs (Ex st' : state,
    localsInvariant pre post false (fun w => w) ns res (fst stn_st, st')
    /\ [| evalInstrs (fst stn_st) st' (Assign (LvMem (Sp + 0)%loc) Rp :: nil)
      = Some (snd stn_st) |])%PropX
  -> (length ns' <= res)%nat
  -> res' = res - length ns'
  -> ns ++ ns' = ns''
  -> NoDup ("rp" :: ns ++ ns')
  -> (forall vs1 vs2, (forall x, In x ns
    -> sel vs1 x = sel vs2 x)
  -> pre vs1 = pre vs2)
  -> (forall vs1 vs2, (forall x, In x ns
    -> sel vs1 x = sel vs2 x)
  -> post vs1 = post vs2)
  -> interp specs (localsInvariant pre post true (fun w => w)
    ns'' res' stn_st).
  post; subst.
  apply subst_qspecOut_fwd in H.
  apply qspecOut_fwd in H.
  destruct H.
  post.
  change (locals ("rp" :: ns) x1 res (Regs x Sp))
    with (locals_in ("rp" :: ns) x1 res (Regs x Sp) ns' ("rp" :: ns ++ ns') (res - length ns')) in H1.
  assert (ok_in ("rp" :: ns) res ns' ("rp" :: ns ++ ns') (res - length ns')).
  red; intuition.
  change (LvMem (Sp + 0)%loc) with (LvMem (Sp + variablePosition ("rp" :: ns ++ ns') "rp")%loc) in H7.
  assert (In "rp" ("rp" :: ns ++ ns')) by intuition.
  evaluate auto_ext.
  generalize dependent x2.
  rewrite <- H10.
  erewrite H4.
  intros.
  descend.
  apply subst_qspecOut_bwd.
  eapply qspecOut_bwd.
  post.
  step auto_ext.
  intros.
  match goal with
    | [ |- himp _ ?P ?Q ] =>
      match P with
        | context[pre ?X _] =>
          match Q with
            | context[pre ?Y _] => equate X Y
          end
      end
  end.
  step auto_ext.
  descend.
  eauto.
  step auto_ext.
  clear H8.
  descend.
  step auto_ext.
  Focus 2.
  intuition subst.
  unfold sel at 1 3.
  rewrite sel_upd_ne.
  specialize (@merge_agree x1 x4 ("rp" :: ns)).
  unfold agree_on; intro Hag.
  rewrite (proj1 (Forall_forall _ _) Hag _ (or_intror _ H11)); auto.
  inversion H3; subst.
  intro; subst.
  apply H14.
  apply in_or_app; tauto.

  eapply Imply_trans; [ eapply subst_qspecOut_fwd' | ].
  eapply Imply_trans; [ | eapply subst_qspecOut_bwd' ].

  erewrite H5.
  rewrite H10.
  eapply Imply_trans; [ apply qspecOut_fwd' | ].
  eapply Imply_trans; [ | apply qspecOut_bwd'' ].
  simpl.
  post.
  step auto_ext.
  instantiate (3 := sel x1).
  step auto_ext.
  change ("rp" :: ns ++ ns') with (("rp" :: ns) ++ ns').
  rewrite H1.
  apply prelude_out; auto.
  intros; unfold sel at 1 3.
  rewrite sel_upd_ne.
  specialize (@merge_agree x1 x4 ("rp" :: ns)).
  unfold agree_on; intro Hag.
  rewrite (proj1 (Forall_forall _ _) Hag _ (or_intror _ H12)); auto.
  inversion H3; subst.
  intro; subst.
  apply H15.
  apply in_or_app; tauto.
Qed.

Theorem localsInvariant_inEx : forall specs A p q p',
  (forall x, interp specs (Ex st' : state,
      p st' x
      /\ q st')%PropX
    -> interp specs (p' x))
  -> interp specs (Ex st' : state,
    (Ex x : A, p st' x)
    /\ q st')%PropX
  -> interp (pc := W) (state := settings * state) specs (Ex x : A, p' x).
  propxFo.
  exists x0.
  apply simplify_fwd.
  apply H.
  propxFo; eauto.
Qed.

Lemma word_le : forall sz (u v : word sz),
  u = v \/ u < v
  -> u <= v.
  intuition subst; nomega.
Qed.

Hint Resolve word_le.

Hint Rewrite wordToNat_natToWord_idempotent using reflexivity : sepFormula.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_destroy1_spec0 (g_rd: Pointer) (map_addr: Z64) (rtt_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, rtt_addr, level with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _rtt_addr, VZ64 _level =>
      rely is_int64 _map_addr;
      rely is_int64 _rtt_addr;
      rely is_int64 _level;
      when' _t'1, adt == table_destroy_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 _rtt_addr) (VZ64 _level) adt;
      rely is_int64 _t'1;
      Some (adt, (VZ64 _t'1))
     end
    .

End SpecLow.


Axiom T : Type.

Lemma foo : True * Type.
Proof.
  split.
  par: abstract (exact I || exact T).
Defined.

(* Yes, these names are generated hence
   the test is fragile.  I want to assert
   that abstract was correctly handled
   by par: *)
Check foo_subproof.
Check foo_subproof0.
Check (refl_equal _ :
  foo =
  pair foo_subproof foo_subproof0).

Lemma bar : True * Type.
Proof.
  split.
  par: (exact I || exact T).
Defined.
Check (refl_equal _ :
  bar = pair I T).


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                             confluence_LSL.v                             *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

                 (* Confluence du lambda-sigma-lift *)

Require Import TS.
Require Import sur_les_relations.
Require Import sigma_lift.
Require Import lambda_sigma_lift.
Require Import terminaison_SL.
Require Import conf_local_SL.
Require Import betapar.
Require Import SLstar_bpar_SLstar.
Require Import conf_strong_betapar.
Require Import commutation.
Require Import Newman.
Require Import Yokouchi.

Goal forall b : wsort, explicit_confluence _ (e_relSL b).
intros b.
apply Newman.
apply relSL_noetherian.
apply conf_local_SL.
Save confluence_SL.

Goal forall b : wsort, explicit_strong_confluence _ (e_slstar_bp_slstar b).
intro b; unfold e_slstar_bp_slstar in |- *.
change
  (explicit_strong_confluence _
     (Rstar_S_Rstar (TS b) (e_relSL b) (e_beta_par b)))
 in |- *.
apply Yokouchi.
apply confluence_SL.
apply relSL_noetherian.
apply sconf_betapar.
intros f g h H H0.
unfold Rstar_S_Rstar in |- *.
change (exists k : TS b, e_relSLstar _ g k /\ e_slstar_bp_slstar _ h k)
 in |- *.
apply commutation with f; assumption.
Save strong_confluence_slbpsl.

Goal forall b : wsort, explicit_confluence _ (e_slstar_bp_slstar b).
intro b; apply strong_conf_conf; apply strong_confluence_slbpsl.
Save confluence_slbpsl.

(**********************************************)
(*        lambda-sigma-lift est confluent     *)
(**********************************************)

Theorem confluence_LSL : forall b : wsort, explicit_confluence _ (e_relLSL b).
Proof.
intro b; apply inclus_conf with (e_slstar_bp_slstar b).
apply relLSL_inclus_slbpsl.
change (explicit_inclus _ (e_slstar_bp_slstar b) (e_relLSLstar b)) in |- *.
apply slbpsl_inclus_relLSLstar.
apply confluence_slbpsl.
Qed.


(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype fintype.
From mathcomp Require Import tuple seq fintype bigop ssralg finalg.
From mathcomp Require Import ssrfun choice zmodp fingroup.

Require Import mpoly polyall polydec ssrring.

Import GRing.Theory.

Open Local Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(* -------------------------------------------------------------------- *)
Local Notation simp := Monoid.simpm.

Reserved Notation "\- x" (at level 50).

(* -------------------------------------------------------------------- *)
(* FIXME: move me                                                       *)
Lemma ltn_pred (n m : nat): (n.-1 < m.-1) -> (n < m).
Proof. by case: n m => [|n] [|m]. Qed.

Lemma maxn_pred n m: maxn n.-1 m.-1 = (maxn n m).-1.
Proof. by case: n m => [|n] [|m]; rewrite ?(maxn0, max0n, maxnSS). Qed.

Definition monotone f := forall m n, (f m <= f n) = (m <= n).

Lemma map_maxn f n m: monotone f -> f (maxn n m) = maxn (f n) (f m).
Proof.
  move=> mono_f; rewrite /maxn [f n < _]ltnNge mono_f.
  by rewrite -ltnNge; case: (_ < _).
Qed.

(* -------------------------------------------------------------------- *)
Module ECUFieldType.
  Record mixin_of (K : ringType) : Type := Mixin {
    _ : 2%:R != 0 :> K;
    _ : 3%:R != 0 :> K
  }.

  Section ClassDef.
    Record class_of (K : Type) := Class {
      base  : GRing.Field.class_of K;
      mixin : mixin_of (GRing.Field.Pack base K)
    }.

    Local Coercion base : class_of >-> GRing.Field.class_of.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.

    Local Coercion sort : type >-> Sortclass.

    Variables (T : Type) (cT : type).

    Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
    Definition clone c of phant_id class c := @Pack T c T.

    Definition pack b0 (m0 : mixin_of (@GRing.Field.Pack T b0 T)) :=
      fun bT b & phant_id (@GRing.Field.class bT) b =>
      fun    m & phant_id m0 m => Pack (@Class T b m) T.

    Definition eqType          := Equality.Pack             class cT.
    Definition choiceType      := Choice.Pack               class cT.
    Definition zmodType        := GRing.Zmodule.Pack        class cT.
    Definition ringType        := GRing.Ring.Pack           class cT.
    Definition comRingType     := GRing.ComRing.Pack        class cT.
    Definition unitRingType    := GRing.UnitRing.Pack       class cT.
    Definition comUnitRingType := GRing.ComUnitRing.Pack    class cT.
    Definition idomainType     := GRing.IntegralDomain.Pack class cT.
    Definition fieldType       := GRing.Field.Pack          class cT.
  End ClassDef.

  Module Exports.
    Coercion base  : class_of >-> GRing.Field.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion sort  : type     >-> Sortclass.

    Bind Scope ring_scope with sort.

    Coercion eqType : type >-> Equality.type.
    Canonical eqType.
    Coercion choiceType : type >-> Choice.type.
    Canonical choiceType.
    Coercion zmodType : type >-> GRing.Zmodule.type.
    Canonical zmodType.
    Coercion ringType : type >-> GRing.Ring.type.
    Canonical ringType.
    Coercion comRingType : type >-> GRing.ComRing.type.
    Canonical comRingType.
    Coercion unitRingType : type >-> GRing.UnitRing.type.
    Canonical unitRingType.
    Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
    Canonical comUnitRingType.
    Coercion idomainType : type >-> GRing.IntegralDomain.type.
    Canonical idomainType.
    Coercion fieldType : type >-> GRing.Field.type.
    Canonical fieldType.

    Notation ecuFieldType := type.
    Notation ECUFieldType T m := (@pack T _ m _ _ id _ id).
    Notation ECUFieldMixin := Mixin.

    Notation "[ 'ecuFieldType' 'of' T ]" := (@clone T _ _ id)
      (at level 0, format "[ 'ecuFieldType'  'of'  T ]") : form_scope.
  End Exports.
End ECUFieldType.

Export ECUFieldType.Exports.

Section ECUFieldTypeTheory.
  Variable K : ecuFieldType.

  Lemma ecu_chi2: 2%:R != 0 :> K.
  Proof. by case: K => [? [? []]]. Qed.

  Lemma ecu_chi3: 3%:R != 0 :> K.
  Proof. by case: K => [? [? []]]. Qed.

  Lemma ecu_eq_oppr:
    forall (x : K), x = -x -> x = 0.
  Proof.
    move=> x; move/(congr1 (+%R x)); rewrite subrr -mulr2n => /eqP.
    by rewrite -mulr_natl mulf_eq0 (negbTE ecu_chi2) => /eqP.
  Qed.
End ECUFieldTypeTheory.

(* -------------------------------------------------------------------- *)
Module ECUFinField.
  Local Notation mixin_of T b := (Finite.mixin_of (EqType T b)).
  Local Notation fin_ c := (@Finite.Class _ c c).
  Local Notation do_pack pack T := (pack T _ _ id _ _ id).

  Local Notation base_group T vT fT :=
    (@FinGroup.PackBase T (FinRing.groupMixin vT) (Finite.class fT)).
  Local Notation fin_group B V := (@FinGroup.Pack B (@addNr V)).

  Section ClassDef.
    Record class_of R := Class {
      base  : ECUFieldType.class_of R;
      mixin : mixin_of R base
    }.

    Definition base2 R (c : class_of R) := FinRing.Field.Class (mixin c).

    Local Coercion base  : class_of >-> ECUFieldType.class_of.
    Local Coercion base2 : class_of >-> FinRing.Field.class_of.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.
    Local Coercion sort : type >-> Sortclass.

    Definition pack := FinRing.gen_pack Pack Class ECUFieldType.class.

    Variable cT : type.

    Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.

    Let xT := let: Pack T _ _ := cT in T.
    Notation xclass := (class : class_of xT).

    Definition eqType := @Equality.Pack cT xclass xT.
    Definition choiceType := @Choice.Pack cT xclass xT.
    Definition countType := @Countable.Pack cT (fin_ xclass) xT.
    Definition finType := @Finite.Pack cT (fin_ xclass) xT.
    Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
    Definition finZmodType := @FinRing.Zmodule.Pack cT xclass xT.
    Definition ringType := @GRing.Ring.Pack cT xclass xT.
    Definition finRingType := @FinRing.Ring.Pack cT xclass xT.
    Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
    Definition finComRingType := @FinRing.ComRing.Pack cT xclass xT.
    Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
    Definition finUnitRingType := @FinRing.UnitRing.Pack cT xclass xT.
    Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
    Definition finComUnitRingType := @FinRing.ComUnitRing.Pack cT xclass xT.
    Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
    Definition finIdomainType := @FinRing.IntegralDomain.Pack cT xclass xT.
    Definition fieldType := @GRing.Field.Pack cT xclass xT.
    Definition finFieldType := @FinRing.Field.Pack cT xclass xT.
    Definition ecuFieldType := @ECUFieldType.Pack cT xclass xT.

    Definition join_finType := @Finite.Pack fieldType (fin_ xclass) xT.
    Definition join_finZmodType := @FinRing.Zmodule.Pack fieldType xclass xT.
    Definition join_finRingType := @FinRing.Ring.Pack fieldType xclass xT.
    Definition join_finUnitRingType := @FinRing.UnitRing.Pack fieldType xclass xT.
    Definition join_finComRingType := @FinRing.ComRing.Pack fieldType xclass xT.
    Definition join_finComUnitRingType := @FinRing.ComUnitRing.Pack fieldType xclass xT.
    Definition join_finIdomainType := @FinRing.IntegralDomain.Pack fieldType xclass xT.
    Definition join_finFieldType := @FinRing.Field.Pack fieldType xclass xT.

    Definition baseFinGroupType := base_group cT zmodType finType.
    Definition finGroupType := fin_group baseFinGroupType zmodType.
    Definition join_baseFinGroupType := base_group zmodType zmodType finType.
    Definition join_finGroupType := fin_group join_baseFinGroupType zmodType.
  End ClassDef.

  Module Exports.
    Coercion base  : class_of >-> ECUFieldType.class_of.
    Coercion base2 : class_of >-> FinRing.Field.class_of.
    Coercion sort  : type >-> Sortclass.

    Bind Scope ring_scope with sort.

    Coercion eqType : type >-> Equality.type.
    Canonical eqType.
    Coercion choiceType : type >-> Choice.type.
    Canonical choiceType.
    Coercion countType : type >-> Countable.type.
    Canonical countType.
    Coercion finType : type >-> Finite.type.
    Canonical finType.
    Coercion zmodType : type >-> GRing.Zmodule.type.
    Canonical zmodType.
    Coercion finZmodType : type >-> FinRing.Zmodule.type.
    Canonical finZmodType.
    Coercion ringType : type >-> GRing.Ring.type.
    Canonical ringType.
    Coercion finRingType : type >-> FinRing.Ring.type.
    Canonical finRingType.
    Coercion comRingType : type >-> GRing.ComRing.type.
    Canonical comRingType.
    Coercion finComRingType : type >-> FinRing.ComRing.type.
    Canonical finComRingType.
    Coercion unitRingType : type >-> GRing.UnitRing.type.
    Canonical unitRingType.
    Coercion finUnitRingType : type >-> FinRing.UnitRing.type.
    Canonical finUnitRingType.
    Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
    Canonical comUnitRingType.
    Coercion finComUnitRingType : type >-> FinRing.ComUnitRing.type.
    Canonical finComUnitRingType.
    Coercion idomainType : type >-> GRing.IntegralDomain.type.
    Canonical idomainType.
    Coercion finIdomainType : type >-> FinRing.IntegralDomain.type.
    Canonical finIdomainType.
    Coercion fieldType : type >-> GRing.Field.type.
    Canonical fieldType.
    Coercion finFieldType : type >-> FinRing.Field.type.
    Canonical finFieldType.
    Coercion ecuFieldType : type >-> ECUFieldType.type.
    Canonical ecuFieldType.

    Canonical fieldType.
    Canonical join_finType.
    Canonical join_finZmodType.
    Canonical join_finRingType.
    Canonical join_finComRingType.
    Canonical join_finUnitRingType.
    Canonical join_finComUnitRingType.
    Canonical join_finIdomainType.
    Canonical join_finFieldType.

    Notation finECUFieldType := ECUFinField.type.

    Notation "[ 'finECUFieldType' 'of' T ]" := (do_pack pack T)
      (at level 0, format "[ 'finECUFieldType'  'of'  T ]") : form_scope.

    Canonical baseFinGroupType.
    Canonical finGroupType.
    Canonical join_baseFinGroupType.
    Canonical join_finGroupType.
  End Exports.
End ECUFinField.

Export ECUFinField.Exports.

(* -------------------------------------------------------------------- *)
Module ECUDecFieldType.
  Section ClassDef.
    Record class_of (K : Type) := Class {
      base  : ECUFieldType.class_of K;
      mixin : GRing.DecidableField.mixin_of (GRing.UnitRing.Pack base K)
    }.

    Local Coercion base : class_of >-> ECUFieldType.class_of.

    Definition base2 F m := GRing.DecidableField.Class (@mixin F m).
    Local Coercion base2 : class_of >-> GRing.DecidableField.class_of.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.

    Local Coercion sort : type >-> Sortclass.

    Variables (T : Type) (cT : type).

    Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
    Definition clone c of phant_id class c := @Pack T c T.

    Definition pack b0 (m0 : GRing.DecidableField.mixin_of (@GRing.UnitRing.Pack T b0 T)) :=
      fun bT b  & phant_id (@ECUFieldType.class bT) b =>
      fun    m  & phant_id m0 m =>
        Pack (@Class T b m) T.

    Definition eqType             := Equality.Pack             class cT.
    Definition choiceType         := Choice.Pack               class cT.
    Definition zmodType           := GRing.Zmodule.Pack        class cT.
    Definition ringType           := GRing.Ring.Pack           class cT.
    Definition comRingType        := GRing.ComRing.Pack        class cT.
    Definition unitRingType       := GRing.UnitRing.Pack       class cT.
    Definition comUnitRingType    := GRing.ComUnitRing.Pack    class cT.
    Definition idomainType        := GRing.IntegralDomain.Pack class cT.
    Definition fieldType          := GRing.Field.Pack          class cT.
    Definition decFieldType       := GRing.DecidableField.Pack class cT.
    Definition ecuFieldType       := ECUFieldType.Pack         class cT.
  End ClassDef.

  Module Exports.
    Coercion base  : class_of >-> ECUFieldType.class_of.
    Coercion sort  : type     >-> Sortclass.

    Bind Scope ring_scope with sort.

    Coercion eqType : type >-> Equality.type.
    Canonical eqType.
    Coercion choiceType : type >-> Choice.type.
    Canonical choiceType.
    Coercion zmodType : type >-> GRing.Zmodule.type.
    Canonical zmodType.
    Coercion ringType : type >-> GRing.Ring.type.
    Canonical ringType.
    Coercion comRingType : type >-> GRing.ComRing.type.
    Canonical comRingType.
    Coercion unitRingType : type >-> GRing.UnitRing.type.
    Canonical unitRingType.
    Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
    Canonical comUnitRingType.
    Coercion idomainType : type >-> GRing.IntegralDomain.type.
    Canonical idomainType.
    Coercion fieldType : type >-> GRing.Field.type.
    Canonical fieldType.
    Coercion decFieldType : type >-> GRing.DecidableField.type.
    Canonical decFieldType.
    Coercion ecuFieldType : type >-> ECUFieldType.type.
    Canonical ecuFieldType.

    Notation ecuDecFieldType := ECUDecFieldType.type.
    Notation EcuDecFieldMixin := GRing.DecidableField.Mixin.
    Notation EcuDecFieldType T m := (@pack T _ m _ _ id _ id).

    Notation "[ 'ecuDecFieldType' 'of' T ]" := (@pack T _ _ _ id _ id)
      (at level 0, format "[ 'ecuDecFieldType'  'of'  T ]") : form_scope.
  End Exports.
End ECUDecFieldType.

Export ECUDecFieldType.Exports.

(* -------------------------------------------------------------------- *)
Record ecuType (K : ringType) := {
  cA : K;
  cB : K;
  _  : 4%:R * cA^+3 + 27%:R * cB^+2 != 0
}.

Notation "K '#a'" := (K.(cA)) (at level 30).
Notation "K '#b'" := (K.(cB)) (at level 30).

Section ECUTypeTheory.
  Variable K : ringType.
  Variable E : ecuType K.

  Lemma ecu_DN0: 4%:R * (E#a)^+3 + 27%:R * (E#b)^+2 != 0 :> K.
  Proof. by case: E. Qed.
End ECUTypeTheory.

(* -------------------------------------------------------------------- *)
Section PointDef.
  Inductive point (K : Type) : Type :=
  | EC_Inf : point K
  | EC_In  : K -> K -> point K.
End PointDef.

Section PointEq.
  Variable T : eqType.

  Local Notation point := (point T).

  Definition point_eq (p1 p2 : point) :=
    match p1, p2 with
    | EC_Inf     , EC_Inf      => true
    | EC_In x1 y1, EC_In x2 y2 => [&& (x1 == x2) & (y1 == y2)]
    | _          , _           => false
    end.

  Lemma point_eqP:
    forall (p1 p2 : point), reflect (p1 = p2) (point_eq p1 p2).
  Proof.
    move=> p1 p2; apply: (iffP idP); last first.
    + by move=> {p2} <-; case: p1 => //= *; rewrite !eqxx.
    move: p1 p2 => [|x1 y1] [|x2 y2] //=.
    by case/andP; do 2! (move/eqP=> ->).
  Qed.

  Definition point_eqMixin := EqMixin point_eqP.

  Canonical Structure point_eqType :=
    Eval hnf in (EqType _ point_eqMixin).
End PointEq.

(* -------------------------------------------------------------------- *)
Notation "∞"           := (@EC_Inf _)    (at level 8).
Notation "(| x , y |)" := (@EC_In _ x y) (at level 8, x, y at level 15).

(* -------------------------------------------------------------------- *)
Section PointChoice.
  Variable T : choiceType.

  Definition encode (p : point T) :=
    match p with
    | EC_Inf    => [::]
    | EC_In x y => [:: x; y]
    end.

  Definition decode (c : seq T) :=
    match c with
    | [::]      => Some (EC_Inf _)
    | [:: x; y] => Some (EC_In x y)
    | _         => None
    end.

  Lemma codeK : pcancel encode decode.
  Proof. by case. Qed.

  Definition point_choiceMixin := PcanChoiceMixin codeK.

  Canonical Structure point_choiceType :=
    Eval hnf in (ChoiceType _ point_choiceMixin).
End PointChoice.

(* -------------------------------------------------------------------- *)
Section PointCount.
  Variable T : countType.

  Definition pickle (p : point T) :=
    match p with
    | EC_Inf    => None
    | EC_In x y => Some (x, y)
    end.

  Definition unpickle (p : option (T * T)) :=
    match p with
    | None        => EC_Inf _
    | Some (x, y) => EC_In x y
    end.

  Definition pickleK: cancel pickle unpickle.
  Proof. by case. Qed.

  Definition point_countMixin := CanCountMixin pickleK.

  Canonical Structure point_countType :=
    Eval hnf in (CountType _ point_countMixin).
End PointCount.

(* -------------------------------------------------------------------- *)
Section PointFinType.
  Variable T : finType.

  Definition points := (EC_Inf T) :: [seq (|x.1, x.2|) | x : T*T].

  Lemma uniq_points: uniq points.
  Proof.
    rewrite /points /=; apply/andP; split.
    + by apply/memPn=> P /mapP [x _ ->].
    + rewrite map_inj_uniq ?enum_uniq //.
      by case=> [x1 y1] [x2 y2]; case => -> ->.
  Qed.

  Lemma total_points : points =i {: point T}.
  Proof.
    case=> [|x y] //; rewrite /points inE /=.
    pose xy := (x, y); have ->: (|x, y|) = (|xy.1, xy.2|) by [].
    by apply: map_f; rewrite {}/xy; apply: mem_enum.
  Qed.

  Definition point_finMixin := UniqFinMixin uniq_points total_points.
  Canonical point_finType := FinType (point T) point_finMixin.

  Lemma npoints: #|{: point T}| = (#|T|^2).+1.
  Proof.
    rewrite /= cardT enumT unlock /=.
    by rewrite size_map -cardT /= card_prod.
  Qed.
End PointFinType.

(* -------------------------------------------------------------------- *)
Section EC.
  Variable K : ringType.
  Variable E : ecuType K.

  Definition oncurve (p : point K) := (
    match p with
    | EC_Inf    => true
    | EC_In x y => y^+2 == x^+3 + E#a * x + E#b
    end).

  Inductive ec : Type := EC p of oncurve p.

  Coercion point_of_ec p := let: EC p _ := p in p.

  Canonical Structure ec_subType := [subType for point_of_ec by ec_rect].

  Definition ec_eqMixin := [eqMixin of ec by <:].
  Canonical Structure ec_eqType := Eval hnf in EqType ec ec_eqMixin.

  Definition ec_choiceMixin := [choiceMixin of ec by <:].
  Canonical Structure ec_choiceType := Eval hnf in ChoiceType ec ec_choiceMixin.

  Lemma oncurve_ec: forall p : ec, oncurve p.
  Proof. exact: valP. Qed.

  Hint Resolve oncurve_ec.
End EC.

Notation "[ 'oc' 'of' p ]" := (oncurve_ec p).

(* -------------------------------------------------------------------- *)
Section ECCountType.
  Variable K : finRingType.
  Variable E : ecuType K.

  Definition ec_countMixin := [countMixin of (ec_subType E) by <:].
  Canonical Structure ec_countType := Eval hnf in CountType (ec E) ec_countMixin.

  Canonical ec_subCountType := Eval hnf in [subCountType of ec E].
End ECCountType.

(* -------------------------------------------------------------------- *)
Section ECFinType.
  Variable K : finFieldType.
  Variable E : ecuType K.

  Local Notation ec := (@ec K E).

  Definition ec_finMixin := [finMixin of ec by <:].
  Canonical ec_finType := Eval hnf in (FinType ec ec_finMixin).
End ECFinType.

(* -------------------------------------------------------------------- *)
Section XPoly.
  Variable K : ringType.
  Variable E : ecuType K.

  Local Notation a := (E#a).
  Local Notation b := (E#b).

  Definition Xpoly := locked (Poly [:: b; a; 0; 1]).

  Lemma size_Xpoly : size Xpoly = 4.
  Proof.
    by unlock Xpoly; rewrite (@PolyK _ 0) //= oner_neq0.
  Qed.

  Lemma XpolyE: Xpoly = 'X^3 + a *: 'X + b%:P.
  Proof.
    apply/polyP=> i; unlock Xpoly; rewrite (@PolyK _ 0) //= ?oner_neq0 //.
    rewrite !coef_add_poly coefXn coefC coefZ coefX; move: i.
    by do 5! (case; first by rewrite !simp); move=> ?; rewrite /= !simp.
  Qed.

  Lemma XpolyN0: Xpoly != 0.
  Proof. by rewrite -size_poly_eq0 size_Xpoly. Qed.

  Lemma horner_Xpoly:
    forall x, Xpoly.[x] = x ^+ 3 + a * x + b.
  Proof. by move=> x; rewrite XpolyE !(hornerXn, hornerE). Qed.

  Lemma Xpoly_oncurve c:
    (root Xpoly c) = oncurve E (|c, 0|).
  Proof.
    by rewrite rootE horner_Xpoly /= expr2 mulr0 eq_sym.
  Qed.

  Lemma oncurve_root x y: oncurve E (|x, y|) = root ('X ^+ 2 - (Xpoly.[x])%:P) y.
  Proof.
    by rewrite rootE !(hornerE, hornerXn, horner_Xpoly) subr_eq0.
  Qed.

  Lemma Xpoly_monic: Xpoly \is monic.
  Proof.
    apply/monicP; unlock lead_coef Xpoly.
    by rewrite !(PolyK (c := 0)) //= oner_eq0.
  Qed.

  Lemma map_XpolyE (rT : ringType) (f : {rmorphism K -> rT}):
    map_poly f Xpoly = 'X^3 + (f (E#a)) *: 'X + (f (E#b))%:P.
  Proof.
    pose rwE := (rmorphD, map_polyC, map_polyZ, map_polyXn, map_polyX).
    by rewrite XpolyE; do! rewrite !rwE /=.
  Qed.
End XPoly.

(* -------------------------------------------------------------------- *)
Module ECGroup.
  Section Defs.
    Variable K : ecuFieldType.
    Variable E : ecuType K.

    Local Notation Xpoly := (@Xpoly _ E).

    Lemma eqrN_eq0 (y : K): (y == -y) = (y == 0).
    Proof.
      rewrite -addr_eq0 -{1 2}[y]mul1r -mulrDl.
      by rewrite mulf_eq0 (negbTE (ecu_chi2 K)).
    Qed.

    Definition neg (p : point K) :=
      if p is (|x, y|) then (|x, -y|) else ∞.

    Definition add (p1 p2 : point K) :=
      let p1 := if oncurve E p1 then p1 else ∞ in
      let p2 := if oncurve E p2 then p2 else ∞ in

        match p1, p2 with
        | ∞, _ => p2 | _, ∞ => p1

        | (|x1, y1|), (|x2, y2|) =>
          if   x1 == x2
          then if   (y1 == y2) && (y1 != 0)
               then
                 let s  := (3%:R * x1^+2 + E#a) / (2%:R * y1) in
                 let xs := s^+2 - 2%:R * x1 in
                   (| xs, - s * (xs - x1) - y1 |)
               else
                 ∞
          else
            let s  := (y2 - y1) / (x2 - x1) in
            let xs := s^+2 - x1 - x2 in
              (| xs, - s * (xs - x1) - y1 |)
        end.

    Lemma zeroO : oncurve E ∞.
    Proof. by []. Qed.

    Lemma negO : forall p, oncurve E p -> oncurve E (neg p).
    Proof. by case=> [|x y] //=; rewrite sqrrN. Qed.

    Lemma oncurveN p: (oncurve E p) = (oncurve E (neg p)).
    Proof.
      apply/idP/idP; move/negO => //.
      by case: p => [|x y] //=; rewrite opprK.
    Qed.

    Lemma oncurveN_fin x y: oncurve E (|x, -y|) = oncurve E (|x, y|).
    Proof. by move: (oncurveN (|x, y|)). Qed.

    Local Notation sizep := (size : {poly _} -> _).

    Definition line (p q : K * K) : K * K * K :=
      let: (x1, y1) := p in
      let: (x2, y2) := q in

      match oncurve E (|x1, y1|) && oncurve E (|x2, y2|) with
      | false => (0, 0, 0)
      | true  =>
          if   x1 == x2
          then if   (y1 == y2) && (y1 != 0)
               then
                 let s := (3%:R * x1^+2 + E#a) / (2%:R * y1) in
                   (1, -s, y2 - s * x2)
               else
                 (0, 1, x1)
          else
            let s := (y2 - y1) / (x2 - x1) in
              (1, -s, y2 - s * x2)
      end.

    Definition ladd (p1 p2 : point K) :=
      let p1 := if oncurve E p1 then p1 else ∞ in
      let p2 := if oncurve E p2 then p2 else ∞ in

        match p1, p2 with
        | ∞, _ => neg p2 | _, ∞ => neg p1
        | (|x1, y1|), (|x2, y2|) =>
            let: (u, v, c) := line (x1, y1) (x2, y2) in
              if u == 0 then ∞ else
                let: x := u^-2 * v ^+ 2 - (x1 + x2) in
                let: y := u^-1 * (c - v * x) in
                  (|x, y|)
        end.

    Lemma ladd_addE p q: ladd p q = neg (add p q).
    Proof.
      rewrite /ladd /add;
        set pp := if oncurve E p then _ else _;
        set qq := if oncurve E q then _ else _.
      have oncve_pp: oncurve E pp by rewrite {}/pp; case h: (oncurve E p).
      have oncve_qq: oncurve E qq by rewrite {}/qq; case h: (oncurve E q).
      move: {p q} pp oncve_pp qq oncve_qq.
      case=> [|x1 y1] oncve_1 [|x2 y2] oncve_2 //.
      rewrite /line oncve_1 oncve_2 /=.
      case: (x1 =P x2); first (case: andP; first last).
      + by move=> _ _; rewrite eqxx.
      + case=> /eqP <- nz_y1 <-; rewrite oner_eq0.
        rewrite !(simp, expr1n, invr1, opprD, opprK) /=.
        by set s := ((_ + E#a) / _); congr (|_, _|); ssring.
      + move/eqP => ne_x1x2; rewrite oner_eq0.
        rewrite !(simp, expr1n, invr1, opprD, opprK) /=.
        set s := (y2 - y1) / _; congr (|_, _|); first by ssring.
        set l := (y2 - _ - _); set r := - _.
          have {l}->: l = s^+3 - s * (x1 + x2) + (y2 - s * x2) by ssring.
          have {r}->: r = s^+3 - s * (x1 + x2) + (y1 - s * x1) by ssring.
        have nz_x2Bx1: x2 - x1 != 0 by rewrite subr_eq0 eq_sym.
        congr (_ + _); apply/(@mulfI _ (x2 - x1)) => //.
        by rewrite !mulrBr !mulrA [_ / _]mulrAC divff // !simp; ssring.
    Qed.

    Lemma line_outcveE p q:
         ~~ (oncurve E (|p.1, p.2|) && oncurve E (|q.1, q.2|))
      -> line p q = (0, 0, 0).
    Proof. by case: p q => [x1 y1] [x2 y2]; rewrite /line => /negbTE ->. Qed.

    Lemma line_sym p q: line p q = line q p.
    Proof.
      case: p q => [x1 y1] [x2 y2]; rewrite /line;
        have [oncve_1 | outcve_1] := (boolP (oncurve E (|x1, y1|)));
        have [oncve_2 | outcve_2] := (boolP (oncurve E (|x2, y2|))) => //=.
      rewrite ![x2==_]eq_sym; case: (x1 =P x2) => [<-|/eqP ne_x1x2]; last first.
        rewrite -![y2 - y1]opprB -![x2 - x1]opprB !invrN !mulrNN.
        congr (_, _, _); rewrite [X in _-X=_]mulrAC [X in _=_-X]mulrAC.
        rewrite -[X in X+_=_]divr1 -[X in _=X+_]divr1 -!mulNr.
        rewrite !addf_div ?(oner_neq0, subr_eq0, ne_x1x2) // !simp.
        by congr (_ / _); rewrite !opprB !(mulrDl, mulrDr); ssring.
      rewrite ![y2==_]eq_sym; case: (y1 =P y2) => [<-|/eqP ne_y1y2] => //=.
      by rewrite [0==y1]eq_sym; have [->|->] := (eqVneq y1 0); rewrite ?eqxx.
    Qed.

    Lemma line_okl p q:
      let: (u, v, c) := line p q in
        u * p.2 + v * p.1 - c = 0.
    Proof.
      case: p q => [x1 y1] [x2 y2]; rewrite /line;
        have [oncve_1 | outcve_1] := (boolP (oncurve E (|x1, y1|)));
        have [oncve_2 | outcve_2] := (boolP (oncurve E (|x2, y2|)));
          rewrite ?(simp, oppr0) //=.
      case: (x1 =P x2) => [<-|/eqP ne_x1x2]; last first.
        rewrite !simp /= mulNr ![_ / _ * _]mulrAC opprD opprK !addrA.
        rewrite [_-y2]addrAC -!addrA -mulNr -mulrDl !addrA.
        rewrite -[y1-y2]divr1 addf_div ?(oner_eq0, subr_eq0) 1?eq_sym //.
        apply/eqP; rewrite !simp /=.
        rewrite mulf_eq0 invr_eq0 orbC subr_eq0 eq_sym (negbTE ne_x1x2) /=.
        by apply/eqP; ssring.
      case: (y1 =P y2) => [<-|/eqP ne_y1y2] /=; last by rewrite !simp subrr.
      have [->|nz_y1] := eqVneq y1 0; first by rewrite eqxx /= !simp subrr.
      by rewrite nz_y1 !simp; ssring.
    Qed.

    Lemma line_okr p q:
      let: (u, v, c) := line p q in
        u * q.2 + v * q.1 - c = 0.
    Proof. by rewrite line_sym; apply: line_okl. Qed.

    Lemma thdimp p q:
      let: (u, v, c) := line p q in
      let: r := Xpoly - (u^-1 *: (v *: 'X - c%:P)) ^+ 2 in
      let: z := u ^- 2 * v ^+ 2 - (p.1 + q.1) in
        u != 0 -> r = ('X - p.1%:P) * ('X - q.1%:P) * ('X - z%:P).
    Proof.
      set pp := (|p.1, p.2|); set qq := (|q.1, q.2|).
      case: (boolP (oncurve E pp && oncurve E qq)); last first.
        by move/line_outcveE=> ->; rewrite eqxx.
      case/andP=> oncve_p oncve_q; case lE: (line p q) => [[u v] c].
      move=> nz_u; set r := (Xpoly - _);
        set c0 := E#b - u^-2 * c^+2;
        set c1 := E#a + (u^-2 * v * c) *+ 2;
        set c2 := - u^-2 * v^+2;
          have Er: r = Poly [:: c0; c1; c2; 1].
      + apply/polyP=> i; unlock Xpoly; rewrite (@PolyK _ 0) //= ?oner_neq0 //.
        pose coefE := (coefMC, coefCM, coefE).
        rewrite /r XpolyE !(exprZn, sqrrB) !coefE; move: i.
        do 4! (case; first by rewrite !(simp, oppr0, exprVn, eqxx) //=; ssring).
        by move=> i; rewrite !(simp, oppr0, exprVn, eqxx) /= nth_nil.
      have sz_r: size r = 4 by rewrite Er (@PolyK _ 0) // oner_eq0.
      have nz_r: r != 0 by rewrite -size_poly_eq0 sz_r.
      have monic_r: r \is monic.
        apply/monicP; rewrite Er lead_coefE -{2}Er sz_r.
        by rewrite (@PolyK _ 0) // oner_neq0.
      have root_pVq: forall s, (s == p) || (s == q) -> root r s.1.
        move=> s eq_s_pq; have oncve_s: oncurve E (|s.1, s.2|).
          by case/orP: eq_s_pq => /eqP ->.
        have: u * s.2 + v * s.1 - c = 0.
          case/orP: eq_s_pq => /eqP->.
          + by move: (line_okl p q); rewrite lE.
          + by move: (line_okr p q); rewrite lE.
        move/eqP; rewrite -addrA addrC addr_eq0 => /eqP vsBcE.
        rewrite rootE /r !(horner_exp, hornerE) /= vsBcE.
        rewrite !mulrN sqrrN mulrA mulVf // mul1r.
        by rewrite horner_Xpoly -(eqP oncve_s) subrr.
      have h: forall x, count (pred1 x) [:: p.1; q.1] <= \mu_x r.
        move=> x /=; rewrite addn0; case: (p.1 =P x); last first.
          move/eqP=> ne_p1x; rewrite add0n; case: (q.1 =P x) => //=.
          move=> <-; rewrite mu_gt0 //; apply: root_pVq.
          by rewrite eqxx orbT.
        move=> /esym Exp; case: (q.1 =P x); last first.
          move/eqP=> ne_q1x; rewrite addn0 /= mu_gt0 // Exp.
          by apply: root_pVq; rewrite eqxx.
        move=> /esym Exq /=; rewrite addn1; move: lE.
        have pairE: forall x, (x.1, x.2) = x by move=> ?? [].
        rewrite /line -[p]pairE -[q]pairE {pairE} oncve_p oncve_q /=.
        rewrite -Exp -Exq eqxx /=; case: andP; last first.
          by move=> _ [/esym z_u _ _]; rewrite z_u eqxx in nz_u.
        case=> [/eqP eq_p2q2 nz_q2] [/esym one_u /esym Ev /esym Ec].
        apply: ltn_pred; rewrite /= -subn1 -mu_deriv_char; first last.
        + by rewrite Exp; apply: root_pVq; rewrite eqxx.
        + rewrite sz_r; case => [|[|[|[|i]]]] // _.
          * by rewrite inE /= ecu_chi2.
          * by rewrite inE /= ecu_chi3.
        rewrite mu_gt0; last first.
          rewrite Er /deriv -{1}Er sz_r -size_poly_eq0.
          by rewrite polyseq_poly // (@PolyK _ 0) //= ?(oner_neq0, ecu_chi3).
        rewrite rootE /deriv /horner sz_r polyseq_poly; last first.
          by rewrite Er (@PolyK _ 0) ?(oner_neq0, ecu_chi3).
        rewrite Er (@PolyK _ 0) ?oner_eq0 //= mul0r add0r mulr1n.
        rewrite /c2 /c1 one_u expr1n invr1 !(mul1r, mulN1r).
        set w := (_ + _ : K); pose k := (3%:R * x^+2 + E#a).
        have {w} ->: w = k - 2%:R * x * v^+2 + 2%:R * (c * v) by ssring.
        pose w := (2%:R * p.2); apply/eqP/(@mulIf _ (w^+2)).
          by rewrite expf_neq0 // mulf_neq0 // ecu_chi2.
        rewrite mul0r 2!mulrDl !mulNr.
        have ->:  2%:R * (c * v) * w ^+ 2 = 2%:R * (c * w) * (v * w) by ssring.
        have ->: (2%:R * x * v ^+ 2) * w ^+ 2 = 2%:R * x * (v * w)^+2 by ssring.
        have ->: v * w = - (3%:R * x ^+ 2 + E #a).
          rewrite Ev /w -mulNr -mulrA mulVf ?mulr1 //.
          by rewrite mulf_neq0 // ecu_chi2.
        have ->: c * w = q.2 * w - (3%:R * x ^+ 2 + E #a) * x.
          rewrite Ec /w mulrBl; congr (_ - _); rewrite mulrAC.
          congr (_ * _); rewrite -mulrA mulVf ?mulr1 //.
          by rewrite mulf_neq0 // ecu_chi2.
        by rewrite -eq_p2q2 {}/w {}/k Exp; ssring.
      have: ('X - p.1%:P) * ('X - q.1%:P) %| r.
        move: (@roots_dvdp _ r [:: p.1; q.1]).
        rewrite !big_cons big_nil mulr1; apply.
        by apply/allP=> x _; rewrite inE; apply: h.
      case/dvdpP=> qr Er'; have/(congr1 sizep) := Er'.
      have := nz_r; rewrite {1}Er' mulf_eq0 => /norP [nz_qr _].
      rewrite sz_r !size_mul // ?(mulf_neq0, polyXsubC_eq0) //.
      rewrite !size_XsubC /= addn3 /=; case=> /esym/eqP.
      case/size_polyf2P=> k; rewrite eqp_monic ?monicXsubC //; last first.
        by move: monic_r; rewrite Er' !(monicMr, monicXsubC) //.
      move/eqP=> Eqr {nz_qr}; move: Er'; rewrite {}Eqr => Er'.
      have/(congr1 (fun (x : {poly K})=> x`_2)) := Er'.
      set cs := [tuple k; p.1; q.1]; move/esym/eqP: (mroots_sum cs).
      rewrite 3!big_cons big_nil mulr1 eqr_oppLR => /eqP->.
      rewrite {1}Er (@PolyK _ 0) ?oner_neq0 // unlock /= !simp /=.
      move=> Ec2; have: k = - (c2 + p.1 + q.1) by rewrite Ec2; ssring.
      move=> Ek; move: Er'; rewrite Ek=> ->.
      rewrite !mulrA [X in _ = X]mulrC !mulrA; congr (_ * _ * _).
      by rewrite -!polyC_opp opprK /c2; congr ('X + _%:P); ssring.
    Qed.

    Lemma negK: involutive neg.
    Proof. by case=> [|x y] //=; rewrite opprK. Qed.

    Lemma addO p q: oncurve E (add p q).
    Proof.
      rewrite oncurveN -ladd_addE /ladd;
        set pp := if oncurve E p then _ else _;
        set qq := if oncurve E q then _ else _.
      have oncve_pp: oncurve E pp by rewrite {}/pp; case h: (oncurve E p).
      have oncve_qq: oncurve E qq by rewrite {}/qq; case h: (oncurve E q).
      move: {p q} pp oncve_pp qq oncve_qq.
      case=> [|x1 y1] oncve_1 [|x2 y2] oncve_2; rewrite -?oncurveN //.
      case h: (line _ _) => [[u v] c]; case: (u =P 0) => //.
      move/eqP=> nz_u; set z := u ^- 2 * v ^+ 2 - (x1 + x2).
      move: (thdimp (x1, y1) (x2, y2)); rewrite h => /(_ nz_u) /=.
      move/(congr1 (fun p => p.[z]))/esym; rewrite -/z.
      rewrite hornerM hornerXsubC subrr mulr0 => /esym/eqP.
      rewrite 2!hornerE subr_eq0 horner_Xpoly => /eqP->.
      apply/eqP; rewrite -mul_polyC !(horner_exp, hornerE) /=.
      by rewrite !exprMn; congr (_ * _); rewrite -[c-_]opprK opprB sqrrN.
    Qed.

    Lemma add0o : {in (oncurve E), left_id ∞ add}.
    Proof.
      move=> p; rewrite /in_mem /= => oncve_p.
      by rewrite /add /= oncve_p.
    Qed.

    Lemma addNo : left_inverse ∞ neg add.
    Proof.
      move=> p; rewrite /add -oncurveN.
      have [|] := (boolP (oncurve E p)) => // _.
      case: p=> [|x y] //=; rewrite eqxx /= eq_sym; case Hy0: (y == 0).
      + by rewrite (eqP Hy0) oppr0 eqxx //.
      + rewrite oppr_eq0 Hy0 andbT; case HyN: (y == -y) => //=.
        by absurd false=> //; rewrite -Hy0 -eqrN_eq0 HyN.
    Qed.

    Lemma addoC : commutative add.
    Proof.
      move=> p1 p2; rewrite /add;
        have [|] := (boolP (oncurve E p1)) => // _;
        have [|] := (boolP (oncurve E p2)) => // _; first last.
      + by case: p2.
      + by case: p1.
      case: p1 p2 => [|x1 y1] [|x2 y2] //=.
      rewrite [x2 == _]eq_sym [y2 == _]eq_sym.
      case Ex: (x1 == x2); first (case Ey: (y1 == y2)) => //=.
      + by rewrite -(eqP Ey) -(eqP Ex); case Ey0: (y1 == 0).
      + congr (| _, _ |); first (rewrite -!addrA; congr (_^+2 + _)).
        * by rewrite -[y2 - _]opprB -[x2 - _]opprB invrN mulrNN.
        * by rewrite addrC.
      rewrite -[y2 - _]opprB -[x2 - _]opprB invrN mulrNN.
      set Dx := (x1 - x2); set Dy := (y1 - y2); set a := Dy / Dx.
      have HDx: Dx != 0 by apply/negP; rewrite subr_eq0 Ex.
      rewrite !mulrDr -!addrA; congr (-a * a ^+ 2 + _); rewrite !mulrNN.
      rewrite ![a * x1 + _]addrCA; congr (_ + (_ + _)).
      rewrite ![a * _]mulrC /a !mulrA -[y1]mul1r -[y2]mul1r.
      rewrite -[1](divff HDx) ![Dx / Dx * _]mulrAC.
      rewrite -!mulrBl; congr (_ / _).
      rewrite /Dx /Dy !mulrDl !mulrDr !mulNr !mulrN.
      rewrite !opprB !addrA [_ - (_ * y1)]addrC !addrA addNr add0r.
      symmetry; rewrite -[_ - _ + _]addrA addNr addr0.
      by rewrite addrC.
    Qed.

    Notation   zeroec := (EC zeroO).
    Definition negec  := [fun p     : ec E => EC (negO [oc of p])].
    Definition addec  := [fun p1 p2 : ec E => EC (addO p1 p2)].

    Lemma addNe : left_inverse zeroec negec addec.
    Proof. by move=> [p Hp]; apply/eqP; rewrite eqE /= addNo. Qed.

    Lemma add0e : left_id zeroec addec.
    Proof. by move=> [p Hp]; apply/eqP; rewrite eqE /= add0o. Qed.

    Lemma addeC : commutative addec.
    Proof.
      move=> [p1 Hp1] [p2 Hp2]; apply/eqP=> /=.
      by rewrite eqE /= addoC.
    Qed.
  End Defs.
End ECGroup.

Local Notation "\- x" := (@ECGroup.neg _ x).

(* -------------------------------------------------------------------- *)
Section ECGroupTheory.
  Variable K : ecuFieldType.
  Variable E : ecuType K.

  Lemma oncurveN p: (oncurve E p) = (oncurve E (\- p)).
  Proof. by apply: ECGroup.oncurveN. Qed.

  Lemma oncurveN_fin x y: oncurve E (|x, -y|) = oncurve E (|x, y|).
  Proof. by apply: ECGroup.oncurveN_fin. Qed.
End ECGroupTheory.

(* -------------------------------------------------------------------- *)
Section ECTheory.
  Variable K : idomainType.
  Variable E : ecuType K.

  Local Notation a := (E#a).
  Local Notation b := (E#b).

  Lemma smooth : forall x, \mu_x (Xpoly E) <= 1.
  Proof.
    move=> x; rewrite leqNgt -root_le_mu ?XpolyN0 //.
    apply/negP; case/Pdiv.IdomainMonic.dvdpP.
    + by rewrite monic_exp ?monicXsubC.
    move=> /= p Hfactor; move: (congr1 (size : {poly _} -> _) Hfactor).
    have HpN0: p != 0.
    + by apply/negP => /eqP Hp; move/eqP: Hfactor;
        rewrite Hp mul0r (negbTE (XpolyN0 _)).
    rewrite size_Xpoly size_proper_mul; last first.
    + rewrite mulf_neq0 // lead_coef_eq0 //.
      by rewrite expf_neq0 ?polyXsubC_eq0.
    rewrite size_exp_XsubC addnC /=; case/esym; case/polyseq2.
    move=> [p2 p1] /= Hp1N0 Ep; move/polyP: Hfactor => EC.
    + move: (EC 3); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite !simp => Ep1; rewrite -!Ep1 in Ep => {Ep1 Hp1N0}.
    + move: (EC 2); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite !simp => /esym /eqP; rewrite subr_eq0=> /eqP Ep2.
      rewrite Ep2 in Ep => {Ep2}.
    + move: (EC 1%N); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite mul1r -mulrN mulrCA 2!mulrA -natrM /=.
      rewrite mulrN -mulrA -expr2; move/(congr1 -%R).
      rewrite opprD opprK -{2}[x^+2]mul1r -mulrBl.
      rewrite -(@natrB _ _ 1) //; move/(congr1 -%R); rewrite opprK=> Ea.
    + move: (EC 0%N); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite -mulrA -exprS => Eb.
    move: (ecu_DN0 E).
    rewrite Ea Eb exprNn exprMn -exprM -signr_odd expr1.
    rewrite mulN1r mulrN -natrX mulrA -natrM.
    rewrite exprMn -exprM -natrX [27%:R * _]mulrA -natrM.
    by rewrite addrC subrr eqxx.
  Qed.
End ECTheory.

(* -------------------------------------------------------------------- *)
Section XPolyClosed.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Hypothesis closedK : GRing.ClosedField.axiom K.

  Local Notation clK := (ClosedFieldType K closedK).

  Lemma Xpoly_factor:
    exists2 cs : 3.-tuple K,
      (uniq cs) & Xpoly E = \prod_(c <- cs) ('X - c%:P).
  Proof.
    move: (PolyClosed.roots_factor_theorem_f closedK (Xpoly E)).
    rewrite (monicP (Xpoly_monic E)) scale1r; set cs := roots _ => ->.
    have size_cs: size cs == 3 by rewrite (@roots_size clK) size_Xpoly.
    exists (Tuple size_cs)=> //=; apply: count_mem_uniq.
    move=> k; rewrite -roots_mu ?XpolyN0 //; move: (smooth E k).
    rewrite leq_eqVlt ltnS leqn0 rootsP ?XpolyN0 // mem_root -rootE.
    by rewrite -mu_gt0 ?XpolyN0 //; case/orP=> /eqP->.
  Qed.
End XPolyClosed.