(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski and Johannes Waldmann, 2010-04
*)

Set Implicit Arguments.

Require Import ATropicalBasedInt2 Matrix2 OrdSemiRing2 VecUtil
  AMonAlg2 SN RelUtil NatUtil AWFMInterpretation LogicUtil
  AMatrixBasedInt2_Trop Bool VecArith2 SemiRing2 VecOrd.

Definition matrixInt := @matrixInt_trop matrix_trop.
Definition mkMatrixInt := @mkMatrixInt_trop matrix_trop.

(***********************************************************************)
(** ** Condition for a tropical interpretation to be valid. *)

Section S.

  Variable dim : nat.
  Variable Sig : Signature.

  Section Somewhere_tfinite.

    Definition somewhere_tfinite n (fi : matrixInt dim n) :=
      Vexists (fun m => get_elem_trop m (dim_pos dim)
        (dim_pos dim) <> PlusInf) (args_trop fi)
      \/ Vnth (const_trop fi) (dim_pos dim) <> PlusInf.

    Definition bsomewhere_tfinite n (fi : matrixInt dim n) :=
      bVexists
      (fun m => tropical_is_finite (get_elem_trop m
        (dim_pos dim) (dim_pos dim))) (args_trop fi)
      || tropical_is_finite (Vnth (const_trop fi) (dim_pos dim)).

    Require Import BoolUtil.

    Lemma bsomewhere_tfinite_ok : forall n (fi : matrixInt dim n),
      bsomewhere_tfinite fi = true <-> somewhere_tfinite fi.

    Proof.
      intros. unfold bsomewhere_tfinite, somewhere_tfinite.
      rewrite orb_eq. rewrite tropical_is_finite_ok.
      rewrite bVexists_ok. refl. intro. apply tropical_is_finite_ok.
    Qed.

    Require Import List ListForall.

    Variable Fs : list Sig.
    Variable Fs_ok : forall f : Sig, In f Fs.
    Variable mc: MatrixMethodConf_trop Sig dim.
    Notation trsInt := (trsInt_trop mc).

    Lemma fin_somewhere_tfinite :
      forallb (fun f => bsomewhere_tfinite (trsInt f)) Fs = true ->
      forall f : Sig, somewhere_tfinite (trsInt f).

    Proof.
      rewrite forallb_forall. intros H f. rewrite <- bsomewhere_tfinite_ok.
      apply H. apply Fs_ok.
    Qed.

  End Somewhere_tfinite.

  Implicit Arguments fin_somewhere_tfinite [Fs].

  Ltac somewhere_tfinite Fs_ok :=
    apply (fin_somewhere_tfinite _ _ Fs_ok);
      (check_eq || fail 10 "invalid tropical interpretation").

  (***********************************************************************)
  (** ** Proving termination with a tropical interpretation. *)

  Section TTropicalInt.

    Variable mc : MatrixMethodConf_trop Sig dim.
    Parameter trsIntOk : forall f : Sig, somewhere_tfinite  (trsInt_trop mc f).

    Section MonotoneAlgebra.

      Lemma mat_times_vec_at0_positive : forall n (m : matrix_trop n n)
        (v : vector At n) (dim_pos : n > 0),
        get_elem_trop m dim_pos dim_pos <> PlusInf ->
        Vnth v dim_pos <> PlusInf ->
        Vnth (mat_vec_prod_trop m v) dim_pos <> PlusInf.

      Proof.
        destruct n; intros. absurd_arith.
        VSntac v. unfold matrix_trop in m. VSntac m.
        unfold mat_vec_prod_trop, col_mat_to_vec_trop, get_col_trop. rewrite Vnth_map.
        set (w := mat_mult_spec_trop). unfold get_elem_trop, get_row_trop in w. rewrite w.
        simpl. VSntac (Vhead m). unfold dot_product_trop.
        simpl. rewrite A_plus_commt. apply tropical_plus_notInf_leftt.
        apply tropical_mult_notInft.
        rewrite H2 in H. unfold get_elem_trop in H. simpl in H.
        rewrite Vhead_nth.
        rewrite <- (Vnth_eq (Vhead m) dim_pos (lt_O_Sn n)); trivial.
        rewrite H1 in H0. hyp.
      Qed.

      Notation mat_times_vec := (@mat_vec_prod_trop dim dim).
      Notation mint := (matrixInt_trop matrix_trop dim).
      Notation "x >_0 y" := (gtx_trop x y) (at level 70).
      Notation "x >>= y" := (get x y) (at level 70).
      Notation "x >> y" := (gtt x y) (at level 70).
      Notation "x + y" := (Aplust x y).
      Notation "x * y" := (Amultt x y).
      Notation "X =A= Y" := (eqAt X Y) (at level 70).

      Lemma gtx_plus_compat : forall m m' n n',
        m >_0 m' -> n >_0 n' -> m + n >_0 m' + n'.

      Proof.
        intros. destruct H. destruct H0.
        left. apply plus_gt_compatt; hyp.
        destruct H0. rewrite H0. rewrite H1.
        do 2 rewrite A_plus_0_rt. left. hyp.
        destruct H. rewrite H. rewrite H1.
        do 2 rewrite A_plus_0_lt. hyp.
      Qed.

      Lemma gtx_mult_compat : forall m m' n n',
        m >_0 m' -> n >>= n' -> m * n >_0 m' * n'.

      Proof.
        intros.
        destruct m; destruct m'; destruct n; destruct n';
          destruct H; destruct H0; simpl;
            try solve
              [ elimtype False; auto
                | intuition; discr
                | left; simpl; auto
                | left; simpl in *; omega
                | right; auto
              ].
        left. simpl. injection H0. intro. subst n. simpl in H. omega.
      Qed.

      Definition dom2vec_trop (d : dom_trop dim) := dom2vec_trop d.

      Lemma eval_some_notInf : forall n (mi : mint n) (v : vector (dom_trop dim) n),
        Vexists (fun m => get_elem_trop m (dim_pos dim)
          (dim_pos dim) <> PlusInf) (args_trop mi) ->
        Vfold_left Aplust A0t
        (Vmap (fun v => Vnth v (dim_pos dim))
          (Vmap2 mat_times_vec (args_trop mi) (Vmap dom2vec_trop v))) <> PlusInf.

      Proof.
        induction n; intros; simpl; destruct mi.
        VOtac. auto.
        simpl in H. VSntac args_trop. rewrite H0 in H; simpl. destruct H.
        rewrite A_plus_commt. apply tropical_plus_notInf_leftt.
        apply mat_times_vec_at0_positive. hyp.
        VSntac v. simpl. destruct (Vhead v).
        unfold vec_invariant_trop, vec_at0_trop in v0. simpl in *.
        (* TODO... change - specific to tropical... *)
        intuition. clear H1. unfold A1t in v0. rewrite H2 in v0.
        contradiction.
        apply tropical_plus_notInf_leftt.
        rewrite <- Vmap_tail.
        apply (IHn (mkMatrixInt_trop const_trop (Vtail args_trop))). hyp.
      Qed.

      Lemma mi_eval_at0 : forall n (mi : matrixInt dim n) (v : vector (dom_trop dim) n),
        somewhere_tfinite mi ->
        vec_at0_trop (mi_eval_aux_trop mi (Vmap dom2vec_trop v)) <> PlusInf.

      Proof.
        intros. unfold mi_eval_aux_trop, vec_at0_trop.
        rewrite vector_plus_nth_trop. destruct H.
        rewrite add_vectors_nth_trop. apply tropical_plus_notInf_leftt.
        apply eval_some_notInf. hyp.
        rewrite A_plus_commt. apply tropical_plus_notInf_leftt. hyp.
      Qed.

      Notation trsInt := (trsInt_trop mc).

      Lemma mi_eval_ok : forall f v,
        vec_invariant_trop (mi_eval_aux_trop (trsInt f) (Vmap dom2vec_trop v)).

      Proof.
        intros. unfold vec_invariant_trop, vec_at0_trop.
        apply tropical_plus_inf_max.
        set (w := mi_eval_at0). (*unfold vec_at0 in w.*) apply w.
        apply trsIntOk.
      Qed.

      Definition I := I_trop mc mi_eval_ok.
      Definition succ := @succ_trop dim.
      Definition succ' := @succ'_trop Sig dim mc.
      Definition succ'_sub :=
        @succ'_sub_trop Sig dim  gtx_plus_compat gtx_mult_compat mc mi_eval_ok.
      Definition succ'_dec := @succ'_dec_trop Sig dim mc.
      Definition succeq := @succeq_trop dim.
      Definition succeq' := @succeq_trop' Sig dim mc.
      Definition succeq'_sub := @succeq'_sub_trop Sig dim mc mi_eval_ok.
      Definition succeq'_dec := @succeq'_dec_trop Sig dim mc.
      Definition refl_succeq := @refl_succeq_trop dim.
      Definition monotone_succeq := @monotone_succeq_trop Sig dim mc mi_eval_ok.
      Definition trans_succeq := @trans_succeq_trop dim.
      Definition succ_succeq_compat := @succ_succeq_compat_trop dim ge_gt_eq.

      Lemma succ_wf : WF succ.

      Proof.
        apply WF_incl with
          (fun x y => vec_at0_trop (dom2vec_trop x) >> vec_at0_trop (dom2vec_trop y)).
        intros x y xy.
        destruct (@Vforall2n_nth _ _ gtx_trop _
          (dom2vec_trop x) (dom2vec_trop y) _ (dim_pos dim) xy).
        hyp.
        destruct H. destruct x.
        (* TODO: change, specific for tropical *)
        absurd (A0t = Vnth x (dim_pos dim)).
        unfold vec_invariant_trop in v.
        intro eq. clear H xy. rewrite eq in v. exact (gt_irreflt _ v).
        intuition.
        fold (@Rof (dom_trop dim) At gtt (fun v => vec_at0_trop (dom2vec_trop v))).
        apply WF_inverse. apply gt_WFt.
      Qed.

      Lemma trans_succ : transitive succ.

      Proof.
        unfold succ, succ_trop. apply Rof_trans with (f:=dom2vec_trop).
        unfold succ_vec_trop. apply Vreln_trans. apply gtx_trans_trop.
      Qed.

    (** Define record type for MonotoneAlgType for domain arctic
       natural numbers. *)

      Definition matAlg_trop := mkbMonoAlgType Sig I succ succeq refl_succeq
        trans_succ trans_succeq monotone_succeq succ_wf succ_succeq_compat
        succ' succeq' succ'_sub succeq'_sub succ'_dec succeq'_dec.

    End MonotoneAlgebra.

    Ltac prove_cc_succ Fs_ok :=
      fail 10 "tropical matrices cannot be used for proving total termination".

  End TTropicalInt.

End S.


Require Import Qreals.
Require Import List.
Require Import mdp qvalues fixed_point.
Require Import RealAdd CoquelicotAdd.
Require Import utils.Utils.
Require Import Lra Lia PushNeg.
Require Import Expectation RandomVariableFinite RbarExpectation.
Require Import SigmaAlgebras ProbSpace.
Require Import ConditionalExpectation.
Require Import DVector RealVectorHilbert VectorRandomVariable.
Require Import DiscreteProbSpace ProductSpace.

Set Bullet Behavior "Strict Subproofs".

Section qlearn_aux.

Context {Ts : Type} {dom: SigmaAlgebra Ts}.

  Lemma inter_coll_le_sup {prts: ProbSpace dom} (f : nat -> Ts -> R) (eps:R)
          {rv : forall n, RandomVariable dom borel_sa (f n)}
          {rv2 : forall n, RandomVariable dom Rbar_borel_sa (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x)))}:
    forall n,
      event_equiv
        (inter_of_collection (fun t : nat => event_le dom (rvabs (f (n + t)%nat)) eps))
        (event_Rbar_le (fun x0 : Ts => Sup_seq (fun m : nat => Rabs (f (n + m)%nat x0))) (const eps)).
    Proof.
      intros n z.
      simpl.
      unfold rvabs, const, pre_event_complement.
      split; intros.
      - replace (Finite eps) with (Sup_seq (fun n => eps)).
        + apply Sup_seq_le.
          intros.
          simpl.
          apply H.
        + apply Sup_seq_const.
          - rewrite Rbar_sup_eq_lub in H.
            unfold Rbar_lub, proj1_sig in H.
            match_destr_in H.
            unfold Rbar_is_lub, Rbar_is_upper_bound in r.
            destruct r.
            generalize (Rbar_le_trans  (Rabs (f (n + n0)%nat z)) x eps); intros.
            simpl in H2.
            apply H2; trivial.
            destruct x.
            + specialize (H0 ( Rabs (f (n + n0)%nat z))).
              simpl in H0.
              apply H0.
              now exists n0.
            + trivial.
            + specialize (H0 (Rabs (f (n + 0)%nat z))).
              simpl in H0.
              apply H0.
              now exists (0%nat).
    Qed.

    Lemma event_Rbar_gt_complement (f : Ts -> Rbar) (eps:R)
          {rv : RandomVariable dom Rbar_borel_sa f} :
      event_equiv
        (event_Rbar_gt f (const eps))
        (event_complement (event_Rbar_le f (const eps))).
    Proof.
      intros ?.
      unfold event_Rbar_gt, event_Rbar_le, event_complement, pre_event_complement, proj1_sig.
      unfold Rbar_gt.
      split; intros.
      - now apply Rbar_lt_not_le.
      - now apply Rbar_not_le_lt.
    Qed.

  Lemma union_coll_gt_sup {prts: ProbSpace dom} (f : nat -> Ts -> R) (eps:posreal)
          {rv : forall n, RandomVariable dom borel_sa (f n)}
          {rv2 : forall n, RandomVariable dom Rbar_borel_sa (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x)))}:
    forall n,
      event_equiv
        (union_of_collection (fun t : nat => event_gt dom (rvabs (f (n + t)%nat)) eps))
        (event_Rbar_gt (fun x0 : Ts => Sup_seq (fun m : nat => Rabs (f (n + m)%nat x0))) (const (pos eps))).
    Proof.
      intros n.
      generalize (inter_coll_le_sup f eps); intros.
      assert (event_equiv
                (union_of_collection (fun t : nat => event_gt dom (rvabs (f (n + t)%nat)) eps))
                (event_complement (inter_of_collection (fun t : nat => event_le dom (rvabs (f (n + t)%nat)) eps)))).
      {
        rewrite inter_of_collection_complement.
        intros ?.
        simpl.
        unfold pre_event_complement.
        split; intros; destruct H0; exists x0; lra.
     }
      rewrite H0.
      rewrite event_Rbar_gt_complement.
      apply event_complement_proper.
      apply inter_coll_le_sup.
  Qed.

Lemma sa_sigma_not_convergent (X : nat -> Ts -> R) (X0 : Ts -> R) (eps : posreal) (N : nat)
      {rv : forall n, RandomVariable dom borel_sa (X n)}
      {rv0 : RandomVariable dom borel_sa X0} :
  sa_sigma _ (fun omega => exists n : nat, (n >= N)%nat /\ Rabs (X n omega - X0 omega) >= eps).
Proof.
  apply sa_countable_union; intros n.
  apply sa_inter; try apply sa_sigma_const_classic.
  apply sa_le_ge; intros r.
  apply Rabs_measurable.
  generalize (minus_measurable dom (X n) (X0)); intros.
  rewrite rvminus_unfold in H.
  apply H.
  -- apply rv_measurable; try apply rv.
  -- apply rv_measurable; try apply rv0.
Qed.

Lemma sa_sigma_not_full_convergent (X : nat -> Ts -> R) X0
      {rv : forall (n:nat), RandomVariable dom borel_sa (X n)}
  {rv0 : RandomVariable dom borel_sa X0}:
  sa_sigma _ (fun omega => exists (eps : posreal), forall N:nat,
                  exists (n : nat),
                    (n >= N)%nat /\
                    Rabs ((X n omega) - (X0 omega)) >= eps).
Proof.
   assert (eqq1:pre_event_equiv
                 (fun omega => exists (eps : posreal), forall N:nat,
                        exists (n : nat),
                          (n >= N)%nat /\
                          Rabs ((X n omega) - (X0 omega)) >= eps)
                 (fun omega => exists (eps : QArith_base.Q),
                      (QArith_base.Qlt {| QArith_base.Qnum := 0; QArith_base.Qden := 1 |} eps) /\
                      forall N:nat,
                      exists (n : nat),
                        (n >= N)%nat /\
                        Rabs ((X n omega) - (X0 omega)) >= Q2R eps)).
  {
    intros x.
    split.
    - intros [eps HH].
      destruct (Q_dense 0 eps) as [q [ql qr]].
      + apply cond_pos.
      + exists q.
        split.
        * apply Qreals.Rlt_Qlt.
          unfold QArith_base.inject_Z.
          unfold Q2R.
          simpl.
          rewrite Rmult_0_l.
          apply ql.
        * intros N.
          destruct (HH N) as [n [Hn1 Hn2]].
          exists n.
          intuition lra.
    - intros [eps [epos HH]].
      assert (qepspos: 0 < Q2R eps).
      {
        apply Qreals.Qlt_Rlt in epos.
        now rewrite RMicromega.Q2R_0 in epos.
      }
      exists (mkposreal (Q2R eps) qepspos).
      intros N.
      destruct (HH N) as [n [Hn1 Hn2]].
      exists n. intuition lra.
  }
  rewrite eqq1.
  apply sa_countable_union_iso; try typeclasses eauto.
  intros.
  destruct (Rlt_dec 0 (Q2R i)).
  - assert (QArith_base.Qlt {| QArith_base.Qnum := 0; QArith_base.Qden := 1 |} i).
    {
      apply Qreals.Rlt_Qlt.
      now rewrite RMicromega.Q2R_0.
    }
    eapply (sa_proper _  (fun omega => (forall N : nat,
      exists n : nat,
        (n >= N)%nat /\ Rabs (X n omega - X0 omega) >= Q2R i))).
    + firstorder.
    + apply sa_pre_countable_inter; intros N.
      now apply (sa_sigma_not_convergent X X0 (mkposreal _ r)).
  - eapply sa_proper; try apply sa_none.
    assert (~ QArith_base.Qlt {| QArith_base.Qnum := 0; QArith_base.Qden := 1 |} i).
    {
      intros qlt.
      apply Qreals.Qlt_Rlt in qlt.
      now rewrite RMicromega.Q2R_0 in qlt.
    }
    firstorder.
Qed.

  Lemma recip_pos (m : nat) : 0 < /(1 + INR m).
  Proof.
    apply Rinv_pos.
    generalize (pos_INR m). generalize (INR m) as x; intros.
    lra.
  Qed.

Lemma almost_convergent_iff (X : nat -> Ts -> R) X0
       {rv : forall n, RandomVariable dom borel_sa (X n)}
   {rv0 : RandomVariable dom borel_sa X0}:
   event_equiv ((exist (sa_sigma _) _ (sa_sigma_not_full_convergent X X0)))
               (union_of_collection
                  (fun m => inter_of_collection
                           (fun k => exist (sa_sigma _) _ (sa_sigma_not_convergent X X0 (mkposreal (/(1 + INR m)) (recip_pos _)) k)))).
 Proof.
    simpl.
   intros omega. simpl.
   split; intros.
   + destruct H as [eps Heps].
     generalize (archimed_cor1 eps (cond_pos eps)); intros.
     destruct H as [N [HN1 HN2]].
     assert (/(1 + INR N) < eps).
     {
       eapply Rlt_trans; eauto.
       apply Rinv_lt_contravar; try lra.
       apply Rmult_lt_0_compat; try (now apply lt_0_INR).
       generalize (pos_INR N). generalize (INR N) as x; intros.
       lra.
     }
     exists N.
     intros n1.
     specialize (Heps n1).
     destruct Heps as [n0 [Hn1 Hn2]].
     exists n0.
     repeat split; try trivial.
     eapply Rge_trans; eauto.
     lra.
   + destruct H as [N HN].
     exists (mkposreal (/(1 + INR N)) (recip_pos _)).
     simpl. intros N0.
     specialize (HN N0).
     assumption.
 Qed.

Lemma almost_is_lim_seq_iff {prts : ProbSpace dom} (X : nat -> Ts -> R) X0
      {rv : forall (n:nat), RandomVariable dom borel_sa (X n)}
  {rv0 : RandomVariable dom borel_sa X0}:
  almost _ (fun omega => is_lim_seq (fun n => X n omega) (X0 omega)) <->
  (forall (eps:posreal),
      is_lim_seq (fun N =>
                    ps_P (exist (sa_sigma _) _ (sa_sigma_not_convergent X X0 eps N))) 0).
Proof.
  assert (H1 : forall (eps: posreal),let E := fun n => exist (sa_sigma _) _
                                                     (sa_sigma_not_convergent X X0 eps n) in
                                is_lim_seq (fun k => ps_P (E k)) (ps_P (inter_of_collection E))).
  {
    intros eps E.
    apply is_lim_descending.
    intros n. repeat red. intros omega H.
    red in H. destruct H as [n0 [m0 H]].
    exists n0. repeat split; try lia; trivial.
  }
  split; intros.
  + rewrite almost_alt_eq in H.
    unfold almost_alt in H.
    destruct H as [E [HE Heps]].
    specialize (H1 eps). simpl in H1.
    enough (Hpsp : ps_P (
                    inter_of_collection(
                        fun n => (exist (sa_sigma _) _ (sa_sigma_not_convergent X X0 eps n)))) = 0).
    - now rewrite <-Hpsp.
    - apply ps_P_sub_zero with E; trivial.
      intros omega.
      simpl; specialize (Heps omega).
      intros. apply Heps. push_neg.
      setoid_rewrite is_lim_seq_Reals.
      unfold Un_cv. push_neg. exists eps.
      split; try apply cond_pos.
      now unfold R_dist.
  + (* forall 0<δ, P(B_δ) = 0*)
    assert (Hinter : forall eps:posreal, let E :=
         fun n : nat => exist (sa_sigma _) _ (sa_sigma_not_convergent X X0 eps n) in
                                    (ps_P (inter_of_collection E)) = 0).
    {
      intros eps E.
      rewrite <-Rbar_finite_eq.
      rewrite <-(is_lim_seq_unique _ _ (H eps)). symmetry.
      apply is_lim_seq_unique. apply H1.
    }
    clear H.
    rewrite almost_alt_eq.
    unfold almost_alt.
    exists (exist (sa_sigma _) _ (sa_sigma_not_full_convergent X X0)).
    split.
    ++ rewrite almost_convergent_iff.
       rewrite <-ps_union_countable_union_iff.
       intros n; apply (Hinter ({| pos := /(1 + INR n); cond_pos := recip_pos n|})).
    ++ intros omega Hnot.
       simpl. setoid_rewrite is_lim_seq_Reals in Hnot.
       unfold Un_cv in Hnot. push_neg_in Hnot.
       destruct Hnot as [eps [Heps Hx]].
       now exists (mkposreal eps Heps).
Qed.

  Lemma conv_prob_sup_0_as {prts: ProbSpace dom} (f : nat -> Ts -> R)
          {rv : forall n, RandomVariable dom borel_sa (f n)}
          {rv2 : forall n, RandomVariable dom Rbar_borel_sa (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x)))}:
      (forall (eps:posreal),
        is_lim_seq (fun n => ps_P (event_Rbar_gt (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x))) (const (pos eps)))) 0) ->
      almost prts (fun x => is_lim_seq (fun n => f n x) 0).
    Proof.
      intros.
      rewrite  almost_is_lim_seq_iff.
      intros.
      assert (0 < eps) by apply cond_pos.
      assert (0 < eps/2) by lra.
      specialize (H (mkposreal _ H1)).
      apply is_lim_seq_le_le with (u := fun n => 0)
                                  (w :=  (fun n : nat =>
         ps_P
           (event_Rbar_gt (fun x : Ts => Sup_seq (fun m : nat => Rabs (f (n + m)%nat x)))
                          (const (pos (mkposreal _ H1)))))); trivial.
      - intros.
        split.
        + apply ps_pos.
        + apply ps_sub.
          rewrite <- union_coll_gt_sup.
          intros ? ?.
          simpl.
          simpl in H2.
          destruct H2 as [? [? ?]].
          exists (x0 - n)%nat.
          rewrite Rminus_0_r in H3.
          unfold rvabs.
          replace (n + (x0 - n))%nat with x0  by lia.
          lra.
        - apply is_lim_seq_const.
          Unshelve.
          + apply rv.
          + apply rvconst.
          + apply rv.
    Qed.

    Lemma conv_as_prob_sup_0 {prts: ProbSpace dom} (f : nat -> Ts -> R)
          {rv : forall n, RandomVariable dom borel_sa (f n)}
          {rv2 : forall n, RandomVariable dom Rbar_borel_sa (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x)))}:
      almost prts (fun x => is_lim_seq (fun n => f n x) 0) ->
      (forall (eps:posreal),
        is_lim_seq (fun n => ps_P (event_Rbar_gt (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x))) (const (pos eps)))) 0).
   Proof.
     intros.
     rewrite almost_is_lim_seq_iff in H.
     intros.
     specialize (H eps).
     assert (RandomVariable dom borel_sa (fun _ : Ts => 0)) by apply rvconst.
     apply is_lim_seq_le_le with (u := fun n => 0)
                                 (w :=  (fun N : nat =>
         ps_P (ProbSpace := prts)
           (exist (sa_sigma dom)
                  (fun omega : Ts =>
                     exists n : nat, (n >= N)%nat /\ Rabs (f n omega - 0) >= eps)
                  (sa_sigma_not_convergent f (fun _ : Ts => 0) eps N)))).
     intros.
     - split.
       + apply ps_pos.
       + apply ps_sub.
         rewrite <- union_coll_gt_sup.
         intros ? ?.
         simpl.
         simpl in H1.
         destruct H1.
         exists (n + x0)%nat.
         split; try lia.
         unfold rvabs in H1.
         rewrite Rminus_0_r.
         lra.
    - apply is_lim_seq_const.
    - revert H.
      apply is_lim_seq_ext.
      intros.
      apply ps_proper.
      intros ?.
      simpl.
      reflexivity.
      Unshelve.
      + apply rv.
      + apply rvconst.
      + apply rv.
  Qed.

  Lemma lim_ps_sub_1_0 {prts: ProbSpace dom} (f : nat -> Ts -> R)
          {rv : forall n, RandomVariable dom borel_sa (f n)}
          {rv2 : forall n, RandomVariable dom Rbar_borel_sa (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x)))}:
    forall (eps:posreal),
      is_lim_seq (fun n => ps_P (event_Rbar_le (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x))) (const (pos eps)))) 1 <->
      is_lim_seq (fun n => ps_P (event_Rbar_gt (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x))) (const (pos eps)))) 0.
    Proof.
      intros.
      split; intros.
      - apply is_lim_seq_ext with
         (u := (fun n : nat =>
                  1 - ps_P
                        (event_Rbar_le
                           (fun x : Ts => Sup_seq (fun m : nat => Rabs (f (n + m)%nat x))) (const (pos eps))))).
        + intros.
          rewrite <- ps_complement.
          apply ps_proper.
          intros ?.
          simpl.
          unfold pre_event_complement.
          match_destr; simpl; lra.
        + apply is_lim_seq_minus with (l1 := 1) (l2 := 1); trivial.
          * apply is_lim_seq_const.
          * unfold is_Rbar_minus, is_Rbar_plus; simpl.
            f_equal.
            apply Rbar_finite_eq.
            lra.
      - apply is_lim_seq_ext with
            (u := (fun n =>
                     1 -
                     ps_P (event_Rbar_gt
                             (fun x : Ts => Sup_seq (fun m : nat => Rabs (f (n + m)%nat x))) (const (pos eps))))).
        + intros.
          rewrite <- ps_complement.
          apply ps_proper.
          intros ?.
          simpl.
          unfold pre_event_complement.
          match_destr; simpl; lra.
        + apply is_lim_seq_minus with (l1 := 1) (l2 := 0); trivial.
          * apply is_lim_seq_const.
          * unfold is_Rbar_minus, is_Rbar_plus; simpl.
            f_equal.
            apply Rbar_finite_eq.
            lra.
  Qed.

  Lemma conv_prob_sup_1_as {prts: ProbSpace dom} (f : nat -> Ts -> R)
          {rv : forall n, RandomVariable dom borel_sa (f n)}
          {rv2 : forall n, RandomVariable dom Rbar_borel_sa (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x)))}:
      (forall (eps:posreal),
        is_lim_seq (fun n => ps_P (event_Rbar_le (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x))) (const (pos eps)))) 1) ->
      almost prts (fun x => is_lim_seq (fun n => f n x) 0).
   Proof.
     intros.
     apply (@conv_prob_sup_0_as _ _ _ rv2); trivial.
     intros.
     now rewrite <- lim_ps_sub_1_0.
  Qed.

  Lemma conv_as_prob_sup_1  {prts: ProbSpace dom} (f : nat -> Ts -> R)
          {rv : forall n, RandomVariable dom borel_sa (f n)}
          {rv2 : forall n, RandomVariable dom Rbar_borel_sa (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x)))}:
      almost prts (fun x => is_lim_seq (fun n => f n x) 0) ->
      forall (eps:posreal),
        is_lim_seq (fun n => ps_P (event_Rbar_le (fun x => Sup_seq (fun m => Rabs (f (n + m)%nat x))) (const (pos eps)))) 1.
    Proof.
      intros.
      rewrite lim_ps_sub_1_0; trivial.
      now apply  conv_as_prob_sup_0.
    Qed.

    Lemma nneg_expec_inf_sum {prts : ProbSpace dom} (f : nat -> Ts -> Rbar)
          {rv : forall n, RandomVariable dom Rbar_borel_sa (f n)}
          {nnf : forall n, Rbar_NonnegativeFunction (f n)}
          {pofrf : Rbar_NonnegativeFunction
            (fun omega : Ts => ELim_seq (sum_Rbar_n (fun k : nat => f k omega)))} :
      ELim_seq (sum_Rbar_n (fun k => Rbar_NonnegExpectation (f k))) =
      Rbar_NonnegExpectation (fun omega => ELim_seq (sum_Rbar_n (fun k => f k omega))).
    Proof.
      assert (forall k,
                 Rbar_NonnegativeFunction
                   (fun omega : Ts => sum_Rbar_n (fun j : nat => f j omega) k)).
      {
        unfold Rbar_NonnegativeFunction; intros.
        apply sum_Rbar_n_nneg_nneg; intros.
        apply nnf.
      }
      rewrite ELim_seq_ext with
          (v := (fun k => Rbar_NonnegExpectation
                            (fun omega => sum_Rbar_n (fun j => f j omega) k))).
      rewrite monotone_convergence_Rbar_rvlim.
      - now unfold Rbar_rvlim.
      - intros.
        apply sum_Rbar_n_rv.
        intros.
        apply rv.
      - intros.
        unfold Rbar_rv_le.
        intros ?.
        apply sum_Rbar_n_pos_incr.
        intros.
        apply nnf.
      - intros.
        generalize Rbar_NonnegExpectation_sum; intros.
        now rewrite Rbar_NonnegExpectation_sum with (Xlim_pos := H).
   Qed.

    Lemma Injective_iso {A A' B} (f:A->B) {iso:Isomorphism A A'} :
      FinFun.Injective f -> FinFun.Injective (fun a' => f (iso_b a')).
    Proof.
      intros inj a1 a2 eqq.
      apply inj in eqq.
      apply (f_equal (iso_f (Isomorphism := iso))) in eqq.
      now repeat rewrite iso_f_b in eqq.
    Qed.

    Program Instance countable_iso {A B} {count:Countable A} {iso:Isomorphism A B} : Countable B
      := {| countable_index b := countable_index (iso_b b) |}.
    Next Obligation.
      apply Injective_iso.
      apply countable_index_inj.
    Qed.

    Context {T:Type} {countableT:Countable T}.

    Instance countable_ivector {n:nat} : Countable (ivector T n).
    Proof.
      induction n; simpl.
      - apply unit_countable.
      - apply prod_countable; trivial.
    Qed.

    Instance countable_vector {n:nat} : Countable (vector T n).
    Proof.
      apply (@countable_iso (ivector T n)).
      - apply countable_ivector.
      - apply Isomorphism_symm.
        apply vec_to_ivec_encoder.
    Qed.

    Definition vec_pmf {n} (p0 : ProbSpace (discrete_sa T)) : (vector T n) -> R :=
      fun v =>
        vector_fold_left Rmult (vector_map ps_P (vector_map discrete_singleton v)) 1.

    Definition ivec_pmf {n} (p0 : ProbSpace (discrete_sa T)) : (ivector T n) -> R :=
      fun v =>
        ivector_fold_left Rmult (ivector_map ps_P (ivector_map discrete_singleton v)) 1.

    Lemma vec_to_ivec_pmf {n} (p0 : ProbSpace (discrete_sa T)) (v:vector T n) :
      vec_pmf p0 v = ivec_pmf p0 (iso_f (Isomorphism := vec_to_ivec_encoder) v).
    Proof.
      unfold vec_pmf, ivec_pmf, vector_fold_left.
      destruct v as [x []].
      generalize 1.
      now induction x; simpl in *.
    Qed.

    Lemma vec_pmf_pos {n} (p0 : ProbSpace (discrete_sa T)):
      forall v,
        0 <= vec_pmf (n:=n) p0 v.
    Proof.
      intros.
      unfold vec_pmf, vector_fold_left, vector_map.
      destruct v; simpl.
      assert (forall (e:R),
                 forall (l : list R),
                   0 <= e ->
                   (forall f, In f l -> 0<=f) ->
                   0 <= fold_left Rmult l e).
      {
        intros.
        revert H.
        revert e0.
        induction l.
        - intros.
          now simpl.
        - intros.
          simpl.
          apply IHl.
          + intros.
            apply H0.
            now apply in_cons.
          + apply Rmult_le_pos; trivial.
            apply H0.
            simpl.
            tauto.
      }
      apply H; try lra.
      intros.
      apply in_map_iff in H0.
      destruct H0 as [? [? ?]].
      rewrite <- H0.
      apply ps_pos.
    Qed.

    Lemma vec_pmf_sum1 {n} (p0 : ProbSpace (discrete_sa T)):
      countable_sum (vec_pmf (n:=n) p0) 1.
    Proof.
      Admitted.

    Program Definition vectorPMF {n} (p0 : ProbSpace (discrete_sa T)) : prob_mass_fun (vector T n) := {| pmf_pmf := vec_pmf p0 |}.
    Next Obligation.
      apply vec_pmf_pos.
    Qed.
    Next Obligation.
      apply vec_pmf_sum1.
    Qed.

    Global Instance vector_discrete_ps {n} (p0 : ProbSpace (discrete_sa T)): ProbSpace (discrete_sa (vector T n)) := discrete_ps (vectorPMF p0).

End qlearn_aux.


Require Import ListAux.
Require Import TreeAux.
Lemma bankersq2consistent_BankersqReverse0 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((list_order  il_0 u_0 u_1)/\(list_member  il_1 u_1)) -> (list_order  il_1 u_1 u_0)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse1 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_order  il_0 u_0 u_1))/\(list_member  il_1 u_1)) -> (list_member  il_0 u_1)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse2 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_order  il_0 u_0 u_1))/\(list_member  il_1 u_1)) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse3 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(list_order  il_0 u_1 u_0)/\(not (list_order  il_0 u_0 u_1))/\(list_member  il_1 u_1)) -> (list_member  il_1 u_0)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse4 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_order  il_0 u_1 u_0))/\(not (list_order  il_0 u_0 u_1))/\(list_member  il_1 u_1)) -> (not (list_member  il_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse5 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_order  il_0 u_1 u_0))/\(not (list_order  il_0 u_0 u_1))/\(list_member  il_1 u_1)) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse6 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_member  il_0 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse7 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse8 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_member  il_1 u_1))) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse9 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(list_member  il_0 u_0)/\(not (list_member  il_1 u_1))) -> (list_member  il_1 u_0)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqReverse10 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_member  il_0 u_0))/\(not (list_member  il_1 u_1))) -> (not (list_member  il_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.


Require Import compcert.lib.Integers.
Require Import Recdef.
Require Import Bvector.
Require Import List. Import ListNotations.
Require Import Arith.
Require Import compcert.lib.Coqlib.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.XorCorrespondence.
Require Import sha.ByteBitRelations.

Definition concat {A : Type} (l : list (list A)) : list A :=
  flat_map id l.

Lemma concat_length {A}: forall L (l:list A), In l L -> (length (concat L) >= length l)%nat.
Proof.  unfold concat. induction L; simpl; intros. contradiction.
  rewrite app_length.
  destruct H; subst. unfold id. omega.
  specialize (IHL _ H). omega.
Qed.

Lemma concat_InBlocks b: forall l (F: Forall (fun x : list bool => length x = b) l),
      InBlocks b (concat l).
induction l; simpl; intros. constructor.
econstructor. 2: reflexivity.
 apply Forall_inv in F; trivial.
 apply IHl. apply Forall_tl in F; trivial.
Qed.

Lemma concat_app {A} (l1 l2:list A): l1 ++ l2 = l1 ++ concat (l2 :: nil).
Proof.
  unfold concat. simpl.
  rewrite -> app_nil_r. reflexivity.
Qed.

(* Replacing splitVector *)
Definition splitList {A : Type} (n : nat) (l : list A) : (list A * list A) :=
  (firstn n l, skipn n l).

Lemma split_append_id : forall {A : Type} (len : nat) (l1 l2 : list A),
                               length l1 = len -> length l2 = len ->
                               splitList len (l1 ++ l2) = (l1, l2).
Proof.
  induction len; intros l1 l2 len1 len2.
  - apply list_nil in len1; apply list_nil in len2.
    subst. reflexivity.
  - unfold splitList.
    rewrite -> firstn_exact. rewrite -> skipn_exact.
    * reflexivity. * assumption. * assumption.
Qed.

(* Replacing BVxor *)
Definition BLxor (xs : Blist) (ys : Blist) :=
  map (fun p => xorb (fst p) (snd p)) (combine xs ys).

Lemma BLxor_length: forall n l1 l2
      (len1: length l1 = n) (len2: length l2 = n), length (BLxor l1 l2) = n.
Proof.
  induction n as [ | n']; intros.
  - apply list_nil in len1. apply list_nil in len2.
    subst. reflexivity.
  - destruct l1; destruct l2; inversion len1; inversion len2.
    simpl.
    rewrite -> map_length.
    rewrite -> combine_length.
    rewrite H0. rewrite H1. simpl.
    f_equal.
    apply min_l.
    omega.
Qed.

Theorem xor_eq : forall (n : nat) (v1 v2 : Bvector.Bvector n),
                   BLxor (Vector.to_list v1) (Vector.to_list v2) =
                   Vector.to_list (Bvector.BVxor n v1 v2).
Proof.
  eapply Vector.rect2.
  reflexivity.
  intros. simpl. rewrite (VectorToList_cons _ _ (xorb a b)).
   rewrite <- H. clear H. unfold BLxor.
   rewrite VectorToList_combine. reflexivity.
Qed.

Lemma inner_general_mapByte : forall (ip : Blist) (IP_list : list byte) (k : Blist) (K : list byte),
                            bytes_bits_lists ip (map Byte.unsigned IP_list) ->
                            bytes_bits_lists k (map Byte.unsigned K) ->
     bytes_bits_lists (BLxor k ip)
                      (map Byte.unsigned
                           (map (fun p0 : byte * byte => Byte.xor (fst p0) (snd p0))
                                (combine K IP_list))).
Proof.
  intros ip IP_list k K ip_eq k_eq.
  unfold BLxor. simpl.
  remember (map Byte.unsigned IP_list). remember (map Byte.unsigned K) as KL.
  generalize dependent K. generalize dependent IP_list. generalize dependent ip. generalize dependent l.
  induction k_eq.
  - simpl; intros. destruct K; simpl in *. constructor. discriminate.
  - intros l ip ip_eq.
    induction ip_eq; simpl; intros.
    + destruct IP_list; simpl in *. 2: discriminate.
      destruct K; simpl in *. discriminate. constructor.
    + destruct IP_list. discriminate. simpl in Heql. inversion Heql; clear Heql. subst byte0 bytes0.
      destruct K; simpl in HeqKL. discriminate. inversion HeqKL; clear HeqKL; subst.
      simpl.
      constructor.
      * eapply IHk_eq; try reflexivity.
        apply ip_eq.
      * unfold Byte.xor. rewrite Byte.unsigned_repr.
        apply xor_correspondence. apply H. apply H0.
        destruct (@isbyteZ_xor (Byte.unsigned i0) (Byte.unsigned i)).
        apply isByte_ByteUnsigned.
        apply isByte_ByteUnsigned.
        assert (BMU: Byte.max_unsigned = 255). reflexivity. omega.
Qed.

Function hash_blocks_bits (b:nat) (B:(0<b)%nat) (hash_block_bit : Blist -> Blist -> Blist) (r: Blist)
         (msg: Blist) {measure length msg} : Blist :=
  match msg with
  | nil => r
  | _ => hash_blocks_bits b B hash_block_bit (hash_block_bit r (firstn b msg)) (skipn b msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) b).
 rewrite skipn_short. simpl; omega. rewrite <- teq; omega.
 rewrite skipn_length; rewrite <- teq; omega.
Defined.

Lemma add_blocksize_length l n: 0<=n ->
      BinInt.Z.add n (Zcomplements.Zlength l) = Zcomplements.Zlength ((Coqlib.list_repeat (Z.to_nat n) true) ++ l).
Proof. intros. do 2 rewrite Zlength_correct.
  rewrite app_length, length_list_repeat, Nat2Z.inj_add, Z2Nat.id; trivial.
Qed.

Lemma hash_blocks_bits_len c b (B:(0<b)%nat) h
          (HH: forall x y, length x = c -> length y = b -> length (h x y)  = c)
          r l: length r = c ->
      InBlocks b l ->
      length (hash_blocks_bits b B h r l) = c.
Proof.
  apply hash_blocks_bits_ind.
  intros. trivial.
  intros. destruct _x. contradiction. subst msg; clear y.
  inv H1.
  apply H; clear H. rewrite HH. trivial. trivial.
    rewrite H3, firstn_exact; trivial.
    rewrite H3, skipn_exact; trivial.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
   + intros. reflexivity.
   + destruct n2.
   * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
   * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
   + intros. destruct n. reflexivity. reflexivity.
   + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

Theorem theorem0 : forall (v : natural) (w : natural) (x : natural) (y : natural) (z : lst), eq (drop (Succ v) (drop w (drop x (Cons y z)))) (drop v (drop w (drop x z))).
Proof.
intros.
rewrite lem.
lfind. Admitted.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype choice ssrnat seq fintype generic_quotient.
From mathcomp
Require Import bigop ssralg poly polydiv matrix mxpoly countalg ring_quotient.

(******************************************************************************)
(* This files contains two main contributions:                                *)
(* 1. Theorem "closed_field_QEMixin"                                          *)
(*    A proof that algebraically closed field enjoy quantifier elimination,   *)
(*    as described in                                                         *)
(*    ``A formal quantifier elimination for algebraically closed fields'',    *)
(*     proceedings of Calculemus 2010, by Cyril Cohen and Assia Mahboubi      *)
(*                                                                            *)
(* We constructs an instance of quantifier elimination mixin,                 *)
(* (see the ssralg library) from the theory of polynomials with coefficients  *)
(* is an algebraically closed field (see the polydiv library).                *)
(* The algebraic operations operating on fomulae are implemented in CPS style *)
(* We provide one CPS counterpart for each operation involved in the proof    *)
(* of quantifier elimination. See the paper  for more details.                *)
(*                                                                            *)
(* 2. Theorems "countable_field_extension" and "countable_algebraic_closure"  *)
(*    constructions for both simple extension and algebraic closure of        *)
(*    countable fields, by Georges Gonthier.                                  *)
(*    Note that the construction of the algebraic closure relies on the       *)
(*    above mentionned quantifier elimination.                                *)
(******************************************************************************)

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

Import GRing.Theory.
Local Open Scope ring_scope.

Import Pdiv.Ring.
Import PreClosedField.

Module ClosedFieldQE.
Section ClosedFieldQE.

Variables (F : fieldType) (F_closed : GRing.ClosedField.axiom F).

Notation fF := (@GRing.formula F).
Notation tF := (@GRing.term F).
Notation qf f := (GRing.qf_form f && GRing.rformula f).
Definition polyF := seq tF.

Lemma qf_simpl (f : fF) :
  (qf f -> GRing.qf_form f) * (qf f -> GRing.rformula f).
Proof. by split=> /andP[]. Qed.

Notation cps T := ((T -> fF) -> fF).
Definition ret T1 : T1 -> cps T1 := fun x k => k x.
Arguments ret {T1} x k /.

Definition bind T1 T2 (x : cps T1) (f : T1 -> cps T2) : cps T2 :=
  fun k => x (fun x => f x k).
Arguments bind {T1 T2} x f k /.
Notation "''let' x <- y ; z" :=
  (bind y (fun x => z)) (at level 99, x at level 0, y at level 0,
    format "'[hv' ''let'  x  <-  y ;  '/' z ']'").

Definition cpsif T (c : fF) (t : T) (e : T) : cps T :=
  fun k => GRing.If c (k t) (k e).
Arguments cpsif {T} c t e k /.
Notation "''if' c1 'then' c2 'else' c3" := (cpsif c1%T c2%T c3%T)
  (at level 200, right associativity, format
"'[hv   ' ''if'  c1  '/' '[' 'then'  c2  ']' '/' '[' 'else'  c3 ']' ']'").

Notation eval := GRing.eval.
Notation rterm := GRing.rterm.
Notation qf_eval := GRing.qf_eval.

Fixpoint eval_poly (e : seq F) pf :=
  if pf is c :: q then eval_poly e q * 'X + (eval e c)%:P else 0.

Definition rpoly (p : polyF) := all (@rterm F) p.

Definition sizeT : polyF -> cps nat := (fix loop p :=
  if p isn't c :: q then ret 0%N
  else 'let n <- loop q;
       if n is m.+1 then ret m.+2 else
       'if (c == 0) then 0%N else 1%N).

Definition qf_red_cps T (x : cps T) (y : _ -> T) :=
   forall e k, qf_eval e (x k) = qf_eval e (k (y e)).
Notation "x ->_ e y" := (qf_red_cps x (fun e => y))
  (e ident, at level 90, format "x  ->_ e  y").

Definition qf_cps T D (x : cps T) :=
  forall k, (forall y, D y -> qf (k y)) -> qf (x k).

Lemma qf_cps_ret T D (x : T) : D x -> qf_cps D (ret x).
Proof. move=> ??; exact. Qed.
Hint Resolve qf_cps_ret : core.

Lemma qf_cps_bind T1 D1 T2 D2 (x : cps T1) (f : T1 -> cps T2) :
  qf_cps D1 x -> (forall x, D1 x -> qf_cps D2 (f x)) -> qf_cps D2 (bind x f).
Proof. by move=> xP fP k kP /=; apply: xP => y ?; apply: fP. Qed.

Lemma qf_cps_if T D (c : fF) (t : T) (e : T) : qf c -> D t -> D e ->
  qf_cps D ('if c then t else e).
Proof.
move=> qfc Dt De k kP /=; have [qft qfe] := (kP _ Dt, kP _ De).
by do !rewrite qf_simpl //.
Qed.

Lemma sizeTP (pf : polyF) : sizeT pf ->_e size (eval_poly e pf).
Proof.
elim: pf=> [|c qf qfP /=]; first by rewrite /= size_poly0.
move=> e k; rewrite size_MXaddC qfP -(size_poly_eq0 (eval_poly _ _)).
by case: (size (eval_poly e qf))=> //=; case: eqP; rewrite // orbF.
Qed.

Lemma sizeT_qf (p : polyF) : rpoly p -> qf_cps xpredT (sizeT p).
Proof.
elim: p => /= [_|c p ihp /andP[rc rq]]; first exact: qf_cps_ret.
apply: qf_cps_bind; first exact: ihp.
move=> [|n] //= _; last exact: qf_cps_ret.
by apply: qf_cps_if; rewrite //= rc.
Qed.

Definition isnull (p : polyF) : cps bool :=
  'let n <- sizeT p; ret (n == 0%N).

Lemma isnullP (p : polyF) : isnull p ->_e (eval_poly e p == 0).
Proof. by move=> e k; rewrite sizeTP size_poly_eq0. Qed.

Lemma isnull_qf (p : polyF) : rpoly p -> qf_cps xpredT (isnull p).
Proof.
move=> rp; apply: qf_cps_bind; first exact: sizeT_qf.
by move=> ? _; apply: qf_cps_ret.
Qed.

Definition lt_sizeT (p q : polyF) : cps bool :=
  'let n <- sizeT p; 'let m <- sizeT q; ret (n < m).

Definition lift (p : {poly F}) := map GRing.Const p.

Lemma eval_lift (e : seq F) (p : {poly F}) : eval_poly e (lift p) = p.
Proof.
elim/poly_ind: p => [|p c]; first by rewrite /lift polyseq0.
rewrite -cons_poly_def /lift polyseq_cons /nilp.
case pn0: (_ == _) => /=; last by move->; rewrite -cons_poly_def.
move=> _; rewrite polyseqC.
case c0: (_==_)=> /=.
  move: pn0; rewrite (eqP c0) size_poly_eq0; move/eqP->.
  by apply: val_inj=> /=; rewrite polyseq_cons // polyseq0.
by rewrite mul0r add0r; apply: val_inj=> /=; rewrite polyseq_cons // /nilp pn0.
Qed.

Fixpoint lead_coefT p : cps tF :=
  if p is c :: q then
    'let l <- lead_coefT q; 'if (l == 0) then c else l
  else ret 0%T.

Lemma lead_coefTP (k : tF -> fF) :
 (forall x e, qf_eval e (k x) = qf_eval e (k (eval e x)%:T%T)) ->
  forall (p : polyF) (e : seq F),
  qf_eval e (lead_coefT p k) = qf_eval e (k (lead_coef (eval_poly e p))%:T%T).
Proof.
move=> kP p e; elim: p => [|a p IHp]/= in k kP e *.
  by rewrite lead_coef0 kP.
rewrite IHp; last by move=> *; rewrite //= -kP.
rewrite GRing.eval_If /= lead_coef_eq0.
case p'0: (_ == _); first by rewrite (eqP p'0) mul0r add0r lead_coefC -kP.
rewrite lead_coefDl ?lead_coefMX // polyseqC size_mul ?p'0 //; last first.
  by rewrite -size_poly_eq0 size_polyX.
rewrite size_polyX addnC /=; case: (_ == _)=> //=.
by rewrite ltnS lt0n size_poly_eq0 p'0.
Qed.

Lemma lead_coefT_qf (p : polyF) : rpoly p -> qf_cps (@rterm _) (lead_coefT p).
Proof.
elim: p => [_|c q ihp //= /andP[rc rq]]; first by apply: qf_cps_ret.
apply: qf_cps_bind => [|y ty]; first exact: ihp.
by apply: qf_cps_if; rewrite //= ty.
Qed.

Fixpoint amulXnT (a : tF) (n : nat) : polyF :=
  if n is n'.+1 then 0%T :: (amulXnT a n') else [:: a].

Lemma eval_amulXnT  (a : tF) (n : nat) (e : seq F) :
  eval_poly e (amulXnT a n) = (eval e a)%:P * 'X^n.
Proof.
elim: n=> [|n] /=; first by rewrite expr0 mulr1 mul0r add0r.
by move->; rewrite addr0 -mulrA -exprSr.
Qed.

Lemma ramulXnT: forall a n, rterm a -> rpoly (amulXnT a n).
Proof. by move=> a n; elim: n a=> [a /= -> //|n ihn a ra]; apply: ihn. Qed.

Fixpoint sumpT (p q : polyF) :=
  match p, q with a :: p, b :: q => (a + b)%T :: sumpT p q
                | [::], q => q | p, [::] => p end.

Lemma eval_sumpT (p q : polyF) (e : seq F) :
  eval_poly e (sumpT p q) = (eval_poly e p) + (eval_poly e q).
Proof.
elim: p q => [|a p Hp] q /=; first by rewrite add0r.
case: q => [|b q] /=; first by rewrite addr0.
rewrite Hp mulrDl -!addrA; congr (_ + _); rewrite polyC_add addrC -addrA.
by congr (_ + _); rewrite addrC.
Qed.

Lemma rsumpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (sumpT p q).
Proof.
elim: p q=> [|a p ihp] q rp rq //; move: rp; case/andP=> ra rp.
case: q rq => [|b q]; rewrite /= ?ra ?rp //=.
by case/andP=> -> rq //=; apply: ihp.
Qed.

Fixpoint mulpT (p q : polyF) :=
  if p isn't a :: p then [::]
  else sumpT [seq (a * x)%T | x <- q] (0%T :: mulpT p q).

Lemma eval_mulpT (p q : polyF) (e : seq F) :
  eval_poly e (mulpT p q) = (eval_poly e p) * (eval_poly e q).
Proof.
elim: p q=> [|a p Hp] q /=; first by rewrite mul0r.
rewrite eval_sumpT /= Hp addr0 mulrDl addrC mulrAC; congr (_ + _).
elim: q=> [|b q Hq] /=; first by rewrite mulr0.
by rewrite Hq polyC_mul mulrDr mulrA.
Qed.

Lemma rpoly_map_mul (t : tF) (p : polyF) (rt : rterm t) :
  rpoly [seq (t * x)%T | x <- p] = rpoly p.
Proof.
by rewrite /rpoly all_map /= (@eq_all _ _ (@rterm _)) // => x; rewrite /= rt.
Qed.

Lemma rmulpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (mulpT p q).
Proof.
elim: p q=> [|a p ihp] q rp rq //=; move: rp; case/andP=> ra rp /=.
apply: rsumpT; last exact: ihp.
by rewrite rpoly_map_mul.
Qed.

Definition opppT : polyF -> polyF := map (GRing.Mul (- 1%T)%T).

Lemma eval_opppT (p : polyF) (e : seq F) :
  eval_poly e (opppT p) = - eval_poly e p.
Proof.
by elim: p; rewrite /= ?oppr0 // => ? ? ->; rewrite !mulNr opprD polyC_opp mul1r.
Qed.

Definition natmulpT n : polyF -> polyF := map (GRing.Mul n%:R%T).

Lemma eval_natmulpT  (p : polyF) (n : nat) (e : seq F) :
  eval_poly e (natmulpT n p) = (eval_poly e p) *+ n.
Proof.
elim: p; rewrite //= ?mul0rn // => c p ->.
rewrite mulrnDl mulr_natl polyC_muln; congr (_ + _).
by rewrite -mulr_natl mulrAC -mulrA mulr_natl mulrC.
Qed.

Fixpoint redivp_rec_loopT (q : polyF) sq cq (c : nat) (qq r : polyF)
  (n : nat) {struct n} : cps (nat * polyF * polyF) :=
  'let sr <- sizeT r;
  if sr < sq then ret (c, qq, r) else
  'let lr <- lead_coefT r;
  let m := amulXnT lr (sr - sq) in
  let qq1 := sumpT (mulpT qq [::cq]) m in
  let r1 := sumpT (mulpT r ([::cq])) (opppT (mulpT m q)) in
  if n is n1.+1 then redivp_rec_loopT q sq cq c.+1 qq1 r1 n1
  else ret (c.+1, qq1, r1).

Fixpoint redivp_rec_loop (q : {poly F}) sq cq
   (k : nat) (qq r : {poly F}) (n : nat) {struct n} :=
    if size r < sq then (k, qq, r) else
      let m := (lead_coef r) *: 'X^(size r - sq) in
      let qq1 := qq * cq%:P + m in
      let r1 := r * cq%:P - m * q in
      if n is n1.+1 then redivp_rec_loop q sq cq k.+1 qq1 r1 n1 else
        (k.+1, qq1, r1).

Lemma redivp_rec_loopTP (k : nat * polyF * polyF -> fF) :
  (forall c qq r e,  qf_eval e (k (c,qq,r))
    = qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r))))
  -> forall q sq cq c qq r n e
    (d := redivp_rec_loop (eval_poly e q) sq (eval e cq)
      c (eval_poly e qq) (eval_poly e r) n),
    qf_eval e (redivp_rec_loopT q sq cq c qq r n k)
    = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)).
Proof.
move=> Pk q sq cq c qq r n e /=.
elim: n c qq r k Pk e => [|n Pn] c qq r k Pk e; rewrite sizeTP.
  case ltrq : (_ < _); first by rewrite /= ltrq /= -Pk.
  rewrite lead_coefTP => [|a p]; rewrite Pk.
    rewrite ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=.
    by rewrite ltrq //= mul_polyC ?(mul0r,add0r).
  by symmetry; rewrite Pk ?(eval_mulpT,eval_amulXnT,eval_sumpT, eval_opppT).
case ltrq : (_<_); first by rewrite /= ltrq Pk.
rewrite lead_coefTP.
  rewrite Pn ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=.
  by rewrite ltrq //= mul_polyC ?(mul0r,add0r).
rewrite -/redivp_rec_loopT => x e'.
rewrite Pn; last by move=> *; rewrite Pk.
symmetry; rewrite Pn; last by move=> *; rewrite Pk.
rewrite Pk ?(eval_lift,eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT).
by rewrite mul_polyC ?(mul0r,add0r).
Qed.

Lemma redivp_rec_loopT_qf (q : polyF) (sq : nat) (cq : tF)
  (c : nat) (qq r : polyF) (n : nat) :
  rpoly q -> rterm cq -> rpoly qq -> rpoly r ->
  qf_cps (fun x => [&& rpoly x.1.2 & rpoly x.2])
         (redivp_rec_loopT q sq cq c qq r n).
Proof.
do ![move=>x/(pair x){x}] => rw; elim: n => [|n IHn]//= in q sq cq c qq r rw *;
apply: qf_cps_bind; do ?[by apply: sizeT_qf; rewrite !rw] => sr _;
case: ifPn => // _; do ?[by apply: qf_cps_ret; rewrite //= ?rw];
apply: qf_cps_bind; do ?[by apply: lead_coefT_qf; rewrite !rw] => lr /= rlr;
[apply: qf_cps_ret|apply: IHn];
by do !rewrite ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul,rlr,rw) //=.
Qed.

Definition redivpT (p : polyF) (q : polyF) : cps (nat * polyF * polyF) :=
  'let b <- isnull q;
  if b then ret (0%N, [::0%T], p) else
  'let sq <- sizeT q; 'let sp <- sizeT p;
  'let lq <- lead_coefT q;
  redivp_rec_loopT q sq lq 0 [::0%T] p sp.

Lemma redivp_rec_loopP  (q : {poly F}) (c : nat) (qq r : {poly F}) (n : nat) :
  redivp_rec q c qq r n = redivp_rec_loop q (size q) (lead_coef q) c qq r n.
Proof. by elim: n c qq r => [| n Pn] c qq r //=; rewrite Pn. Qed.

Lemma redivpTP (k : nat * polyF * polyF -> fF) :
  (forall c qq r e,
     qf_eval e (k (c,qq,r)) =
     qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r)))) ->
  forall p q e (d := redivp (eval_poly e p) (eval_poly e q)),
    qf_eval e (redivpT p q k) = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)).
Proof.
move=> Pk p q e /=; rewrite isnullP unlock /=.
case q0 : (eval_poly e q == 0) => /=; first by rewrite Pk /= mul0r add0r polyC0.
rewrite !sizeTP lead_coefTP /=; last by move=> *; rewrite !redivp_rec_loopTP.
rewrite redivp_rec_loopTP /=; last by move=> *; rewrite Pk.
by rewrite mul0r add0r polyC0 redivp_rec_loopP.
Qed.

Lemma redivpT_qf (p : polyF) (q : polyF) : rpoly p -> rpoly q ->
  qf_cps (fun x => [&& rpoly x.1.2 & rpoly x.2]) (redivpT p q).
Proof.
move=> rp rq; apply: qf_cps_bind => [|[] _]; first exact: isnull_qf.
  by apply: qf_cps_ret.
apply: qf_cps_bind => [|sp _]; first exact: sizeT_qf.
apply: qf_cps_bind => [|sq _]; first exact: sizeT_qf.
apply: qf_cps_bind => [|lq rlq]; first exact: lead_coefT_qf.
by apply: redivp_rec_loopT_qf => //=.
Qed.

Definition rmodpT (p : polyF) (q : polyF) : cps polyF :=
  'let d <- redivpT p q; ret d.2.
Definition rdivpT (p : polyF) (q : polyF) : cps polyF :=
  'let d <- redivpT p q; ret d.1.2.
Definition rscalpT (p : polyF) (q : polyF) : cps nat :=
  'let d <- redivpT p q; ret d.1.1.
Definition rdvdpT (p : polyF) (q : polyF) : cps bool :=
  'let d <- rmodpT p q; isnull d.

Fixpoint rgcdp_loop n (pp qq : {poly F}) {struct n} :=
  let rr := rmodp pp qq in if rr == 0 then qq
    else if n is n1.+1 then rgcdp_loop n1 qq rr else rr.

Fixpoint rgcdp_loopT n (pp : polyF) (qq : polyF) : cps polyF :=
  'let rr <- rmodpT pp qq; 'let nrr <- isnull rr; if nrr then ret qq
    else if n is n1.+1 then rgcdp_loopT n1 qq rr else ret rr.

Lemma rgcdp_loopP (k : polyF -> fF) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall n p q e,
    qf_eval e (rgcdp_loopT n p q k) =
    qf_eval e (k (lift (rgcdp_loop n (eval_poly e p) (eval_poly e q)))).
Proof.
move=> Pk n p q e; elim: n => /= [| m IHm] in p q e *;
rewrite redivpTP /==> *; rewrite ?isnullP ?eval_lift -/(rmodp _ _);
by case: (_ == _); do ?by rewrite -?Pk ?IHm ?eval_lift.
Qed.

Lemma rgcdp_loopT_qf (n : nat) (p : polyF) (q : polyF) :
  rpoly p -> rpoly q -> qf_cps rpoly (rgcdp_loopT n p q).
Proof.
elim: n => [|n IHn] in p q * => rp rq /=;
(apply: qf_cps_bind=> [|rr rrr]; [
  apply: qf_cps_bind => [|[[a u] v]]; do ?exact: redivpT_qf;
  by move=> /andP[/= ??]; apply: (@qf_cps_ret _ rpoly)|
apply: qf_cps_bind => [|[] _];
by [apply: isnull_qf|apply: qf_cps_ret|apply: IHn]]).
Qed.

Definition rgcdpT (p : polyF) (q : polyF) : cps polyF :=
  let aux p1 q1 : cps polyF :=
    'let b <- isnull p1; if b then ret q1
    else 'let n <- sizeT p1; rgcdp_loopT n p1 q1 in
  'let b <- lt_sizeT p q; if b then aux q p else aux p q.

Lemma rgcdpTP (k : polyF -> fF) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
   forall p q e, qf_eval e (rgcdpT p q k) =
                 qf_eval e (k (lift (rgcdp (eval_poly e p) (eval_poly e q)))).
Proof.
move=> Pk p q e; rewrite /rgcdpT /rgcdp !sizeTP /=.
case: (_ < _); rewrite !isnullP /=; case: (_ == _); rewrite -?Pk ?sizeTP;
by rewrite ?rgcdp_loopP.
Qed.

Lemma rgcdpT_qf (p : polyF) (q : polyF) :
   rpoly p -> rpoly q -> qf_cps rpoly (rgcdpT p q).
Proof.
move=> rp rq k kP; rewrite /rgcdpT /=; do ![rewrite sizeT_qf => // ? _].
case: (_ < _); rewrite ?isnull_qf // => -[]; rewrite ?kP // => _;
by rewrite sizeT_qf => // ? _; rewrite rgcdp_loopT_qf.
Qed.

Fixpoint rgcdpTs (ps : seq polyF) : cps polyF :=
  if ps is p :: pr then 'let pr <- rgcdpTs pr; rgcdpT p pr else ret [::0%T].

Lemma rgcdpTsP (k : polyF -> fF) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall ps e,
    qf_eval e (rgcdpTs ps k) =
    qf_eval e (k (lift (\big[@rgcdp _/0%:P]_(i <- ps)(eval_poly e i)))).
Proof.
move=> Pk ps e; elim: ps k Pk => [|p ps Pps] /= k Pk.
  by rewrite /= big_nil Pk /= mul0r add0r.
by rewrite big_cons Pps => *; rewrite !rgcdpTP // !eval_lift -?Pk.
Qed.

Lemma rgcdpTs_qf (ps : seq polyF) :
   all rpoly ps -> qf_cps rpoly (rgcdpTs ps).
Proof.
elim: ps => [_|c p ihp /andP[rc rp]] //=; first exact: qf_cps_ret.
by apply: qf_cps_bind => [|r rr]; [apply: ihp|apply: rgcdpT_qf].
Qed.

Fixpoint rgdcop_recT n (q : polyF) (p : polyF) :=
  if n is m.+1 then
    'let g <- rgcdpT p q; 'let sg <- sizeT g;
    if sg == 1%N then ret p
    else 'let r <- rdivpT p g;
          rgdcop_recT m q r
  else 'let b <- isnull q; ret [::b%:R%T].

Lemma rgdcop_recTP (k : polyF -> fF) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p))))
  -> forall p q n e, qf_eval e (rgdcop_recT n p q k)
    = qf_eval e (k (lift (rgdcop_rec (eval_poly e p) (eval_poly e q) n))).
Proof.
move=> Pk p q n e; elim: n => [|n Pn] /= in k Pk p q e *.
  rewrite isnullP /=.
  by case: (_ == _); rewrite Pk /= mul0r add0r ?(polyC0, polyC1).
rewrite /rcoprimep rgcdpTP ?sizeTP ?eval_lift => * /=.
  case: (_ == _);
  by do ?[rewrite /= ?(=^~Pk, redivpTP, rgcdpTP, sizeTP, Pn, eval_lift) //==> *].
do ?[rewrite /= ?(=^~Pk, redivpTP, rgcdpTP, sizeTP, Pn, eval_lift) //==> *].
case: (_ == _);
by do ?[rewrite /= ?(=^~Pk, redivpTP, rgcdpTP, sizeTP, Pn, eval_lift) //==> *].
Qed.

Lemma rgdcop_recT_qf (n : nat) (p : polyF) (q : polyF) :
  rpoly p -> rpoly q -> qf_cps rpoly (rgdcop_recT n p q).
Proof.
elim: n => [|n ihn] in p q * => k kP rp rq /=.
  by rewrite isnull_qf => //*; rewrite rq.
rewrite rgcdpT_qf=> //*; rewrite sizeT_qf=> //*.
case: (_ == _); rewrite ?kP ?rq //= redivpT_qf=> //= ? /andP[??].
by rewrite ihn.
Qed.

Definition rgdcopT q p := 'let sp <- sizeT p; rgdcop_recT sp q p.

Lemma rgdcopTP (k : polyF -> fF) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall p q e, qf_eval e (rgdcopT p q k) =
                qf_eval e (k (lift (rgdcop (eval_poly e p) (eval_poly e q)))).
Proof. by move=> *; rewrite sizeTP rgdcop_recTP 1?Pk. Qed.

Lemma rgdcopT_qf (p : polyF) (q : polyF) :
  rpoly p -> rpoly q -> qf_cps rpoly (rgdcopT p q).
Proof.
by move=> rp rq k kP; rewrite sizeT_qf => //*; rewrite rgdcop_recT_qf.
Qed.

Definition ex_elim_seq (ps : seq polyF) (q : polyF) : fF :=
  ('let g <- rgcdpTs ps; 'let d <- rgdcopT q g;
  'let n <- sizeT d; ret (n != 1%N)) GRing.Bool.

Lemma ex_elim_seqP (ps : seq polyF) (q : polyF) (e : seq F) :
  let gp := (\big[@rgcdp _/0%:P]_(p <- ps)(eval_poly e p)) in
  qf_eval e (ex_elim_seq ps q) = (size (rgdcop (eval_poly e q) gp) != 1%N).
Proof.
by do ![rewrite (rgcdpTsP,rgdcopTP,sizeTP,eval_lift) //= | move=> * //=].
Qed.

Lemma ex_elim_seq_qf  (ps : seq polyF) (q : polyF) :
  all rpoly ps -> rpoly q -> qf (ex_elim_seq ps q).
Proof.
move=> rps rq; apply: rgcdpTs_qf=> // g rg; apply: rgdcopT_qf=> // d rd.
exact : sizeT_qf.
Qed.

Fixpoint abstrX (i : nat) (t : tF) :=
  match t with
    | 'X_n => if n == i then [::0; 1] else [::t]
    | - x => opppT (abstrX i x)
    | x + y => sumpT (abstrX i x) (abstrX i y)
    | x * y => mulpT (abstrX i x) (abstrX i y)
    | x *+ n => natmulpT n (abstrX i x)
    | x ^+ n => let ax := (abstrX i x) in iter n (mulpT ax) [::1]
    | _ => [::t]
  end%T.

Lemma abstrXP  (i : nat) (t : tF) (e : seq F) (x : F) :
  rterm t -> (eval_poly e (abstrX i t)).[x] = eval (set_nth 0 e i x) t.
Proof.
elim: t => [n | r | n | t tP s sP | t tP | t tP n | t tP s sP | t tP | t tP n] h.
- move=> /=; case ni: (_ == _);
    rewrite //= ?(mul0r,add0r,addr0,polyC1,mul1r,hornerX,hornerC);
    by rewrite // nth_set_nth /= ni.
- by rewrite /= mul0r add0r hornerC.
- by rewrite /= mul0r add0r hornerC.
- by case/andP: h => *; rewrite /= eval_sumpT hornerD tP ?sP.
- by rewrite /= eval_opppT hornerN tP.
- by rewrite /= eval_natmulpT hornerMn tP.
- by case/andP: h => *; rewrite /= eval_mulpT hornerM tP ?sP.
- by [].
- elim: n h => [|n ihn] rt; first by rewrite /= expr0 mul0r add0r hornerC.
  by rewrite /= eval_mulpT exprSr hornerM ihn // mulrC tP.
Qed.

Lemma rabstrX (i : nat) (t : tF) : rterm t -> rpoly (abstrX i t).
Proof.
elim: t; do ?[ by move=> * //=; do ?case: (_ == _)].
- move=> t irt s irs /=; case/andP=> rt rs.
  by apply: rsumpT; rewrite ?irt ?irs //.
- by move=> t irt /= rt; rewrite rpoly_map_mul ?irt //.
- by move=> t irt /= n rt; rewrite rpoly_map_mul ?irt //.
- move=> t irt s irs /=; case/andP=> rt rs.
  by apply: rmulpT; rewrite ?irt ?irs //.
- move=> t irt /= n rt; move: (irt rt)=> {rt} rt; elim: n => [|n ihn] //=.
  exact: rmulpT.
Qed.

Implicit Types tx ty : tF.

Lemma abstrX_mulM (i : nat) : {morph abstrX i : x y / x * y >-> mulpT x y}%T.
Proof. by []. Qed.

Lemma abstrX1 (i : nat) : abstrX i 1%T = [::1%T].
Proof. done. Qed.

Lemma eval_poly_mulM e : {morph eval_poly e : x y / mulpT x y >-> x * y}.
Proof. by move=> x y; rewrite eval_mulpT. Qed.

Lemma eval_poly1 e : eval_poly e [::1%T] = 1.
Proof. by rewrite /= mul0r add0r. Qed.

Notation abstrX_bigmul := (big_morph _ (abstrX_mulM _) (abstrX1 _)).
Notation eval_bigmul := (big_morph _ (eval_poly_mulM _) (eval_poly1 _)).
Notation bigmap_id := (big_map _ (fun _ => true) id).

Lemma rseq_poly_map (x : nat) (ts : seq tF) :
  all (@rterm _) ts ->  all rpoly (map (abstrX x) ts).
Proof.
by elim: ts => //= t ts iht; case/andP=> rt rts; rewrite rabstrX // iht.
Qed.

Definition ex_elim (x : nat) (pqs : seq tF * seq tF) :=
  ex_elim_seq (map (abstrX x) pqs.1)
  (abstrX x (\big[GRing.Mul/1%T]_(q <- pqs.2) q)).

Lemma ex_elim_qf (x : nat) (pqs : seq tF * seq tF) :
  GRing.dnf_rterm pqs -> qf (ex_elim x pqs).
case: pqs => ps qs; case/andP=> /= rps rqs.
apply: ex_elim_seq_qf; first exact: rseq_poly_map.
apply: rabstrX=> /=.
elim: qs rqs=> [|t ts iht] //=; first by rewrite big_nil.
by case/andP=> rt rts; rewrite big_cons /= rt /= iht.
Qed.

Lemma holds_conj : forall e i x ps, all (@rterm _) ps ->
  (GRing.holds (set_nth 0 e i x)
               (foldr (fun t : tF => GRing.And (t == 0)) GRing.True%T ps)
  <-> all ((@root _)^~ x) (map (eval_poly e \o abstrX i) ps)).
Proof.
move=> e i x; elim=> [|p ps ihps] //=.
case/andP=> rp rps; rewrite rootE abstrXP //.
constructor; first by case=> -> hps; rewrite eqxx /=; apply/ihps.
by case/andP; move/eqP=> -> psr; split=> //; apply/ihps.
Qed.

Lemma holds_conjn (e : seq F) (i : nat) (x : F) (ps : seq tF) :
  all (@rterm _) ps ->
  (GRing.holds (set_nth 0 e i x)
               (foldr (fun t : tF => GRing.And (t != 0)) GRing.True ps) <->
  all (fun p => ~~root p x) (map (eval_poly e \o abstrX i) ps)).
Proof.
elim: ps => [|p ps ihps] //=.
case/andP=> rp rps; rewrite rootE abstrXP //.
constructor; first by case=> /eqP-> hps /=; apply/ihps.
by case/andP=> pr psr; split; first apply/eqP=> //; apply/ihps.
Qed.

Lemma holds_ex_elim: GRing.valid_QE_proj ex_elim.
Proof.
move=> i [ps qs] /= e; case/andP=> /= rps rqs.
rewrite ex_elim_seqP big_map.
have -> : \big[@rgcdp _/0%:P]_(j <- ps) eval_poly e (abstrX i j) =
          \big[@rgcdp _/0%:P]_(j <- (map (eval_poly e) (map (abstrX i) (ps)))) j.
  by rewrite !big_map.
rewrite -!map_comp.
  have aux I (l : seq I) (P : I -> {poly F}) :
    \big[(@gcdp F)/0]_(j <- l) P j %= \big[(@rgcdp F)/0]_(j <- l) P j.
    elim: l => [| u l ihl] /=; first by rewrite !big_nil eqpxx.
    rewrite !big_cons; move: ihl; move/(eqp_gcdr (P u)) => h.
    by apply: eqp_trans h _; rewrite eqp_sym; apply: eqp_rgcd_gcd.
case g0: (\big[(@rgcdp F)/0%:P]_(j <- map (eval_poly e \o abstrX i) ps) j == 0).
  rewrite (eqP g0) rgdcop0.
  case m0 : (_ == 0)=> //=; rewrite ?(size_poly1,size_poly0) //=.
    rewrite abstrX_bigmul eval_bigmul -bigmap_id in m0.
    constructor=> [[x] // []] //.
    case=> _; move/holds_conjn=> hc; move/hc:rqs.
    by rewrite -root_bigmul //= (eqP m0) root0.
  constructor; move/negP:m0; move/negP=>m0.
  case: (closed_nonrootP F_closed _ m0) => x {m0}.
  rewrite abstrX_bigmul eval_bigmul -bigmap_id root_bigmul=> m0.
  exists x; do 2?constructor=> //; last by apply/holds_conjn.
  apply/holds_conj; rewrite //= -root_biggcd.
  by rewrite (eqp_root (aux _ _ _ )) (eqP g0) root0.
apply: (iffP (closed_rootP F_closed _)) => -[x Px]; exists x; move: Px => //=.
  rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 //.
  rewrite -(eqp_root (aux _ _ _ )) root_biggcd  abstrX_bigmul eval_bigmul.
  rewrite -bigmap_id root_bigmul; case/andP=> psr qsr.
  do 2?constructor; first by apply/holds_conj.
  by apply/holds_conjn.
rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 // -(eqp_root (aux _ _ _)).
rewrite root_biggcd abstrX_bigmul eval_bigmul -bigmap_id.
rewrite root_bigmul=> [[] // [hps hqs]]; apply/andP.
constructor; first by apply/holds_conj.
by apply/holds_conjn.
Qed.

Lemma wf_ex_elim : GRing.wf_QE_proj ex_elim.
Proof. by move=> i bc /= rbc; apply: ex_elim_qf. Qed.

Definition Mixin := QEdecFieldMixin wf_ex_elim holds_ex_elim.

End ClosedFieldQE.
End ClosedFieldQE.
Notation closed_field_QEMixin := ClosedFieldQE.Mixin.

Import CodeSeq.

Lemma countable_field_extension (F : countFieldType) (p : {poly F}) :
    size p > 1 ->
  {E : countFieldType & {FtoE : {rmorphism F -> E} &
  {w : E | root (map_poly FtoE p) w
         & forall u : E, exists q, u = (map_poly FtoE q).[w]}}}.
Proof.
pose fix d i :=
  if i is i1.+1 then
    let d1 := oapp (gcdp (d i1)) 0 (unpickle i1) in
    if size d1 > 1 then d1 else d i1
  else p.
move=> p_gt1; have sz_d i: size (d i) > 1 by elim: i => //= i IHi; case: ifP.
have dv_d i j: i <= j -> d j %| d i.
  move/subnK <-; elim: {j}(j - i)%N => //= j IHj; case: ifP => //=.
  case: (unpickle _) => /= [q _|]; last by rewrite size_poly0.
  exact: dvdp_trans (dvdp_gcdl _ _) IHj.
pose I : pred {poly F} := [pred q | d (pickle q).+1 %| q].
have I'co q i: q \notin I -> i > pickle q -> coprimep q (d i).
  rewrite inE => I'q /dv_d/coprimep_dvdl-> //; apply: contraR I'q.
  rewrite coprimep_sym /coprimep /= pickleK /= neq_ltn.
  case: ifP => [_ _| ->]; first exact: dvdp_gcdr.
  rewrite orbF ltnS leqn0 size_poly_eq0 gcdp_eq0 -size_poly_eq0.
  by rewrite -leqn0 leqNgt ltnW //.
have memI q: reflect (exists i, d i %| q) (q \in I).
  apply: (iffP idP) => [|[i dv_di_q]]; first by exists (pickle q).+1.
  have [le_i_q | /I'co i_co_q] := leqP i (pickle q).
    rewrite inE /= pickleK /=; case: ifP => _; first exact: dvdp_gcdr.
    exact: dvdp_trans (dv_d _ _ le_i_q) dv_di_q.
  apply: contraR i_co_q _.
  by rewrite /coprimep (eqp_size (dvdp_gcd_idr dv_di_q)) neq_ltn sz_d orbT.
have I_ideal : idealr_closed I.
  split=> [||a q1 q2 Iq1 Iq2]; first exact: dvdp0.
    by apply/memI=> [[i /idPn[]]]; rewrite dvdp1 neq_ltn sz_d orbT.
  apply/memI; exists (maxn (pickle q1).+1 (pickle q2).+1); apply: dvdp_add.
    by apply: dvdp_mull; apply: dvdp_trans Iq1; apply/dv_d/leq_maxl.
  by apply: dvdp_trans Iq2; apply/dv_d/leq_maxr.
pose Iaddkey := GRing.Pred.Add (DefaultPredKey I) I_ideal.
pose Iidkey := MkIdeal (GRing.Pred.Zmod Iaddkey I_ideal) I_ideal.
pose E := ComRingType _ (@Quotient.mulqC _ _ _ (KeyedPred Iidkey)).
pose PtoE : {rmorphism {poly F} -> E} := [rmorphism of \pi_E%qT : {poly F} -> E].
have PtoEd i: PtoE (d i) = 0.
  by apply/eqP; rewrite piE Quotient.equivE subr0; apply/memI; exists i.
pose Einv (z : E) (q := repr z) (dq := d (pickle q).+1) :=
  let q_unitP := Bezout_eq1_coprimepP q dq in
  if q_unitP is ReflectT ex_uv then PtoE (sval (sig_eqW ex_uv)).1 else 0.
have Einv0: Einv 0 = 0.
  rewrite /Einv; case: Bezout_eq1_coprimepP => // ex_uv.
  case/negP: (oner_neq0 E); rewrite piE -[_ 1]/(PtoE 1); have [uv <-] := ex_uv.
  by rewrite rmorphD !rmorphM PtoEd /= reprK !mulr0 addr0.
have EmulV: GRing.Field.axiom Einv.
  rewrite /Einv=> z nz_z; case: Bezout_eq1_coprimepP => [ex_uv |]; last first.
    move/Bezout_eq1_coprimepP; rewrite I'co //.
    by rewrite piE -{1}[z]reprK -Quotient.idealrBE subr0 in nz_z.
  apply/eqP; case: sig_eqW => {ex_uv} [uv uv1]; set i := _.+1 in uv1 *.
  rewrite piE /= -[z]reprK -(rmorphM PtoE) -Quotient.idealrBE.
  by rewrite -uv1 opprD addNKr -mulNr; apply/memI; exists i; apply: dvdp_mull.
pose Efield := FieldType _ (FieldMixin EmulV Einv0).
pose Ecount := CountType Efield (CanCountMixin reprK).
pose FtoE := [rmorphism of PtoE \o polyC]; pose w : E := PtoE 'X.
have defPtoE q: (map_poly FtoE q).[w] = PtoE q.
  by rewrite map_poly_comp horner_map [_.['X]]comp_polyXr.
exists [countFieldType of Ecount], FtoE, w => [|u].
  by rewrite /root defPtoE (PtoEd 0%N).
by exists (repr u); rewrite defPtoE /= reprK.
Qed.

Lemma countable_algebraic_closure (F : countFieldType) :
  {K : countClosedFieldType & {FtoK : {rmorphism F -> K} | integralRange FtoK}}.
Proof.
pose minXp (R : ringType) (p : {poly R}) := if size p > 1 then p else 'X.
have minXp_gt1 R p: size (minXp R p) > 1.
  by rewrite /minXp; case: ifP => // _; rewrite size_polyX.
have minXpE (R : ringType) (p : {poly R}) : size p > 1 -> minXp R p = p.
  by rewrite /minXp => ->.
have ext1 p := countable_field_extension (minXp_gt1 _ p).
pose ext1fT E p := tag (ext1 E p).
pose ext1to E p : {rmorphism _ -> ext1fT E p} := tag (tagged (ext1 E p)).
pose ext1w E p : ext1fT E p := s2val (tagged (tagged (ext1 E p))).
have ext1root E p: root (map_poly (ext1to E p) (minXp E p)) (ext1w E p).
  by rewrite /ext1w; case: (tagged (tagged (ext1 E p))).
have ext1gen E p u: {q | u = (map_poly (ext1to E p) q).[ext1w E p]}.
  by apply: sig_eqW; rewrite /ext1w; case: (tagged (tagged (ext1 E p))) u.
pose pExtEnum (E : countFieldType) := nat -> {poly E}.
pose Ext := {E : countFieldType & pExtEnum E}; pose MkExt : Ext := Tagged _ _.
pose EtoInc (E : Ext) i := ext1to (tag E) (tagged E i).
pose incEp E i j :=
  let v := map_poly (EtoInc E i) (tagged E j) in
  if decode j is [:: i1; k] then
    if i1 == i then odflt v (unpickle k) else v
  else v.
pose fix E_ i := if i is i1.+1 then MkExt _ (incEp (E_ i1) i1) else MkExt F \0.
pose E i := tag (E_ i); pose Krep := {i : nat & E i}.
pose fix toEadd i k : {rmorphism E i -> E (k + i)%N} :=
  if k is k1.+1 then [rmorphism of EtoInc _ (k1 + i)%N \o toEadd _ _]
  else [rmorphism of idfun].
pose toE i j (le_ij : i <= j) :=
  ecast j {rmorphism E i -> E j} (subnK le_ij) (toEadd i (j - i)%N).
have toEeq i le_ii: toE i i le_ii =1 id.
  by rewrite /toE; move: (subnK _); rewrite subnn => ?; rewrite eq_axiomK.
have toEleS i j leij leiSj z: toE i j.+1 leiSj z = EtoInc _ _ (toE i j leij z).
  rewrite /toE; move: (j - i)%N {leij leiSj}(subnK _) (subnK _) => k.
  by case: j /; rewrite (addnK i k.+1) => eq_kk; rewrite [eq_kk]eq_axiomK.
have toEirr := congr1 ((toE _ _)^~ _) (bool_irrelevance _ _).
have toEtrans j i k leij lejk leik z:
  toE i k leik z = toE j k lejk (toE i j leij z).
- elim: k leik lejk => [|k IHk] leiSk lejSk.
    by case: j => // in leij lejSk *; rewrite toEeq.
  have:= lejSk; rewrite {1}leq_eqVlt ltnS => /predU1P[Dk | lejk].
    by rewrite -Dk in leiSk lejSk *; rewrite toEeq.
  by have leik := leq_trans leij lejk; rewrite !toEleS -IHk.
have [leMl leMr] := (leq_maxl, leq_maxr); pose le_max := (leq_max, leqnn, orbT).
pose pairK (x y : Krep) (m := maxn _ _) :=
  (toE _ m (leMl _ _) (tagged x), toE _ m (leMr _ _) (tagged y)).
pose eqKrep x y := prod_curry (@eq_op _) (pairK x y).
have eqKrefl : reflexive eqKrep by move=> z; apply/eqP; apply: toEirr.
have eqKsym : symmetric eqKrep.
  move=> z1 z2; rewrite {1}/eqKrep /= eq_sym; move: (leMl _ _) (leMr _ _).
  by rewrite maxnC => lez1m lez2m; congr (_ == _); apply: toEirr.
have eqKtrans : transitive eqKrep.
  rewrite /eqKrep /= => z2 z1 z3 /eqP eq_z12 /eqP eq_z23.
  rewrite -(inj_eq (fmorph_inj (toE _ _ (leMr (tag z2) _)))).
  rewrite -!toEtrans ?le_max // maxnCA maxnA => lez3m lez1m.
  rewrite {lez1m}(toEtrans (maxn (tag z1) (tag z2))) // {}eq_z12.
  do [rewrite -toEtrans ?le_max // -maxnA => lez2m] in lez3m *.
  by rewrite (toEtrans (maxn (tag z2) (tag z3))) // eq_z23 -toEtrans.
pose K := {eq_quot (EquivRel _  eqKrefl eqKsym eqKtrans)}%qT.
have cntK : Countable.mixin_of K := CanCountMixin reprK.
pose EtoKrep i (x : E i) : K := \pi%qT (Tagged E x).
have [EtoK piEtoK]: {EtoK | forall i, EtoKrep i =1 EtoK i} by exists EtoKrep.
pose FtoK := EtoK 0%N; rewrite {}/EtoKrep in piEtoK.
have eqEtoK i j x y:
  toE i _ (leMl i j) x = toE j _ (leMr i j) y -> EtoK i x = EtoK j y.
- by move/eqP=> eq_xy; rewrite -!piEtoK; apply/eqmodP.
have toEtoK j i leij x : EtoK j (toE i j leij x) = EtoK i x.
  by apply: eqEtoK; rewrite -toEtrans.
have EtoK_0 i: EtoK i 0 = FtoK 0 by apply: eqEtoK; rewrite !rmorph0.
have EtoK_1 i: EtoK i 1 = FtoK 1 by apply: eqEtoK; rewrite !rmorph1.
have EtoKeq0 i x: (EtoK i x == FtoK 0) = (x == 0).
  by rewrite /FtoK -!piEtoK eqmodE /= /eqKrep /= rmorph0 fmorph_eq0.
have toErepr m i leim x lerm:
  toE _ m lerm (tagged (repr (EtoK i x))) = toE i m leim x.
- have: (Tagged E x == repr (EtoK i x) %[mod K])%qT by rewrite reprK piEtoK.
  rewrite eqmodE /= /eqKrep; case: (repr _) => j y /= in lerm * => /eqP /=.
  have leijm: maxn i j <= m by rewrite geq_max leim.
  by move/(congr1 (toE _ _ leijm)); rewrite -!toEtrans.
pose Kadd (x y : K) := EtoK _ (prod_curry +%R (pairK (repr x) (repr y))).
pose Kopp (x : K) := EtoK _ (- tagged (repr x)).
pose Kmul (x y : K) := EtoK _ (prod_curry *%R (pairK (repr x) (repr y))).
pose Kinv (x : K) := EtoK _ (tagged (repr x))^-1.
have EtoK_D i: {morph EtoK i : x y / x + y >-> Kadd x y}.
  move=> x y; apply: eqEtoK; set j := maxn (tag _) _; rewrite !rmorphD.
  by rewrite -!toEtrans ?le_max  // => lexm leym; rewrite !toErepr.
have EtoK_N i: {morph EtoK i : x / - x >-> Kopp x}.
  by move=> x; apply: eqEtoK; set j := tag _; rewrite !rmorphN toErepr.
have EtoK_M i: {morph EtoK i : x y / x * y >-> Kmul x y}.
  move=> x y; apply: eqEtoK; set j := maxn (tag _) _; rewrite !rmorphM.
  by rewrite -!toEtrans ?le_max  // => lexm leym; rewrite !toErepr.
have EtoK_V i: {morph EtoK i : x / x^-1 >-> Kinv x}.
  by move=> x; apply: eqEtoK; set j := tag _; rewrite !fmorphV toErepr.
case: {toErepr}I in (Kadd) (Kopp) (Kmul) (Kinv) EtoK_D EtoK_N EtoK_M EtoK_V.
pose inEi i z := {x : E i | z = EtoK i x}; have KtoE z: {i : nat & inEi i z}.
  by elim/quotW: z => [[i x] /=]; exists i, x; rewrite piEtoK.
have inEle i j z: i <= j -> inEi i z -> inEi j z.
  by move=> leij [x ->]; exists (toE i j leij x); rewrite toEtoK.
have KtoE2 z1 z2: {i : nat & inEi i z1 & inEi i z2}.
  have [[i1 Ez1] [i2 Ez2]] := (KtoE z1, KtoE z2).
  by exists (maxn i1 i2); [apply: inEle Ez1 | apply: inEle Ez2].
have KtoE3 z1 z2 z3: {i : nat & inEi i z1 & inEi i z2 * inEi i z3}%type.
  have [[i1 Ez1] [i2 Ez2 Ez3]] := (KtoE z1, KtoE2 z2 z3).
  by exists (maxn i1 i2); [apply: inEle Ez1 | split; apply: inEle (leMr _ _) _].
have KaddC: commutative Kadd.
  by move=> u v; have [i [x ->] [y ->]] := KtoE2 u v; rewrite -!EtoK_D addrC.
have KaddA: associative Kadd.
  move=> u v w; have [i [x ->] [[y ->] [z ->]]] := KtoE3 u v w.
  by rewrite -!EtoK_D addrA.
have Kadd0: left_id (FtoK 0) Kadd.
  by move=> u; have [i [x ->]] := KtoE u; rewrite -(EtoK_0 i) -EtoK_D add0r.
have KaddN: left_inverse (FtoK 0) Kopp Kadd.
  by move=> u; have [i [x ->]] := KtoE u; rewrite -EtoK_N -EtoK_D addNr EtoK_0.
pose Kzmod := ZmodType K (ZmodMixin KaddA KaddC Kadd0 KaddN).
have KmulC: commutative Kmul.
  by move=> u v; have [i [x ->] [y ->]] := KtoE2 u v; rewrite -!EtoK_M mulrC.
have KmulA: @associative Kzmod Kmul.
  move=> u v w; have [i [x ->] [[y ->] [z ->]]] := KtoE3 u v w.
  by rewrite -!EtoK_M mulrA.
have Kmul1: left_id (FtoK 1) Kmul.
  by move=> u; have [i [x ->]] := KtoE u; rewrite -(EtoK_1 i) -EtoK_M mul1r.
have KmulD: left_distributive Kmul Kadd.
  move=> u v w; have [i [x ->] [[y ->] [z ->]]] := KtoE3 u v w.
  by rewrite -!(EtoK_M, EtoK_D) mulrDl.
have Kone_nz: FtoK 1 != FtoK 0 by rewrite EtoKeq0 oner_neq0.
pose KringMixin := ComRingMixin KmulA KmulC Kmul1 KmulD Kone_nz.
pose Kring := ComRingType (RingType Kzmod KringMixin) KmulC.
have KmulV: @GRing.Field.axiom Kring Kinv.
  move=> u; have [i [x ->]] := KtoE u; rewrite EtoKeq0 => nz_x.
  by rewrite -EtoK_V -[_ * _]EtoK_M mulVf ?EtoK_1.
have Kinv0: Kinv (FtoK 0) = FtoK 0 by rewrite -EtoK_V invr0.
pose Kuring := [comUnitRingType of UnitRingType _ (FieldUnitMixin KmulV Kinv0)].
pose KfieldMixin := @FieldMixin _ _ KmulV Kinv0.
pose Kidomain := IdomainType Kuring (FieldIdomainMixin KfieldMixin).
pose Kfield := FieldType Kidomain KfieldMixin.
have EtoKrmorphism i: rmorphism (EtoK i : E i -> Kfield).
  by do 2?split=> [x y|]; rewrite ?EtoK_D ?EtoK_N ?EtoK_M ?EtoK_1.
pose EtoKM := RMorphism (EtoKrmorphism _); have EtoK_E: EtoK _ = EtoKM _ by [].
have toEtoKp := @eq_map_poly _ Kring _ _(toEtoK _ _ _).
have Kclosed: GRing.ClosedField.axiom Kfield.
  move=> n pK n_gt0; pose m0 := \max_(i < n) tag (KtoE (pK i)); pose m := m0.+1.
  have /fin_all_exists[pE DpE] (i : 'I_n): exists y, EtoK m y = pK i.
    pose u := KtoE (pK i); have leum0: tag u <= m0 by rewrite (bigmax_sup i).
    by have [y ->] := tagged u; exists (toE _ _ (leqW leum0) y); rewrite toEtoK.
  pose p := 'X^n - rVpoly (\row_i pE i); pose j := code [:: m0; pickle p].
  pose pj := tagged (E_ j) j; pose w : E j.+1 := ext1w (E j) pj.
  have lemj: m <= j by rewrite (allP (ltn_code _)) ?mem_head.
  exists (EtoKM j.+1 w); apply/eqP; rewrite -subr_eq0; apply/eqP.
  transitivity (EtoKM j.+1 (map_poly (toE m j.+1 (leqW lemj)) p).[w]).
    rewrite -horner_map -map_poly_comp toEtoKp EtoK_E; move/EtoKM: w => w.
    rewrite rmorphB [_ 'X^n]map_polyXn !hornerE hornerXn; congr (_ - _ : Kring).
    rewrite (@horner_coef_wide _ n) ?size_map_poly ?size_poly //.
    by apply: eq_bigr => i _; rewrite coef_map coef_rVpoly valK mxE /= DpE.
  suffices Dpj: map_poly (toE m j lemj) p = pj.
    apply/eqP; rewrite EtoKeq0 (eq_map_poly (toEleS _ _ _ _)) map_poly_comp Dpj.
    rewrite -rootE -[pj]minXpE ?ext1root // -Dpj size_map_poly.
    by rewrite size_addl ?size_polyXn ltnS ?size_opp ?size_poly.
  rewrite {w}/pj; elim: {-9}j lemj => // k IHk lemSk.
  move: lemSk (lemSk); rewrite {1}leq_eqVlt ltnS => /predU1P[<- | lemk] lemSk.
    rewrite {k IHk lemSk}(eq_map_poly (toEeq m _)) map_poly_id //= /incEp.
    by rewrite codeK eqxx pickleK.
  rewrite (eq_map_poly (toEleS _ _ _ _)) map_poly_comp {}IHk //= /incEp codeK.
  by rewrite -if_neg neq_ltn lemk.
suffices{Kclosed} algF_K: {FtoK : {rmorphism F -> Kfield} | integralRange FtoK}.
  pose Kdec := DecFieldType Kfield (closed_field_QEMixin Kclosed).
  pose KclosedField := ClosedFieldType Kdec Kclosed.
  by exists [countClosedFieldType of CountType KclosedField cntK].
exists (EtoKM 0%N) => /= z; have [i [{z}z ->]] := KtoE z.
suffices{z} /(_ z)[p mon_p]: integralRange (toE 0%N i isT).
  by rewrite -(fmorph_root (EtoKM i)) -map_poly_comp toEtoKp; exists p.
rewrite /toE /E; clear - minXp_gt1 ext1root ext1gen.
move: (i - 0)%N (subnK _) => n; case: i /.
elim: n => [|n IHn] /= z; first exact: integral_id.
have{z} [q ->] := ext1gen _ _ z; set pn := tagged (E_ _) _.
apply: integral_horner.
  by apply/integral_poly=> i; rewrite coef_map; apply: integral_rmorph.
apply: integral_root (ext1root _ _) _.
  by rewrite map_poly_eq0 -size_poly_gt0 ltnW.
by apply/integral_poly=> i; rewrite coef_map; apply: integral_rmorph.
Qed.


(** This module defines the syntax of terms, values, and types in
Simply RaTT *)

From Coq Require Export Nat.

Definition loc : Set := nat.
Definition index := nat.

(* Types *)
Inductive type : Set :=
(* Standard λ-calculus with sums and products *)
| Unit    : type
| Nat     : type
| TypeVar : index -> type
| Times   : type -> type -> type
| Plus    : type -> type -> type
| Arrow   : type -> type -> type
(* Reactive types *)
| Delay   : type -> type
| Box     : type -> type
(* Temporal recursive types *)
| Mu      : type -> type.

Bind Scope type_scope with type.
Open Scope type_scope.

(* Notation for pretty types *)

(*  Terms  *)
Inductive term :  Type :=
(* λ-calculus with sums and products *)
| var     : index -> term
| unit    : term
| natlit  : nat -> term
| abs     : term -> term
| app     : term -> term -> term
| pair    : term -> term -> term
| pr1     : term -> term
| pr2      : term -> term
| in1     : term -> term
| in2     : term -> term
| case    : term -> term -> term -> term
(* Reactive terms *)
| delay   : term -> term
| adv     : term -> term
| ref     : loc  -> term
| box     : term -> term
| unbox   : term -> term
| progr   : term -> term
| promote : term -> term
(* Temporal recursive terms *)
| out     : term -> term
| into    : term -> term
| fixp    : term -> term.

Inductive isvalue : term -> Prop :=
| value_unit : isvalue unit
| value_nat n : isvalue (natlit n)
| value_ref l : isvalue (ref l)
| value_abs t : isvalue (abs t)
| value_box t : isvalue (box t)
| value_into v : isvalue v -> isvalue (into v)
| value_fixp t : isvalue (fixp t)
| value_pair v1 v2 : isvalue v1 -> isvalue v2 -> isvalue (pair v1 v2)
| value_in1 v: isvalue v -> isvalue (in1 v)
| value_in2 v: isvalue v -> isvalue (in2 v).

Hint Constructors isvalue.