(* PosOrder.v *)

Require Import Utf8.
Require Import QArith.
Require Import NPeano.
Require Import Sorted.

Require Import Misc.
Require Import NbarM.
Require Import QbarM.
Require Import SplitList.
Require Import Field2.
Require Import Fpolynomial.
Require Import Fsummation.
Require Import Newton.
Require Import ConvexHull.
Require Import ConvexHullMisc.
Require Import PolyConvexHull.
Require Import Puiseux_base.
Require Import Power_series.
Require Import Puiseux_series.
Require Import Ps_add.
Require Import Ps_mul.
Require Import Ps_div.
Require Import PSpolynomial.
Require Import AlgCloCharPol.
Require Import CharactPolyn.
Require Import F1Eq.

Set Implicit Arguments.

Theorem ps_lap_in_compat : ∀ α (R : ring α) (K : field R) a b la lb,
  (a = b)%ps
  → (la = lb)%pslap
    → ps_lap_in a la
      → ps_lap_in b lb.
Proof.
intros α R K a b la lb Hab Hlab Hla.
unfold ps_lap_eq in Hlab.
revert a b Hab lb Hlab Hla.
induction la as [| c]; intros; [ contradiction | idtac ].
simpl in Hla.
destruct Hla as [(Hcla, Hca)| Hla].
 destruct lb as [| d]; [ contradiction | idtac ].
 apply lap_eq_cons_inv in Hlab.
 destruct Hlab as (Hcd, Hlab).
 left.
 split.
  intros H; apply Hcla; clear Hcla.
  rewrite <- H.
  constructor; assumption.

  rewrite <- Hcd, <- Hab; assumption.

 simpl.
 destruct lb as [| d].
  apply lap_eq_cons_nil_inv in Hlab.
  destruct Hlab as (Hc, Hlab).
  eapply IHla; eassumption.

  apply lap_eq_cons_inv in Hlab.
  destruct Hlab as (Hcd, Hlab).
  right.
  eapply IHla; eassumption.
Qed.

Add Parametric Morphism α (R : ring α) (K : field R) : (@ps_lap_in α R K)
  with signature eq_ps ==> (@lap_eq _ (ps_ring K)) ==> iff
  as list_in_eq_ps_morph.
Proof.
intros a b Hab la lb Hlab.
split; intros Hl.
 eapply ps_lap_in_compat; eassumption.

 symmetry in Hab, Hlab.
 eapply ps_lap_in_compat; eassumption.
Qed.

Definition g_lap_of_ns α {R : ring α} {K : field R}
    {acf : algeb_closed_field K} f L :=
  let c₁ := ac_root (Φq f L) in
  let pl := [ini_pt L … oth_pts L ++ [fin_pt L]] in
  let tl := List.map (term_of_point f) pl in
  let l₁ := List.map (λ t, power t) tl in
  let l₂ := list_seq_except 0 (length (al f)) l₁ in
  ([ps_monom 1%K (- β L)] *
   (ps_lap_summ ps_field l₁
      (λ h,
       let āh := ps_poly_nth h f in
       let ah := ps_monom (coeff_of_term R h tl) 0 in
       let αh := ord_of_pt h pl in
       [((āh - ah * ps_monom 1%K αh) * ps_monom 1%K (Qnat h * γ L))%ps] *
       [ps_monom c₁ 0; 1%ps … []] ^ h) +
    ps_lap_summ ps_field l₂
      (λ l,
       let āl := ps_poly_nth l f in
       [(āl * ps_monom 1%K (Qnat l * γ L))%ps] *
       [ps_monom c₁ 0; 1%ps … []] ^ l)))%pslap.

Definition g_of_ns α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} f L := (POL (g_lap_of_ns f L))%pol.

Section theorems.

Variable α : Type.
Variable R : ring α.
Variable K : field R.
Variable acf : algeb_closed_field K.

Theorem coeff_of_hl_eq_order : ∀ h la li,
  h ∈ li
  → coeff_of_hl K la h li = order_coeff (List.nth h la 0%ps).
Proof.
intros h la li Hh.
induction li as [| i]; [ contradiction | simpl ].
destruct (eq_nat_dec h i) as [| Hhi]; [ subst; reflexivity | idtac ].
apply IHli.
apply Nat.neq_sym in Hhi.
destruct Hh as [Hh| ]; [ contradiction | assumption ].
Qed.

(* [Walker, p 101] « O(āh - ah.x^αh) > 0 » (with fixed typo) *)
Theorem order_āh_minus_ah_xαh_gt_αh : ∀ f L pl tl h āh ah αh,
  newton_segments f = Some L
  → pl = [ini_pt L … oth_pts L ++ [fin_pt L]]
    → tl = List.map (term_of_point f) pl
      → h ∈ List.map (λ t, power t) tl
        → āh = ps_poly_nth h f
          → ah = ps_monom (coeff_of_term R h tl) 0
            → αh = ord_of_pt h pl
              → (order (āh - ah * ps_monom 1%K αh)%ps > qfin αh)%Qbar.
Proof.
intros f L pl tl h āh ah αh HL Hpl Htl Hh Hāh Hah Hαh.
remember HL as Hval; clear HeqHval.
eapply order_in_newton_segment with (h := h) (αh := αh) in Hval; eauto .
 rewrite <- Hāh in Hval.
 unfold order, Qbar.gt.
 remember (āh - ah * ps_monom 1%K αh)%ps as s eqn:Hs .
 remember (series_order (ps_terms s) 0) as n eqn:Hn .
 symmetry in Hn.
 destruct n as [n| ]; [ idtac | constructor ].
 apply Qbar.qfin_lt_mono.
 unfold order in Hval.
 remember (series_order (ps_terms āh) 0) as m eqn:Hm .
 symmetry in Hm.
 destruct m as [m| ]; [ idtac | discriminate Hval ].
 injection Hval; clear Hval; intros Hval.
 rewrite <- Hval.
 subst s; simpl.
 unfold cm; simpl.
 unfold cm; simpl.
 subst ah; simpl.
 unfold ps_ordnum_add; simpl.
 unfold cm, cm_factor; simpl.
 rewrite Z.mul_1_r.
 unfold Qlt; simpl.
 rewrite Pos2Z.inj_mul.
 rewrite Z.mul_assoc.
 rewrite Z.mul_shuffle0.
 apply Z.mul_lt_mono_pos_r; [ apply Pos2Z.is_pos | idtac ].
 rewrite <- Hval; simpl.
 rewrite Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
 rewrite Z.min_l.
  rewrite Z.mul_add_distr_r.
  apply Z.add_lt_mono_l.
  rewrite <- positive_nat_Z, <- Nat2Z.inj_mul.
  apply Nat2Z.inj_lt.
  apply Nat.nle_gt; intros Hmn.
  apply series_order_iff in Hn.
  remember ps_add as g; simpl in Hn; subst g.
  destruct Hn as (Hni, Hn).
  remember (ps_monom (coeff_of_term R h tl) 0 * ps_monom 1%K αh)%ps as v.
  simpl in Hn.
  unfold cm, cm_factor in Hn; simpl in Hn.
  subst v; simpl in Hn.
  unfold cm in Hn; simpl in Hn.
  rewrite Z.mul_1_r in Hn.
  rewrite <- Hval in Hn; simpl in Hn.
  rewrite Z.min_l in Hn.
   rewrite Z.sub_diag in Hn; simpl in Hn.
   rewrite Nat.sub_0_r in Hn.
   rewrite Z.min_r in Hn.
    destruct (zerop (n mod Pos.to_nat (ps_polydo āh))) as [Hnp| Hnp].
     apply Nat.mod_divides in Hnp; auto with Arith.
     destruct Hnp as (p, Hp).
     rewrite Nat.mul_comm in Hp.
     rewrite Hp in Hmn.
     apply Nat.mul_le_mono_pos_r in Hmn; [ idtac | apply Pos2Nat.is_pos ].
     rewrite Hp in Hn.
     rewrite Nat.div_mul in Hn; auto with Arith; simpl in Hn.
     rewrite Z.mul_add_distr_r in Hn.
     rewrite Z.add_simpl_l in Hn.
     rewrite Z2Nat.inj_mul in Hn; simpl in Hn.
      rewrite Nat2Z.id in Hn.
      rewrite <- Hp in Hn.
      destruct (eq_nat_dec p m) as [Hpm| Hpm].
       subst p.
       rewrite <- Hp, Nat.sub_diag in Hn.
       destruct (lt_dec n n) as [Hnn| Hnn].
        revert Hnn; apply Nat.lt_irrefl.

        rewrite Nat.mod_0_l in Hn; auto with Arith; simpl in Hn.
        rewrite Nat.div_0_l in Hn; auto with Arith; simpl in Hn.
        unfold convol_mul in Hn.
        simpl in Hn.
        unfold summation in Hn; simpl in Hn.
        rewrite Nat.mod_0_l in Hn; auto with Arith; simpl in Hn.
        rewrite Nat.div_0_l in Hn; auto with Arith; simpl in Hn.
        rewrite rng_mul_1_r, rng_add_0_r in Hn.
        rewrite Htl in Hn.
        rewrite coeff_of_term_pt_eq in Hn.
        rewrite Hāh in Hn; simpl in Hn.
        unfold ps_poly_nth, ps_lap_nth in Hn; simpl in Hn.
        rewrite Hāh in Hm.
        unfold coeff_of_pt in Hn.
        rewrite coeff_of_hl_eq_order in Hn.
         unfold order_coeff in Hn.
         unfold ps_poly_nth, ps_lap_nth in Hm.
         rewrite Hm in Hn.
         rewrite rng_add_opp_r in Hn.
         apply Hn; reflexivity.

         subst tl; simpl in Hh.
         revert Hh; clear; intros.
         induction pl as [| (i, ai)]; [ assumption | simpl ].
         simpl in Hh.
         destruct Hh as [Hh| Hh]; [ left; assumption | idtac ].
         right; apply IHpl; assumption.

       destruct (lt_dec n (m * Pos.to_nat (ps_polydo āh))) as [Hnp| Hnp].
        apply series_order_iff in Hm.
        destruct Hm as (Hmi, Hm).
        apply Nat_le_neq_lt in Hmn; [ idtac | assumption ].
        apply Hmi in Hmn.
        rewrite rng_add_0_r in Hn; contradiction.

        apply Hnp.
        rewrite Hp.
        apply Nat.mul_lt_mono_pos_r; [ apply Pos2Nat.is_pos | idtac ].
        apply Nat_le_neq_lt; assumption.

      apply Nat2Z.is_nonneg.

      apply Pos2Z.is_nonneg.

     rewrite rng_add_0_l in Hn.
     rewrite Z.mul_add_distr_r in Hn.
     rewrite Z.add_simpl_l in Hn.
     rewrite Z2Nat.inj_mul in Hn; simpl in Hn.
      rewrite Nat2Z.id in Hn.
      destruct (lt_dec n (m * Pos.to_nat (ps_polydo āh))) as [Hnm| Hnm].
       apply Hn; reflexivity.

       apply Hnm; clear Hnm.
       destruct (eq_nat_dec n (m * Pos.to_nat (ps_polydo āh))) as [Heq| Hne].
        rewrite Heq in Hnp.
        rewrite Nat.mod_mul in Hnp; auto with Arith.
        exfalso; revert Hnp; apply Nat.lt_irrefl.

        apply Nat_le_neq_lt; assumption.

      apply Nat2Z.is_nonneg.

      apply Pos2Z.is_nonneg.

    rewrite Z.mul_add_distr_r.
    apply Z.le_sub_le_add_l.
    rewrite Z.sub_diag, <- positive_nat_Z, <- Nat2Z.inj_mul.
    apply Nat2Z.is_nonneg.

   rewrite Z.mul_add_distr_r.
   apply Z.le_sub_le_add_l.
   rewrite Z.sub_diag, <- positive_nat_Z, <- Nat2Z.inj_mul.
   apply Nat2Z.is_nonneg.

  apply Z.le_sub_le_add_l.
  rewrite Z.sub_diag.
  apply Nat2Z.is_nonneg.

 rewrite Hαh.
 rewrite Htl in Hh; simpl in Hh.
 rewrite List.map_map in Hh.
 simpl in Hh.
 apply ord_is_ord_of_pt; [ idtac | idtac | assumption ].
  rewrite Hpl.
  eapply ini_oth_fin_pts_sorted; eassumption.

  intros pt Hpt.
  eapply points_in_newton_segment_have_nat_abscissa; [ eassumption | idtac ].
  subst pl; assumption.
Qed.

(* [Walker, p 101] « O(āl.x^(l.γ₁)) > β₁ » *)
Theorem order_āl_xlγ₁_gt_β₁ : ∀ f L pl tl l₁ l₂ l āl,
  newton_segments f = Some L
  → pl = [ini_pt L … oth_pts L ++ [fin_pt L]]
    → tl = List.map (term_of_point f) pl
      → l₁ = List.map (λ t, power t) tl
        → split_list (List.seq 0 (length (al f))) l₁ l₂
          → l ∈ l₂
            → āl = ps_poly_nth l f
              → (order (āl * ps_monom 1%K (Qnat l * γ L))%ps >
                 qfin (β L))%Qbar.
Proof.
intros f L pl tl l₁ l₂ l āl HL Hpl Htl Hl₁ Hsl Hl Hāl.
remember (āl * ps_monom 1%K (Qnat l * γ L))%ps as s eqn:Hs .
remember (series_order (ps_terms s) 0) as n eqn:Hn .
symmetry in Hn.
destruct n as [n| ].
 remember (points_of_ps_polynom f) as pts eqn:Hpts .
 remember Hpts as Hval; clear HeqHval.
 remember (order āl) as m eqn:Hm .
 symmetry in Hm.
 destruct m as [m| ].
  eapply in_pol_in_pts in Hval; try eassumption.
  remember HL as H; clear HeqH.
  eapply points_not_in_any_newton_segment with (αh := m) (h := Qnat l) in H;
   try eassumption.
   unfold order, Qbar.gt.
   rewrite Hn.
   apply Qbar.qfin_lt_mono.
   remember (β L) as βL.
   remember (γ L) as γL.
   rewrite Hs, Hāl; simpl.
   unfold cm; simpl.
   rewrite <- Hāl.
   eapply Qlt_le_trans; [ eassumption | idtac ].
   unfold Qle; simpl.
   do 2 rewrite Pos2Z.inj_mul.
   do 2 rewrite Z.mul_assoc.
   apply Z.mul_le_mono_pos_r; [ apply Pos2Z.is_pos | idtac ].
   do 3 rewrite Z.mul_add_distr_r.
   rewrite Z.add_shuffle0.
   apply Z.add_le_mono.
    unfold order in Hm.
    remember (series_order (ps_terms āl) 0) as p eqn:Hp .
    symmetry in Hp.
    destruct p as [p| ]; [ idtac | discriminate Hm ].
    injection Hm; clear Hm; intros Hm.
    rewrite <- Hm; simpl.
    do 2 rewrite Z.mul_add_distr_r.
    apply Z.add_le_mono_l.
    apply Z.mul_le_mono_pos_r; [ apply Pos2Z.is_pos | idtac ].
    rewrite <- positive_nat_Z.
    rewrite <- Nat2Z.inj_mul.
    apply Nat2Z.inj_le.
    rewrite Hs in Hn; simpl in Hn.
    unfold cm_factor in Hn; simpl in Hn.
    apply series_order_iff in Hn; simpl in Hn.
    apply series_order_iff in Hp; simpl in Hp.
    destruct Hn as (Hni, Hn).
    destruct Hp as (Hpi, Hp).
    unfold convol_mul in Hn.
    rewrite summation_only_one_non_0 with (v := n) in Hn.
     rewrite Nat.sub_diag in Hn; simpl in Hn.
     rewrite Nat.mod_0_l in Hn; auto with Arith; simpl in Hn.
     rewrite Nat.div_0_l in Hn; auto with Arith; simpl in Hn.
     rewrite rng_mul_1_r in Hn.
     destruct (zerop (n mod Pos.to_nat (Qden (γL)))) as [Hng| Hng].
      apply Nat.mod_divides in Hng; auto with Arith.
      destruct Hng as (g, Hg).
      rewrite Hg, Nat.mul_comm.
      apply Nat.mul_le_mono_l.
      rewrite Hg in Hn.
      rewrite Nat.mul_comm in Hn.
      rewrite Nat.div_mul in Hn; auto with Arith.
      apply Nat.nlt_ge.
      clear H; intros H.
      apply Hpi in H.
      contradiction.

      exfalso; apply Hn; reflexivity.

     split; [ apply Nat.le_0_l | reflexivity ].

     intros i (_, Hin) Hinn.
     apply rng_mul_eq_0.
     right.
     unfold series_stretch; simpl.
     destruct (zerop ((n - i) mod Pos.to_nat (ps_polydo āl))) as [Hz| Hz].
      apply Nat.mod_divides in Hz; auto with Arith.
      destruct Hz as (c, Hc).
      rewrite Nat.mul_comm in Hc; rewrite Hc.
      rewrite Nat.div_mul; auto with Arith.
      destruct c; [ idtac | reflexivity ].
      rewrite Nat.mul_0_l in Hc.
      apply Nat.sub_0_le in Hc.
      exfalso; apply Hinn, Nat.le_antisymm; auto with Arith.

      reflexivity.

    rewrite Z.mul_shuffle0; reflexivity.

   split; [ eassumption | idtac ].
   intros Hlm.
   apply split_list_comm in Hsl.
   eapply sorted_split_in_not_in in Hsl; try eassumption.
    apply Hsl; clear Hsl.
    subst l₁ tl pl.
    rewrite List.map_map; simpl.
    destruct Hlm as [Hlm| Hlm].
     left; rewrite Hlm; simpl.
     rewrite nat_num_Qnat; reflexivity.

     right.
     rewrite List.map_app; simpl.
     apply List.in_or_app.
     destruct Hlm as [Hlm| Hlm].
      right; rewrite Hlm.
      left; simpl; rewrite nat_num_Qnat; reflexivity.

      left.
      revert Hlm; clear; intros.
      remember (oth_pts L) as pts; clear Heqpts.
      induction pts as [| (i, ai)]; [ contradiction | idtac ].
      destruct Hlm as [Hlm| Hlm].
       injection Hlm; clear Hlm; intros; subst; simpl.
       left; rewrite nat_num_Qnat; reflexivity.

       right; apply IHpts, Hlm.

    remember (length (al f)) as len; clear.
    remember 0%nat as b; clear Heqb.
    revert b.
    induction len; intros; [ constructor | simpl ].
    constructor; [ apply IHlen | idtac ].
    destruct len; constructor.
    apply Nat.lt_succ_diag_r.

  unfold order in Hm.
  remember (series_order (ps_terms āl) 0) as v eqn:Hv .
  symmetry in Hv.
  destruct v; [ discriminate Hm | idtac ].
  apply ps_series_order_inf_iff in Hv.
  assert (s = 0)%ps as Hsz.
   rewrite Hs.
   rewrite Hv.
   rewrite ps_mul_0_l; reflexivity.

   apply order_inf in Hsz.
   rewrite Hsz; constructor.

 unfold order; simpl.
 rewrite Hn; constructor.
Qed.

Theorem order_mul : ∀ a b, (order (a * b)%ps = order a + order b)%Qbar.
Proof.
intros a b.
symmetry.
pose proof (ps_adjust_eq K a 0 (ps_polydo b)) as Ha.
pose proof (ps_adjust_eq K b 0 (ps_polydo a)) as Hb.
rewrite Hb in |- * at 1.
rewrite Ha in |- * at 1.
unfold order; simpl.
unfold cm_factor, cm; simpl.
do 2 rewrite series_shift_0.
remember (series_stretch (ps_polydo b) (ps_terms a)) as sa eqn:Hsa .
remember (series_stretch (ps_polydo a) (ps_terms b)) as sb eqn:Hsb .
remember (series_order sa 0) as na eqn:Hna .
remember (series_order sb 0) as nb eqn:Hnb .
remember (series_order (sa * sb)%ser 0) as nc eqn:Hnc .
symmetry in Hna, Hnb, Hnc.
destruct na as [na| ].
 destruct nb as [nb| ].
  destruct nc as [nc| ].
   simpl.
   rewrite Z.sub_0_r.
   rewrite Z.sub_0_r.
   unfold Qeq; simpl.
   symmetry.
   rewrite Pos2Z.inj_mul.
   rewrite Z.mul_assoc.
   rewrite Z.mul_shuffle0.
   apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
   symmetry.
   rewrite Pos2Z.inj_mul.
   rewrite Z.mul_assoc.
   rewrite Z.add_comm.
   rewrite Pos2Z.inj_mul.
   rewrite Z.mul_assoc.
   rewrite Z.mul_shuffle0.
   rewrite <- Z.mul_add_distr_r.
   rewrite <- Z.mul_add_distr_r.
   rewrite <- Z.mul_assoc.
   apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
   rewrite Z.add_comm.
   rewrite Z.add_shuffle1.
   rewrite <- Z.add_assoc.
   rewrite <- Z.add_assoc.
   apply Z.add_cancel_l.
   apply Z.add_cancel_l.
   apply series_order_iff in Hna; simpl in Hna.
   apply series_order_iff in Hnb; simpl in Hnb.
   apply series_order_iff in Hnc; simpl in Hnc.
   destruct Hna as (Hia, Hna).
   destruct Hnb as (Hib, Hnb).
   destruct Hnc as (Hic, Hnc).
   rewrite <- Nat2Z.inj_add.
   apply Nat2Z.inj_iff.
   destruct (lt_dec (na + nb) nc) as [Hlt| Hge].
    apply Hic in Hlt.
    unfold convol_mul in Hlt.
    rewrite summation_only_one_non_0 with (v := na) in Hlt.
     rewrite Nat.add_comm, Nat.add_sub in Hlt.
     apply fld_eq_mul_0_l in Hlt; try assumption; contradiction.

     split; [ apply Nat.le_0_l | apply le_plus_l ].

     intros i (_, Hiab) Hina.
     destruct (lt_dec i na) as [Hilt| Hige].
      rewrite Hia; [ idtac | assumption ].
      rewrite rng_mul_0_l; reflexivity.

      apply Nat.nlt_ge in Hige.
      rewrite Hib; [ rewrite rng_mul_0_r; reflexivity | idtac ].
      apply Nat.add_lt_mono_r with (p := i).
      rewrite Nat.sub_add; auto with Arith.
      rewrite Nat.add_comm.
      apply Nat.add_lt_mono_l, Nat_le_neq_lt; auto with Arith.

    apply Nat.nlt_ge in Hge.
    destruct (lt_dec nc (na + nb)) as [Hclt| Hcge].
     unfold convol_mul in Hnc.
     rewrite all_0_summation_0 in Hnc.
      exfalso; apply Hnc; reflexivity.

      intros h (_, Hhc).
      destruct (lt_dec h na) as [Hha| Hha].
       rewrite Hia; [ idtac | assumption ].
       rewrite rng_mul_0_l; reflexivity.

       destruct (lt_dec (nc - h) nb) as [Hhb| Hhb].
        rewrite Hib; [ idtac | assumption ].
        rewrite rng_mul_0_r; reflexivity.

        exfalso; apply Hhb; clear Hhb.
        apply Nat.add_lt_mono_r with (p := h).
        rewrite Nat.sub_add; auto with Arith.
        eapply Nat.lt_le_trans; eauto .
        rewrite Nat.add_comm.
        apply Nat.add_le_mono_l.
        apply Nat.nlt_ge in Hha; auto with Arith.

     apply Nat.nlt_ge in Hcge.
     apply Nat.le_antisymm; assumption.

   exfalso.
   apply series_order_iff in Hna; simpl in Hna.
   apply series_order_iff in Hnb; simpl in Hnb.
   apply series_order_iff in Hnc; simpl in Hnc.
   destruct Hna as (Hia, Hna).
   destruct Hnb as (Hib, Hnb).
   pose proof (Hnc (na + nb)%nat) as Hnab.
   unfold convol_mul in Hnab.
   destruct (le_dec na nb) as [Hab| Hab].
    rewrite summation_only_one_non_0 with (v := na) in Hnab.
     rewrite Nat.add_comm, Nat.add_sub in Hnab.
     apply fld_eq_mul_0_l in Hnab; try assumption; contradiction.

     split; [ apply Nat.le_0_l | apply le_plus_l ].

     intros i (_, Hiab) Hina.
     destruct (lt_dec i na) as [Hilt| Hige].
      rewrite Hia; [ idtac | assumption ].
      rewrite rng_mul_0_l; reflexivity.

      apply Nat.nlt_ge in Hige.
      rewrite Hib.
       rewrite rng_mul_0_r; reflexivity.

       apply Nat.add_lt_mono_r with (p := i).
       rewrite Nat.sub_add; auto with Arith.
       rewrite Nat.add_comm.
       apply Nat.add_lt_mono_l, Nat_le_neq_lt; auto with Arith.

    apply Nat.nle_gt in Hab.
    rewrite summation_only_one_non_0 with (v := na) in Hnab.
     rewrite Nat.add_comm, Nat.add_sub in Hnab.
     apply fld_eq_mul_0_l in Hnab; try assumption; contradiction.

     split; [ apply Nat.le_0_l | apply le_plus_l ].

     intros i (_, Hiab) Hina.
     destruct (lt_dec i na) as [Hilt| Hige].
      rewrite Hia; [ idtac | assumption ].
      rewrite rng_mul_0_l; reflexivity.

      apply Nat.nlt_ge in Hige.
      rewrite Hib; [ rewrite rng_mul_0_r; reflexivity | idtac ].
      apply Nat.add_lt_mono_r with (p := i).
      rewrite Nat.sub_add; auto with Arith.
      rewrite Nat.add_comm.
      apply Nat.add_lt_mono_l, Nat_le_neq_lt; auto with Arith.

  simpl.
  apply series_series_order_inf_iff in Hnb.
  rewrite Hnb in Hnc.
  rewrite rng_mul_0_r in Hnc.
  simpl in Hnc.
  rewrite series_order_series_0 in Hnc.
  subst nc; constructor.

 simpl.
 apply series_series_order_inf_iff in Hna.
 rewrite Hna in Hnc.
 rewrite rng_mul_0_l in Hnc.
 simpl in Hnc.
 rewrite series_order_series_0 in Hnc.
 subst nc; constructor.
Qed.

Theorem order_add : ∀ a b,
  (order (a + b)%ps ≥ Qbar.min (order a) (order b))%Qbar.
Proof.
intros a b.
unfold Qbar.ge.
set (k₁ := ps_polydo b).
set (k₂ := ps_polydo a).
set (v₁ := (ps_ordnum a * Zpos k₁)%Z).
set (v₂ := (ps_ordnum b * Zpos k₂)%Z).
set (n₁ := Z.to_nat (v₂ - Z.min v₁ v₂)).
set (n₂ := Z.to_nat (v₁ - Z.min v₁ v₂)).
pose proof (ps_adjust_eq K a n₂ k₁) as Ha.
pose proof (ps_adjust_eq K b n₁ k₂) as Hb.
rewrite Hb in |- * at 1.
rewrite Ha in |- * at 1.
rewrite eq_ps_add_add₂.
unfold ps_add₂.
unfold adjust_ps_from.
fold k₁ k₂.
fold v₁ v₂.
rewrite Z.min_comm.
fold n₁ n₂.
remember (adjust_ps n₂ k₁ a) as pa eqn:Hpa .
remember (adjust_ps n₁ k₂ b) as pb eqn:Hpb .
unfold order; simpl.
remember (ps_terms pa) as sa eqn:Hsa .
remember (ps_terms pb) as sb eqn:Hsb .
remember (series_order sa 0) as na eqn:Hna .
remember (series_order sb 0) as nb eqn:Hnb .
remember (series_order (sa + sb)%ser 0) as nc eqn:Hnc .
symmetry in Hna, Hnb, Hnc.
destruct na as [na| ].
 destruct nb as [nb| ].
  destruct nc as [nc| ]; [ simpl | constructor ].
  apply Qbar.le_qfin.
  rewrite Hpa, Hpb; simpl.
  subst k₁ k₂ n₁ n₂; simpl.
  unfold cm_factor; simpl.
  subst v₁ v₂; simpl.
  unfold cm_factor; simpl.
  rewrite Pos.mul_comm.
  rewrite Qmin_same_den.
  unfold Qle; simpl.
  apply Z.mul_le_mono_nonneg_r; [ apply Pos2Z.is_nonneg | idtac ].
  remember (ps_ordnum a * Zpos (ps_polydo b))%Z as ab.
  remember (ps_ordnum b * Zpos (ps_polydo a))%Z as ba.
  rewrite Z2Nat.id.
   rewrite Z2Nat.id.
    rewrite Z.sub_sub_distr.
    rewrite Z.sub_diag, Z.add_0_l.
    rewrite Z.sub_sub_distr.
    rewrite Z.sub_diag, Z.add_0_l.
    rewrite Z.add_min_distr_l.
    apply Z.add_le_mono_l.
    rewrite <- Nat2Z.inj_min.
    apply Nat2Z.inj_le.
    apply series_order_iff in Hna; simpl in Hna.
    apply series_order_iff in Hnb; simpl in Hnb.
    apply series_order_iff in Hnc; simpl in Hnc.
    remember ps_terms_add as f; simpl in Hnc; subst f.
    destruct Hna as (Hina, Hna).
    destruct Hnb as (Hinb, Hnb).
    destruct Hnc as (Hinc, Hnc).
    apply Nat.nlt_ge.
    intros Hc.
    apply Nat.min_glb_lt_iff in Hc.
    destruct Hc as (Hca, Hcb).
    apply Hina in Hca.
    apply Hinb in Hcb.
    rewrite Hca, Hcb in Hnc.
    rewrite rng_add_0_l in Hnc.
    apply Hnc; reflexivity.

    rewrite <- Z.sub_max_distr_l.
    rewrite Z.sub_diag.
    rewrite Z.max_comm, <- Z2Nat_id_max.
    apply Nat2Z.is_nonneg.

   rewrite <- Z.sub_max_distr_l.
   rewrite Z.sub_diag.
   rewrite <- Z2Nat_id_max.
   apply Nat2Z.is_nonneg.

  destruct nc as [nc| ]; [ simpl | constructor ].
  apply Qbar.le_qfin.
  unfold Qle; simpl.
  apply Z.mul_le_mono_pos_r; [ apply Pos2Z.is_pos | idtac ].
  apply Z.add_le_mono_l.
  apply Nat2Z.inj_le.
  apply series_series_order_inf_iff in Hnb.
  rewrite Hnb in Hnc.
  rewrite rng_add_0_r in Hnc.
  rewrite Hna in Hnc.
  injection Hnc; intros; subst na; reflexivity.

 simpl.
 apply series_series_order_inf_iff in Hna.
 rewrite Hna in Hnc.
 rewrite rng_add_0_l in Hnc.
 rewrite Hnb in Hnc; subst nc.
 destruct nb as [nb| ]; [ idtac | constructor ].
 apply Qbar.le_qfin.
 rewrite Hpa, Hpb; simpl.
 subst k₁ k₂ n₁ n₂; simpl.
 unfold cm_factor; simpl.
 subst v₁ v₂; simpl.
 unfold cm_factor; simpl.
 rewrite Pos.mul_comm.
 unfold Qle; simpl.
 apply Z.mul_le_mono_pos_r; [ apply Pos2Z.is_pos | idtac ].
 apply Z.add_le_mono_r.
 rewrite Z2Nat.id.
  rewrite Z2Nat.id.
   do 2 rewrite Z.sub_sub_distr.
   do 2 rewrite Z.sub_diag; simpl.
   reflexivity.

   rewrite <- Z.sub_max_distr_l.
   rewrite Z.sub_diag.
   rewrite <- Z2Nat_id_max.
   apply Nat2Z.is_nonneg.

  rewrite <- Z.sub_max_distr_l.
  rewrite Z.sub_diag.
  rewrite Z.max_comm.
  rewrite <- Z2Nat_id_max.
  apply Nat2Z.is_nonneg.
Qed.

Theorem list_in_ps_lap_in : ∀ a l,
  (a ≠ 0)%ps
  → a ∈ l
    → ps_lap_in a l.
Proof.
intros a l Ha Hal.
revert a Ha Hal.
induction l as [| x]; intros; [ assumption | idtac ].
destruct Hal as [Hal| Hal].
 subst a; left; split; [ idtac | reflexivity ].
 intros H.
 apply lap_eq_cons_nil_inv in H.
 destruct H; contradiction.

 right; apply IHl; assumption.
Qed.

Theorem ps_lap_nilp : ∀ la : list (puiseux_series α),
  {@lap_eq _ (ps_ring K) la []} +
  {not (@lap_eq _ (ps_ring K) la [])}.
Proof.
intros la.
induction la as [| a]; [ left; reflexivity | idtac ].
destruct IHla as [IHla| IHla].
 destruct (ps_zerop _ a) as [Ha| Ha].
  left.
  rewrite IHla, Ha.
  constructor; reflexivity.

  right.
  intros H; apply Ha.
  apply lap_eq_cons_nil_inv in H.
  destruct H; assumption.

 right.
 intros H; apply IHla.
 apply lap_eq_cons_nil_inv in H.
 destruct H; assumption.
Qed.

Theorem ps_lap_in_add : ∀ la lb,
  (∀ m, ps_lap_in m la → (order m > 0)%Qbar)
  → (∀ m, ps_lap_in m lb → (order m > 0)%Qbar)
    → (∀ m, ps_lap_in m (la + lb) → (order m > 0)%Qbar).
Proof.
intros la lb Hla Hlb m Hlab.
unfold ps_lap_add in Hlab.
destruct (ps_lap_nilp la) as [Hlaz| Hlanz].
 rewrite Hlaz in Hlab.
 rewrite lap_add_nil_l in Hlab.
 apply Hlb; assumption.

 destruct (ps_lap_nilp lb) as [Hlbz| Hlbnz].
  rewrite Hlbz in Hlab.
  rewrite lap_add_nil_r in Hlab.
  apply Hla; assumption.

  revert lb Hlb Hlab Hlbnz.
  induction la as [| a]; intros.
   simpl in Hlab.
   apply Hlb; assumption.

   rename m into n.
   simpl in Hlab.
   destruct lb as [| b]; [ apply Hla; assumption | idtac ].
   simpl in Hlab.
   destruct Hlab as [(Hlab, Hab)| Hlab].
    rewrite <- Hab.
    pose proof (order_add a b) as H.
    assert (order a > 0)%Qbar as Ha.
     apply Hla.
     left; split; [ assumption | reflexivity ].

     assert (order b > 0)%Qbar as Hb.
      apply Hlb.
      left; split; [ assumption | reflexivity ].

      unfold Qbar.ge in H.
      unfold Qbar.gt in Ha, Hb.
      destruct (Qbar.min_dec (order a) (order b)) as [Hoab| Hoab].
       rewrite Hoab in H.
       eapply Qbar.lt_le_trans; [ idtac | eassumption ].
       assumption.

       rewrite Hoab in H.
       eapply Qbar.lt_le_trans; [ idtac | eassumption ].
       assumption.

    destruct (ps_zerop _ a) as [Haz| Hanz].
     rewrite Haz in Hlanz.
     destruct (ps_zerop _ b) as [Hbz| Hbnz].
      rewrite Hbz in Hlbnz.
      eapply IHla.
       intros m Hm; apply Hla; right; assumption.

       intros HH; apply Hlanz.
       constructor; [ reflexivity | assumption ].

       intros m Hm; apply Hlb; right; eassumption.

       assumption.

       intros HH; apply Hlbnz.
       constructor; [ reflexivity | assumption ].

      clear Hlbnz.
      destruct (ps_lap_nilp lb) as [Hlbz| Hlbnz].
       rewrite Hlbz in Hlab.
       rewrite lap_add_nil_r in Hlab.
       apply Hla; right; assumption.

       eapply IHla.
        intros m Hm; apply Hla; right; assumption.

        intros HH; apply Hlanz.
        constructor; [ reflexivity | assumption ].

        intros m Hm; apply Hlb; right; eassumption.

        assumption.

        assumption.

     destruct (ps_zerop _ b) as [Hbz| Hbnz].
      rewrite Hbz in Hlbnz.
      clear Hlanz.
      destruct (ps_lap_nilp la) as [Hlaz| Hlanz].
       rewrite Hlaz in Hlab.
       rewrite lap_add_nil_l in Hlab.
       apply Hlb; right; assumption.

       eapply IHla.
        intros m Hm; apply Hla; right; assumption.

        assumption.

        intros m Hm; apply Hlb; right; eassumption.

        assumption.

        intros HH; apply Hlbnz.
        constructor; [ reflexivity | assumption ].

      clear Hlanz.
      clear Hlbnz.
      destruct (ps_lap_nilp la) as [Hlaz| Hlanz].
       rewrite Hlaz in Hlab.
       rewrite lap_add_nil_l in Hlab.
       apply Hlb; right; assumption.

       destruct (ps_lap_nilp lb) as [Hlbz| Hlbnz].
        rewrite Hlbz in Hlab.
        rewrite lap_add_nil_r in Hlab.
        apply Hla; right; assumption.

        eapply IHla.
         intros m Hm; apply Hla; right; assumption.

         assumption.

         intros m Hm; apply Hlb; right; eassumption.

         assumption.

         assumption.
Qed.

(* very close to 'ps_lap_in_add'. Is there a way to have only one theorem?
   or a theorem grouping these two together? *)
Theorem ps_lap_in_add_ge : ∀ la lb,
  (∀ m, ps_lap_in m la → (order m ≥ 0)%Qbar)
  → (∀ m, ps_lap_in m lb → (order m ≥ 0)%Qbar)
    → (∀ m, ps_lap_in m (la + lb) → (order m ≥ 0)%Qbar).
Proof.
intros la lb Hla Hlb m Hlab.
unfold ps_lap_add in Hlab.
destruct (ps_lap_nilp la) as [Hlaz| Hlanz].
 rewrite Hlaz in Hlab.
 rewrite lap_add_nil_l in Hlab.
 apply Hlb; assumption.

 destruct (ps_lap_nilp lb) as [Hlbz| Hlbnz].
  rewrite Hlbz in Hlab.
  rewrite lap_add_nil_r in Hlab.
  apply Hla; assumption.

  revert lb Hlb Hlab Hlbnz.
  induction la as [| a]; intros.
   simpl in Hlab.
   apply Hlb; assumption.

   rename m into n.
   simpl in Hlab.
   destruct lb as [| b]; [ apply Hla; assumption | idtac ].
   simpl in Hlab.
   destruct Hlab as [(Hlab, Hab)| Hlab].
    rewrite <- Hab.
    pose proof (order_add a b) as H.
    assert (order a ≥ 0)%Qbar as Ha.
     apply Hla.
     left; split; [ assumption | reflexivity ].

     assert (order b ≥ 0)%Qbar as Hb.
      apply Hlb.
      left; split; [ assumption | reflexivity ].

      unfold Qbar.ge in H.
      unfold Qbar.gt in Ha, Hb.
      destruct (Qbar.min_dec (order a) (order b)) as [Hoab| Hoab].
       rewrite Hoab in H.
       eapply Qbar.le_trans; [ idtac | eassumption ].
       assumption.

       rewrite Hoab in H.
       eapply Qbar.le_trans; [ idtac | eassumption ].
       assumption.

    destruct (ps_zerop _ a) as [Haz| Hanz].
     rewrite Haz in Hlanz.
     destruct (ps_zerop _ b) as [Hbz| Hbnz].
      rewrite Hbz in Hlbnz.
      eapply IHla.
       intros m Hm; apply Hla; right; assumption.

       intros HH; apply Hlanz.
       constructor; [ reflexivity | assumption ].

       intros m Hm; apply Hlb; right; eassumption.

       assumption.

       intros HH; apply Hlbnz.
       constructor; [ reflexivity | assumption ].

      clear Hlbnz.
      destruct (ps_lap_nilp lb) as [Hlbz| Hlbnz].
       rewrite Hlbz in Hlab.
       rewrite lap_add_nil_r in Hlab.
       apply Hla; right; assumption.

       eapply IHla.
        intros m Hm; apply Hla; right; assumption.

        intros HH; apply Hlanz.
        constructor; [ reflexivity | assumption ].

        intros m Hm; apply Hlb; right; eassumption.

        assumption.

        assumption.

     destruct (ps_zerop _ b) as [Hbz| Hbnz].
      rewrite Hbz in Hlbnz.
      clear Hlanz.
      destruct (ps_lap_nilp la) as [Hlaz| Hlanz].
       rewrite Hlaz in Hlab.
       rewrite lap_add_nil_l in Hlab.
       apply Hlb; right; assumption.

       eapply IHla.
        intros m Hm; apply Hla; right; assumption.

        assumption.

        intros m Hm; apply Hlb; right; eassumption.

        assumption.

        intros HH; apply Hlbnz.
        constructor; [ reflexivity | assumption ].

      clear Hlanz.
      clear Hlbnz.
      destruct (ps_lap_nilp la) as [Hlaz| Hlanz].
       rewrite Hlaz in Hlab.
       rewrite lap_add_nil_l in Hlab.
       apply Hlb; right; assumption.

       destruct (ps_lap_nilp lb) as [Hlbz| Hlbnz].
        rewrite Hlbz in Hlab.
        rewrite lap_add_nil_r in Hlab.
        apply Hla; right; assumption.

        eapply IHla.
         intros m Hm; apply Hla; right; assumption.

         assumption.

         intros m Hm; apply Hlb; right; eassumption.

         assumption.

         assumption.
Qed.

Theorem ps_lap_in_mul : ∀ la lb,
  (∀ m, ps_lap_in m la → (order m > 0)%Qbar)
  → (∀ m, ps_lap_in m lb → (order m ≥ 0)%Qbar)
    → (∀ m, ps_lap_in m (la * lb) → (order m > 0)%Qbar).
Proof.
intros la lb Hla Hlb m Hlab.
unfold ps_lap_mul in Hlab.
revert m lb Hlb Hlab.
induction la as [| a]; intros.
 rewrite lap_mul_nil_l in Hlab; contradiction.

 rewrite lap_mul_cons_l in Hlab.
 eapply ps_lap_in_add; [ idtac | idtac | eassumption ].
  intros n Hn.
  destruct (ps_zerop _ a) as [Ha| Ha].
   rewrite Ha in Hn.
   rewrite lap_eq_0 in Hn.
   rewrite lap_mul_nil_l in Hn; contradiction.

   assert (order a > 0)%Qbar as Hoa.
    apply Hla; left; split; [ idtac | reflexivity ].
    intros H.
    apply lap_eq_cons_nil_inv in H.
    destruct H; contradiction.

    revert Hlb Hn Hoa; clear -K; intros.
    rewrite lap_mul_const_l in Hn.
    induction lb as [| b]; [ contradiction | idtac ].
    simpl in Hn.
    destruct Hn as [(Hab, Hn)| Hn].
     rewrite <- Hn, order_mul.
     eapply Qbar.lt_le_trans; [ eassumption | idtac ].
     apply Qbar.le_sub_le_add_l.
     rewrite Qbar.sub_diag.
     destruct (ps_zerop _ b) as [Hb| Hb].
      rewrite Hb, order_0; constructor.

      apply Hlb; left; split; [ idtac | reflexivity ].
      intros H; apply Hb.
      apply lap_eq_cons_nil_inv in H.
      destruct H; assumption.

     apply IHlb; [ idtac | assumption ].
     intros p Hp.
     apply Hlb; right; assumption.

  intros n Hn.
  simpl in Hn.
  destruct Hn as [(Hab, Hn)| Hn].
   symmetry in Hn.
   rewrite Hn, order_0; constructor.

   eapply IHla; try eassumption.
   intros p Hp.
   apply Hla; right; assumption.
Qed.

Theorem ps_lap_in_mul_ge : ∀ la lb,
  (∀ m, ps_lap_in m la → (order m ≥ 0)%Qbar)
  → (∀ m, ps_lap_in m lb → (order m ≥ 0)%Qbar)
    → (∀ m, ps_lap_in m (la * lb) → (order m ≥ 0)%Qbar).
Proof.
intros la lb Hla Hlb m Hlab.
unfold ps_lap_mul in Hlab.
revert m lb Hlb Hlab.
induction la as [| a]; intros.
 rewrite lap_mul_nil_l in Hlab; contradiction.

 rewrite lap_mul_cons_l in Hlab.
 eapply ps_lap_in_add_ge; [ idtac | idtac | eassumption ].
  intros n Hn.
  destruct (ps_zerop _ a) as [Ha| Ha].
   rewrite Ha in Hn.
   rewrite lap_eq_0 in Hn.
   rewrite lap_mul_nil_l in Hn; contradiction.

   assert (order a ≥ 0)%Qbar as Hoa.
    apply Hla; left; split; [ idtac | reflexivity ].
    intros H.
    apply lap_eq_cons_nil_inv in H.
    destruct H; contradiction.

    revert Hlb Hn Hoa; clear -K; intros.
    rewrite lap_mul_const_l in Hn.
    induction lb as [| b]; [ contradiction | idtac ].
    simpl in Hn.
    destruct Hn as [(Hab, Hn)| Hn].
     rewrite <- Hn, order_mul.
     eapply Qbar.le_trans; [ eassumption | idtac ].
     apply Qbar.le_sub_le_add_l.
     rewrite Qbar.sub_diag.
     destruct (ps_zerop _ b) as [Hb| Hb].
      rewrite Hb, order_0; constructor.

      apply Hlb; left; split; [ idtac | reflexivity ].
      intros H; apply Hb.
      apply lap_eq_cons_nil_inv in H.
      destruct H; assumption.

     apply IHlb; [ idtac | assumption ].
     intros p Hp.
     apply Hlb; right; assumption.

  intros n Hn.
  simpl in Hn.
  destruct Hn as [(Hab, Hn)| Hn].
   symmetry in Hn.
   rewrite Hn, order_0; constructor.

   eapply IHla; try eassumption.
   intros p Hp.
   apply Hla; right; assumption.
Qed.

Theorem ps_lap_in_summation : ∀ f l,
  (∀ i, i ∈ l → ∀ m, ps_lap_in m (f i) → (order m > 0)%Qbar)
  → (∀ m, ps_lap_in m (ps_lap_summ ps_field l f) → (order m > 0)%Qbar).
Proof.
intros f l Hi m Hm.
revert m Hm.
induction l as [| j]; intros; [ contradiction | idtac ].
simpl in Hm.
apply ps_lap_in_add in Hm; [ assumption | idtac | idtac ].
 intros n Hn.
 apply IHl; [ idtac | assumption ].
 intros k Hk p Hp.
 eapply Hi; [ idtac | eassumption ].
 right; assumption.

 intros k Hk.
 eapply Hi; [ idtac | eassumption ].
 left; reflexivity.
Qed.

Theorem ps_monom_order : ∀ c n, (c ≠ 0)%K → order (ps_monom c n) = qfin n.
Proof.
intros c n Hc.
unfold order.
remember (series_order (ps_terms (ps_monom c n)) 0) as m eqn:Hm .
symmetry in Hm.
apply series_order_iff in Hm.
simpl in Hm; simpl.
destruct m as [m| ].
 destruct Hm as (Him, Hm).
 destruct m as [| m]; [ simpl | exfalso; apply Hm; reflexivity ].
 simpl in Hm.
 rewrite Z.add_0_r; destruct n; reflexivity.

 pose proof (Hm 0%nat); contradiction.
Qed.

Theorem ps_monom_0_order : ∀ c n, (c = 0)%K → order (ps_monom c n) = qinf.
Proof.
intros c n Hc.
unfold order.
remember (series_order (ps_terms (ps_monom c n)) 0) as m eqn:Hm .
symmetry in Hm.
apply series_order_iff in Hm.
simpl in Hm; simpl.
destruct m as [m| ]; [ exfalso | reflexivity ].
destruct Hm as (Him, Hm).
destruct m as [| m]; apply Hm; [ assumption | reflexivity ].
Qed.

Theorem ps_monom_order_ge : ∀ c n, (order (ps_monom c n) ≥ qfin n)%Qbar.
Proof.
intros c n.
unfold order.
remember (series_order (ps_terms (ps_monom c n)) 0) as m eqn:Hm .
symmetry in Hm.
unfold Qbar.ge.
destruct m as [m| ]; [ idtac | constructor ].
apply Qbar.le_qfin.
apply series_order_iff in Hm.
simpl in Hm; simpl.
destruct Hm as (Him, Hm).
destruct m as [| m]; [ simpl | exfalso; apply Hm; reflexivity ].
simpl in Hm.
rewrite Z.add_0_r; destruct n; simpl.
unfold Qle; simpl; reflexivity.
Qed.

Theorem ps_lap_in_power : ∀ la n,
  (∀ a, ps_lap_in a la → (order a ≥ 0)%Qbar)
  → (∀ m, ps_lap_in m (la ^ n) → (order m ≥ 0)%Qbar).
Proof.
intros la n Ha m Hm.
revert m la Ha Hm.
induction n; intros.
 simpl in Hm.
 destruct Hm as [(H₁, Hm)| ]; [ idtac | contradiction ].
 rewrite <- Hm.
 apply ps_monom_order_ge.

 simpl in Hm.
 eapply ps_lap_in_mul_ge in Hm; try eassumption.
 intros p Hp.
 eapply IHn; eassumption.
Qed.

(* [Walker, p 101 « each power of y₁ in g(x,y₁) has a coefficient of
   positive order » *)
Theorem each_power_of_y₁_in_g_has_coeff_pos_ord : ∀ f L g,
  newton_segments f = Some L
  → g = g_of_ns f L
    → ∀ m, m ∈ al g → (order m > 0)%Qbar.
Proof.
intros f L g HL Hg m Hm.
remember (al g) as la eqn:Hla .
subst g.
unfold g_of_ns, g_lap_of_ns in Hla.
remember (ac_root (Φq f L)) as c₁ eqn:Hc₁ .
remember [ini_pt L … oth_pts L ++ [fin_pt L]] as pl eqn:Hpl .
remember (List.map (term_of_point f) pl) as tl eqn:Htl .
remember (List.map (λ t, power t) tl) as l₁ eqn:Hl₁ .
remember (list_seq_except 0 (length (al f)) l₁) as l₂ eqn:Hl₂ .
simpl in Hla.
remember (order m) as om eqn:Hom .
symmetry in Hom.
destruct om as [om| ]; [ idtac | constructor ].
assert (m ≠ 0)%ps as Hmnz.
 intros H.
 apply order_inf in H.
 rewrite H in Hom; discriminate Hom.

 subst la.
 apply list_in_ps_lap_in in Hm; [ idtac | assumption ].
 progress unfold ps_lap_add in Hm.
 progress unfold ps_lap_mul in Hm.
 rewrite lap_mul_add_distr_l in Hm.
 rewrite <- Hom.
 apply ps_lap_in_add in Hm; [ assumption | idtac | idtac ].
  clear m om Hom Hmnz Hm.
  intros m Hm.
  progress unfold ps_lap_summ in Hm.
  rewrite lap_mul_summation in Hm.
  eapply ps_lap_in_summation; [ idtac | eassumption ].
  clear m Hm.
  intros h Hh m Hm.
  simpl in Hm.
  rewrite lap_mul_assoc in Hm.
  apply ps_lap_in_mul in Hm; [ assumption | idtac | idtac ].
   clear m Hm.
   intros m Hm.
   remember (ps_poly_nth h f) as āh eqn:Hāh .
   remember (ps_monom (coeff_of_term R h tl) 0) as ah eqn:Hah .
   remember (ord_of_pt h pl) as αh eqn:Hαh .
   rewrite lap_mul_const_l in Hm; simpl in Hm.
   destruct Hm as [(Hmnz, Hm)| ]; [ idtac | contradiction ].
   rewrite <- Hm; simpl.
   rewrite order_mul.
   remember (āh - ah * ps_monom 1%K αh)%ps as aa.
   remember (ps_monom 1%K (Qnat h * γ L))%ps as bb.
   remember (ps_monom 1%K (- β L)) as cc.
   remember (order (aa * bb)) as oaa.
   apply Qbar.lt_le_trans with (m := (qfin (- β L) + oaa)%Qbar).
    subst oaa.
    rewrite order_mul.
    rewrite Qbar.add_comm.
    rewrite Heqaa, Heqbb.
    apply Qbar.le_lt_trans with (m := qfin (αh + Qnat h * γ L - β L)).
     apply Qbar.le_qfin.
     apply Qplus_le_l with (z := β L).
     rewrite <- Qminus_minus_assoc.
     rewrite Qminus_diag.
     rewrite Qplus_0_l.
     unfold Qminus, Qopp; simpl.
     rewrite Qplus_0_r.
     remember (points_of_ps_polynom f) as pts.
     eapply points_in_convex; try eassumption.
     eapply in_pol_in_pts; try eassumption.
     rewrite Hāh.
     eapply order_in_newton_segment; try eassumption.
     rewrite Hαh.
     apply ord_is_ord_of_pt.
      rewrite Hpl.
      eapply ini_oth_fin_pts_sorted; eassumption.

      intros pt Hpt.
      rewrite Hpl in Hpt.
      eapply points_in_newton_segment_have_nat_abscissa; eassumption.

      rewrite Hl₁, Htl in Hh.
      rewrite List.map_map in Hh; assumption.

     unfold Qminus.
     rewrite Qbar.qfin_inj_add.
     apply Qbar.add_lt_mono_r; [ intros H; discriminate H | idtac ].
     rewrite Qbar.qfin_inj_add.
     apply Qbar.add_lt_le_mono; [ intros H; discriminate H | idtac | idtac ].
      rewrite Hl₁ in Hh.
      eapply order_āh_minus_ah_xαh_gt_αh; eassumption.

      apply ps_monom_order_ge.

    destruct oaa as [oaa| ].
     apply Qbar.add_le_mono_r; [ intros H; discriminate H | idtac ].
     subst cc; apply ps_monom_order_ge.

     simpl.
     rewrite Qbar.add_comm; constructor.

   clear m Hm.
   intros m Hm.
   eapply ps_lap_in_power; [ idtac | eassumption ].
   clear m Hm.
   intros m Hm.
   simpl in Hm.
   destruct Hm as [(Hn, Hm)| Hm].
    rewrite <- Hm.
    apply ps_monom_order_ge.

    destruct Hm as [(Hn, Hm)| ]; [ idtac | contradiction ].
    rewrite <- Hm.
    apply ps_monom_order_ge.

  clear m om Hom Hmnz Hm.
  intros m Hm.
  progress unfold ps_lap_summ in Hm.
  rewrite lap_mul_summation in Hm.
  eapply ps_lap_in_summation; [ idtac | eassumption ].
  clear m Hm.
  intros h Hh m Hm.
  simpl in Hm.
  rewrite lap_mul_assoc in Hm.
  apply ps_lap_in_mul in Hm; [ assumption | idtac | idtac ].
   clear m Hm.
   intros m Hm.
   simpl in Hm.
   destruct Hm as [(H₁, H₂)| Hm]; [ idtac | contradiction ].
   unfold summation in H₁, H₂; simpl in H₁, H₂.
   rewrite ps_add_0_r in H₂.
   rewrite <- H₂.
   rewrite order_mul.
   remember (ps_poly_nth h f) as āh.
   apply Qbar.lt_sub_lt_add_l; [ intros H; discriminate H | idtac ].
   rewrite Qbar.sub_0_l.
   destruct (fld_zerop 1%K) as [Hoz| Honz].
    rewrite ps_monom_0_order; [ simpl | assumption ].
    rewrite order_mul.
    rewrite ps_monom_0_order; [ simpl | assumption ].
    rewrite Qbar.add_comm; constructor.

    rewrite ps_monom_order; [ simpl | assumption ].
    rewrite Qopp_opp.
    eapply order_āl_xlγ₁_gt_β₁; try eassumption.
    apply except_split_seq; [ idtac | idtac | assumption ].
     subst l₁ tl.
     rewrite List.map_map; simpl.
     apply Sorted_map; simpl.
     remember HL as Hsort; clear HeqHsort.
     apply ini_oth_fin_pts_sorted in Hsort.
     rewrite <- Hpl in Hsort.
     pose proof (points_in_newton_segment_have_nat_abscissa K f HL)
      as Hnat.
     rewrite <- Hpl in Hnat.
     revert Hsort Hnat; clear; intros.
     induction pl as [| p]; [ constructor | idtac ].
     apply Sorted_inv in Hsort.
     destruct Hsort as (Hsort, Hrel).
     constructor.
      apply IHpl; [ assumption | idtac ].
      intros pt Hpt.
      apply Hnat; right; assumption.

      revert Hrel Hnat; clear; intros.
      induction pl as [| q]; constructor.
      apply HdRel_inv in Hrel.
      unfold fst_lt in Hrel; simpl.
      unfold nat_num; simpl.
      assert (p ∈ [p; q … pl]) as Hp by (left; reflexivity).
      assert (q ∈ [p; q … pl]) as Hq by (right; left; reflexivity).
      apply Hnat in Hp.
      apply Hnat in Hq.
      destruct Hp as (h, (αh, Hp)).
      destruct Hq as (i, (αi, Hq)).
      subst p q; simpl in Hrel; simpl.
      do 2 rewrite Nat2Z.id.
      apply Qnat_lt; assumption.

     subst l₁; simpl.
     apply List.Forall_forall; intros i Hi.
     split; [ apply Nat.le_0_l | idtac ].
     subst tl; simpl in Hi.
     rewrite List.map_map in Hi.
     simpl in Hi.
     revert HL Hpl Hi; clear; intros.
     apply ord_is_ord_of_pt in Hi.
      rewrite Hpl in Hi at 2.
      unfold newton_segments in HL.
      eapply ns_in_init_pts in Hi; [ idtac | eassumption ].
      eapply in_pts_in_pol with (def := 0%ps) in Hi; try reflexivity.
      destruct Hi as (Hi, Ho).
      apply Nat.nle_gt.
      intros H.
      apply List.nth_overflow with (d := 0%ps) in H.
      rewrite H in Ho.
      rewrite order_0 in Ho.
      discriminate Ho.

      rewrite Hpl.
      eapply ini_oth_fin_pts_sorted; eassumption.

      intros pt Hpt.
      subst pl.
      eapply points_in_newton_segment_have_nat_abscissa; eassumption.

   clear m Hm.
   intros m Hm.
   eapply ps_lap_in_power; [ idtac | eassumption ].
   intros a Ha.
   simpl in Ha.
   destruct Ha as [(Hn, Ha)| Ha].
    rewrite <- Ha.
    apply ps_monom_order_ge.

    destruct Ha as [(_, Ha)| Ha]; [ idtac | contradiction ].
    rewrite <- Ha; simpl.
    apply ps_monom_order_ge.
Qed.

End theorems.


Require Import VST.floyd.proofauto.
Require Import Core.Core Core.Notations.

Open Scope IntScope.

Fixpoint required_size_loop n z l :=
  match n with
  | O => l
  | S n => if z >>u (Int.repr l) * (Int.repr 7) == 0
          then l
          else required_size_loop n z (l + 1)%Z
  end.

Definition required_size z := required_size_loop 4%nat z 1%Z.

Lemma required_size_spec:
         forall l : int, forall i : Z,
           i = 1%Z \/ i = 2 \/ i = 3 \/ i = 4 \/ i = 5 ->
           (forall j : Z, 0 <= j < i ->
               (l >>u (Int.repr j) * (Int.repr 7)) == 0 = false) ->
                 l >>u (Int.repr i) * (Int.repr 7) = 0 ->
           required_size l = i.
Proof.
  intros l i N B SH.
  repeat break_or_hyp.
  * unfold required_size.
      cbn in *.
      rewrite SH.
      replace (0 == 0) with true by reflexivity;
      auto.
  * unfold required_size.
      cbn.
    do 1 erewrite B.
    autorewrite with norm in *.
    cbn in *.
    rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    normalize.
    nia.
  * unfold required_size;
      cbn.
    erewrite B.
    erewrite B.
     autorewrite with norm in *;
    cbn in *;
    rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    all: normalize;
    nia.
  * unfold required_size;
      cbn.
    erewrite B.
    erewrite B.
    erewrite B.
     rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    all: nia.
  * unfold required_size;
      cbn.
    erewrite B.
    erewrite B.
    erewrite B.
     erewrite B.
    all: nia.
Qed.

Fixpoint serialize_tag_loop s n t :=
  match n with
  | O => []
  | S n =>
     let b := Int.zero_ext 8
              (Int.repr 128 or
                        ((t >>u Int.repr (s * 7)) & Int.repr 127)) in
     serialize_tag_loop (s + 1)%Z n t ++ [b]
  end.

Definition serialize_tag t :=
  let s := required_size t in
  let n := Z.to_nat (s - 1) in
  serialize_tag_loop 0%Z n t ++ [Int.zero_ext 8 (t & Int.repr 127)].

Lemma loop_len_req_size : forall n l i,
    len (serialize_tag_loop i n l) = Z.of_nat n.
Proof.
  induction n; intros.
  - reflexivity.
  - simpl.
    erewrite Zlength_app.
    erewrite IHn.
    cbn.
    nia.
Qed.

Lemma req_size_32 : forall l, 1 <= required_size l <= 5.
Proof.
  intros.
  unfold required_size.
  cbn.
  repeat break_if; autorewrite with norm; nia.
Qed.

Open Scope Z.

Require Import ExtLib.Structures.Monad Types.

Inductive DWT_Error := .

 Delimit Scope monad_scope with monad.

  Notation "c >>= f" := (@bind _ _ _ _ c f) (at level 58, left associativity) : monad_scope.
  Notation "f =<< c" := (@bind _ _ _ _ c f) (at level 61, right associativity) : monad_scope.
  Notation "f >=> g" := (@mcompose _ _ _ _ _ f g) (at level 55, right associativity) : monad_scope.

  Notation "x <- c1 ;; c2" := (@bind _ _ _ _ c1 (fun x => c2))
    (at level 61, c1 at next level, right associativity) : monad_scope.

  Notation "e1 ;; e2" := (_ <- e1%monad ;; e2%monad)%monad
    (at level 61, right associativity) : monad_scope.

  Notation "' pat <- c1 ;; c2" :=
    (@bind _ _ _ _ c1 (fun x => match x with pat => c2 end))
    (at level 61, pat pattern, c1 at next level, right associativity) : monad_scope.

(*
Definition tag_serialize (tag size : int): errW1 asn_enc_rval :=
  let tclass := (tag & Int.repr 3)%int in
  let tval := tag >>u (Int.repr 2) in
  if 30 >=? Int.unsigned tval then
    if eq_dec size 0%int
    then raise (CustomError DWT_Error)
    else (tell1 [Int.zero_ext 8 ((tclass << Int.repr 6) or tval)]%int
               ;; ret (encode 1))
  else
    let r := required_size tval in
    if eq_dec size 0%int
       then raise (CustomError DWT_Error)
       else
         let t := (Int.zero_ext 8 ((tclass << Int.repr 6) or Int.repr 31))%int in
         tell1 [t] ;;
               if Int.unsigned size - 1 <? r
               then raise (CustomError DWT_Error)
               else
                 tell1 (serialize_tag tval) ;; ret (encode (r + 1)). *)

Definition tag_serialize (tag size : int): errW1 asn_enc_rval :=
  let tclass := (tag & Int.repr 3)%int in
  let tval := tag >>u (Int.repr 2) in
  if 30 >=? Int.unsigned tval then
    if eq_dec size 0%int
    then ret (encode 1)
    else tell1 [Int.zero_ext 8 ((tclass << Int.repr 6) or tval)]%int
               ;; ret (encode 1)
  else
    let r := required_size tval in
    if eq_dec size 0%int
    then (if Int.unsigned size - 1 <? r
          then ret (encode (r + 1))
          else
            tell1 (serialize_tag tval) ;; ret (encode (r + 1)))
       else
         let t := (Int.zero_ext 8 ((tclass << Int.repr 6) or Int.repr 31))%int in
         tell1 [t] ;;
               if Int.unsigned size - 1 <? r
               then  ret (encode (r + 1))
               else
                 tell1 (serialize_tag tval) ;; ret (encode (r + 1)).

(*
Lemma tag_serialize_req_size : forall l s,
    let (ls, z) := tag_serialize l s in
    z <> -1 -> len ls = z.
Proof.
intros.
unfold tag_serialize.
repeat break_if; auto; try nia.
intros.
pose proof (req_size_32 (l >>u Int.repr 2)).
unfold serialize_tag.
autorewrite with sublist list;
erewrite loop_len_req_size;
erewrite Z2Nat.id; try nia.
Qed.

Lemma tag_serialize_req_size_gt0 : forall l s,
    let (ls, z) := tag_serialize l s in
    z <> -1 -> 0 < z.
Proof.
intros.
unfold tag_serialize.
repeat break_if; auto; try nia.
intros.
pose proof (req_size_32 (l >>u Int.repr 2)).
nia.
Qed.

Lemma shr_lt_zero_35:
             forall x, Int.shru x (Int.repr 35)
                  = if Int.ltu x Int.zero then Int.mone else Int.zero.
Proof.
  intros. apply Int.same_bits_eq; intros.
  rewrite Int.bits_shru; auto.
  rewrite Int.unsigned_repr.
  transitivity (Int.testbit x (Int.zwordsize - 1)).
  f_equal.
Admitted.
*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export Setoid Morphisms Morphisms_Prop.

Set Implicit Arguments.

(* The following tactic uses solve_proper to solve the goals
relating to well-definedness that are produced by applying induction.
We declare it to take the tactic that applies the induction theorem
and not the induction theorem itself because the tactic may, for
example, supply additional arguments, as does NZinduct_center in
NZBase.v *)

Ltac induction_maker n t :=
  try intros until n; pattern n; t; clear n; [solve_proper | ..].


Require Import ssreflect.
(* Require Import Utf8. *)
From stdpp Require Import decidable tactics.

(* Provides stdpp decidable equality for naturals. *)
From stdpp Require Import numbers.
Require Import Program.
From Equations Require Import Equations.

(* Undo effects of loading stdpp. *)
Set Transparent Obligations.
Ltac eqn_simpl := program_simplify; Equations.CoreTactics.equations_simpl;
                              try program_solve_wf.
Obligation Tactic := eqn_simpl.

Set Suggest Proof Using.
Set Default Proof Using "Type*".
Implicit Types (n : nat).

Inductive kty : nat → Type :=
  | TTop : kty 0
  | TBot : kty 0
  | kTLam {n} (T : kty n) : kty (S n)

with kind : nat → Type :=
  | kintv (L U : kty 0) : kind 0
  | kpi {n} (T : kty 0) (K : kind n) : kind (S n).
Derive Signature for kty kind.

Derive NoConfusion NoConfusionHom for kty.
Show Obligation Tactic.

Fail Derive EqDec for kty kind.
Fail Derive EqDec for kty.
Obligation Tactic := idtac.
Fail Derive EqDec for kty.
Obligation Tactic := eqn_simpl.

(* Solve All Obligations with eqn_simpl. *)
(* Derive NoConfusion NoConfusionHom for kty.
Next Obligation. eqn_simpl. simplify_eq. vm_compute. Qed.
Derive NoConfusion NoConfusionHom for kty kind. *)

(* Comment in the { and } to fix the ? *)
Equations kty_eq_dec n (T1 T2 : kty n) : Decision (T1 = T2) by struct T1 :=
(* { *)
  kty_eq_dec n TTop TTop := left _;
  kty_eq_dec n TBot TBot := left _;
  kty_eq_dec _ (kTLam T1) (kTLam T2) :=
    let _ : ∀ n, EqDecision (kty n) := kty_eq_dec in
    cast_if (decide (T1 = T2)) ;
  kty_eq_dec _ _ _ := right _
(* } *)
with
kind_eq_dec n (K1 K2 : kind n): Decision (K1 = K2) by struct K1 :=
  kind_eq_dec 0 (kintv L1 U1) (kintv L2 U2) :=
    let _ : ∀ n, EqDecision (kty n) := kty_eq_dec in
    cast_if_and (decide (L1 = L2)) (decide (U1 = U2));
  kind_eq_dec n (kpi S1 K1) (kpi S2 K2) :=
    let _ : ∀ n, EqDecision (kty n) := kty_eq_dec in
    let _ : ∀ n, EqDecision (kind n) := kind_eq_dec in
    cast_if_and (decide (S1 = S2)) (decide (K1 = K2)).
Next Obligation. eqn_simpl; simplify_eq/=. Defined.

Next Obligation. eqn_simpl. simplify_eq. Defined.

About kind_eq_dec.


From Undecidability Require Import TM.Util.TM_facts.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.DepPairs EqdepFacts.

Set Default Goal Selector "!".

Section While.

  Variable n : nat.
  Variable sig : finType.

  Variable F : finType.
  (* Label [None] indicates continueing, [Some f] means breaking out of the loop and terminating in the label [f]. *)
  Variable pM : pTM sig (option F) n.

  Definition While_trans :
    (TM.state (projT1 pM)) * Vector.t (option sig) n ->
    (TM.state (projT1 pM)) * Vector.t (option sig * move) n :=
    fun '(q,s) =>
      if halt q
      then (start (projT1 pM), nop_action)
      else trans (q,s).

  Definition WhileTM : TM sig n :=
    Build_TM While_trans (start (projT1 pM))
              (fun q => halt q && match projT2 pM q with
                               | Some _ => true
                               | None => false
                               end).

  Hypothesis (defF : inhabitedC F).

  Definition While_part : state (projT1 pM) -> F :=
    fun q =>
      match projT2 pM q with
      | Some y => y
      | None => default
      end.

  Definition While : pTM sig F n :=
    (WhileTM; While_part).

  Local Arguments loopM {_ _} _ _ _.
  Local Arguments halt {_ _} _ _.
  Local Arguments step {_ _} _ _.

  Lemma step_comp (c : mconfig sig (state (projT1 pM)) n) :
    haltConf c = false ->
    step (projT1 pM) c = step WhileTM c.
  Proof.
    intros HHalt. unfold haltConf in HHalt.
    destruct c as [q t]. cbn in *.
    cbv [step]. cbn. rewrite HHalt. reflexivity.
  Qed.

  Lemma halt_comp (c : mconfig sig (state (projT1 pM)) n) :
    haltConf (M := projT1 pM) c = false ->
    haltConf (M := WhileTM)     c = false.
  Proof.
    intros HHalt. cbn in *.
    destruct c as [q t]. cbn in *.
    apply andb_false_iff. now left.
  Qed.

  Lemma While_trans_repeat (c : mconfig sig (state WhileTM) n) :
    haltConf (M := projT1 pM) c = true ->
    projT2 pM (cstate c) = None ->
    step WhileTM c = initc (WhileTM) (ctapes c).
  Proof.
    intros HHalt HRepeat. unfold haltConf in HHalt.
    destruct c as [q t]; cbn in *.
    unfold step. cbn -[doAct_multi] in *. rewrite HHalt. unfold initc. f_equal. apply doAct_nop.
  Qed.

  Lemma While_split k (c1 c3 : mconfig sig (state (projT1 pM)) n) :
    loopM WhileTM c1 k = Some c3 ->
    exists k1 k2 c2,
      loopM (projT1 pM) c1 k1 = Some c2 /\
      loopM WhileTM c2 k2 = Some c3 /\
      k1 + k2 <= k.
  Proof.
    unfold loopM. intros HLoop.
    apply loop_split with (h := haltConf (M := projT1 pM)) in HLoop as (k1&c2&k2&HLoop&HLoop'&Hk).
    - exists k1, k2, c2. repeat split; eauto.
      apply loop_lift with (lift := id) (f' := step (projT1 pM)) (h' := haltConf (M := projT1 pM)) in HLoop.
      + apply HLoop.
      + auto.
      + apply step_comp.
    - apply halt_comp.
  Qed.

  Lemma While_split_repeat k (c1 c2 : mconfig sig (state WhileTM) n) :
    loopM WhileTM c1 k = Some c2 ->
    haltConf (M := projT1 pM) c1 = true ->
    projT2 pM (cstate c1) = None ->
    exists k' : nat,
      k = S k' /\
      loopM WhileTM (initc WhileTM (ctapes c1)) k' = Some c2.
  Proof.
    intros HLoop HHalt HRepeat. unfold haltConf in HHalt.
    destruct k as [ | k']; cbn in *.
    - rewrite HHalt, HRepeat in HLoop. cbn in HLoop. inv HLoop.
    - rewrite HHalt, HRepeat in HLoop. cbn in HLoop. exists k'. split; [reflexivity|].
      now rewrite While_trans_repeat in HLoop by auto.
  Qed.

  Lemma While_split_term k (c1 c2 : mconfig sig (state WhileTM) n) (f : F) :
    loopM WhileTM c1 k = Some c2 ->
    haltConf (M := projT1 pM) c1 = true ->
    projT2 pM (cstate c1) = Some f ->
    c2 = c1.
  Proof.
    intros HLoop HHalt HTerm. unfold loopM in *.
    eapply loop_eq_0. 2: apply HLoop. unfold haltConf in *. cbn in *. now rewrite HHalt, HTerm.
  Qed.

  Lemma While_merge_repeat k1 k2 (c1 c2 c3 : mconfig sig (state WhileTM) n) :
    loopM (projT1 pM) c1 k1 = Some c2 ->
    (projT2 pM) (cstate c2) = None ->
    loopM WhileTM (initc WhileTM (ctapes c2)) k2 = Some c3 ->
    loopM WhileTM c1 (k1+(1+k2)) = Some c3.
  Proof.
    intros HLoop1 HRepeat HLoop2. unfold loopM in *.
    eapply loop_lift with (lift := id) (f' := step (WhileTM)) (h' := haltConf (M := projT1 pM)) in HLoop1; cbv [id] in *; cbn; auto; cycle 1.
    { intros. symmetry. now apply step_comp. }
    apply loop_merge with (h := haltConf (M := projT1 pM)) (a2 := c2).
    - apply halt_comp.
    - apply HLoop1.
    - cbn [loop plus]. rewrite While_trans_repeat; auto. 2: apply (loop_fulfills HLoop1).
      cbn in *. setoid_rewrite (loop_fulfills HLoop1). now rewrite HRepeat.
  Qed.

  Lemma While_merge_term k1 (c1 c2 : mconfig sig (state WhileTM) n) (f : F) :
    loopM (projT1 pM) c1 k1 = Some c2 ->
    (projT2 pM) (cstate c2) = Some f ->
    loopM WhileTM c1 k1 = Some c2.
  Proof.
    intros HLoop HTerm. unfold loopM in *.
    eapply loop_lift with (lift := id) (f' := step (WhileTM)) (h' := haltConf (M := projT1 pM)) in HLoop; cbv [id] in *; cbn; auto; cycle 1.
    { intros. symmetry. now apply step_comp. }
    unfold loopM.
    replace k1 with (k1 + 0) by lia.
    apply loop_merge with (h := haltConf (M := projT1 pM)) (a2 := c2).
    - apply halt_comp.
    - apply HLoop.
    - cbn in *. setoid_rewrite (loop_fulfills HLoop). rewrite HTerm. cbn. reflexivity.
  Qed.

  (* ** Correctness of [While] *)

  Variable R : pRel sig (option F) n.

  Inductive While_Rel : pRel sig F n :=
  | While_Rel''_one :
      forall tin yout tout, R tin (Some yout, tout) -> While_Rel tin (yout, tout)
  | While_Rel''_loop :
      forall tin tmid yout tout,
        R tin (None, tmid) ->
        While_Rel tmid (yout, tout) ->
        While_Rel tin (yout, tout).

  Lemma While_Realise :
    pM ⊨ R -> While ⊨ While_Rel.
  Proof.
    intros HRel. hnf in HRel; hnf. intros t k; revert t. apply complete_induction with (x := k); clear k; intros k IH. intros tin c3 HLoop.
    apply While_split in HLoop as (k1&k2&c2&HLoop1&HLoop2&Hk).
    destruct (projT2 pM (cstate c2)) as [ f | ] eqn:E; cbn in *; [ clear IH | ].
    - apply While_split_term with (f := f) in HLoop2 as ->; auto. 2: apply (loop_fulfills HLoop1). unfold While_part. rewrite E.
      constructor 1. specialize HRel with (1 := HLoop1). now rewrite E in HRel.
    - apply While_split_repeat in HLoop2 as (k2'&->&HLoop2); auto. 2: apply (loop_fulfills HLoop1).
      specialize IH with (2 := HLoop2); spec_assert IH by lia.
      econstructor 2.
      + specialize HRel with (1 := HLoop1). rewrite E in HRel. eassumption.
      + apply IH.
  Qed.

  (* ** Termination of [While] *)
  Section While_TerminatesIn.
    Variable (T T' : Rel (tapes sig n) nat).

    Lemma While_TerminatesIn_ind :
      pM ⊨ R ->
      projT1 pM ↓ T' ->
      (forall (tin : tapes sig n) (k : nat),
          T tin k ->
          exists k1,
            T' tin k1 /\
            (forall ymid tmid, R tin (Some ymid, tmid) -> k1 <= k) /\
            (forall tmid, R tin (None, tmid) -> exists k2, T tmid k2 /\ 1 + k1 + k2 <= k)) ->
      WhileTM ↓T.
    Proof.
      intros Realise_M Term_M Hyp tin i. revert tin. apply complete_induction with (x:=i); clear i; intros i IH tin.
      intros (i1&HT1&HT2&HT3) % Hyp. (* todo: i *)
      pose proof (Term_M _ _ HT1) as (oconf&Hloop).
      specialize (Realise_M _ _ _ Hloop).
      destruct (projT2 pM (cstate oconf)) as [ ymid | ] eqn:E1.
      - specialize HT2 with (1 := Realise_M).
        exists oconf. eapply loop_monotone; eauto. eapply While_merge_term; eauto.
      - specialize HT3 with (1 := Realise_M) as (i2&HT3&Hi).
        specialize (IH i2 ltac:(lia) _ HT3) as (oconf2&Hloop2).
        exists oconf2. apply loop_monotone with (k1 := i1 + (1 + i2)). 2: lia.
        eapply While_merge_repeat; eauto.
    Qed.

  End While_TerminatesIn.

  (* Alternative for [While_TerminatesIn] using co-induction *)
  Section While_TerminatesIn_coind.
    Variable (T : Rel (tapes sig n) nat).

    CoInductive While_T : tRel sig n :=
    | While_T_intro tin k k1 :
        T tin k1 ->
        (forall tmid ymid,
            R tin (Some ymid, tmid) -> k1 <= k) ->
        (forall tmid,
            R tin (None, tmid) ->
            exists k2, While_T tmid k2 /\ 1 + k1 + k2 <= k) ->
        While_T tin k.

    Lemma While_TerminatesIn :
      pM ⊨ R ->
      projT1 pM ↓ T ->
      WhileTM ↓ While_T.
    Proof.
      intros HRel HTerm. eapply While_TerminatesIn_ind; eauto.
      intros tin k' HCoInd. destruct HCoInd as [ t k k1 H1 H2 H3 ]. eauto.
    Qed.

  End While_TerminatesIn_coind.

End While.

Arguments While : simpl never.
Arguments While {n sig F} pM {defF}.

(* Deprecated name *)
Notation WHILE := While (only parsing).

(* ** (Co-) Induction Principle for Correctness (Running Time) of [While] *)

Section WhileInduction.
  Variable (sig : finType) (n : nat) (F : finType).

  Variable R1 : pRel sig (option F) n.
  Variable R2 : pRel sig F n.

  Lemma WhileInduction :
    (forall tin yout tout (HLastStep: R1 tin (Some yout, tout)), R2 tin (yout, tout)) ->
    (forall tin tmid tout yout
       (HStar : R1 tin (None, tmid)) (HLastStep : R2 tmid (yout, tout)), R2 tin (yout, tout)) ->
    While_Rel R1 <<=2 R2.
  Proof. intros H1 H2. intros tin tout. induction 1; eauto. Qed.

End WhileInduction.

Section WhileCoInduction.
  Variable (sig : finType) (n : nat) (F : finType).

  Variable R : pRel sig (option F) n.
  Variable T T' : tRel sig n.

  Lemma WhileCoInduction :
    (forall (tin : tapes sig n) (k : nat) (HT : T tin k),
        exists k1,
          T' tin k1 /\
          forall (ymid : option F) tmid,
            R tin (ymid, tmid) ->
            match ymid with
            | Some _ => k1 <= k
            | None => exists k2, T tmid k2 /\ 1 + k1 + k2 <= k
            end) ->
    T <<=2 While_T R T'.
  Proof.
    intros. cofix IH. intros tin k HT. specialize H with (1 := HT) as (k1&H1&H2). econstructor; eauto.
    - intros tmid ymid HR. specialize (H2 (Some ymid) tmid); cbn in *. auto.
    - intros tmid HR. specialize (H2 None tmid) as (k2&H3&H4); eauto.
  Qed.

End WhileCoInduction.

(* Alternative definition of [While_Rel] *)
Section OtherWhileRel.

  Variable (sig : finType) (n : nat) (F : finType).

  Variable R : Rel (tapes sig n) (option F * tapes sig n).

  Definition While_Rel' : pRel sig F n :=
    (star (R |_ None)) ∘ ⋃_y (R |_(Some y)) ||_y.

  Goal While_Rel R =2 While_Rel'.
  Proof.
    unfold While_Rel'. split.
    {
      apply WhileInduction; intros; cbn in *.
      - eexists. split. { constructor. } now exists yout.
      - destruct HLastStep as (y&IH1&?&<-&IH2); cbn in *.
        eexists. split; eauto. econstructor; eauto.
    }
    {
      intros tin (yout, tout) H.  cbn in H. destruct H as (tmid&HStar&HLastStep).
      induction HStar as [ tin | tin tmid tmid2 HS1 HS2 IH].
      - destruct HLastStep as (?&<-&H). now constructor.
      - spec_assert IH by assumption.
        destruct HLastStep as (?&<-&H).
        econstructor 2.
        + apply HS1.
        + apply IH.
    }
  Qed.

End OtherWhileRel.


Require Import ABS.Lang.Syntax.
Require Import ABS.Lang.Bindings.
Require Import ABS.Lang.Operational.
Require Import BindingsFacts_map_0.
Require Import ABS.Util.Subset.

Set Implicit Arguments.

Implicit Types EV HV V L : Set.

Lemma Xs_eff_app EV HV L (𝓔 𝓔' : eff EV HV L) :
Xs_eff (𝓔 ++ 𝓔') = Xs_eff 𝓔 \u Xs_eff 𝓔'.
Proof.
induction 𝓔 ; simpl.
+ rewrite union_empty_l ; auto.
+ rewrite IH𝓔, union_assoc ; auto.
Qed.

Section section_Xs_map_and_bind.

Lemma
L_map_lid_Xs
L L' (f : L → L')
(ι : lid L) :
Xs_lid (L_map_lid f ι) = Xs_lid ι.
Proof.
destruct ι ; crush.
Qed.

Hint Rewrite L_map_lid_Xs.

Lemma
L_map_lbl_Xs
HV L L' (f : L → L')
(ℓ : lbl HV L) :
Xs_lbl (L_map_lbl f ℓ) = Xs_lbl ℓ.
Proof.
destruct ℓ ; crush.
Qed.

Hint Rewrite L_map_lbl_Xs.

Lemma
L_map_ef_Xs
EV HV L L' (f : L → L')
(ε : ef EV HV L) :
Xs_ef (L_map_ef f ε) = Xs_ef ε.
Proof.
destruct ε ; crush.
Qed.

Hint Rewrite L_map_ef_Xs.

Lemma
L_map_eff_Xs
EV HV L L' (f : L → L')
(𝓔 : eff EV HV L) :
Xs_eff (L_map_eff f 𝓔) = Xs_eff 𝓔.
Proof.
induction 𝓔 ; crush.
Qed.

Hint Rewrite L_map_eff_Xs.

Fixpoint
L_map_ty_Xs
EV HV L L' (f : L → L')
(T : ty EV HV L) :
Xs_ty (L_map_ty f T) = Xs_ty T
.
Proof.
destruct T ; crush.
Qed.

Hint Rewrite L_map_ty_Xs.

Fixpoint
L_map_hd_Xs
EV HV V L L' (f : L → L')
(h : hd EV HV V L) :
Xs_hd (L_map_hd f h) = Xs_hd h
with
L_map_tm_Xs
EV HV V L L' (f : L → L')
(t : tm EV HV V L) :
Xs_tm (L_map_tm f t) = Xs_tm t
with
L_map_val_Xs
EV HV V L L' (f : L → L')
(v : val EV HV V L) :
Xs_val (L_map_val f v) = Xs_val v
.
Proof.
+ destruct h ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite L_map_hd_Xs.
Hint Rewrite L_map_tm_Xs.
Hint Rewrite L_map_val_Xs.

Lemma
HV_map_lbl_Xs
HV L HV' (f : HV → HV')
(ℓ : lbl HV L) :
Xs_lbl (HV_map_lbl f ℓ) = Xs_lbl ℓ.
Proof.
destruct ℓ ; crush.
Qed.

Hint Rewrite HV_map_lbl_Xs.

Lemma
HV_map_ef_Xs
EV HV L HV' (f : HV → HV')
(ε : ef EV HV L) :
Xs_ef (HV_map_ef f ε) = Xs_ef ε.
Proof.
destruct ε ; crush.
Qed.

Hint Rewrite HV_map_ef_Xs.

Lemma
HV_map_eff_Xs
EV HV L HV' (f : HV → HV')
(𝓔 : eff EV HV L) :
Xs_eff (HV_map_eff f 𝓔) = Xs_eff 𝓔.
Proof.
induction 𝓔 ; crush.
Qed.

Hint Rewrite HV_map_eff_Xs.

Fixpoint
HV_map_ty_Xs
EV HV L HV' (f : HV → HV')
(T : ty EV HV L) :
Xs_ty (HV_map_ty f T) = Xs_ty T
.
Proof.
destruct T ; crush.
Qed.

Hint Rewrite HV_map_ty_Xs.

Fixpoint
HV_map_hd_Xs
EV HV V L HV' (f : HV → HV')
(h : hd EV HV V L) :
Xs_hd (HV_map_hd f h) = Xs_hd h
with
HV_map_tm_Xs
EV HV V L HV' (f : HV → HV')
(t : tm EV HV V L) :
Xs_tm (HV_map_tm f t) = Xs_tm t
with
HV_map_val_Xs
EV HV V L HV' (f : HV → HV')
(v : val EV HV V L) :
Xs_val (HV_map_val f v) = Xs_val v
.
Proof.
+ destruct h ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite HV_map_hd_Xs.
Hint Rewrite HV_map_tm_Xs.
Hint Rewrite HV_map_val_Xs.

Lemma
EV_map_ef_Xs
EV HV L EV' (f : EV → EV')
(ε : ef EV HV L) :
Xs_ef (EV_map_ef f ε) = Xs_ef ε.
Proof.
destruct ε ; crush.
Qed.

Hint Rewrite EV_map_ef_Xs.

Lemma
EV_map_eff_Xs
EV HV L EV' (f : EV → EV')
(𝓔 : eff EV HV L) :
Xs_eff (EV_map_eff f 𝓔) = Xs_eff 𝓔.
Proof.
induction 𝓔 ; crush.
Qed.

Hint Rewrite EV_map_eff_Xs.

Fixpoint
EV_map_ty_Xs
EV HV L EV' (f : EV → EV')
(T : ty EV HV L) :
Xs_ty (EV_map_ty f T) = Xs_ty T
.
Proof.
destruct T ; crush.
Qed.

Hint Rewrite EV_map_ty_Xs.

Fixpoint
EV_map_hd_Xs
EV HV V L EV' (f : EV → EV')
(h : hd EV HV V L) :
Xs_hd (EV_map_hd f h) = Xs_hd h
with
EV_map_tm_Xs
EV HV V L EV' (f : EV → EV')
(t : tm EV HV V L) :
Xs_tm (EV_map_tm f t) = Xs_tm t
with
EV_map_val_Xs
EV HV V L EV' (f : EV → EV')
(v : val EV HV V L) :
Xs_val (EV_map_val f v) = Xs_val v
.
Proof.
+ destruct h ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite EV_map_hd_Xs.
Hint Rewrite EV_map_tm_Xs.
Hint Rewrite EV_map_val_Xs.

Fixpoint
V_map_hd_Xs
EV HV V L V' (f : V → V')
(h : hd EV HV V L) :
Xs_hd (V_map_hd f h) = Xs_hd h
with
V_map_tm_Xs
EV HV V L V' (f : V → V')
(t : tm EV HV V L) :
Xs_tm (V_map_tm f t) = Xs_tm t
with
V_map_val_Xs
EV HV V L V' (f : V → V')
(v : val EV HV V L) :
Xs_val (V_map_val f v) = Xs_val v
.
Proof.
+ destruct h ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite V_map_hd_Xs.
Hint Rewrite V_map_tm_Xs.
Hint Rewrite V_map_val_Xs.

Fixpoint
V_map_ktx_Xs
EV HV V L V' (f : V → V')
(K : ktx EV HV V L) :
Xs_ktx (V_map_ktx f K) = Xs_ktx K.
Proof.
destruct K ; crush.
Qed.

Hint Resolve subset_empty_l.
Hint Resolve subset_union_l subset_union_r.
Hint Resolve subset_refl.

Lemma
L_bind_lid_Xs
L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(ι : lid L) :
Xs_lid (L_bind_lid f ι) \c Xs_lid ι \u B.
Proof.
destruct ι ; simpl ; auto.
Qed.

Lemma
L_bind_lbl_Xs
HV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(ℓ : lbl HV L) :
Xs_lbl (L_bind_lbl f ℓ) \c Xs_lbl ℓ \u B.
Proof.
destruct ℓ ; simpl.
+ auto.
+ eapply subset_trans ; [ apply L_bind_lid_Xs ; auto | auto ].
Qed.

Lemma
L_bind_ef_Xs
EV HV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(ε : ef EV HV L) :
Xs_ef (L_bind_ef f ε) \c Xs_ef ε \u B.
Proof.
destruct ε ; simpl.
+ auto.
+ eapply subset_trans ; [ apply L_bind_lbl_Xs ; auto | auto ].
Qed.

Lemma
L_bind_eff_Xs
EV HV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(𝓔 : eff EV HV L) :
Xs_eff (L_bind_eff f 𝓔) \c Xs_eff 𝓔 \u B.
Proof.
induction 𝓔 ; simpl.
+ auto.
+ apply union_subset.
  - eapply subset_trans ; [ apply L_bind_ef_Xs ; auto | ].
    auto using union_subset.
  - rewrite <- union_assoc ; auto.
Qed.

Hint Resolve union_subset.

Fixpoint
L_bind_ty_Xs
EV HV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(T : ty EV HV L) :
Xs_ty (L_bind_ty f T) \c Xs_ty T \u B
.
Proof.
destruct T ; simpl.
- auto.
- repeat apply union_subset.
  * eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | auto ].
  * eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | auto ].
  * eapply subset_trans ; [ apply L_bind_eff_Xs with (B := B) ; auto | auto ].
- eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | auto ].
- eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | auto ].
Qed.

Fixpoint
L_bind_hd_Xs
EV HV V L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(h : hd EV HV V L) :
Xs_hd (L_bind_hd f h) \c Xs_hd h \u B
with
L_bind_val_Xs
EV HV V L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(v : val EV HV V L) :
Xs_val (L_bind_val f v) \c Xs_val v \u B
with
L_bind_tm_Xs
EV HV V L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(t : tm EV HV V L) :
Xs_tm (L_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct h ; simpl.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_lid_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
+ destruct v ; simpl.
  - auto.
  - auto.
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_hd_Xs with (B := B) ; auto | auto ].
+ destruct t ; simpl.
  - eapply subset_trans ; [ apply L_bind_val_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply L_bind_eff_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply L_bind_hd_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
    * auto.
Qed.

Lemma
HV_bind_lbl_Xs
EV HV V L HV'
B (f : HV → hd EV HV' V L) (Q : ∀ x, Xs_lbl (lbl_hd (f x)) \c B)
(ℓ : lbl HV L) :
Xs_lbl (HV_bind_lbl f ℓ) \c Xs_lbl ℓ \u B.
Proof.
destruct ℓ ; simpl ; auto.
Qed.

Lemma
HV_bind_ef_Xs
EV HV V L HV'
B (f : HV → hd EV HV' V L) (Q : ∀ x, Xs_lbl (lbl_hd (f x)) \c B)
(ε : ef EV HV L) :
Xs_ef (HV_bind_ef f ε) \c Xs_ef ε \u B.
Proof.
destruct ε ; simpl.
+ auto.
+ eapply subset_trans ; [ apply HV_bind_lbl_Xs ; auto | auto ].
Qed.

Lemma
HV_bind_eff_Xs
EV HV V L HV'
B (f : HV → hd EV HV' V L) (Q : ∀ x, Xs_lbl (lbl_hd (f x)) \c B)
(𝓔 : eff EV HV L) :
Xs_eff (HV_bind_eff f 𝓔) \c Xs_eff 𝓔 \u B.
Proof.
induction 𝓔 ; simpl.
+ auto.
+ apply union_subset.
  - eapply subset_trans ; [ apply HV_bind_ef_Xs ; auto | ].
    auto using union_subset.
  - rewrite <- union_assoc ; auto.
Qed.

Hint Rewrite lbl_EV_map_hd lbl_HV_map_hd.

Fixpoint
HV_bind_ty_Xs
EV HV V L HV'
B (f : HV → hd EV HV' V L) (Q : ∀ x, Xs_lbl (lbl_hd (f x)) \c B)
(T : ty EV HV L) :
Xs_ty (HV_bind_ty f T) \c Xs_ty T \u B
.
Proof.
destruct T ; simpl.
- auto.
- repeat apply union_subset.
  * eapply subset_trans ; [ apply HV_bind_ty_Xs with (B := B) ; auto | auto ].
  * eapply subset_trans ; [ apply HV_bind_ty_Xs with (B := B) ; auto | auto ].
  * eapply subset_trans ; [ apply HV_bind_eff_Xs with (B := B) ; auto | auto ].
- eapply subset_trans ; [ apply HV_bind_ty_Xs with (B := B) ; auto | auto ].
- eapply subset_trans ; [ apply HV_bind_ty_Xs with (B := B) ; auto | auto ].
Qed.

Lemma Xs_lbl_hd EV HV V L (h : hd EV HV V L) B :
Xs_hd h \c B → Xs_lbl (lbl_hd h) \c B.
Proof.
destruct h ; eauto using union_subset_inv_l.
Qed.

Hint Resolve Xs_lbl_hd.

Fixpoint
HV_bind_hd_Xs
EV HV V L HV'
B (f : HV → hd EV HV' V L) (Q : ∀ x, Xs_hd (f x) \c B)
(h : hd EV HV V L) :
Xs_hd (HV_bind_hd f h) \c Xs_hd h \u B
with
HV_bind_val_Xs
EV HV V L HV'
B (f : HV → hd EV HV' V L) (Q : ∀ x, Xs_hd (f x) \c B)
(v : val EV HV V L) :
Xs_val (HV_bind_val f v) \c Xs_val v \u B
with
HV_bind_tm_Xs
EV HV V L HV'
B (f : HV → hd EV HV' V L) (Q : ∀ x, Xs_hd (f x) \c B)
(t : tm EV HV V L) :
Xs_tm (HV_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct h ; simpl.
  - auto.
  - apply union_subset.
    * auto.
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
+ destruct v ; simpl.
  - auto.
  - auto.
  - eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply HV_bind_hd_Xs with (B := B) ; auto | auto ].
+ destruct t ; simpl.
  - eapply subset_trans ; [ apply HV_bind_val_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply HV_bind_eff_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply HV_bind_hd_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := B) ; auto | auto ].
    * auto.
Qed.

Lemma
EV_bind_ef_Xs
EV HV L EV'
B (f : EV → eff EV' HV L) (Q : ∀ x, Xs_eff (f x) \c B)
ε :
Xs_eff (EV_bind_ef f ε) \c Xs_ef ε \u B.
Proof.
destruct ε ; simpl.
+ auto.
+ apply union_subset ; auto.
Qed.

Lemma
EV_bind_eff_Xs
EV HV L EV'
B (f : EV → eff EV' HV L) (Q : ∀ x, Xs_eff (f x) \c B)
𝓔 :
Xs_eff (EV_bind_eff f 𝓔) \c Xs_eff 𝓔 \u B.
Proof.
induction 𝓔 ; simpl.
+ auto.
+ rewrite Xs_eff_app.
  apply union_subset.
  - eapply subset_trans ; [ apply EV_bind_ef_Xs ; auto | ].
    auto using union_subset.
  - rewrite <- union_assoc ; auto.
Qed.

Fixpoint
EV_bind_ty_Xs
EV HV L EV'
B (f : EV → eff EV' HV L) (Q : ∀ x, Xs_eff (f x) \c B)
T :
Xs_ty (EV_bind_ty f T) \c Xs_ty T \u B
.
Proof.
destruct T ; simpl.
  - auto.
  - repeat apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply EV_bind_eff_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | auto ].
Qed.

Fixpoint
EV_bind_hd_Xs
EV HV V L EV'
B (f : EV → eff EV' HV L) (Q : ∀ x, Xs_eff (f x) \c B)
(h : hd EV HV V L) :
Xs_hd (EV_bind_hd f h) \c Xs_hd h \u B
with
EV_bind_val_Xs
EV HV V L EV'
B (f : EV → eff EV' HV L) (Q : ∀ x, Xs_eff (f x) \c B)
(v : val EV HV V L) :
Xs_val (EV_bind_val f v) \c Xs_val v \u B
with
EV_bind_tm_Xs
EV HV V L EV'
B (f : EV → eff EV' HV L) (Q : ∀ x, Xs_eff (f x) \c B)
(t : tm EV HV V L) :
Xs_tm (EV_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct h ; simpl.
  - auto.
  - apply union_subset.
    * auto.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
+ destruct v ; simpl.
  - auto.
  - auto.
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_hd_Xs with (B := B) ; auto | auto ].
+ destruct t ; simpl.
  - eapply subset_trans ; [ apply EV_bind_val_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply EV_bind_eff_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply EV_bind_hd_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
    * auto.
Qed.

Fixpoint
V_bind_hd_Xs
EV HV V L V'
B (f : V → val EV HV V' L) (Q : ∀ x, Xs_val (f x) \c B)
h :
Xs_hd (V_bind_hd f h) \c Xs_hd h \u B
with
V_bind_val_Xs
EV HV V L V'
B (f : V → val EV HV V' L) (Q : ∀ x, Xs_val (f x) \c B)
v :
Xs_val (V_bind_val f v) \c Xs_val v \u B
with
V_bind_tm_Xs
EV HV V L V'
B (f : V → val EV HV V' L) (Q : ∀ x, Xs_val (f x) \c B)
t :
Xs_tm (V_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct h ; simpl.
  - auto.
  - apply union_subset.
    * auto.
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
+ destruct v ; simpl.
  - auto.
  - auto.
  - eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply V_bind_hd_Xs with (B := B) ; auto | auto ].
+ destruct t ; simpl.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply V_bind_hd_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply V_bind_tm_Xs with (B := B) ; auto | auto ].
    * auto.
Qed.

End section_Xs_map_and_bind.

Section section_Xs_ktx_plug.

Hint Rewrite union_empty_l.

Lemma Xs_ktx_plug EV HV V L (K : ktx EV HV V L) t :
Xs_tm (ktx_plug K t) = Xs_ktx K \u Xs_tm t.
Proof.
induction K ; simpl.
+ crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite union_assoc, (union_comm _ (Xs_ktx K)).
  crush.
Qed.

End section_Xs_ktx_plug.


(* Test the behaviour of hnf and simpl introduced in revision *)

Variable n:nat.
Definition a:=0.

Eval simpl in (fix plus (n m : nat) {struct n} : nat :=
  match n with
  | 0 => m
  | S p => S (p + m)
  end) a a.

Eval hnf in match (plus (S n) O) with S n => n | _ => O end.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv1 (plus lv2 (Succ Zero))) (plus lv2 (Succ Zero)))).
Admitted.
QuickChick conj20synthconj3.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^291 - 19
Base: 58.2
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 58 + 1/5;
    bitwidth := 64;
    s := 2^291;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj11synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus Zero (plus (mult lv0 lv1) lv2)) (plus lv2 (mult lv0 lv1))).
Admitted.
QuickChick conj11synthconj1.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Y P Z Q Qprime Cprime X : Universe, ((wd_ A Y /\ (wd_ P Y /\ (wd_ Q Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P Q /\ (wd_ A Z /\ (wd_ B Y /\ (wd_ Y Qprime /\ (wd_ Qprime Cprime /\ (wd_ Y Z /\ (wd_ Z X /\ (wd_ C Y /\ (wd_ P C /\ (wd_ Y Cprime /\ (col_ P Y Q /\ (col_ P Y C /\ (col_ Z Y X /\ (col_ Qprime Y Cprime /\ (col_ Q Z Qprime /\ (col_ A Y Z /\ (col_ B A Y /\ col_ X C Cprime))))))))))))))))))))))) -> col_ P Q C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coq.Lists Require Import List.
From Equations Require Import Equations.

(* This type is from VST: https://github.com/PrincetonUniversity/VST/blob/v2.1/floyd/compact_prod_sum.v#L6 *)
Fixpoint compact_prod (T: list Type): Type :=
  match T with
  | nil => unit
  | t :: nil => t
  | t :: T0 => (t * compact_prod T0)%type
  end.

(* The rest is a nonsensical, just to give a minimalistic reproducible example *)
Inductive foo :=
| Nat : foo
| List : foo.

Definition foo_type (f:foo) : Type :=
  match f with
  | Nat => nat
  | List => list unit
  end.

Equations num (f:foo) (val:foo_type f) : nat :=
  num Nat val := val;
  num List val := length val.

Equations sum (fs : list foo) (val: compact_prod (map foo_type fs)) : nat by struct fs := {
  sum nil _ := 0;
  sum (cons f tl) val := sum_aux f tl val }

where sum_aux (f:foo) (fs : list foo) (val: compact_prod (map foo_type (f::fs))) : nat by struct fs := {
  sum_aux f nil val := num f val;
  sum_aux f (cons hd tl) val := num f (fst val) + sum_aux hd tl (snd val)}.