(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)

(*****************************************************************************)
(*  some doc here                                                            *)
(*****************************************************************************)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat seq choice fintype div tuple finfun.
From mathcomp
Require Import bigop finset fingroup perm ssralg poly.
From mathcomp
Require Import polydiv mxpoly binomial bigop ssralg finalg zmodp matrix.
From mathcomp
Require Import mxalgebra polyXY ring_quotient.
From Newtonsums
Require Import auxresults valuation fraction revpoly fracrev polydec.
From Newtonsums
Require Import truncpowerseries expansiblefracpoly.

Import FracField.

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

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope quotient_scope.
Local Open Scope tfps_scope.

Local Notation "x =p y"  := (perm_eq x y) (at level 70, no associativity).

Local Notation "p ^^ f" := (map_frac f p)  (f at next level, at level 30).
Local Notation "p ^^^ f" := (map_frac (map_poly f) p)
                              (f at next level, at level 30).

Section MoreBigop.

Lemma prod_const (R : ringType) (I : Type) (s : seq I) (a : R) :
  \prod_(i <- s) a = a ^+ (size s).
Proof.
rewrite big_const_seq count_predT.
elim: (size s) => [|m ih] //=.
by rewrite ih exprS.
Qed.

Lemma prod_cond_const (R : ringType) (I : Type) (s : seq I) (P : pred I)
  (a : R) : \prod_(i <- s | P i) a = a ^+ (count P s).
Proof. by rewrite -big_filter prod_const size_filter. Qed.

End MoreBigop.

Local Notation "p ^ f" := (map_poly f p) : ring_scope.

Section MorePoly.

Lemma deriv_prod (K : fieldType) (I : eqType) rI (F : I -> {poly K}) :
  (\prod_(i <- rI) (F i)) ^`() = \sum_(i <- rI) (F i) ^`()
  * (\prod_(j <- (rem i rI)) (F j)).
Proof.
elim: rI => [| a l iH]; first by rewrite !big_nil; exact: derivC.
rewrite !big_cons rem_cons derivM iH ; congr (_ + _).
rewrite big_distrr [LHS]/= !big_seq ; apply: eq_big => // i i_in_l.
rewrite mulrA [X in X * _]mulrC -mulrA ; congr (_ * _).
have [a_eq_i | a_neq_i] := boolP (a == i).
  move/eqP : a_eq_i ->.
  by rewrite /= eqxx (eq_big_perm _ (perm_to_rem i_in_l)) big_cons.
move/negbTE : a_neq_i => /= ->.
by rewrite big_cons.
Qed.

Lemma horner_prod_comm (K : fieldType) (s : seq {poly K}) (x : K) :
  (\prod_(q <- s) (q)).[x] = \prod_(q <- s) (q.[x]).
Proof. by rewrite -horner_evalE rmorph_prod. Qed.

End MorePoly.

Section PolynomialFractions.

Variables (K L : fieldType) (iota : {injmorphism K -> L}).

Hint Resolve tofrac_inj.

Fact size_map_iota_p (p : {poly K}) : size (p ^ iota) = size p.
Proof. by rewrite size_map_inj_poly // rmorph0. Qed.

Fact lead_coef_map_iota_p (p : {poly K}) :
  lead_coef (p ^ iota) = iota (lead_coef p).
Proof. by rewrite lead_coef_map_inj // rmorph0. Qed.

Lemma devs_fracpoly_iota (x : {fracpoly K}) :
    (0.-fppole) (x ^^^ iota) = (0.-fppole) x.
Proof. by rewrite -[0](rmorph0 iota); apply: fppole_map. Qed.

End PolynomialFractions.

Import truncpowerseries.Notations.

Section NewtonRepresentation.

Definition newton (K : fieldType) (p : {poly K}) :=
  revp p^`() // revp p.

Lemma newtonC (K : fieldType) (c : K) : newton c%:P = 0.
Proof. by rewrite /newton derivC revp0 rmorph0 mul0r. Qed.

Lemma newton0 (K : fieldType) : newton 0 = 0 :> {fracpoly K}.
Proof. by rewrite newtonC. Qed.

Lemma newton_devs (K : fieldType) (p : {poly K}): devs (newton p).
Proof.
have [-> | p_neq0] := eqVneq p 0; first by rewrite newton0 -unfold_in rpred0.
by apply: (contra (@devs_frac _ _ _)); rewrite coef0_revp lead_coef_eq0.
Qed.

Definition newton_tfps (K : fieldType) (m : nat) (p : {poly K}) :=
  Tfpsfp m (newton p).

Variables (K L : fieldType) (iota : {injmorphism K -> L}).

(* Hint Resolve tofrac_inj. *)

Lemma newton_eq (p q: {poly K}): p %= q -> newton p = newton q.
Proof.
move/eqpP => [ [ a b ] /= /andP [ a_neq0 b_neq0 ] ].
move/(congr1 (fun x => a^-1 *: x)).
rewrite !scalerA mulrC divff // scale1r => ->.
rewrite /newton !derivZ !revpZ -!mul_polyC rmorphM [X in _ / X]rmorphM /=.
rewrite -mulf_div divff ?mul1r // raddf_eq0; last exact: tofrac_inj.
by rewrite polyC_eq0 mulf_neq0 // invr_eq0.
Qed.

Lemma newton_map_poly (p : {poly K}) : newton (p ^ iota) = (newton p) ^^^ iota.
Proof.
by rewrite /newton fmorph_div /= deriv_map !map_fracE !revp_map.
Qed.

Lemma newton_tfps0 (m : nat) : newton_tfps m (0 : {poly K}) = 0.
Proof. by rewrite /newton_tfps newton0 Tfpsfp0. Qed.

Hypothesis char_K_is_zero : [char K] =i pred0.

Hint Resolve char_K_is_zero.

Section Variable_m.
Variable (m : nat).

Lemma geometric_series (K' : fieldType) (a : K') :
  Tfpsfp m (((1 - a *: 'X)%:F) ^-1) = [tfps j => a ^+ j].
Proof.
have dev: devs (1 - a *: 'X)%:F^-1 by apply: devs_inv1subCX.
rewrite Tfpsfp_inv_tofrac; last first.
  by rewrite coefB coefC coefZ coefX mulr0 subr0 oner_neq0.
have Hunit: (Tfpsp m (1 - a *: 'X)) \is a GRing.unit.
  by rewrite Tfpsp_is_unit coefB coefC coefZ coefX mulr0 subr0 oner_neq0.
apply: (mulrI Hunit); rewrite divrr; last first.
  by rewrite Tfpsp_is_unit coefB coefC coefZ coefX mulr0 subr0 oner_neq0.
apply/val_inj=> /=; rewrite modp_mul2.
rewrite mulrBl mul1r /=; apply/polyP=> i.
rewrite coef_modXn !poly_def mulr_sumr /=.
rewrite [X in _ - X](eq_bigr (fun i => a ^+ (nat_of_ord i).+1 *:
                                              'X^(nat_of_ord i).+1)); last first.
  by move=> j _; rewrite -scalerAr -scalerAl scalerA -exprS -exprSr.
rewrite -opprB -sumrB.
rewrite -(big_mkord predT (fun i => a ^+ i.+1 *: 'X^i.+1 - a ^+ i *: 'X^i)) /=.
rewrite telescope_sumr // opprB coefB !coefZ !expr0 mul1r coefXn.
have [|] := ltnP; last by rewrite coefC; case: i.
by rewrite ltn_neqAle => /andP [ /negbTE -> _]; rewrite mulr0 subr0.
Qed.

End Variable_m.

Lemma newton_tfps_map_iota (m : nat) (p : {poly K}) :
    map_tfps iota (newton_tfps m p) = newton_tfps m (p ^ iota).
Proof. by rewrite map_Tfpsfp /newton_tfps newton_map_poly. Qed.

End NewtonRepresentation.

Section Newton.

Variables (K : fieldType) (L : closedFieldType) (f : {injmorphism K -> L}).

Definition iroots (p : {poly K}) := roots (p ^ f).

Fact irootsC c : iroots c%:P = [::].
Proof. by rewrite /iroots map_polyC rootsC. Qed.

Fact iroots0 : iroots 0 = [::]. Proof. by rewrite irootsC. Qed.

Fact factorization (p : {poly K}) : p ^ f =
(f (lead_coef p)) *: \prod_(r <- iroots p) ('X - r%:P).
Proof. by rewrite (roots_factor_theorem_f (p ^ f)) lead_coef_map. Qed.

Fact coef0_iroots (p : {poly K}) : f p`_0 =
  (f (lead_coef p)) * (\prod_(r <- iroots p) -r).
Proof.
rewrite -coef_map_id0 ; last exact: rmorph0.
rewrite factorization -horner_coef0 -horner_evalE linearZ /= rmorph_prod.
congr (_ * _) ; apply: eq_bigr => i _.
by rewrite /= horner_evalE hornerXsubC add0r.
Qed.

Fact irootsP (p : {poly K}) : p != 0 -> iroots p =i root (p ^ f).
Proof. move => p_neq0 x ; by rewrite /iroots rootsP // map_poly_eq0. Qed.

Lemma perm_eq_roots (p q : {poly L}) : p %= q -> (roots p) =p (roots q).
Proof.
move/eqpP => [[a b] /= /andP [a_neq0 b_neq0] H].
move: (@perm_eq_roots_mulC L a p a_neq0) ; rewrite perm_eq_sym => Hp.
apply: (perm_eq_trans Hp).
by rewrite H perm_eq_roots_mulC.
Qed.

Lemma lead_coef_revp (p : {poly K}) : p`_0 != 0 ->
  f (lead_coef (revp p)) =
  (f (lead_coef p)) * (\prod_(r <- iroots p) (-r)).
Proof.
move => H ; rewrite -coef0_iroots.
have -> : lead_coef (revp p) = p`_0 ; last by [].
rewrite lead_coef_revp.
have [->|pN0] := eqVneq p 0; rewrite ?valp0 //.
rewrite -valp_eq0E // in H.
by move/eqP : H ->.
Qed.

Lemma comp_p_q (p : {poly K}) (q : {fracpoly K}) :
  ((p ^ f) %:F) \FPo (q ^^^ f)
  = ((f (lead_coef p))%:FP) * \prod_(r <- iroots p) ((q ^^^ f) - (r%:FP)).
Proof.
have [peq0 | pneq0] := boolP (p == 0).
  by move/eqP: peq0 => ->; rewrite lead_coef0 !rmorph0 comp_fracpoly0 mul0r.
have p_fact := (factorization p).
rewrite p_fact /comp_fracpoly map_fracE /= linearZ_LR rmorph_prod /=.
rewrite fpeval_tofrac hornerZ; congr (_ * _).
rewrite -horner_evalE rmorph_prod; apply: eq_bigr => i _.
rewrite rmorphB /= map_polyX map_polyC horner_evalE.
exact: hornerXsubC.
Qed.

Fact  iroots_size (p : {poly K}) : size (iroots p) = (size p).-1.
Proof. by rewrite /iroots roots_size size_map_iota_p. Qed.

(* should be in revpoly with K a closed field *)
Lemma revp_factorization (p : {poly K}) : ((revp p) ^ f) =
    (f (lead_coef p)) *: (\prod_(r <- iroots p) (1 - r*:'X)).
Proof.
have [p_eq0 | p_neq0] := boolP (p == 0).
  by move/eqP : p_eq0 ->; rewrite revp0 lead_coef0 !rmorph0 scale0r.
apply/eqP; rewrite -(inj_eq (@tofrac_inj _)) -revp_map tofrac_revp.
rewrite size_map_iota_p -(map_fracpolyXV f) comp_p_q /=.
rewrite -mul_polyC rmorphM /= -mulrA ; apply/eqP ; congr (_ * _).
have -> : 'X%:F ^+ (size p).-1 = \prod_(r <- iroots p) 'X%:F => [t|].
  rewrite (big_const_seq 1 (@GRing.mul _) (iroots p) predT 'X%:F).
  have -> : count predT (iroots p) = (size p).-1
    by rewrite count_predT iroots_size.
  exact: Monoid.iteropE.
rewrite -big_split rmorph_prod; apply: eq_big => //= i _.
rewrite mulrBl rmorphD /= map_fracpolyXV mulrC divff; last first.
  by rewrite raddf_eq0 ?polyX_eq0 //; apply: tofrac_inj.
by rewrite rmorphN /= tofrac_scale.
Qed.

Definition mu (x : L) (p : {poly K}) := polyorder.multiplicity x (p ^ f).

(* should be in revpoly with K a closed field *)
Lemma revp_factorization2 (p : {poly K}) : ((revp p) ^ f) =
  (f (lead_coef p)) * (-1)^+((size p).-1 - (mu 0 p))
  * (\prod_(r <- iroots p | r != 0) r)
  *: (\prod_(r <- iroots p | r != 0) ('X - (r ^-1)%:P)).
Proof.
rewrite revp_factorization -mulrA -scalerA.
have [-> | p_neq0] := eqVneq p 0 ; first by rewrite lead_coef0 rmorph0 !scale0r.
congr (_ *: _).
rewrite (bigID (fun r => (r == 0)) predT _) /=.
rewrite (eq_bigr (fun r => 1)) => [|r /eqP ->]; last by rewrite scale0r subr0.
rewrite big1_eq mul1r -scalerA -scaler_prod.
have <- : \prod_(i <- iroots p | i != 0) -(1 : L) =
                                                  (-1) ^+ ((size p).-1 - mu 0 p).
  rewrite prod_cond_const; congr (_ ^+ _).
  rewrite -iroots_size -(count_predC (fun x => x == 0)) addnC.
  have ->: mu 0 p = count (eq_op^~ 0) (iroots p).
    rewrite /mu roots_mu ; last by rewrite map_poly_eq0.
    by apply: eq_in_count.
  rewrite -addnBA // subnn addn0.
  by apply: eq_in_count.
rewrite -scaler_prod ; apply: eq_bigr => r Hr.
by rewrite scalerBr scaleN1r opprB -[r *: (r^-1)%:P]mul_polyC -polyC_mul divff.
Qed.

Fact zero_in_iroots (p : {poly K}) : p != 0 -> (0 \in (iroots p)) = (root p 0).
Proof.
move => p_neq0.
rewrite rootsP ?map_poly_eq0 //.
by rewrite (qualifE 0) -{1}[0](rmorph0 f) horner_map fmorph_eq0.
Qed.

Fact pneq0 (p : {poly K}) : ~~ (root p 0) -> p != 0.
Proof. apply: contra => /eqP -> ; exact: root0. Qed.

(* is there a notation for GRing.inv ? *)
(* revpoly result without iota *)
Lemma roots_revp (p : {poly K}) : ~~ root p 0 ->
  iroots (revp p) =p map (GRing.inv) (iroots p).
Proof.
move => zeroNroot.
have p_neq0 : p != 0 by apply: pneq0.
rewrite {1}/iroots revp_factorization2 roots_mulC ; last first.
  apply: mulf_neq0.
    apply: mulf_neq0 ; first by rewrite fmorph_eq0 lead_coef_eq0.
    apply: expf_neq0.
    by rewrite oppr_eq0 oner_eq0.
  rewrite prodf_seq_neq0.
  apply/allP => x.
  by rewrite implybb.
rewrite (eq_bigl (fun r => r^-1 != 0)) => [ | r] ; last by rewrite /= invr_eq0.
rewrite big_seq_cond (eq_bigl (fun x => x \in iroots p)) ; last first.
  move => x /=.
  apply: andb_idr => Hx.
  rewrite invr_eq0 ; apply/negP => /eqP x_eq0.
  rewrite x_eq0 in Hx.
  move: Hx.
  rewrite zero_in_iroots //.
  by move/negbTE : zeroNroot ->.
rewrite -big_seq -(big_map (fun r => r^-1) predT (fun x => ('X - x%:P))).
exact: perm_eq_roots_factors.
Qed.

(* should be in fraction with K a closed field *)
Lemma deriv_p_over_p (p : {poly K}) : p != 0 ->
((p ^`())%:F / (p%:F)) ^^^ f = \sum_(r <- iroots p) (('X - r%:P)%:F) ^-1.
Proof.
move => pN0; rewrite map_frac_frac /= -deriv_map (factorization _) derivZ.
rewrite -!mul_polyC !rmorphM -mulf_div divff; last first.
  rewrite raddf_eq0; last exact: tofrac_inj.
  by rewrite polyC_eq0 fmorph_eq0 lead_coef_eq0.
rewrite mul1r deriv_prod rmorph_sum big_distrl !big_seq.
apply: eq_big => // i i_in_roots.
rewrite derivXsubC mul1r /= [X in _ / X%:F](big_rem i) i_in_roots //.
rewrite [X in _ / (_ * X)%:F]big_seq_cond.
rewrite (eq_bigl (fun j => j \in rem i (iroots p))) ; last first.
  by move => j; apply: andb_idr; apply: (mem_subseq (rem_subseq _ _)).
rewrite -(big_seq _ _ _ _) rmorphM /= invrM ; last 2 first.
+ rewrite unitfE raddf_eq0; last exact: tofrac_inj.
  by rewrite polyXsubC_eq0.
+ rewrite unitfE raddf_eq0; last exact: tofrac_inj.
  by rewrite monic_neq0 // monic_prod_XsubC.
+ rewrite mulrA divff ?mul1r // raddf_eq0 ;last exact: tofrac_inj.
  by rewrite monic_neq0 // monic_prod_XsubC.
Qed.

Hypothesis char_K_is_zero : [char K] =i pred0.

Lemma newton_roots (p : {poly K}) : (newton p) ^^^ f =
  \sum_(r <- iroots p) (1 - r *: 'X)%:F ^-1.
Proof.
have [p_big|p_small] := ltnP 1 (size p); last first.
  by rewrite [p]size1_polyC // irootsC big_nil newtonC rmorph0.
have p_neq0 : p != 0 by rewrite -size_poly_gt0 (ltn_trans _ p_big).
have pred_sp_gt0 : 0 < (size p).-1 by rewrite -subn1 subn_gt0.
rewrite /newton !tofrac_revp size_deriv // -mulf_div.
have -> : (size p).-1 = (size p).-2.+1 by rewrite prednK.
rewrite -[X in _ * X]invf_div -expfB // subSnn expr1.
rewrite -comp_fracpoly_div ?tofracpolyXV_eq0 //.
rewrite fmorph_div /= fracpoly_iota_comp_fracpoly.
rewrite fmorphV /= !map_fracE /= map_polyX deriv_p_over_p //.
rewrite (@big_morph _ _ (fun x => x \FPo 'X^-1) 0 +%R); first last.
- by rewrite comp_fracpoly0.
- by move=> g h /=; rewrite comp_fracpolyD ?nocomp_fracpolyXV.
rewrite mulr_suml; apply: eq_bigr => i _; rewrite comp_fracpolyV -invfM.
rewrite comp_poly_frac !rmorphB /= map_polyX map_polyC /= hornerXsubC.
by rewrite mulrDl mulVf ?rmorph_eq0 ?polyX_eq0 // mulNr -mul_polyC rmorphM.
Qed.

Definition cadd (p q : {poly K}) :=
  if (p == 0) then (q ^ f) else
  if (q == 0) then (p ^ f) else
  \prod_(r <- [seq s+t | s <- iroots p, t <- iroots q]) ('X - r%:P).

Lemma caddP (p q : {poly K}) : p != 0 -> q != 0 -> cadd p q =
               \prod_(r <- [seq s+t | s <- iroots p, t <- iroots q]) ('X - r%:P).
Proof.
move/negbTE => p_neq0 /negbTE q_neq0.
by rewrite /cadd p_neq0 q_neq0.
Qed.

Lemma cadd0p (p : {poly K}) : cadd 0 p = (p ^ f).
Proof. by rewrite /cadd eqxx. Qed.

Lemma caddp0 (p : {poly K}) : cadd p 0 = (p ^ f).
Proof.
rewrite /cadd.
have [ -> | p_neq0] := eqVneq p 0 ; first by rewrite eqxx.
by rewrite (negbTE p_neq0) eqxx.
Qed.

Lemma cadd_is_prod (p q : {poly K}) :
  p != 0 -> q != 0 -> cadd p q =
  \prod_(r <- [seq s+t | s <- iroots p, t <- iroots q]) ('X - r%:P).
Proof. rewrite /cadd ; by move/negbTE -> ; move/negbTE ->. Qed.

Lemma size_cadd (p q : {poly K}) : p != 0 -> q != 0 ->
  (size (cadd p q)).-1 = (((size p).-1) * ((size q).-1))%N.
Proof.
move => p_neq0 q_neq0.
by rewrite caddP // size_prod_XsubC size_allpairs !iroots_size.
Qed.

Definition cmul (p q : {poly K}) :=
   if (p == 0) || (q == 0) then 0 else
   \prod_(r <- [seq s*t | s <- iroots p, t <- iroots q]) ('X - r%:P).

Lemma cmul0p (p : {poly K}) : cmul 0 p = 0.
Proof. by rewrite /cmul eqxx. Qed.

Lemma cmulp0 (p : {poly K}) : cmul p 0 = 0.
Proof. by rewrite /cmul eqxx orbT. Qed.

Lemma cmul_is_prod (p q : {poly K}) :
  p != 0 -> q != 0 ->  cmul p q =
             \prod_(r <- [seq s*t | s <- iroots p, t <- iroots q]) ('X - r%:P).
Proof. rewrite /cmul ; by move/negbTE -> ; move/negbTE ->. Qed.

Lemma cmul_neq0 (p q : {poly K}) :
  p != 0 -> q != 0 -> cmul p q != 0.
Proof.
move => p_neq0 q_neq0.
rewrite cmul_is_prod // prodf_seq_neq0.
apply/allP => x _.
by rewrite polyXsubC_eq0.
Qed.

Lemma roots_cmul (p q : {poly K}) :
  roots (cmul p q) =p [seq s*t | s <- iroots p, t <- iroots q].
Proof.
have [p_eq0 | p_neq0] := eqVneq p 0.
+ rewrite p_eq0 cmul0p roots0 perm_eq_sym perm_eq_nil.
  by rewrite -size_eq0 size_allpairs iroots0 /= mul0n.
+ have [q_eq0 | q_neq0] := eqVneq q 0.
  rewrite q_eq0 cmulp0 roots0 perm_eq_sym perm_eq_nil.
  by rewrite -size_eq0 size_allpairs iroots0 /= muln0.
rewrite cmul_is_prod //.
exact: perm_eq_roots_factors.
Qed.

Lemma roots_cadd(p q : {poly K}) :
  p != 0 -> q != 0 ->
  roots (cadd p q) =p [seq s+t | s <- iroots p, t <- iroots q].
Proof.
move => p_neq0 q_neq0.
rewrite cadd_is_prod //; exact: perm_eq_roots_factors.
Qed.

Local Notation "f ^ g" := (map_tfps g f).

Lemma iota_newton_tfps (p : {poly K}) (m : nat) :
  newton_tfps m p ^ f = [tfps j => \sum_(r <- iroots p) r ^+ j].
Proof.
rewrite map_Tfpsfp /= newton_roots.
rewrite (big_morph_in (@devsD _) _ (@TfpsfpD _ _) (@Tfpsfp0 _ _)); last 2 first.
- exact: rpred0.
- apply/allP => x /=; move/mapP; rewrite filter_predT; move=> [y hy ->].
  exact: devs_inv1subCX.
apply/eq_tfps => i /=; rewrite coef_poly ltn_ord /=.
rewrite (@big_morph _ _ (fun (x : {tfps L m}) => x`_i) 0 +%R); last 2 first.
- by move => x y; apply: coefD.
- exact: coef0.
by apply: eq_bigr => x _; rewrite geometric_series /= coef_poly ltn_ord.
Qed.

Lemma map_poly_tfps m (s : {tfps K m}) :
  map_poly f (val s) = val (s ^ f).
Proof.
by rewrite /= modp_small // size_polyXn ltnS size_map_poly size_tfps.
Qed.

Lemma newton_tfps_coef0 (p : {poly K}) (m : nat) :
    (newton_tfps m p)`_0 = ((size p).-1)%:R.
Proof.
apply: (@rmorph_inj _ _ f).
rewrite -coef_map map_poly_tfps iota_newton_tfps coef_tfps /=.
rewrite rmorph_nat -iroots_size -sum1_size natr_sum.
by apply: eq_bigr => r; rewrite expr0.
Qed.

End Newton.

Section Conversion.

Variable (K : fieldType) (L : closedFieldType) (f : {injmorphism K -> L}).

Local Notation "f ^ g" := (map_tfps g f).

Hypothesis char_L_is_zero : [char L] =i pred0.

Hint Resolve char_L_is_zero.

Lemma char_K_is_zero : [char K] =i pred0.
Proof. move => x ; by rewrite -(fmorph_char f). Qed.

Hint Resolve char_K_is_zero.

Lemma nth_newton_tfps (p : {poly L}) (m i : nat) :
  (newton_tfps m p)`_i = if i < m.+1 then
  (\sum_(r <- iroots [injmorphism of idfun] p) r ^+i) else 0.
Proof.
have -> : val (newton_tfps m p) =
                            map_tfps [injmorphism of (@idfun L)] (newton_tfps m p).
  by rewrite -map_poly_tfps map_poly_id.
by rewrite iota_newton_tfps //= coef_poly.
Qed.

Lemma iroots_idfun (p : {poly L}) :
  iroots [injmorphism of (@idfun L)] p = roots p.
Proof. by rewrite /iroots map_poly_idfun. Qed.

Lemma iroots_cmul (p q : {poly K}) :
   iroots [injmorphism of @idfun L] (cmul f p q)
                         =p [seq s*t | s <- iroots f p, t <- iroots f q].
Proof. rewrite iroots_idfun; exact: roots_cmul. Qed.

Lemma iroots_cadd (p q : {poly K}) : p != 0 -> q != 0 ->
   iroots [injmorphism of @idfun L] (cadd f p q)
                       =p [seq s + t | s <- iroots f p, t <- iroots f q].
Proof.
move => p_neq0 q_neq0.
rewrite iroots_idfun ; exact: roots_cadd.
Qed.

Lemma eq_big_allpairs (R : Type) (idx : R) (op : Monoid.com_law idx)
  (I : eqType) (r1 r2 : seq I) (F : I -> R) (h : I -> I -> I) :
  \big[op/idx]_(k <- [seq h i j | i <- r1, j <-r2]) F k =
  \big[op/idx]_(i <- r1) (\big[op/idx]_(j <- r2) F (h i j)).
Proof.
elim: r1; first by rewrite big_nil; apply: big_nil.
move => a l iH /=.
by rewrite big_cat iH big_map big_cons.
Qed.

Lemma newton_cmul (p q : {poly K}) :
  let m := ((size p).-1 * (size p).-1)%N in
  newton_tfps m (cmul f p q) =
  (hmul_tfps (newton_tfps m p) (newton_tfps m q)) ^ f.
Proof.
rewrite /=.
set m := ((size p).-1 * (size p).-1)%N.
have [p_eq0 | p_neq0 ] := eqVneq p 0.
  rewrite p_eq0 newton_tfps0 hmul_tfps0r rmorph0 cmul0p.
  exact: newton_tfps0.
have [q_eq0 | q_neq0] := eqVneq q 0.
  rewrite q_eq0 newton_tfps0 hmul_tfpsr0 rmorph0 cmulp0.
  exact: newton_tfps0.
have -> : newton_tfps m (cmul f p q) =
    newton_tfps m (cmul f p q) ^ [rmorphism of (@idfun L)].
  by rewrite (@map_powerseries_idfun _ _).
rewrite (@map_powerseries_idfun _ _) /=.
rewrite map_hmul !iota_newton_tfps //; apply/eq_tfps => i /=.
rewrite !coef_poly ltn_ord.
rewrite (big_distrl _ _ _) /=.
rewrite nth_newton_tfps ltn_ord.
rewrite (eq_big_perm [seq s * t | s <- iroots f p, t <- iroots f q])
                                                                    ; last first.
exact: iroots_cmul.
rewrite /= eq_big_allpairs /=.
apply: eq_bigr => j _ ; rewrite (big_distrr _ _ _) /=.
apply: eq_bigr => k _ ; rewrite exprMn_comm //.
exact: mulrC.
Qed.

Definition expX (K' : fieldType) (m : nat) := exp (Tfpsp m ('X : {poly K'})).

Lemma expX0 (K' : fieldType) : expX K' 0%N = 1.
Proof.
rewrite -exp0; congr exp; apply/eq_tfps => i /=.
by rewrite expr1 modpp.
Qed.

Lemma nth_expX (K' : fieldType) (m i : nat) :
  (expX K' m)`_i = if i < m.+1 then i`!%:R^-1 else 0.
have [->|m_neq0] := eqVneq m O.
  case:i => [|i]; last by rewrite tfps_nth_default.
  by rewrite coef0_exp ?fact0 ?invr1 // coef0_is_0E coef_Tfpsp coefX.
rewrite /expX /exp coef0_is_0E coef_Tfpsp coefX eqxx /= coef_modXn.
rewrite (eq_bigr (fun i => (nat_of_ord i)`!%:R^-1 *:
                                              'X ^+ (nat_of_ord i))); last first.
  by move => j _; rewrite modp_small // size_polyX size_polyXn !ltnS lt0n.
by rewrite -(@poly_def _ _ (fun i => i`!%:R^-1))  coef_poly; case: (_ < _).
Qed.

(* can be generalized to (exp f) ^ iota = exp (f ^ iota) *)
Lemma map_iota_expX (m : nat) : expX K m ^ f = expX L m.
Proof.
rewrite /expX /exp !coef0_is_0E !nth0_Tfpsp !coefX !eqxx -Tfps_map_poly.
rewrite rmorph_sum; congr Tfpsp; apply: eq_bigr => i _.
rewrite linearZ ; congr (_ *: _).
  by rewrite rmorphV ?rmorph_nat // unitfE natmul_inj // -lt0n fact_gt0.
by rewrite rmorphX /= map_modp map_polyX map_polyXn.
Qed.

Lemma hmul_tfps_p_expX (K' : fieldType) (m : nat ) (p : {tfps K' m}) :
  hmul_tfps p (expX K' m) = [tfps i => p`_i / i`!%:R].
Proof.
apply/val_inj => /=.
apply/polyP => i.
rewrite !coef_poly nth_expX.
by case: (i < m.+1).
Qed.

Lemma aux_newton_cadd (K' : fieldType) (g : {rmorphism K' -> L})
  (m : nat) (s t : seq K') (p : {tfps K' m}) : p \in (@coef0_is_0 K' m) ->
  \sum_(w <- [seq u + v | u <- s, v <- t]) (exp (w *: p)) =
  (\sum_(u <- s) (exp (u *: p))) * (\sum_(v <- t) (exp (v *: p))).
Proof.
move => p0_eq0.
have H : [char K'] =i pred0.
  move => x.
  rewrite -(fmorph_char g).
  by move: x. (* strange *)
rewrite eq_big_allpairs /=.
have -> : \sum_(i <- s) \sum_(j <- t) exp ((i + j) *: p) =
   \sum_(i <- s) \sum_(j <- t) (exp (i *: p)) * (exp (j *: p)).
  apply: eq_bigr => i _.
  apply: eq_bigr => j _.
  rewrite scalerDl exp_is_morphism // ; rewrite -mulr_algr mulrC.
  apply: (@idealMr _ _ (prime_idealr_zmod (coef0_is_0_pideal K' m))
                                            (c0_is_0_keyed K' m) i%:A p) => //.
  apply: (@idealMr _ _ (prime_idealr_zmod (coef0_is_0_pideal K' m))
                                            (c0_is_0_keyed K' m) j%:A p) => //.
rewrite exchange_big /= mulr_sumr.
apply: eq_big => // i _.
by  rewrite mulr_suml.
Qed.

Lemma sum_exp_kX (m : nat) (p : {poly L}) :
  hmul_tfps (newton_tfps m.+1 p) (expX L m.+1) =
  \sum_(r <- iroots [injmorphism of @idfun L] p) (exp (r *: (@Tfpsp L m.+1 'X))).
Proof.
have [ -> | p_neq0] := eqVneq p 0.
  by rewrite newton_tfps0 hmul_tfps0r iroots0 big_nil.
rewrite hmul_tfps_p_expX.
apply/val_inj => /=.
rewrite poly_def.
have -> : \sum_(i < m.+2) ((newton_tfps m.+1 p)`_i / i`!%:R) *: 'X^i =
     \sum_(i < m.+2) ((\sum_(r <- iroots [injmorphism of @idfun L] p) r ^+ i)
                                                               / i`!%:R) *: 'X^i.
  apply: eq_bigr => i _; congr (_ *: _); congr (_ / _).
  rewrite nth_newton_tfps ?ltn_ord //.
have -> : \sum_(i < m.+2)
   ((\sum_(r <- iroots [injmorphism of @idfun L] p) r ^+ i) / i`!%:R) *: 'X^i =
\sum_(i < m.+2)
   ((\sum_(r <- iroots [injmorphism of @idfun L] p) ((r *: 'X) ^+ i) / i`!%:R)).
  apply: eq_bigr => i _.
  have -> :
  \sum_(r <- iroots [injmorphism of @idfun L] p) ((r *: 'X) ^+ i) / i`!%:R =
  \sum_(r <- iroots [injmorphism of @idfun L] p) ((r ^+i) *: ('X ^+ i)) / i`!%:R.
    by apply: eq_bigr => j _; rewrite exprZn.
  rewrite /= mulr_suml scaler_suml; apply: eq_bigr => j _.
  rewrite -polyC1 -scaler_nat invrZ ; last 2 first.
      rewrite unitfE; move/(charf0P L) : char_L_is_zero ->.
      by rewrite -lt0n fact_gt0.
  by rewrite polyC1 unitrE divr1.
  by rewrite -scalerAr divr1 scalerA mulrC.
rewrite exchange_big /=.
rewrite (@big_morph _ _ (fun (x : {tfps L m.+1}) => val x) 0 +%R) //=.
apply: eq_big => //= x _.
rewrite exp_coef0_is_0; last first.
  by rewrite coef0_is_0E coef_modXn coefZ nth0_Tfpsp coefX /= mulr0.
rewrite rmorph_sum /=.
rewrite (@big_morph _ _ (fun (x : {tfps L m.+1}) => val x) 0 +%R) //=.
apply: eq_big => //= i _.
rewrite ['X %% _]modp_small ?size_polyX ?size_polyXn //.
rewrite modp_scalel ['X %% _]modp_small ?size_polyX ?size_polyXn //.
rewrite modp_scalel modp_small; last first.
  rewrite size_polyXn exprZn (leq_ltn_trans (size_scale_leq _ _)) //.
  by rewrite size_polyXn ltnS.
by rewrite mulrC -raddfMn polyC_inv mul_polyC.
Qed.

Lemma newton_cadd (p q : {poly K}) :
  p != 0 -> q != 0 ->
  let m := ((size p).-1 * (size p).-1)%N in
  hmul_tfps (newton_tfps m (cadd f p q)) (expX L m) =
  ((hmul_tfps (newton_tfps m p) (expX K m))
                    * (hmul_tfps (newton_tfps m q) (expX K m))) ^ f.
Proof.
move => p_neq0 q_neq0 /=.
set m := ((size p).-1 * (size p).-1)%N.
case: m => [|m].
  rewrite !expX0; apply/val_inj => /=.
  rewrite expr1 map_modp map_polyX rmorphM !poly_def.
  rewrite !big_ord_recr !big_ord0 !Monoid.simpm.
  rewrite !expr0 !coefC eqxx !mulr1.
  rewrite !(newton_tfps_coef0 [injmorphism of (@idfun L)]) //.
  rewrite !(newton_tfps_coef0 f) //=.
  rewrite size_cadd // natrM !linearZ /=.
  rewrite rmorph1 !rmorph_nat mulr_algr scalerA mulrC expr1 modp_mod.
  rewrite modp_small // size_polyX (leq_ltn_trans (size_scale_leq _ _)) //.
  rewrite size_polyC.
  exact: leq_b1.
rewrite rmorphM /= !map_hmul map_iota_expX !newton_tfps_map_iota.
rewrite !sum_exp_kX.
rewrite (eq_big_perm [seq s + t | s <- iroots f p, t <- iroots f q]) /= ;
  last exact: iroots_cadd.
rewrite !iroots_idfun.
apply: (aux_newton_cadd [rmorphism of @idfun L]).
by rewrite coef0_is_0E nth0_Tfpsp coefX [in X in X == _]eq_sym.
Qed.

Fact aux_conversion1 (p : {poly K}) : ~~ (root p 0) ->
   ((revp p)^`() // revp p) ^^^ f  =
  - \sum_(i <- iroots f p) i%:FP * (1 - i *: 'X)%:F^-1.
Proof.
move => zeroNroot.
rewrite deriv_p_over_p; last by rewrite revp_eq0 pneq0.
 rewrite (eq_big_perm [seq x^-1 | x <- iroots f p]) ;
                                                    last by rewrite roots_revp.
rewrite big_map big_seq (eq_bigr (fun r => - (r%:FP * (1 - r *: 'X)%:F^-1)))
                                                     => [ | r Hr] ; last first.
  rewrite -invf_div ; apply: invr_inj ; rewrite !invrK.
  have r_neq0 : r != 0.
    apply/eqP => r_eq0.
    move: Hr; rewrite r_eq0.
    rewrite zero_in_iroots; last by apply: pneq0.
    by apply/negP.
  rewrite invrN invrK -mulNr -tofracN opprB.
  have H : r%:FP != 0.
    rewrite raddf_eq0 //; last first.
    exact: (inj_comp (@tofrac_inj _) (@polyC_inj _)).
  apply: (mulIf H); rewrite mulrAC -mulrA divff // mulr1 /= -tofracM.
  apply/eqP; rewrite inj_eq; last exact: tofrac_inj.
  by rewrite mulrBl mulrC mul_polyC -polyC_mul mulrC divff.
by rewrite sumrN -big_seq.
Qed.

(* to generalize ? *)
Fact aux_conversion2 (m : nat) (p : {poly K}) :
  ~~ (root p 0) ->
  Tfpsfp m (((revp p)^`() // revp p) ^^^ f) =
  - [tfps i => \sum_(r <- iroots f p) r ^+i.+1].
Proof.
move => zeroNroot.
rewrite aux_conversion1 // TfpsfpN; last first.
  rewrite rpred_sum // => x _; apply: devsM.
    by rewrite /devs fpole_tofrac.
    exact: devs_inv1subCX.
congr (- _).
rewrite (big_morph_in (@devsD _) _ (@TfpsfpD _ _) (@Tfpsfp0 _ _)); last 2 first.
- exact: rpred0.
- apply/allP => x /=; move/mapP; rewrite filter_predT; move=> [y hy ->].
  apply: devsM.
    by rewrite /devs fpole_tofrac.
    exact: devs_inv1subCX.
apply/eq_tfps => i /=; rewrite coef_poly ltn_ord.
rewrite (@big_morph _ _ (fun (x : {tfps L m}) => x`_i) 0 +%R); last 2 first.
- by move => x y; apply: coefD.
- exact: coef0.
apply: eq_bigr => x _; rewrite TfpsfpM -?topredE /= ; last 2 first.
- by rewrite /devs fpole_tofrac.
- exact: devs_inv1subCX.
rewrite coef_modXn ltn_ord geometric_series Tfpsfp_tofrac /=.
by rewrite modCXn // mul_polyC coefZ coef_poly ltn_ord -exprS.
Qed.

End Conversion.

Section MoreConversion.

Variables (K : fieldType) (L : closedFieldType) (f : {injmorphism K -> L}).
Variable (m' : nat).
Let m := m'.+1.

Hypothesis char_L_is_zero : [char L] =i pred0.

Hint Resolve char_L_is_zero.
Hint Resolve (char_K_is_zero f char_L_is_zero).

Fact aux_conversion4 (p : {poly K}) : ~~ root p 0 ->
  Tfpsfp m' ((revp p)^`() // revp p)
  = divfX (((size p).-1)%:R%:S - (newton_tfps m p)).
Proof.
move => zeroNroot.
apply: (@map_tfps_injective _ _ m' f).
rewrite map_Tfpsfp aux_conversion2 // (@map_tfps_divfX _ _ f m'.+1).
rewrite divfXE; last first.
  rewrite coef0_is_0E -map_poly_tfps coef_map coefB nth0_Tfpsp //.
  by rewrite (newton_tfps_coef0 f) // coefC /= subrr rmorph0.
apply/eq_tfps => i.
rewrite coefN !coef_poly ltn_ord rmorphB coefB [X in X`_i.+1]/=.
rewrite [X in val X]/=  newton_tfps_map_iota nth_newton_tfps //.
rewrite ltnS ltn_ord map_modp map_polyXn modp_mod modp_small; last first.
  by rewrite size_map_poly size_polyC size_polyXn (leq_ltn_trans (leq_b1 _)).
by rewrite coef_map coefC /= rmorph0 sub0r /iroots map_poly_id.
Qed.

Lemma exp_prim_derivp_over_p (s : {tfps K m}) :
  s \in (@coef0_is_1 K m) ->
  s = exp (prim_tfps ((s^`()%tfps) / (Tfpsp m' s)))%tfps.
Proof.
move => s0_eq1; apply: log_inj => //.
  by rewrite coef0_is_1E coef0_exp // coef0_is_0E coef0_prim_tfps.
rewrite cancel_log_exp // ?coef0_is_0E ?coef0_prim_tfps //.
apply: pw_eq => //; last first.
  by exists 0; rewrite !horner_coef0 coef0_log // coef0_prim_tfps.
by rewrite deriv_log // prim_tfpsK.
Qed.

Definition newton_inv (p : {tfps K m}) : {poly K} :=
  revp (exp (prim_tfps (divfX ((p`_0)%:S - p)))).

Lemma newton_tfpsK (p : {poly K}) :
  size p <= m.+1 ->  ~~ (root p 0) -> p \is monic ->
  newton_inv (newton_tfps m p) = p.
Proof.
move => sp_lt_Sm Nrootp0 p_monic; rewrite /newton_inv.
apply: (canLR_in (@revp_involutive _)).
  by rewrite qualifE -horner_coef0.
have -> : revp p = Tfpsp m (revp p).
  apply: val_inj => /=; rewrite modp_small //= size_polyXn ltnS.
  by rewrite (leq_trans (size_revp_leq _)).
rewrite [Tfpsp _ _ in RHS]exp_prim_derivp_over_p; last first.
  by rewrite coef0_is_1E nth0_Tfpsp coef0_revp -monicE.
congr (exp (prim_tfps _)).
rewrite (newton_tfps_coef0 f) // -aux_conversion4 //=.
rewrite modp_small; last first.
  by rewrite size_polyXn size_revp (leq_ltn_trans (leq_subr _ _)).
rewrite Tfpsfp_frac; last first.
  by rewrite coef0_revp; move/monicP : p_monic ->; apply: oner_neq0.
congr (_ / _).
rewrite deriv_tfpsE /= modp_small // size_polyXn size_revp.
by rewrite (leq_ltn_trans (leq_subr _ _)).
Qed.

End MoreConversion.


Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz. (* mainly for lia *)
Require Import Utf8 List Basics FinFun.
Require Import Coq.Init.Nat.
Import ListNotations.

(*
  Extends the SN proof by Wang and Rompf to richer path expressions.
  This version features intrinsically-scoped syntax.

  Compatible with Coq 8.12.1.

  TODOs
  * equality for types
  * evaluator on intrinsically-scoped syntax
  * logrel and sn proofs
  * add and fix the self-references in the recursive types
*)

(* ### Syntax ### *)

Inductive Fin : nat -> Set :=
| FZ : forall {n}, Fin (S n)
| FS : forall {n}, Fin n -> Fin (S n)
.

Notation var := Fin.

Check ((fun (x : Fin 2) => x)  (FS FZ)).
Check ((fun (x : Fin 2) => x)  FZ).
Fail Check ((fun (x : Fin 2) => x)  (FS (FS FZ))).

Fixpoint var0 {n : nat} : var (S n) :=
  match n with
  | O => FZ O
  | S m => FS (S m) (@var0 m)
  end.

Inductive ty : nat -> Type :=
| TTop  : forall {n}, ty n
| TBot  : forall {n}, ty n
| TAll  : forall {n}, ty n -> ty (S n) -> ty n
| TSel  : forall {n}, tm n -> ty n
| TMem  : forall {n}, ty n -> ty n -> ty n
(* | TBind : forall {n}, ty (S n)  -> ty n *)
| TAnd  : forall {n}, ty n -> ty n -> ty n
with tm : nat -> Type :=
| tvar    : forall {n}, var n -> tm n
| ttyp    : forall {n}, ty n -> tm n
| tabs    : forall {n}, ty n -> tm (S n) -> tm n
| tapp    : forall {n}, tm n -> tm n -> tm n
(* | tunpack : forall {n}, tm n -> tm (S n) -> tm n *)
.

Inductive vec (T : nat -> Type) : nat -> Type :=
| vnil  : vec T 0
| vcons : forall{n}, vec T n -> T n -> vec T (S n)
.

Notation "∅" := vnil (at level 74).
Notation "G ;; T" := (@vcons _ _ G T) (at level 75).

(* TODO: better use the vector library from the stdlib *)
Variable lookup : forall {T : nat -> Type} {n : nat} (Γ : vec T n) (i : var n), T n.

Definition tenv := vec ty.

Definition Ren (n m : nat) : Type := var n -> var m.
Transparent Ren.

(* TODO is there any nicer way to define this? *)
Definition lift {n m : nat} (ρ : Ren n m) : Ren (S n) (S m).
  refine (fun v => _).
  inversion v as [ k | k v' ].
  apply (FZ m).
  apply (FS m (ρ v')).
Defined.

Fixpoint ren_ty {n m} (ρ : Ren n m) (T : ty n): ty m :=
  match T in ty n , ρ with
  | TTop       , ρ => TTop
  | TBot       , ρ => TBot
  | TAll  T1 T2, ρ => TAll  (ren_ty ρ T1) (ren_ty (lift ρ) T2)
  | TSel  t    , ρ => TSel  (ren_tm ρ t)
  | TMem  T1 T2, ρ => TMem  (ren_ty ρ T1) (ren_ty ρ T2)
  (* | TBind T    , ρ => TBind (ren_ty (lift ρ) T) *)
  | TAnd  T1 T2, ρ => TAnd  (ren_ty ρ T1) (ren_ty ρ T2)
  end
with ren_tm {n m} (ρ : Ren n m) (t : tm n) : tm m :=
  match t in tm n, ρ  with
  | tvar    x    , ρ => tvar    (ρ x)
  | ttyp    T    , ρ => ttyp    (ren_ty ρ T)
  | tabs    T  t , ρ => tabs    (ren_ty ρ T)  (ren_tm (lift ρ) t)
  | tapp    t1 t2, ρ => tapp    (ren_tm ρ t1) (ren_tm ρ t2)
  (* | tunpack t1 t2, ρ => tunpack (ren_tm ρ t1) (ren_tm (lift ρ) t2) *)
  end.

Definition weaken_tm {n} (t : tm n): tm (S n) := ren_tm (FS n) t.
Definition weaken_ty {n} (T : ty n): ty (S n) := ren_ty (FS n) T.

Definition Sub (n m : nat) : Type := var n -> tm m.

(* FIXME: why does this version fail? *)
(* Definition lifts (n m : nat) (σ : Sub n m) : Sub (S n) (S m) := *)
(*   fun v => *)
(*     match v in var (S n), σ return tm (S m) with *)
(*     | FZ n , σ => tvar (FZ m) *)
(*     | FS n v' , σ => weaken_tm (σ v') *)
(*     end. *)

Definition lifts {n m } (σ : Sub n m) : Sub (S n) (S m).
  refine (fun v => _).
  inversion v as [ k | k v' ].
  apply (tvar (FZ m)).
  apply (weaken_tm (σ v')).
Defined.

(* FIXME: same problems here *)
(* Definition extend {n m} (σ : Sub n m) (t : tm m) : Sub (S n) m := *)
(*   fun v => *)
(*     match v in var (S n), σ , t return tm m with *)
(*     | FZ n    , σ , t => t *)
(*     | FS n v' , σ , t => σ v' *)
(*     end. *)

Definition extend {n m} (σ : Sub n m) (t : tm m) : Sub (S n) m.
  refine (fun v => _).
  inversion v as [ k | k v' ].
  apply t.
  apply (σ v').
Defined.

Fixpoint sub_tm {n m} (σ : Sub n m) (t : tm n) : tm m :=
  match t in tm n, σ  with
  | tvar    x    , σ => (σ x)
  | ttyp    T    , σ => ttyp    (sub_tm_ty σ T)
  | tabs    T  t , σ => tabs    (sub_tm_ty σ T) (sub_tm (lifts σ) t)
  | tapp    t1 t2, σ => tapp    (sub_tm σ t1)   (sub_tm σ t2)
  (* | tunpack t1 t2, σ => tunpack (sub_tm σ t1)   (sub_tm (lifts σ) t2) *)
  end
with
sub_tm_ty {n m} (σ : Sub n m) (T : ty n) : ty m :=
  match T in ty n , σ with
  | TTop       , σ => TTop
  | TBot       , σ => TBot
  | TAll  T1 T2, σ => TAll  (sub_tm_ty σ T1) (sub_tm_ty (lifts σ) T2)
  | TSel  t    , σ => TSel  (sub_tm σ t)
  | TMem  T1 T2, σ => TMem  (sub_tm_ty σ T1) (sub_tm_ty σ T2)
  (* | TBind T    , σ => TBind (sub_tm_ty (lifts σ) T) *)
  | TAnd  T1 T2, σ => TAnd  (sub_tm_ty σ T1) (sub_tm_ty σ T2)
  end.

Definition sub1_tm    {n} (this : tm n) (there : tm (S n)) : tm n := sub_tm    (extend tvar this) there.
Definition sub1_tm_ty {n} (this : tm n) (there : ty (S n)) : ty n := sub_tm_ty (extend tvar this) there.

Notation "t1 <~ t2"  := (sub1_tm t2 t1) (at level 75).
Notation "t1 <*~ t2" := (sub1_tm_ty t2 t1) (at level 75).

(* valid expressions that may appear in type selections *)
Inductive wf_tsel : forall {n : nat}, tm n -> Prop :=
| wf_tsel_var : forall {n} (x : var n), wf_tsel (tvar x)
(* | wf_tsel_typ : forall {n} (T : ty n), wf_tsel (ttyp T) (*FIXME: should we also check that T is well-formed? *) *)
(* | wf_tsel_app : forall {n} (t1 t2 : tm n), wf_tsel t1 -> wf_tsel t2 -> wf_tsel (tapp t1 t2) *)
(* | wf_tsel_lam : forall {n} (T : ty n) (t : tm (S n)), wf_tsel t -> wf_tsel (tabs T t) (*FIXME: should we also check that T is well-formed? *) *)
.

Inductive has_type : forall {n : nat}, tenv n -> tm n -> ty n -> Prop :=
| t_var : forall {n} (Γ : tenv n) (x : var n),
    has_type Γ (tvar x) (lookup Γ x)

| t_typ : forall {n} (Γ : tenv n) (T : ty n),
    has_type Γ (ttyp T) (TMem T T)

| t_abs : forall {n} (Γ : tenv n) (t : tm (S n)) (T1 : ty n) (T2 : ty (S n)),
    has_type (Γ ;; T1) t T2 ->
    has_type Γ (tabs T1 t) (TAll T1 T2)

| t_app : forall {n} (Γ : tenv n) (t1 t2 : tm n) (T1 T2 : ty n),
    has_type Γ t1 (TAll T1 (weaken_ty T2)) ->
    has_type Γ t2 T1 ->
    has_type Γ (tapp t1 t2) T2

| t_dapp : forall {n} (Γ : tenv n) (t1 t2 : tm n) (T1: ty n) (T2 : ty (S n)),
    has_type Γ t1 (TAll T1 T2) ->
    has_type Γ t2 T1 ->
    wf_tsel t2 ->
    has_type Γ (tapp t1 t2) (T2 <*~ t2)

| t_and : forall {n} (Γ : tenv n) (x : var n) (T1 T2 : ty n),
    has_type Γ (tvar x) T1 ->
    has_type Γ (tvar x) T2 ->
    has_type Γ (tvar x) (TAnd T1 T2)

(* | t_var_pack : forall {n} (Γ : tenv n) (x : var n) (T : ty (S n)), *)
(*     has_type Γ (tvar x) (T <*~ (tvar x)) -> (* FIXME: how to express self-reference in the intrinsically-scoped style? *) *)
(*     has_type Γ (tvar x) (TBind T) *)

(* FIXME: how to express self-reference in the intrinsically-scoped style? have second sort of variable? *)
(* | t_unpack : forall {n} (Γ : tenv n) (t1 : tm n) (t2 : tm (S n)) (T1: ty (S n)) (T2 : ty n), *)
(*     has_type Γ t1 (TBind T1) -> *)

(*     has_type (Γ ;; (subst_tm_ty (tvar var0 n) T1)) (weaken_ty T2) -> *)
(*     has_type Γ (tunpack t1 t2) T2 *)

| t_sub: forall {n} (Γ : tenv n) (t : tm n) (T1 T2 : ty n),
      has_type Γ t T1 ->
      stp Γ T1 T2 ->
      has_type Γ t T2

with stp : forall {n : nat}, tenv n -> ty n -> ty n -> Prop :=
| stp_top : forall {n} (Γ : tenv n) (T : ty n),
      stp Γ T TTop

| stp_bot : forall {n} (Γ : tenv n) (T : ty n),
      stp Γ T TBot

| stp_mem : forall {n} (Γ : tenv n) (S1 T1 S2 T2 : ty n),
    stp Γ S2 S1 ->
    stp Γ T1 T2 ->
    stp Γ (TMem S1 T1) (TMem S2 T2)

| stp_sel1 : forall {n} (Γ : tenv n) (t : tm n) (T : ty n),
    has_type Γ t (TMem T TTop) ->
    wf_tsel t ->
    stp Γ T (TSel t)

| stp_sel2 : forall {n} (Γ : tenv n) (t : tm n) (T : ty n),
    has_type Γ t (TMem TBot T) ->
    wf_tsel t ->
    stp Γ (TSel t) T

| stp_selx : forall {n} (Γ : tenv n) (t : tm n) (T1 T2 : ty n),
    has_type Γ t (TMem T1 T2) ->
    wf_tsel t ->
    stp Γ (TSel t) (TSel t)

| stp_all : forall {n} (Γ : tenv n) (S1 S2 : ty n) (T1 T2 : ty (S n)),
    stp Γ S2 S1 ->
    stp (Γ ;; S2) T1 T2 ->
    stp Γ (TAll S1 T1) (TAll S2 T2)

(* FIXME: how to express self-reference in the intrinsically-scoped style? have second sort of variable? *)
(* | stp_bindx: forall Γ T1 T1' T2 T2', *)
(*     stp (T1' :: Γ) T1' T2' -> *)
(*     T1' = (open' Γ T1) -> *)
(*     T2' = (open' Γ T2) -> *)
(*     ty_wf Γ (TBind T1) -> *)
(*     ty_wf Γ (TBind T2) -> *)
(*     stp Γ (TBind T1) (TBind T2) *)

| stp_and11: forall {n} (Γ : tenv n) (T T1 T2 : ty n),
    stp Γ T1 T ->
    stp Γ (TAnd T1 T2) T

| stp_and12: forall {n} (Γ : tenv n) (T T1 T2 : ty n),
    stp Γ T2 T ->
    stp Γ (TAnd T1 T2) T

| stp_and2: forall {n} (Γ : tenv n) (T T1 T2 : ty n),
    stp Γ T T1 ->
    stp Γ T T2 ->
    stp Γ T (TAnd T1 T2)

| stp_trans :  forall {n} (Γ : tenv n) (S T U : ty n),
    stp Γ S T ->
    stp Γ T U ->
    stp Γ S U
.

(* TODO type equality! *)

Lemma lift_id : forall {n} {v : var (S n)}, lift id v = v.
Proof.
  intros. dependent destruction v; eauto.
Qed.

Open Scope program_scope.
Lemma lift_comp : forall {n m k} {ρ : Ren n m} {ρ' : Ren m k} {v : var (S n)}, lift (ρ' ∘ ρ) v = lift ρ' (lift ρ v).
Proof.
  intros. dependent destruction v; eauto.
Qed.

(* Lemma substitution : forall {n} {Γ : tenv n} {T1 : ty n} {T2 : ty (S n)}  {t : tm (S n)}, *)
(*     has_type (Γ ;; T1) t T2 -> forall {t' : tm n}, has_type Γ t' T1 -> has_type Γ (t <~ t') (T2 <*~ t'). *)
(* Proof. *)
(*   intros n Γ T1 T2 t Hty. *)
(*   dependent induction Hty; intros. *)
(*   - admit. *)
(*   - unfold sub1_tm. unfold sub1_tm_ty. simpl. constructor. *)
(*   - unfold sub1_tm in *. unfold sub1_tm_ty in *. simpl. constructor. *)
(*     admit. *)
(*   - unfold sub1_tm. unfold sub1_tm_ty. *)

Inductive env (T : Type) : nat -> Type :=
| enil  : env T 0
| econs : forall{n}, env T n -> T -> env T (S n)
.
Arguments econs {T n}.
Arguments enil {T}.

Inductive vl : Type :=
| vabs : forall {n : nat}, env vl n -> tm (S n) -> vl
| vty :  forall {n : nat}, env vl n -> ty n -> vl
.

Definition venv := env vl.

Variable get : forall { T : Type } {n : nat}, env T n -> var n -> T.

Inductive Result : Type :=
| Done   : vl -> Result
| Error  : Result
| NoFuel : Result
.

Fixpoint eval{m : nat}(fuel : nat)(γ : venv m)(t : tm m){struct fuel}: Result :=
  match fuel with
  | 0   => NoFuel
  | S n =>
    match t, γ with
    | tvar x, γ => Done (get γ x)
    | ttyp T, γ    => Done (vty γ T)
    | tabs T t, γ  => Done (vabs γ t)
    | tapp t1 t2, γ =>
      match eval n γ t2 with
      | Done v2 =>
        match eval n γ t1 with
        | Done (vabs γ' t) => eval n (econs γ' v2) t
        | Done _  => Error
        | err => err
        end
      | err => err
      end
    (* | tunpack t1 t2 => *)
    (*   match eval n γ t1 with *)
    (*   | Done v1 => eval n (v1 :: γ) t2 *)
    (*   | err => err *)
    (*   end *)
    end
  end.

Fixpoint vset (n : nat): Type := match n with
                               | 0 => vl -> Prop
                               | S n => vset n -> vl -> Prop
                               end.

Definition vseta  := forall n, vset n.

Notation Dom := vseta.

Definition denv := env Dom.

(* vseta membership *)
Definition vseta_mem (v:vl) (vs1: vseta) (vs2: vseta): Prop :=
  forall n, vs2 (S n) (vs1 n) v.
Notation "⦑ x , y ⦒ ⋵ vs" := (vseta_mem x y vs) (at level 79).

Definition elem2 {A B} (γ : A) (v : B) (P : A -> B -> Prop) := P γ v.
Notation "⟨ H , v ⟩ ∈ D" := (elem2 H v D) (at level 75).
Hint Unfold elem2 : dsub.

(* Subset relation for use in comprehensions with explicit index parameter *)
Definition vset_sub_eq {n:nat}: vset n -> vset n -> Prop :=
  match n with
       | 0 => fun vs1 vs2 => True
       | S n => fun vs1 vs2 => forall vs' v, (vs1 vs' v) -> (vs2 vs' v)
       end.

(* Subset relation closing over all n, for use in the vesta lattice, e.g., monotonicity check*)
Definition vseta_sub_eq (vs1: vseta) (vs2: vseta) :=
  forall n, vset_sub_eq (vs1 n) (vs2 n).

Hint Unfold vset_sub_eq : dsub.
Hint Unfold vseta_sub_eq : dsub.

(* \sqsubseteq *)
Notation "vs1 ⊑# vs2" := (vset_sub_eq vs1 vs2) (at level 75).
Notation "vs1 ⊑  vs2" := (vseta_sub_eq vs1 vs2) (at level 75).

(* vseta comprehension exposing the index in the body *)
Notation "{{ ' p vs n | P }}" := (fun k =>
                                   match k with
                                   | 0   => fun _ => True
                                   | S n => fun (vs : vset n) (v : vl) =>
                                              match v with
                                              | p => P
                                              | _ => False
                                              end
                                   end)
                              (at level 0, p pattern, vs ident, n ident ).

Notation "{{ v vs n | P }}" := (fun k =>
                                   match k with
                                   | 0   => fun _ => True
                                   | S n => fun (vs : vset n) (v : vl) => P
                                   end)
                              (at level 0, v ident, vs ident, n ident ).

(* The domain vseta is a complete lattice, which we require for least and greatest fixpoints of types. *)
Definition vseta_top: vseta := {{ v vs n | True }}.

Definition vseta_bot: vseta := {{ v vs n | False }}.

Definition vseta_join (vs1: vseta) (vs2: vseta): vseta := {{ v vs n | (vs1 (S n) vs v) \/ (vs2 (S n) vs v) }}.
(* \sqcup *)
Notation "vs1 ⊔ vs2" := (vseta_join vs1 vs2) (at level 70, right associativity).

Definition vseta_meet (vs1: vseta) (vs2: vseta): vseta := {{ v vs n | (vs1 (S n) vs v) /\ (vs2 (S n) vs v) }}.
(* \sqcap *)
Notation "vs1 ⊓ vs2" := (vseta_meet vs1 vs2) (at level 65, right associativity).

Lemma subset_refl : forall X, X ⊑ X.
Proof.
  intros. unfold vseta_sub_eq. unfold vset_sub_eq. intros.
  induction n; eauto.
Qed.
Hint Resolve subset_refl : dsub.

Lemma subset_trans : forall {X Y Z}, X ⊑ Y -> Y ⊑ Z -> X ⊑ Z.
Proof.
  intros. unfold vseta_sub_eq in *. induction n.
  - specialize (H 0). specialize (H0 0). simpl. eauto.
  - simpl. intros. specialize (H (S n)). specialize (H0 (S n)).
    eauto.
Qed.

Lemma subset'_refl : forall {n} {X : vset n}, X ⊑# X.
Proof.
  intros. unfold vset_sub_eq.
  induction n; eauto.
Qed.
Hint Resolve subset'_refl : dsub.

Lemma subset'_trans : forall {n} {X Y Z : vset n}, X ⊑# Y -> Y ⊑# Z -> X ⊑# Z.
Proof.
  intros. unfold vset_sub_eq in *. induction n; eauto.
Qed.

Definition ℰ {m : nat} (D : Dom) (γ : venv m) (t : tm m) : Prop :=
  exists k v, eval k γ t = Done v /\ exists vs, ⦑ v, vs ⦒ ⋵ D.

Fixpoint val_type {m : nat} (T : ty m) (ρ : denv m) : Dom :=
  match T , ρ with
  | TTop, _          => vseta_top
  | TAll T1 T2, ρ    =>
     {{ '(vabs γ t) D n | forall vx Dx, ⦑ vx, Dx ⦒ ⋵ (val_type T1 ρ) ->
                                  ⟨ (econs γ vx) , t  ⟩ ∈ ℰ (val_type T2 (econs ρ Dx))  }}
  | TSel (tvar x), ρ => get ρ x
  | TMem T1 T2, ρ    =>
    {{ '(vty γ T) D n | (val_type T1 ρ n) ⊑# D /\ D ⊑# (val_type T2 ρ n) }}
  | TAnd T1 T2 , ρ   => (val_type T1 ρ) ⊓ (val_type T2 ρ)
  | _ , _            => vseta_bot (* we only have this case because we allow arbitrary t in TSel *)
  end.

Inductive 𝒞𝓉𝓍 : forall {n : nat}, (tenv n) -> (denv n) -> (venv n) -> Prop :=
| 𝒞𝓉𝓍_nil :
    𝒞𝓉𝓍 (vnil ty) enil enil
| 𝒞𝓉𝓍_cons : forall {n : nat } {Γ : tenv n} {ρ : denv n} { γ : venv n } {T : ty n} {v D},
    𝒞𝓉𝓍 Γ ρ γ  ->
    ⦑ v, D ⦒ ⋵ (val_type T ρ) ->
    𝒞𝓉𝓍 (Γ ;; T) (econs ρ D) (econs γ v)
.

Lemma fundamental     : (forall {n : nat} {Γ : tenv n} {t : tm n} {T : ty n}, has_type Γ t T -> forall{ρ : denv n} {γ : venv n}, 𝒞𝓉𝓍 Γ ρ γ -> ⟨ γ , t ⟩ ∈ ℰ (val_type T ρ))
with  fundamental_stp : (forall {n : nat} {Γ : tenv n} {S T : ty n}, stp Γ S T -> forall{ρ : denv n} {γ : venv n}, 𝒞𝓉𝓍 Γ ρ γ -> (val_type S ρ) ⊑ (val_type T ρ)).
Proof.
  - clear fundamental. intros m Γ t T Hty. dependent induction Hty; intros ρ γ HΓργ; unfold ℰ in *; unfold elem2 in *.
    + (* t_var *)
      exists 1. exists (get γ x). intuition. exists (get ρ x). admit. (* TODO this is exactly a reasonable lookup lemma *)
    + (* t_typ *)
      exists 1. exists (vty γ T). intuition. exists (val_type T ρ). unfold vseta_mem.
      intros m. simpl. split; apply subset'_refl.
    + (* t_abs *)
      exists 1. exists (vabs γ t). intuition. exists vseta_top. unfold vseta_mem.
      intros m. simpl. intros.
      assert (Hext: 𝒞𝓉𝓍 (Γ;; T1) (econs ρ Dx) (econs γ vx)) by (constructor; eauto).
      apply IHHty in Hext. destruct Hext as [k [vy [Heval [vsy vyvsyT2 ]]]].
      unfold elem2. unfold ℰ. exists k. exists vy. intuition. exists vsy. auto.
    + (* t_app *)
      specialize (IHHty1 _ _ HΓργ). specialize (IHHty2 _ _ HΓργ).
      destruct IHHty1 as [k1 [v1 [evalv1 [vs1 v1vs1inVtyT1T2 ]]]].
      destruct IHHty2 as [k2 [v2 [evalv2 [vs2 v2vs2inVtyT1]]]].
      specialize (v1vs1inVtyT1T2 0). simpl in v1vs1inVtyT1T2.
      destruct v1 as [ i γ' t' | i γ' T' ]; intuition.
      apply v1vs1inVtyT1T2 in v2vs2inVtyT1. unfold elem2 in *. unfold ℰ in *.
      destruct v2vs2inVtyT1 as [k3 [v3 [evalapp [vs3 v3vs3inVtyT2] ]]].
      exists (k1 + k2 + k3). exists v3. split. admit. (* TODO: need to show monotonicity of eval *)
      exists vs3. admit. (* that should be a relatively easy lemma *)
    + (* t_dapp *)
      specialize (IHHty1 _ _ HΓργ). specialize (IHHty2 _ _ HΓργ).
      destruct IHHty1 as [k1 [v1 [evalv1 [vs1 v1vs1inVtyT1T2 ]]]].
      destruct IHHty2 as [k2 [v2 [evalv2 [vs2 v2vs2inVtyT1]]]].
      specialize (v1vs1inVtyT1T2 0). simpl in v1vs1inVtyT1T2.
      destruct v1 as [ i γ' t' | i γ' T' ]; intuition.
      apply v1vs1inVtyT1T2 in v2vs2inVtyT1. unfold elem2 in *. unfold ℰ in *.
      destruct v2vs2inVtyT1 as [k3 [v3 [evalapp [vs3 v3vs3inVtyT2] ]]].
      exists (k1 + k2 + k3). exists v3. split. admit. (* TODO: need to show monotonicity of eval *)
      exists vs3. (* TODO: this one is trickier, maybe first do the original system with single variables in selections? *)
Admitted.


From mathcomp Require Import ssreflect ssrfun seq ssrnat ssrbool eqtype.
From mf Require Import all_mf choice_mf.
Require Import all_cont classical_count classical_cont FMop Umach Ucont Uuniv.
Require Import ClassicalChoice FunctionalExtensionality.

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

Section classical_machines.
  Context (Q Q' A A': Type).
  Notation B := (Q -> A).
  Notation B' := (Q' -> A').
  Local Open Scope baire_scope.

  Lemma mach_choice M (phi: B):
	(forall (q': Q'), exists (a': A') n, M n phi q' = Some a') -> phi \from dom \F_M.
  Proof. by move => Rtot; have [Fphi FphiFphi]:= choice _ Rtot; exists Fphi. Qed.

  Lemma sing_cmpt_elt M F c (phi: B) (Fphi: B') q' a': M \evaluates_to F -> F \is_singlevalued ->
    F phi Fphi -> M c phi q' = Some a' -> a' = Fphi q'.
  Proof.
    move => comp sing FphiFphi ev.
    have [ | [Mphi MphiFphi] prop]:= (comp phi _); first by exists Fphi.
    have eq: Mphi = Fphi by rewrite -(sing phi Fphi Mphi); last apply prop.
    move: Mphi eq MphiFphi => _ -> MphiFphi.
    pose Nphi := (fun q a => (q <> q' /\ Fphi q = a) \/ (q' = q /\ a' = a)).
    have [q | Mphi Mphiprop]:= choice Nphi.
    - by case: (classic (q = q')) => ass; [exists a'; right | exists (Fphi q); left].
    have MphiMphi: (\F_M) phi Mphi => [q | ].
    - by case: (Mphiprop q) => [[_ <-] | [<- <-]]; [ | exists c].
    apply Some_inj; case: (Mphiprop q') => [[ctr] | [_ ->]] //.
    by have <-: Mphi = Fphi by apply/ sing; apply prop.
  Qed.

  Lemma FM_dom_spec (psi: seq A * Q' -> seq Q + A') (phi: B):
    phi \from dom \F_(U psi) <-> (communication psi phi) \is_total.
  Proof.
    split => [[Fphi /FU_spec FphiFphi] q' | tot].
    - by have [Ln prp]:= FphiFphi q'; exists (Ln, (Fphi q')).
    have [LnFphi prp]:= choice _ tot.
    exists (fun q' => (LnFphi q').2); rewrite FU_spec => q'.
    by exists (LnFphi q').1; exact/(prp q').
  Qed.

  Lemma exists_listf (somea: A) (cnt: nat -> Q) (F: B ->> B'): cnt \is_surjective ->
     exists listf, forall phi n, phi \from dom F ->
	listf (map phi (iseg cnt n)) \from dom F /\
	(listf (map phi (iseg cnt n))) \and phi \coincide_on (iseg cnt n).
  Proof.
    move => sur; have [sec min]:= exists_minsec sur.
    pose R := make_mf (fun L psiL =>
      (exists phi, phi \from dom F /\ map phi (iseg cnt (size L)) = L) ->
      (psiL \from dom F /\ map psiL (iseg cnt (size L)) = L)).
    have Rtot: R \is_total.
    move => L.
    case: (classic (exists phi, phi \from dom F /\
       (map phi (iseg cnt (size L)) = L))) => [[psil [fd eq]] | neg]; first by exists psil.
    - by exists (fun _ => somea) => cntr; exfalso; apply neg.
    have [listf listfprp]:= choice _ Rtot.
    exists listf => phi n phifd.
    have [ | fd eq]:= listfprp (map phi (iseg cnt n)).
    - by exists phi; split => //; rewrite !size_map !size_iseg.
    move: eq; rewrite size_map size_iseg; split => //; move: fd => _.
    rewrite coin_lstn => q lstn.
    have [m [ineq <-]]:= iseg_ex lstn.
    have: nth (phi (cnt 0)) ([seq listf [seq phi i | i <- iseg cnt n] i | i <- iseg cnt n]) (n - m).-1 =
	  nth (phi (cnt 0)) ([seq phi i | i <- iseg cnt n]) (n - m).-1.
      by rewrite eq.
    rewrite !(nth_map (cnt 0));
     try by case: (n) ineq =>// n' ineq; rewrite size_iseg subSn //=; have: n' - m <= n' by rewrite leq_subr.
    rewrite nth_iseg; suff ->: (n - (n - m).-1).-1 = m by trivial.
    case: n eq ineq lstn => //n eq ineq lstn.
    by rewrite !subSn //; [ rewrite subKn | rewrite leq_subr].
  Qed.

  Lemma U_universal (someq: Q) (somea : A) (somephi': B') (F: B ->> B'):
    Q \is_countable -> F \is_continuous -> exists psiF, (U psiF) \evaluates_to F.
  Proof.
    have [eqQ' _]:= classic_eqClass Q'.
    set Q'eqType:= EqType Q' eqQ'.
    move => [_ [/pfun_spec [pcnt <-] /PF2MF_cotot psur]] cont.
    have [ | | cnt sur]:= (@count_fun Q pcnt); first apply/inhabits/someq; first exact/psur.
    have [Ff Fprop] := exists_choice (F: _ ->>(Q'eqType -> _)) somephi'.
    have [sec ms] := exists_minsec sur.
    have [mf mfmod]:= exists_minmod ms (cont: (F: _ ->> (Q'eqType -> _)) \is_continuous).
    have [listf listfprop] := exists_listf somea (F: _ ->> (Q'eqType -> _)) sur.
    exists (psiF cnt listf mf Ff).
    rewrite mon_eval; last exact/cont_sing; last exact/U_mon.
    move => phi Fphi FphiFphi.
    have phifd: phi \from dom F by exists Fphi.
    apply/(MpsiF_spec phifd) => //; try by move => n; have []:= listfprop phi n phifd.
    - move => q' n ineq.
      have [a' crt]:= mod_minmod ms (mfmod phi phifd) q'.
      rewrite [mf phi q'](crt phi) //.
      have -> //:= crt (listf (map phi (iseg cnt n))) _ (mf (listf (map phi (iseg cnt n)))).
      + have [_ coin]:= listfprop phi n phifd.
        by apply/coin_sym/coin_subl/coin/iseg_subl.
      by apply/mfmod; have []:= listfprop phi n phifd.
    exact/coin_ref.
    exact/mfmod.
    by move => psi psifd; have [mod min]:= mfmod psi psifd.
  Qed.

  Lemma FqM_dom (psi: seq A * Q' -> seq Q + A'):
    dom (\F_(U psi)) === dom (\F_(queriesM psi)).
  Proof.
    apply/split_set_eq => [phi [Fphi val] | phi [mf /FqM_spec val]].
    - suff ch: (forall q', exists L, exists n, queriesM psi n phi q' = Some L) by apply/(choice _ ch).
      move => q'; have [n eq]:= val q'.
      exists (gather_queries psi n phi q').
      exists n; move: eq; rewrite /U/queriesM.
      by case: (U_rec psi n phi q').
    rewrite FM_dom_spec => q'.
    have [Qn [a' [com _]]]:= val q'.
    by exists (Qn, a').
  Qed.

  Lemma FsM_dom (psi: seq A * Q' -> seq Q + A'):
    dom (\F_(U psi)) === dom (\F_(shapesM psi)).
  Proof.
    apply/split_set_eq => [phi [Fphi FphiFphi] | phi [sf /FsM_spec val]].
    - suff ch: (forall q', exists L, exists n, shapesM psi n phi q' = Some L) by apply/(choice _ ch).
      move => q'; have [n eq]:= FphiFphi q'.
      exists (build_shapes psi n phi q').
      exists n; move: eq; rewrite /U/shapesM.
      by case: (U_rec psi n phi q').
    rewrite FM_dom_spec => q'.
    have [Qn [a' [com _]]] := val q'.
    by exists (Qn, a').
  Qed.

  Lemma FM_cont_spec:
    exists FqM FsM, forall (psi: seq A * Q' -> seq Q + A') phi,
        dom \F_(U psi) \is_subset_of dom (FqM psi)
        /\
        dom \F_(U psi) \is_subset_of dom (FsM psi)
        /\ (forall qf,
               FqM psi phi qf ->
               continuity_modulus \F_(U psi) phi qf
               /\
               continuity_modulus (FqM psi) phi qf
               /\
               continuity_modulus (FsM psi) phi qf)
        /\ (forall sf,
               FsM psi phi sf ->
               continuity_modulus (make_mf (fun psi => \F_(U psi) phi)) psi sf
               /\
               continuity_modulus (make_mf (fun psi => (FqM psi) phi)) psi sf
               /\
               continuity_modulus (make_mf (fun psi => (FsM psi) phi)) psi sf).
  Proof.
    exists (fun psi => \F_(queriesM psi)); exists (fun psi => \F_(shapesM psi)) => psi phi.
    split; first by rewrite FqM_dom.
    split; first by rewrite FsM_dom.
    split => [qf mod | sf mod].
    - split; first exact/FqM_mod_FU.
      split; first exact/FqM_mod_FqM.
      exact/FqM_mod_FsM.
    split; first exact/FsM_mod_FU.
    split; first exact/FsM_mod_FqM.
    exact/FsM_mod_FsM.
  Qed.

  Lemma FM_cont (psi: seq A * Q' -> seq Q + A'): \F_(U psi) \is_continuous.
  Proof.
    rewrite cont_spec => phi /FqM_dom [mf mod].
    by exists mf; apply/FqM_mod_FU.
  Qed.

  Lemma FM_sing (psi: seq A * Q' -> seq Q + A'): \F_(U psi) \is_singlevalued.
  Proof. exact/cont_sing/FM_cont. Qed.

  Lemma FM_val_cont (phi: B): (make_mf (fun psi (Fphi: B') => \F_(U psi) phi Fphi)) \is_continuous.
  Proof.
    rewrite cont_spec => psi [Fphi val].
    have [ | sf val']:= (FsM_dom psi phi).1; first by exists Fphi.
    by exists sf; apply/FsM_mod_FU.
  Qed.
End classical_machines.


From Hammer Require Import Hammer.

From QuicksortComplexity Require vec.
From QuicksortComplexity Require Import monads.
From QuicksortComplexity Require qs_definitions.
From QuicksortComplexity Require Import util.
Require Import List.
From QuicksortComplexity Require Import list_utils.

Section contents.

Import qs_definitions.nonmonadic.

Variable X: Set.
Variable Xle: X -> X -> Prop.
Variable XleDec: forall x y, { Xle x y } + { Xle y x }.
Let leb: X -> X -> IdMonad.M bool := fun x y => unsum_bool (XleDec x y).

Lemma qs_permutes: forall l, Permutation.Permutation l (qs leb l).
Proof with auto. hammer_hook "qs_correct" "qs_correct.qs_permutes".
intro. pattern l, (qs leb l).
apply qs_rect...
intros.
simpl.
apply Permutation.Permutation_cons_app.
apply Permutation.perm_trans with (filter (leb h) t ++ filter (gt leb h) t).
apply complementary_filter_perm.
apply Permutation.perm_trans with (qs leb (filter (leb h) t) ++ qs leb (filter (gt leb h) t)).
apply Permutation.Permutation_app...
apply Permutation.Permutation_app_swap.
Qed.

Variable PO: Relation_Definitions.preorder X Xle.

Lemma  qs_correct: forall l, vec.sorted Xle (vec.from_list (qs leb l)).
Proof with auto.
intro.
pattern l, (qs leb l).
apply qs_rect.
apply vec.sorted_nil.
intros.
simpl.
cset (Permutation.Permutation_sym (qs_permutes (filter (leb h) t))).
cset (Permutation.Permutation_sym (qs_permutes (filter (gt leb h) t))).
apply vec.sorted_app...
simpl.
apply vec.sorted_cons'...
rewrite vec.list_round_trip.
intros.
cset (Permutation.Permutation_in y H1 H3).
destruct (filter_In (leb h) y t).
destruct (H5 H4).
unfold leb in H8.
destruct (XleDec h y) in H8...
discriminate.
intros.
cset (Permutation.Permutation_in _ H2 H3).
destruct (filter_In (gt leb h) x t).
destruct (H6 H5).
unfold gt, leb in H9.
destruct (XleDec h x) in H9.
discriminate.
destruct H4.
subst...
apply (Relation_Definitions.preord_trans _ _ PO x h y)...
cset (Permutation.Permutation_in _ H1 H4).
destruct (filter_In (leb h) y t).
destruct (H11 H10).
unfold leb in H14. destruct (XleDec h y)...
discriminate.
Qed.

End contents.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* Some basic definitions used in cost models, admissibility predicates, etc. *)
Set Implicit Arguments.

Require Import FCF.Comp.

Definition DataTypeFamily := nat -> Set.

Definition FunctionCostModel := forall (A B : Type), (A -> B) -> nat -> Prop.
Definition CompCostModel := forall (A : Set), Comp A -> nat -> Prop.
Definition OC_CostModel := forall (A B C : Set), OracleComp A B C -> (nat -> nat) -> Prop.

Definition pred_comp_fam := forall (A : nat -> Set), (forall n, Comp (A n)) -> Prop.
Definition pred_comp_func_2_fam := forall (A B C : nat -> Set), (forall n, A n -> B n -> Comp (C n)) -> Prop.

Definition pred_oc_fam := forall (A B C : nat -> Set), (forall n, OracleComp (A n) (B n) (C n)) -> Prop.
Definition pred_oc_func_2_fam := forall (A B C D E : nat -> Set), (forall n, A n -> B n -> OracleComp (C n) (D n) (E n)) -> Prop.


(** Thierry Coquand - the computational content of classical logic *)
From Coq Require Import Program.Equality.
From Coq Require Import Unicode.Utf8.
From Coq Require Import Arith.

Set Implicit Arguments.

Inductive M(F: Type -> Type): Type -> Type :=
| K: forall t: Type, F t -> M F t
| ret: forall t: Type, t -> M F t
| bind: forall a b, M F a -> (a -> M F b) -> M F b.

Section CoquandCompContext.
  Hypothesis f: nat -> nat.
  Context (x0: nat).
  Hypothesis H1: forall x, exists y, x < f y.
  Hypothesis H2: f 0 <= x0.

  Definition P := exists n, f n <= x0 /\ x0 < f (S n).
  Definition F: Type -> Type := fun _ => P.

  Definition Δ := M F.

  Lemma lem1: forall n X, f n <= x0 -> x0 < f (S n) -> Δ X.
  Proof.
    intros.
    apply K.
    unfold F, P.
    exists n. split; auto.
  Defined.

  Lemma lem: forall n, Δ (f n <= x0).
  Proof.
    induction n.
    - apply ret. apply H2.
    - eapply bind. eapply IHn.
      intro H.
      destruct (le_gt_dec (f (S n)) x0).
      + apply ret. apply l.
      + eapply lem1. apply H.
        apply g.
  Defined.

  Lemma lem2': forall X, Δ X -> P + X.
  Proof.
    intros.
    induction X0.
    - unfold F in *. left. apply f0.
    - right. apply t0.
    - destruct IHX0.
      + left. apply p.
      + apply X. apply a0.
  Defined.

  Lemma lem2: forall X, ~ X -> Δ X -> P.
  Proof.
    intros.
    apply lem2' in X0.
    destruct X0.
    + apply p.
    + contradiction.
  Defined.

  Lemma final: P.
  Proof.
    destruct (H1 x0).
    rename x into y0.
    eapply (@lem2 (f y0 <= x0)).
    - intros Hcontra.
      apply (le_not_lt (f y0) x0).
      apply Hcontra.
      apply H.
    - apply lem.
  Defined.
End CoquandCompContext.


From Hammer Require Import Hammer.

Require Import NPeano Omega Setoid.
From hahn Require Import HahnBase HahnList HahnRelationsBasic HahnEquational HahnRewrite.
From hahn Require Import HahnSets HahnMaxElt.
From hahn Require Import Zorn.

Set Implicit Arguments.

Section one_extension.

Variable A : Type.
Variable elem : A.
Variable r : relation A.

Definition one_ext : relation A :=
fun x y =>
r⁺ x y
\/ r＊ x elem /\ ~ r＊ y elem.

Lemma one_ext_extends : r ⊆ one_ext.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.one_ext_extends". vauto. Qed.

Lemma one_ext_trans : transitive one_ext.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.one_ext_trans".
red; ins; unfold one_ext in *; desf; desf;
intuition eauto using clos_trans_in_rt, t_trans, rt_trans.
Qed.

Lemma one_ext_irr : acyclic r -> irreflexive one_ext.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.one_ext_irr".
red; ins; unfold one_ext in *; desf; eauto using clos_trans_in_rt.
Qed.

Lemma one_ext_total_elem :
forall x, x <> elem -> one_ext elem x \/ one_ext x elem.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.one_ext_total_elem".
unfold one_ext; ins; rewrite !clos_refl_transE; tauto.
Qed.

End one_extension.

Fixpoint tot_ext A (dom : list A) (r : relation A) : relation A :=
match dom with
| nil => r⁺
| x::l => one_ext x (tot_ext l r)
end.

Lemma tot_ext_extends A dom (r : relation A) : r ⊆ tot_ext dom r.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_extends".
induction dom; ins; eauto using one_ext_extends with hahn.
Qed.

Lemma tot_ext_trans A dom (r : relation A) :  transitive (tot_ext dom r).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_trans".
induction dom; ins; vauto; apply one_ext_trans.
Qed.

Lemma tot_ext_extends2 A dom (r : relation A) : r⁺ ⊆ tot_ext dom r.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_extends2".
eauto using tot_ext_extends, tot_ext_trans with hahn.
Qed.

Lemma tot_ext_irr A (dom : list A) r :
acyclic r -> irreflexive (tot_ext dom r).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_irr".
induction dom; ins.
apply one_ext_irr, trans_irr_acyclic; eauto using tot_ext_trans.
Qed.

Lemma tot_ext_total A (dom : list A) r :
is_total (fun x => In x dom) (tot_ext dom r).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_total".
induction dom; red; ins; desf.
eapply one_ext_total_elem in NEQ; desf; eauto.
eapply not_eq_sym, one_ext_total_elem in NEQ; desf; eauto.
eapply IHdom in NEQ; desf; eapply one_ext_extends in NEQ; eauto.
Qed.

Lemma tot_ext_inv A dom r (x y : A) :
acyclic r -> tot_ext dom r x y -> ~ r y x.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_inv".
red; ins; eapply tot_ext_irr, tot_ext_trans, tot_ext_extends; eauto.
Qed.

Lemma tot_ext_extends_dom A dom dom' (r : relation A) :
tot_ext dom r ⊆ tot_ext (dom' ++ dom) r.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_extends_dom".
induction dom'; ins; eauto using one_ext_extends with hahn.
Qed.

Definition tot_ext_nat r x y := exists k, tot_ext (rev (List.seq 0 k)) r x y.

Lemma tot_ext_nat_extends r : r ⊆ tot_ext_nat r.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_nat_extends".
exists 0; vauto.
Qed.

Lemma tot_ext_nat_trans r : transitive (tot_ext_nat r).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_nat_trans".
unfold tot_ext_nat; red; ins; desf;
destruct (le_lt_dec k k0) as [LE|LE]; [|apply Nat.lt_le_incl in LE];
[exists k0|exists k]; eapply tot_ext_trans; eauto;
rewrite (seq_split _ LE), rev_app_distr; apply tot_ext_extends_dom; eauto.
Qed.

Lemma tot_ext_nat_extends2 r : r⁺ ⊆ tot_ext_nat r.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_nat_extends2".
eauto using tot_ext_nat_extends, tot_ext_nat_trans with hahn.
Qed.

Lemma tot_ext_nat_irr r : acyclic r -> irreflexive (tot_ext_nat r).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_nat_irr".
red; unfold tot_ext_nat; ins; desf; eapply tot_ext_irr; eauto.
Qed.

Lemma tot_ext_nat_total r : is_total (fun _ => True) (tot_ext_nat r).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_nat_total".
unfold tot_ext_nat; red; ins.
eapply tot_ext_total with (r:=r) (dom := rev (List.seq 0 (S (a + b)))) in NEQ;
desf; eauto; rewrite <- in_rev, in_seq; omega.
Qed.

Lemma tot_ext_nat_inv r x y :
acyclic r -> tot_ext_nat r x y -> ~ r y x.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_nat_inv".
red; ins; eapply tot_ext_nat_irr, tot_ext_nat_trans, tot_ext_nat_extends; eauto.
Qed.

Definition Successor A (r s: relation A) :=
<< FUN: functional s >> /\
<< INJ: functional s⁻¹ >> /\
<< SUC: s⁻¹ ⨾ r ⊆ r^? >> /\
<< INC: s ⊆ r >>.

Lemma succ_helper A (r s: relation A) (SUC: s⁻¹ ⨾ r ⊆ r^?):
s⁻¹＊ ⨾ (r \ s⁺) ⊆ r \ s⁺.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.succ_helper".
eapply rt_ind_left with (P:= fun __ => __ ⨾ (r \ s⁺)); relsf.
intros k IH.
rewrite !seqA, IH; relsf.
unfold seq, transp, minus_rel, clos_refl, inclusion in *.
ins; desf; splits.
assert (x = y \/ r x y) by eauto.
by desf; destruct H1; vauto.
by intro; apply H1; vauto.
Qed.

Definition tot_ext_suc A (dom : list A) (r s : relation A) : relation A :=
s⁺ ∪ s＊ ⨾ ⦗max_elt s⦘ ⨾ tot_ext dom r ⨾ ⦗max_elt s⦘ ⨾ s⁻¹＊.

Lemma functional_path A (s: relation A) (FUN: functional s):
(s⁻¹)＊ ⨾ s＊ ⊆ s＊ ∪ (s⁻¹)＊.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.functional_path".
eapply rt_ind_left with (P:= fun __ => __ ⨾ s＊); relsf.
intros k IH.
rewrite !seqA, IH; relsf.
apply inclusion_union_l.
rewrite rt_begin at 1; relsf.
apply inclusion_union_l; vauto.
by rewrite functional_alt in FUN; sin_rewrite FUN; relsf.
rewrite rt_begin at 2; relsf.
Qed.

Lemma functional_path_transp A (s: relation A) (FUN: functional s⁻¹):
s＊⨾ s⁻¹＊ ⊆ s＊ ∪ (s⁻¹)＊.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.functional_path_transp".
rewrite functional_path with (s:=s⁻¹); [rels|done].
Qed.

Lemma last_exists A dom (s: relation A) (ACYC: acyclic s)
a (DOM: forall c, s＊ a c -> In c dom):
exists b, s＊ a b /\ max_elt s b.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.last_exists".
revert a DOM.
induction dom using (well_founded_ind (well_founded_ltof _ (@length _))).
ins; destruct (classic (exists a1, s a a1)); cycle 1.
by exists a; eexists; splits; [vauto| red; eauto].
assert (INa: In a dom).
by apply DOM; vauto.
desc; apply in_split in INa; desf.
assert(exists b, s ＊ a1 b /\ max_elt s b).
{ eapply (H (l1 ++ l2)).
* unfold ltof; rewrite !app_length; simpl; omega.
* ins.
assert(INc: In c (l1 ++ a :: l2)).
by eapply DOM; eapply rt_trans; vauto.
rewrite in_app_iff in *; simpls; desf; eauto.
exfalso; eapply ACYC; eapply t_step_rt; eauto.
}
unfold seq in *; desc; exists b; splits; try done.
apply rt_begin; right; eexists; eauto.
Qed.

Lemma last_functional A (s: relation A) (FUN: functional s):
functional (s＊ ⨾ ⦗max_elt s⦘).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.last_functional".
apply functional_alt.
rewrite transp_seq; relsf.
rewrite !seqA, transp_rt.
sin_rewrite functional_path; [relsf | done].
seq_rewrite seq_eqv_max_rt; rels.
seq_rewrite transp_seq_eqv_max_rt; rels.
basic_solver.
Qed.

Lemma dom_helper A dom (s: relation A)
(IN: s ⊆ ⦗fun x => In x dom⦘ ⨾ s ⨾ ⦗fun x => In x dom⦘)
a (INa: In a dom) b (H: s ＊ a b) : In b dom.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.dom_helper".
ins; apply clos_refl_transE in H; desf.
apply t_rt_step in H; desc.
apply IN in H0; revert H0; basic_solver.
Qed.

Lemma last_exists_rewrite A dom (s: relation A)
(ACYC: acyclic s)
(IN: s ⊆ ⦗fun x : A => In x dom⦘ ⨾ s ⨾ ⦗fun x : A => In x dom⦘):
⦗fun _ => True⦘ ⊆ s＊ ⨾ ⦗max_elt s⦘ ⨾ s⁻¹＊.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.last_exists_rewrite".
unfold inclusion, eqv_rel, seq; ins; desf.
destruct (classic (In y dom)) as [INy|NINy]; cycle 1.
- exists y; splits; vauto.
exists y; splits; vauto.
red; ins; apply IN in REL; revert REL; basic_solver.
- generalize (last_exists dom ACYC (dom_helper dom IN INy)); ins; desc.
exists b; splits; eauto.
exists b; splits; eauto.
apply transp_rt with (r:=s); vauto.
Qed.

Lemma tot_ext_suc_trans A dom (r s: relation A) (SUC: Successor r s) :
transitive (tot_ext_suc dom r s).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_suc_trans".
unfold tot_ext_suc.
apply transitiveI; relsf.
repeat apply inclusion_union_l; eauto with hahn.
- by rewrite ct_ct; rels.
- rewrite inclusion_t_rt at 1.
rewrite !seqA, functional_path; [relsf | apply SUC].
rewrite seq_eqv_max_rt.
basic_solver 16.
- rewrite !seqA.
sin_rewrite functional_path; [relsf | apply SUC].
seq_rewrite seq_eqv_max_rt; relsf.
seq_rewrite transp_seq_eqv_max_rt; relsf.
arewrite_id (⦗max_elt s⦘) at 2; relsf.
sin_rewrite rewrite_trans; [rels| apply tot_ext_trans].
Qed.

Lemma tot_ext_suc_irr A dom (r s: relation A) (SUC: Successor r s)
(ACYC: acyclic r): irreflexive (tot_ext_suc dom r s).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_suc_irr".
red in SUC; desc.
unfold tot_ext_suc; ins.
rewrite irreflexive_union; splits.
by rewrite INC.
rewrite irreflexive_seqC, !seqA, functional_path; [relsf | done].
rewrite irreflexive_union; splits.
- rewrite seq_eqv_max_rt.
generalize (tot_ext_irr dom ACYC); basic_solver.
- rewrite irreflexive_seqC, !seqA.
rewrite transp_seq_eqv_max_rt.
generalize (tot_ext_irr dom ACYC); basic_solver.
Qed.

Lemma tot_ext_suc_total A dom (r s: relation A)
(ACYC: acyclic r) (SUC: Successor r s)
(IN: s ⊆ ⦗fun x => In x dom⦘ ⨾ s ⨾ ⦗fun x => In x dom⦘):
is_total (fun x => In x dom) (tot_ext_suc dom r s).
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_suc_total".
ins; red; ins.
assert (ACYC': acyclic s).
by cdes SUC; rewrite INC; done.
generalize (last_exists dom ACYC' (dom_helper dom IN IWa)); ins; desc.
generalize (last_exists dom ACYC' (dom_helper dom IN IWb)); ins; desc.
destruct (classic (b0=b1)) as [EQ1|NEQ1]; subst.
- assert (XX: (s＊ ∪ s⁻¹＊) a b).
apply functional_path_transp; [apply SUC |].
exists b1; splits.
by generalize H; basic_solver.
by apply transp_rt with (r:=s); generalize H0; basic_solver.
unfold union in XX; desf; apply clos_refl_transE in XX; desf.
by left; unfold tot_ext_suc; basic_solver 2.
by right; unfold tot_ext_suc; apply transp_ct in XX; basic_solver 2.
- assert (tot_ext dom r b0 b1 \/ tot_ext dom r b1 b0); desf.
* generalize (tot_ext_total dom r); intro TOT; eapply TOT; try done.
+ eby eapply dom_helper with (a:=a).
+ eby eapply dom_helper with (a:=b).
* left; red; right.
unfold seq in H, H0; desc.
do 4 (eexists; splits; eauto).
by apply transp_eqv_rel; eauto.
by apply transp_rt with (r:=s); generalize H0; basic_solver 2.
* right; red; right.
unfold seq in H, H0; desc.
do 4 (eexists; splits; eauto).
by apply transp_eqv_rel; eauto.
by apply transp_rt with (r:=s); generalize H0; basic_solver 2.
Qed.

Lemma tot_ext_suc_extends A dom (r s: relation A)
(ACYC: acyclic r) (SUC: Successor r s)
(IN: s ⊆ ⦗fun x => In x dom⦘ ⨾ s ⨾ ⦗fun x => In x dom⦘) :
r ⊆ tot_ext_suc dom r s.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_suc_extends".
arewrite (r ⊆ (r \ s⁺) ∪ s⁺).
by apply inclusion_union_minus.
arewrite (r \ s ⁺ ⊆ ⦗fun _ => True⦘ ⨾ (r \ s ⁺) ⨾ ⦗fun _ => True⦘).
basic_solver.
rewrite !last_exists_rewrite with (s:=s); [|cdes SUC; rewrite INC; done| edone].
rewrite !seqA.
sin_rewrite succ_helper; [|by apply SUC].
rewrite inclusion_minus_rel.
cdes SUC; rewrite INC at 3; rels.
unfold tot_ext_suc.
rewrite inclusion_t_ind with (r' := tot_ext dom r);
[auto with hahn | red; eapply tot_ext_extends | apply tot_ext_trans].
Qed.

Lemma tot_ext_suc_suc A dom (r s: relation A) (SUC: Successor r s) :
Successor (tot_ext_suc dom r s) s.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.tot_ext_suc_suc".
unfold Successor, tot_ext_suc in *; ins; desf; splits; auto with hahn.
relsf.
apply inclusion_union_l; ins.
- rewrite ct_begin at 1.
rewrite functional_alt in FUN; sin_rewrite FUN; basic_solver.
- rewrite rt_begin at 1; relsf.
apply inclusion_union_l; ins.
* arewrite (s⁻¹ ⊆ (s⁻¹)＊) at 1.
seq_rewrite transp_seq_eqv_max_rt; rels; basic_solver 20.
* rewrite !seqA.
rewrite functional_alt in FUN; sin_rewrite FUN; rels.
Qed.

Add Parametric Morphism A : (@one_ext A) with signature
eq ==> same_relation ==> same_relation as one_ext_more.
Proof.
unfold one_ext, same_relation, inclusion; intuition;
eauto 8 using clos_trans_mon, clos_refl_trans_mon.
Qed.

Add Parametric Morphism A : (@tot_ext A) with signature
eq ==> same_relation ==> same_relation as tot_ext_more.
Proof.
induction y; ins; eauto using clos_trans_more, one_ext_more.
Qed.

Add Parametric Morphism : tot_ext_nat with signature
same_relation ==> same_relation as tot_ext_nat_more.
Proof.
unfold tot_ext_nat; split; red; ins; desf; exists k;
eapply tot_ext_more; try eassumption; symmetry; eauto.
Qed.

Add Parametric Morphism A : (@tot_ext_suc A) with signature
eq ==> same_relation ==> same_relation ==> same_relation as tot_ext_suc_more.
Proof.
by unfold tot_ext_suc; ins; rewrite H, H0.
Qed.

Lemma partial_order_included_in_total_order A (R: relation A) (POR: strict_partial_order R):
exists R', inclusion R R' /\ strict_total_order (fun _ => True) R'.
Proof. hammer_hook "HahnTotalExt" "HahnTotalExt.partial_order_included_in_total_order".
forward apply (@zorns_lemma {Q: relation A | <<SUBST: R ⊆ Q>> /\ <<PO: strict_partial_order Q>>}
(fun R1 R2 => proj1_sig R1 ⊆ proj1_sig R2))
as [[M ?] MAX]; desc; simpls.
{ firstorder.  }
{
intros C CHAIN.
tertium_non_datur (C ≡₁ ∅) as [EMP|NEMP].
*
exists (exist (fun Q => R ⊆ Q /\ strict_partial_order Q) R (conj (inclusion_refl _) POR)); ins.
by apply EMP in H.
*
clear NEMP0; rename n into Q.
remember ((fun x y => exists Q, <<CQ: C Q>> /\ <<Qab: proj1_sig Q x y>>)) as M.
enough (MOK: R ⊆ M /\ strict_partial_order M).
by exists (exist _ M MOK); ins; desf; vauto.
desf; splits.
+ red; ins; exists Q; destruct Q; ins; desf; eauto.
+ split; red; ins; desf.
- destruct Q0; ins; desf.
eby eapply a0.
- specialize (CHAIN _ _ H H0); desf.
all: match goal with INCL: ?rel ⊆ _ |- _
=> (match goal with REL : ?rel _ _ |- _ => apply INCL in REL end) end.
all: match goal with H: proj1_sig ?rel _ _ |- _ => exists rel; destruct rel; split; ins; desf end.
all: match goal with TRANS: strict_partial_order ?rel |- ?rel _ _ => eby eapply TRANS end. }

exists M; do 2 (split; ins).
red; ins.
apply NNPP; intro INCOMP; clarify_not.
remember (fun x y => (x = a /\ y = b) \/
M x y \/ (M x a /\ y = b) \/ (x = a /\ M b y) \/ (M x a /\ M b y)) as M'.

assert (MM: M ⊆ M') by (unfolder; ins; desf; eauto).
assert (M'OK: R ⊆ M' /\ strict_partial_order M').
{ split; [eby eapply inclusion_trans |].
split; red; ins; desf; eauto 8 using (proj1 PO), (proj2 PO).
}
specialize (MAX (exist _ M' M'OK) MM); ins.
apply INCOMP, MAX; desf; eauto.
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 eqtype ssrbool ssrnat ssrfun seq.
From mathcomp Require Import choice ssralg bigop.
From mathcomp Require Export word_ssrZ.

Import GRing.Theory.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Local Notation simpm := Monoid.simpm.

Require Import NArith ZArith BinPos Ring_polynom Field_theory.

(* -------------------------------------------------------------------- *)
Declare Scope ssring.

Reserved Notation "x %:S" (at level 2, left associativity, format "x %:S").

Notation "c %:S"   := (PEc c)     : ssring.
Notation "''X_' i" := (PEX _ i)   : ssring.
Notation "x + y"   := (PEadd x y) : ssring.
Notation "x - y"   := (PEsub x y) : ssring.
Notation "- x"     := (PEopp x  ) : ssring.
Notation "x * y"   := (PEmul x y) : ssring.
Notation "x ^+ n"  := (PEpow x n) : ssring.

Notation "0" := PEO : ssring.
Notation "1" := PEI : ssring.

Delimit Scope ssring with S.

(* -------------------------------------------------------------------- *)
Declare Scope ssfield.

Notation "c %:S"   := (FEc c)     : ssfield.
Notation "''X_' i" := (FEX _ i)   : ssfield.
Notation "x + y"   := (FEadd x y) : ssfield.
Notation "x - y"   := (FEsub x y) : ssfield.
Notation "- x"     := (FEopp x  ) : ssfield.
Notation "x * y"   := (FEmul x y) : ssfield.
Notation "x ^-1"   := (FEinv x)   : ssfield.
Notation "x / y"   := (FEdiv x y) : ssfield.
Notation "x ^+ n"  := (FEpow x n) : ssfield.

Notation "0" := FEO : ssfield.
Notation "1" := FEI : ssfield.

Delimit Scope ssfield with F.

(* -------------------------------------------------------------------- *)
Local Coercion Z_of_nat      : nat >-> Z.
Local Coercion N_of_nat      : nat >-> N.
Local Coercion P_of_succ_nat : nat >-> positive.
Local Coercion Z.pos         : positive >-> Z.

(* -------------------------------------------------------------------- *)
Class find (T : Type) (x : T) (xs : seq T) (i:nat).

#[export]
Instance find0 (T : Type) (x : T) (xs : seq T)
 : find x (x :: xs) 0
 := { }.

#[export]
Instance findS (T : Type) (x : T) (y : T) (ys :  seq T) i
 {_: find x ys i}
 : find x (y :: ys) i.+1 | 1
 := { }.

(* -------------------------------------------------------------------- *)
Class closed (T : Type) (xs : seq T).

#[export]
Instance closed_nil T
 : closed (T:=T) nil
 := { }.

#[export]
Instance closed_cons T (x : T) (xs : seq T)
 {_: closed xs}
 : closed (x :: xs)
 := { }.

(* -------------------------------------------------------------------- *)
Class reify (R : ringType) (a : R) (t : PExpr Z) (e : seq R).

#[export]
Instance reify_zero (R : ringType) e : @reify R 0 0%S e := { }.
#[export]
Instance reify_one  (R : ringType) e : @reify R 1 1%S e := { }.

#[export]
Instance reify_natconst (R : ringType) n e
  : @reify R n%:R ((n : Z)%:S)%S e
  := { }.

#[export]
Instance reify_add (R : ringType) a1 a2 t1 t2 e
  {_: @reify R a1 t1 e}
  {_: @reify R a2 t2 e}
  : reify (a1 + a2) (t1 + t2)%S e
  := { }.

#[export]
Instance reify_opp (R : ringType) a t e
  {_: @reify R a t e}
  : reify (-a) (-t)%S e
  := { }.

#[export]
Instance reify_natmul (R : ringType) a n t e
  {_: @reify R a t e}
  : reify (a *+ n) (t * (n : Z)%:S)%S e
  := { }.

#[export]
Instance reify_mul (R : ringType) a1 a2 t1 t2 e
  {_: @reify R a1 t1 e}
  {_: @reify R a2 t2 e}
  : reify (a1 * a2) (t1 * t2)%S e
  := { }.

#[export]
Instance reify_exp (R : ringType) a n t e
  {_: @reify R a t e}
  : reify (a ^+ n) (t ^+ n)%S e | 1
  := { }.

#[export]
Instance reify_var (R : ringType) a i e
  `{find R a e i}
  : reify a ('X_i)%S e
  | 100
  := { }.

Definition reifyl (R : ringType) a t e
  {_: @reify R a t e}
  `{closed (T := R) e}
  := (t, e).

(* -------------------------------------------------------------------- *)
Ltac reify xt xe :=
  match goal with
  |- ?a = 0 =>
     match eval red in (reifyl (a := a)) with
     | (?t, ?e) => pose xt := t; pose xe := e
     end
  end.

(* -------------------------------------------------------------------- *)
Class freify (F : fieldType) (a : F) (t : FExpr Z) (e : seq F).

#[export]
Instance freify_zero (F : fieldType) e : @freify F 0 0%F e := { }.
#[export]
Instance freify_one  (F : fieldType) e : @freify F 1 1%F e := { }.

#[export]
Instance freify_natconst (F : fieldType) n e
  : @freify F n%:R ((n : Z)%:S)%F e
  := { }.

#[export]
Instance freify_add (F : fieldType) a1 a2 t1 t2 e
  {_: @freify F a1 t1 e}
  {_: @freify F a2 t2 e}
  : freify (a1 + a2) (t1 + t2)%F e
  := { }.

#[export]
Instance freify_opp (F : fieldType) a t e
  {_: @freify F a t e}
  : freify (-a) (-t)%F e
  := { }.

#[export]
Instance freify_natmul (F : fieldType) a n t e
  {_: @freify F a t e}
  : freify (a *+ n) (t * (n : Z)%:S)%F e
  := { }.

#[export]
Instance freify_mul (F : fieldType) a1 a2 t1 t2 e
  {_: @freify F a1 t1 e}
  {_: @freify F a2 t2 e}
  : freify (a1 * a2) (t1 * t2)%F e
  := { }.

#[export]
Instance freify_inv (F : fieldType) a t e
  {_: @freify F a t e}
  : freify (a^-1) (t^-1)%F e
  := { }.

#[export]
Instance freify_exp (F : fieldType) a n t e
  {_: @freify F a t e}
  : freify (a ^+ n) (t ^+ n)%F e | 1
  := { }.

#[export]
Instance freify_var (F : fieldType) a i e
  `{find F a e i}
  : freify a ('X_i)%F e
  | 100
  := { }.

Definition freifyl (F : fieldType) a t e
  {_: @freify F a t e}
  `{closed (T := F) e}
  := (t, e).

(* -------------------------------------------------------------------- *)
Ltac freify xt xe :=
  match goal with
  |- ?a = 0 =>
     match eval red in (freifyl (a := a)) with
     | (?t, ?e) => pose xt := t; pose xe := e
     end
  end.

(* -------------------------------------------------------------------- *)
Definition R_of_Z (R : ringType) (z : Z) : R :=
  match z with
  | Z0     => 0
  | Zpos n =>   (nat_of_P n)%:R
  | Zneg n => - (nat_of_P n)%:R
  end.

Arguments R_of_Z [R].

Lemma z0E: 0%Z = 0.
Proof. by []. Qed.

Lemma zaddE (z1 z2 : Z): (z1 + z2)%Z = z1 + z2.
Proof. by []. Qed.

Lemma zoppE (z : Z): (-z)%Z = -z.
Proof. by []. Qed.

Lemma zmulE (z1 z2 : Z): (z1 * z2)%Z = z1 * z2.
Proof. by []. Qed.

Definition zE := (z0E, zaddE, zoppE).

Lemma R_of_Z_is_additive (R : ringType): additive (R_of_Z (R := R)).
Proof.
  have oppm: {morph (R_of_Z (R := R)) : x / -x >-> -x}.
    by case=> [|n|n] //=; rewrite ?(oppr0, opprK).
  have addm z1 z2: R_of_Z (z1 + z2) = R_of_Z z1 + R_of_Z z2 :> R.
    wlog: z1 z2 / (z1 <=? z2)%Z; first move=> wlog.
    + case: (boolP (z1 <=? z2))%Z; first by move/wlog.
    + move/negbTE/Z.leb_gt/Z.lt_le_incl/Z.leb_le.
      by move/wlog; rewrite Z.add_comm addrC.
    case: z1 z2=> [|n1|n1] [|n2|n2] //= _; rewrite ?(addr0, add0r) //.
    + by rewrite Pos2Nat.inj_add natrD.
    + case: (Z.compare_spec n1 n2) => [[->]||].
      * by rewrite Z.pos_sub_diag addrC subrr.
      * move=> lt; rewrite (Z.pos_sub_gt _ _ lt) /=.
        rewrite (Pos2Nat.inj_sub _ _ lt) natrB 1?addrC //.
        apply/leP/Pos2Nat.inj_le/Pos.lt_le_incl/Pos.ltb_lt.
        by rewrite Pos2Z.inj_ltb; apply/Pos.ltb_lt.
      * move=> lt; rewrite (Z.pos_sub_lt _ _ lt) /=.
        rewrite (Pos2Nat.inj_sub _ _ lt) natrB ?opprB 1?addrC //.
        apply/leP/Pos2Nat.inj_le/Pos.lt_le_incl/Pos.ltb_lt.
        by rewrite Pos2Z.inj_ltb; apply/Pos.ltb_lt.
    + by rewrite Pos2Nat.inj_add natrD opprD.
  by move=> z1 z2 /=; rewrite addm oppm.
Qed.

Canonical R_of_Z_additive (R : ringType) := Additive (R_of_Z_is_additive R).

Lemma R_of_Z_is_multiplicative (R : ringType): multiplicative (R_of_Z (R := R)).
Proof.
  split=> //=; case=> [|z1|z1] [|z2|z2] //=;
    rewrite ?simpm // ?(mulNr, mulrN, opprK);
    by rewrite nat_of_P_mult_morphism natrM.
Qed.

Canonical R_of_Z_rmorphism (R : ringType) := AddRMorphism (R_of_Z_is_multiplicative R).

Local Notation REeval :=
  (@PEeval _ 0 +%R *%R (fun x y => x - y) -%R Z R_of_Z nat nat_of_N (@GRing.exp _)).

Lemma RE (R : ringType): @ring_eq_ext R +%R *%R -%R (@eq R).
Proof. by split; do! move=> ? _ <-. Qed.

Local Notation "~%R"   := (fun x y => x - y).
Local Notation "/%R"   := (fun x y => x / y).
Local Notation "^-1%R" := (@GRing.inv _) (only parsing).

Lemma RR (R : comRingType): @ring_theory R 0 1 +%R *%R ~%R -%R (@eq R).
Proof.
  split=> //=;
    [ exact: add0r | exact: addrC | exact: addrA  | exact: mul1r
    | exact: mulrC | exact: mulrA | exact: mulrDl | exact: subrr ].
Qed.

Lemma RZ (R : ringType):
  ring_morph (R := R) 0 1 +%R *%R ~%R -%R eq
    0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool (@R_of_Z _).
Proof.
  split=> //=.
  + by move=> x y; rewrite rmorphD.
  + by move=> x y; rewrite rmorphB.
  + by move=> x y; rewrite rmorphM.
  + by move=> x; rewrite raddfN.
  + by move=> x y /Zeq_bool_eq ->.
Qed.

Lemma PN (R : ringType):
  @power_theory R 1 *%R eq nat nat_of_N (@GRing.exp R).
Proof.
  split=> r [|n] //=; elim: n => //= p ih.
  + by rewrite Pos2Nat.inj_xI exprS -!ih -exprD addnn -mul2n.
  + by rewrite Pos2Nat.inj_xO -!ih -exprD addnn -mul2n.
Qed.

Lemma RF (F : fieldType): @field_theory F 0 1 +%R *%R ~%R -%R /%R ^-1%R (@eq F).
Proof.
  split=> //=; first by apply RR.
  + by apply/eqP; rewrite oner_eq0.
  + by move=> x /eqP nz_z; rewrite mulVf.
Qed.

Definition Rcorrect (R : comRingType) :=
  ring_correct (Eqsth R) (RE R)
    (Rth_ARth (Eqsth R) (RE R) (RR R))
    (RZ R) (PN R)
    (triv_div_th
       (Eqsth R) (RE R)
       (Rth_ARth (Eqsth R) (RE R) (RR R)) (RZ R)).

Definition Fcorrect (F : fieldType) :=
  Field_correct
    (Eqsth F) (RE F) (congr1 GRing.inv)
    (F2AF (Eqsth F) (RE F) (RF F)) (RZ F) (PN F)
    (triv_div_th
       (Eqsth F) (RE F)
       (Rth_ARth (Eqsth F) (RE F) (RR F)) (RZ F)).

(* -------------------------------------------------------------------- *)
Fixpoint Reval (R : ringType) (l : seq R) (pe : PExpr Z) :=
  match pe with
  | 0%S           => 0
  | 1%S           => 1
  | (c%:S)%S      => R_of_Z c
  | ('X_j)%S      => BinList.nth 0 j l
  | (pe1 + pe2)%S => (Reval l pe1) + (Reval l pe2)
  | (pe1 - pe2)%S => (Reval l pe1) - (Reval l pe2)
  | (- pe1)%S     => - (Reval l pe1)
  | (pe1 ^+ n)%S  => (Reval l pe1) ^+ (nat_of_N n)
  | (pe1 * pe2)%S =>
      match pe2 with
      | ((Zpos n)%:S)%S => (Reval l pe1) *+ (nat_of_P n)
      | _               => (Reval l pe1) * (Reval l pe2)
      end
  end.

Local Notation RevalC R :=
  (PEeval 0 1 +%R *%R ~%R -%R (R_of_Z (R := R)) nat_of_N (@GRing.exp R)).

Lemma PEReval (R : ringType): RevalC _ =2 @Reval R.
Proof.
  move=> l; elim => //=; try by do? move=> ?->.
  + move=> pe1 -> pe2 ->; case: pe2 => //=.
    by case=> [|c|c] //=; rewrite mulr_natr.
Qed.

(* -------------------------------------------------------------------- *)
Fixpoint Feval (F : fieldType) (l : seq F) (pe : FExpr Z) :=
  match pe with
  | 0%F           => 0
  | 1%F           => 1
  | (c%:S)%F      => R_of_Z c
  | ('X_j)%F      => BinList.nth 0 j l
  | (pe1 + pe2)%F => (Feval l pe1) + (Feval l pe2)
  | (pe1 - pe2)%F => (Feval l pe1) - (Feval l pe2)
  | (- pe1)%F     => - (Feval l pe1)
  | (pe1 ^+ n)%F  => (Feval l pe1) ^+ (nat_of_N n)
  | (pe^-1)%F     => (Feval l pe)^-1
  | (pe1 / pe2)%F => (Feval l pe1) / (Feval l pe2)
  | (pe1 * pe2)%F =>
      match pe2 with
      | ((Zpos n)%:S)%F => (Feval l pe1) *+ (nat_of_P n)
      | _               => (Feval l pe1) * (Feval l pe2)
      end
  end.

Local Notation FevalC R :=
  (FEeval 0 1 +%R *%R ~%R -%R /%R ^-1%R
          (R_of_Z (R := R)) nat_of_N (@GRing.exp R)).

Lemma PEFeval (F : fieldType): FevalC _ =2 @Feval F.
Proof.
  move=> l; elim => //=; try by do? move=> ?->.
  + move=> pe1 -> pe2 ->; case: pe2 => //=.
    by case=> [|c|c] //=; rewrite mulr_natr.
Qed.

(* -------------------------------------------------------------------- *)
Ltac ssring :=
  let xt := fresh "xt" in
  let xe := fresh "xe" in
    apply/eqP; rewrite -subr_eq0; apply/eqP;
    reify xt xe;
    apply (@Rcorrect _ 100 xe [::] xt (Coq.setoid_ring.Ring_polynom.PEc 0%Z) I);
    vm_compute;exact (erefl true).

(* -------------------------------------------------------------------- *)
Ltac ssfield :=
  let xt := fresh "xt" in
  let xe := fresh "xe" in
    apply/eqP; rewrite -subr_eq0; apply/eqP;
      (* rewrite ?(mulr0, mul0r, mulr1, mul1r); *) freify xt xe;
      move: (@Fcorrect _ 100 xe [::] xt (Field_theory.FEc 0) I [::] (erefl [::]));
      move/(_ _ (erefl _) _ (erefl _) (erefl true)); rewrite !PEFeval;
      apply=> /=; do? split; cbv delta[BinPos.Pos.to_nat] => /= {xt xe};
      try (exact I || apply/eqP).


(*
Copyright © 2007-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.stdlib_omissions.List.

(**
* Classical Logic
This section introduces the classical logic connectives, "classical or"
and "classical exists" through their double negation translation.
Induction principles are given that allow you to destruct these formulas
as you would their constructive counter parts, so long as the conclusion
is double negataion stable.

No classical axioms are assumed.
*)

(**
** Classical or
*)

Section ClassicOr.

Definition orC (P Q:Prop) := ~((~P)/\(~Q)).

Lemma orWeaken : forall P Q, ({P}+{Q}) -> orC P Q.
Proof.
 unfold orC.
 tauto.
Qed.

Lemma orC_ind : forall (P Q G:Prop),
 (~~G -> G) -> (P -> G) -> (Q -> G) -> (orC P Q) -> G.
Proof.
 unfold orC.
 tauto.
Qed.

Lemma orC_stable : forall P Q, ~~(orC P Q) -> orC P Q.
Proof.
 unfold orC.
 auto.
Qed.

End ClassicOr.

(**
** Classical Existential
*)
Section ClassicExists.

Variable A : Type.
Variable P : A->Prop.

Definition existsC : Prop :=
 ~forall x:A, ~P x.

Lemma existsWeaken : (exists x:A, P x) -> existsC.
Proof.
 intros [x Hx] H.
 apply (H x).
 assumption.
Qed.

Lemma existsC_ind : forall (Q:Prop),
 (~~Q -> Q) -> (forall x:A, P x -> Q) -> existsC -> Q.
Proof.
 intros Q HQ H ex.
 apply HQ.
 intros Z.
 apply ex.
 intros x Hx.
 apply Z.
 apply H with x.
 assumption.
Qed.

Lemma existsC_stable : ~~existsC -> existsC.
Proof.
 unfold existsC.
 auto.
Qed.

End ClassicExists.

(**
** Pidgeon Hole Principle
Here we show the classical result of the pigenon hole principle using the
classical quantifiers.

Given a finite list of elements and a relation P(n,x) saying when items from
the list are selected, there classically exists an item that is selected a
classically infinite number of times.
*)

Lemma infinitePidgeonHolePrinicple :
 forall (X:Type) (l:list X) (P:nat -> X -> Prop),
 (forall n, existsC X (fun x => ~~In x l /\ P n x)) ->
 existsC X (fun x => In x l /\ forall n, existsC nat (fun m => (n <= m)%nat /\ (P m x))).
Proof.
 intros X l.
 induction l; intros P HP G.
  apply (HP O).
  intros x [Hx _].
  auto with *.
 apply (G a).
 split; auto with *.
 intros n Hn.
 set (P':= fun m => P (m+n)%nat).
 assert (HP' : forall m : nat, existsC X (fun x => ~~In x l /\ P' m x)).
  intros m.
  unfold P'.
  destruct (HP (m + n)%nat) as [HG | y [Hy0 Hy1]] using existsC_ind.
   apply existsC_stable; auto.
  apply existsWeaken.
  exists y.
  split; auto.
  revert Hy0.
  cut (In y (a  :: l) -> In y l);[tauto|].
  intros Hy0.
  destruct Hy0; auto.
  elim (Hn (m + n)%nat).
  rewrite H.
  auto with *.
 destruct (IHl P' HP') as [HG | x [Hx0 Hx1]] using existsC_ind.
  tauto.
 apply (G x).
 split; auto with *.
 unfold P' in Hx1.
 intros n0.
 destruct (Hx1 n0) as [HG | m [Hm0 Hm1]] using existsC_ind.
  apply existsC_stable; auto.
 apply existsWeaken.
 exists (m + n)%nat.
 split; auto.
 auto with *.
Qed.

(**
This weaker version of the pidgen hole principle uses a function to select
elements from a list instead of a releation.  It may be more convienent to
use at times.
*)
Lemma infinitePidgeonHolePrinicpleB :
 forall (X:Type) (l:list X) (f:nat -> X),
 (forall n, In (f n) l) ->
 existsC X (fun x => In x l /\ forall n, existsC nat (fun m => (n <= m)%nat /\ (f m)=x)).
Proof.
 intros X l f H.
 apply infinitePidgeonHolePrinicple.
 intros n.
 apply existsWeaken.
 exists (f n).
 auto with *.
Qed.


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (C) 2010-2012, ENS de Lyon.
Copyright (C) 2010-2016, Inria.
Copyright (C) 2014-2016, IRIT.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import BinPos.
From Flocq Require Import Raux.
From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop.

Require Import Interval.
Require Import Datatypes Basic_rec.

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

Module TaylorPoly (C : FullOps) (P : PolyOps C).
(** Needs functions defining the recurrences, as well as rec1, rec2, grec1. *)

Definition cst_rec (x : C.T) (n : nat) := C.mask C.zero x.

Definition var_rec (a b : C.T) (n : nat) := C.mask (C.mask C.zero a) b.

Definition T_cst c (x : C.T) := P.rec1 cst_rec (C.mask c x).
(** Note that in addition to the Taylor expansion point that is
the 2nd parameter of T_cst, the first one is the value of
the constant itself. *)

Definition T_var x := P.rec2 var_rec x (C.mask C.one x).

Section PrecIsPropagated1.
Variable u : C.U.

Definition inv_rec (x : C.T) (a : C.T) (n : nat) : C.T := C.div u a (C.opp x).

Definition exp_rec (a : C.T) (n : nat) : C.T := C.div u a (C.from_nat n).

Definition sin_rec (a b : C.T) (n : nat) : C.T :=
  C.div u (C.opp a) (C.mul u (C.from_nat n) (C.from_nat n.-1)).

Definition cos_rec (a b : C.T) (n : nat) : C.T :=
  C.div u (C.opp a) (C.mul u (C.from_nat n) (C.from_nat n.-1)).

Definition pow_aux_rec (p : Z) (x : C.T) (_ : C.T) (n : nat)
  := if Z.ltb p Z0 || Z.geb p (Z.of_nat n) then
        C.power_int u x (p - Z.of_nat n)%Z
     else C.mask C.zero x.

(* Erik: These notations could be used globally *)
Local Notation "i + j" := (C.add u i j).
Local Notation "i - j" := (C.sub u i j).
Local Notation "i * j" := (C.mul u i j).
Local Notation "i / j" := (C.div u i j).

Definition sqrt_rec (x : C.T) (a : C.T) (n : nat) :=
  let nn := C.from_nat n in
  let n1 := C.from_nat n.-1 in
  let one := C.from_nat 1 in
  let two := C.from_nat 2 in
  (one - two * n1) * a / (two * x * nn).

Definition invsqrt_rec (x : C.T) (a : C.T) (n : nat) :=
  let nn := C.from_nat n in
  let n1 := C.from_nat n.-1 in
  let one := C.from_nat 1 in
  let two := C.from_nat 2 in
  C.opp (one + two * n1) * a / (two * x * nn).

(*
Definition ln_rec (x : T) (a b : T) (n : nat) :=
  let nn := tnat n in
  let n1 := tnat n.-1 in
  let n2 := tnat n.-2 in
  topp (n1 * b) / (nn * x).

Definition Deriv_atan J := tinv u (tnat 1 + (tsqr u J)).

(* (2*loc0+2*a*loc1-(loc0+2*a*loc1)*(i1+1))/((1+a^2)*(i1+1)) *)
Definition atan_rec (x0 : T) (a b : T) (np2 : nat) :=
  let n := tnat (np2.-2) in
  let one := tnat 1 in
  let two := tnat 2 in
(*(two*loc0+two*a*loc1-(loc0+two*a*loc1)*(nn))/((one+a*a)*(nn)). (*OLD*)*)
topp ((n*a+two*b*x0*n+two*b*x0) / (n+n*(tsqr u x0)+two+two*(tsqr u x0))).
(* topp ((nn*u+two*v*a*nn+two*v*a)/((one+(tsqr a))*(nn+two)). (*TESTER*)*)

Definition Deriv_asin (x : T) := (tinvsqrt u (tnat 1 - tsqr u x)).

(* -(u(n+1)*(n+1)*(1+2*n)*z0+n^2*u(n))/((n+1)*(n+2)*z0^2-(n+1)*(n+2)) *)
Definition asin_rec (x : T) (a b : T) (n : nat) :=
  let nn := tnat n in
  let n1 := tnat n.-1 in
  let n2 := tnat n.-2 in
  let one := tnat 1 in
  let two := tnat 2 in
  (b*(n1)*(one+two*n2)*x+n2*n2*a)/((n1)*(nn)*(one-tsqr u x)).

Definition Deriv_acos x := (* Eval unfold Deriv_asin in *)
  topp (Deriv_asin x).

Definition acos_rec := asin_rec. (* acos & asin satisfy the same diffeq *)
*)

End PrecIsPropagated1.

Section PrecIsPropagated2.
Variable u : P.U.

(*
Definition T_ln x := trec2 (ln_rec u x) (tln u x) (C.inv u x).
Definition T_atan x := trec2 (atan_rec u x) (tatan u x) (Deriv_atan u x).
Definition T_asin x := trec2 (asin_rec u x) (tasin u x) (Deriv_asin u x).
Definition T_acos x := trec2 (acos_rec u x) (tacos u x) (Deriv_acos u x).
*)

Definition T_inv x := P.rec1 (inv_rec u x) (C.inv u x).

Definition T_exp x := P.rec1 (exp_rec u) (C.exp u x).

Definition T_sin x := P.rec2 (sin_rec u) (C.sin u x) (C.cos u x).

Definition T_cos x := P.rec2 (cos_rec u) (C.cos u x) (C.opp (C.sin u x)).

Definition T_sqrt x := P.rec1 (sqrt_rec u x) (C.sqrt u x).

Definition T_invsqrt x := P.rec1 (invsqrt_rec u x) (C.invsqrt u x).

Definition T_power_int (p : Z) x (n : nat) :=
  P.dotmuldiv u (falling_seq p n) (fact_seq n)
              (P.rec1 (pow_aux_rec u p x) (C.power_int u x p) n).

Definition T_tan x :=
  let polyX := P.lift 1 P.one (* in monomial basis *) in
  let J := C.tan u x in
  let s := [::] in
  let F q n :=
    let q' := P.deriv u q in
    P.div_mixed_r u (P.add u q' (P.lift 2 q')) (C.from_nat n) in
  let G q _ := P.horner u q J (* in monomial basis *) in
  P.grec1 F G polyX s.

Definition T_atan x :=
  let q1 := P.one in
  let J := C.atan u x in
  let s := [:: J] in
  let F q n :=
    let q2nX := P.mul_mixed u (C.from_nat ((n.-1).*2)) (P.lift 1 q) in
    let q' := P.deriv u q in
    P.div_mixed_r u (P.sub u (P.add u q' (P.lift 2 q')) q2nX) (C.from_nat n) in
  let G q n :=
    C.div u (P.horner u q x)
      (C.power_int u (C.add u C.one (C.sqr u x)) (Z_of_nat n)) in
  P.grec1 F G q1 s.

Definition T_ln x n :=
  let lg := C.ln u x in
  let y := C.mask x lg in
  P.polyCons lg
  (if n is n'.+1 then
     let p1 := (-1)%Z in
     P.dotmuldiv u (falling_seq p1 n') (behead (fact_seq n))
                  (P.rec1 (pow_aux_rec u p1 y) (C.power_int u y p1) n')
   else P.polyNil).

End PrecIsPropagated2.
End TaylorPoly.