(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

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

          Buchberger : Application of Dickson lemma

          Henrik Persson

   ************************************************************************** *)

From Coq Require Import List.
From Buchberger Require Import ListProps Bar Dickson Monomials.
From Buchberger Require Export BuchAux.

Set Default Proof Using "Type".

Section thRO.
Load hCoefStructure.
Load hOrderStructure.
Load hBuchAux.

Definition get_mon : poly A0 eqA ltM -> mon n.
intros sp; case sp.
intros x H'; case x.
exact (M1 n).
intros a H'1; exact (T2M a).
Defined.

Theorem get_is_correct :
 forall (a b : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 ~
 zerop A A0 eqA n ltM
   (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
      P) ->
 In b P ->
 ~ zerop A A0 eqA n ltM b ->
 ~
 mdiv n (get_mon b)
   (get_mon
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a P)).
Proof.
intros a b P H' H'0 H'1.
cut
 (irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P
    (s2p A A0 eqA n ltM
       (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
          os a P))).
2: try exact (nf_irreducible a P); auto.
generalize H';
 case
  (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
     P); simpl in |- *; auto.
intros x; case x; simpl in |- *.
intros H'2 H'3; elim H'3; auto.
intros a0 l H'2 H'3 H'4; red in |- *; intros H'5; red in H'4.
red in H'4.
generalize H'0 H'1 H'5; case b.
intros x0; case x0; simpl in |- *.
intros o H'6 H'7; elim H'7; auto.
intros a1 l0 o H'6 H'7 H'8.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a1); [ intros nZa1 | idtac ].
apply
 H'4
   with
     (q := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
             a0 a1 nZa1 l l0); auto.
change
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P
     (pX a0 l)
     (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a0 a1
        nZa1 l l0)) in |- *.
apply reducetop_sp with (1 := cs) (b := a1) (nZb := nZa1) (q := l0); auto.
change
  (inPolySet A A0 eqA n ltM
     (s2p A A0 eqA n ltM (mks A A0 eqA n ltM (pX a1 l0) o)) P)
 in |- *.
apply in_inPolySet; auto.
simpl in |- *; auto.
red in |- *; intros H'9; inversion H'9.
apply divTerm_def with (nZb := nZa1); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
apply divTerm_on_plusM_minusM with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
simpl in |- *; auto.
apply sym_equal; auto.
apply mdiv_div; auto.
apply canonical_nzeroP with (ltM := ltM) (p := l0); auto.
apply nf_irreducible; auto.
Qed.

Definition get_monL : list (poly A0 eqA ltM) -> list (mon n) := map get_mon.

Inductive RO : list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> Prop :=
    RO0 :
      forall (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
      ~
      zerop A A0 eqA n ltM
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a P) ->
      RO
        (P ++
         nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a P :: nil) P.

Definition BadM (l : list (mon n)) := GoodR (mon n) (mdiv n) l -> False.

Lemma l1 :
 forall (cs : list (poly A0 eqA ltM)) (ms : list (mon n)),
 Bar (mon n) (GoodR (mon n) (mdiv n)) ms ->
 forall bs : list (poly A0 eqA ltM),
 ms = get_monL bs ->
 (forall f : poly A0 eqA ltM, In f bs -> ~ zerop A A0 eqA n ltM f) ->
 BadM ms -> Acc RO (cs ++ rev bs).
Proof.
intros cs1 ms1 H; elim H; auto.
intros l H' bs H'0 H'1 H'2.
case H'2; auto.
intros l H' H'0 bs Heq Hnz H'1; auto.
apply Acc_intro; auto.
intros y H'2; inversion H'2; auto.
rewrite <- ass_app.
change
  (Acc RO
     (cs1 ++
      rev bs ++
      rev
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a (cs1 ++ rev bs) :: nil))) in |- *.
rewrite <- distr_rev; simpl in |- *.
change
  (Acc RO
     (cs1 ++
      rev
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a (cs1 ++ rev bs) :: bs))) in |- *.
apply
 H'0
  with
    (a := get_mon
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a (cs1 ++ rev bs))); unfold get_monL in |- *;
 try rewrite Heq; simpl in |- *; auto.
intros f H'3; elim H'3;
 [ intros H'4; rewrite <- H'4; clear H'3 | intros H'4; clear H'3 ];
 auto.
apply tdivGoodP with (trm := mon n) (tdiv := mdiv n); auto.
rewrite <- Heq; auto.
intros g.
intros H'3; cut (ex (fun b : poly A0 eqA ltM => g = get_mon b /\ In b bs)).
intros H'4; elim H'4; intros b E; elim E; intros H'5 H'6; rewrite H'5;
 clear E H'4; auto.
apply get_is_correct; auto.
apply in_or_app; right; apply in_rev; rewrite ?rev_involutive; auto.
apply map_in; auto.
Qed.

Theorem wf_incl : well_founded RO.
Proof.
unfold well_founded in |- *; intros.
apply Acc_intro; intros.
inversion H.
apply
 l1
  with
    (bs := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
             ltM_dec os a0 a :: nil)
    (ms := get_monL
             (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
                ltM_dec os a0 a :: nil)); auto.
change
  (GRBar (mon n) (mdiv n)
     (get_mon
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a0 a) :: nil)) in |- *.
apply nilGRBar; auto.
apply dicksonL with (n := n); auto.
simpl in |- *; intros f H3; case H3; intros.
rewrite <- H4; auto.
elim H4.
red in |- *; intros H4; inversion H4; inversion H5.
Qed.

Lemma RO_lem :
 forall (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 ~
 zerop A A0 eqA n ltM
   (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
      P) ->
 RO
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a P) P) P.
Proof.
intros a P H'; rewrite addEnd_app.
apply RO0; auto.
Qed.

End thRO.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Arith.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ListUtil.Partition.
Require Import Crypto.Util.ListUtil.StdlibCompat.
Require Export Crypto.Util.FixCoqMistakes.
Import ListNotations.
Local Open Scope list_scope.

Module List.
  Definition groupAllBy' {A} (f : A -> A -> bool)
    := fix groupAllBy' (ls : list A) (fuel : nat) : list (list A)
      := match fuel, ls with
         | (O | S _), [] => []
         | O, ls => [ls]
         | S fuel, x :: xs
           => let '(xs, ys) := partition (f x) xs in
              (x :: xs) :: groupAllBy' ys fuel
         end.

  Definition groupAllBy {A} (f : A -> A -> bool) (ls : list A) : list (list A)
    := groupAllBy' f ls (List.length ls).

  Lemma groupAllBy'_eq_fuel' A f ls fuel fuel'
        (H : List.length ls <= fuel <= fuel')
    : @groupAllBy' A f ls fuel = @groupAllBy' A f ls fuel'.
  Proof using Type.
    revert fuel' fuel ls H.
    induction fuel' as [|fuel' IH], fuel as [|fuel], ls as [|x xs];
      try specialize (IH fuel); cbn [List.length groupAllBy']; try lia; try reflexivity.
    destruct (partition (f x) xs) as [xs' ys] eqn:Hp.
    pose proof (@partition_length _ _ _ _ _ Hp).
    intros; f_equal; apply IH; lia.
  Qed.

  Lemma groupAllBy'_eq_fuel A f ls fuel fuel'
        (H : List.length ls <= fuel)
        (H' : List.length ls <= fuel')
    : @groupAllBy' A f ls fuel = @groupAllBy' A f ls fuel'.
  Proof using Type.
    destruct (le_gt_dec fuel fuel').
    all: (idtac + symmetry); apply groupAllBy'_eq_fuel'; lia.
  Qed.

  Lemma expand_groupAllBy {A f ls}
    : @groupAllBy A f ls = match ls with
                           | [] => []
                           | x :: xs
                             => let '(xs, ys) := partition (f x) xs in
                                (x :: xs) :: groupAllBy f ys
                           end.
  Proof using Type.
    induction ls as [|x xs IH]; cbn; try reflexivity.
    cbv [groupAllBy].
    pose proof (partition_length (f x) xs) as H.
    destruct partition; specialize (H _ _ eq_refl).
    f_equal.
    apply groupAllBy'_eq_fuel; lia.
  Qed.

  Lemma concat_groupAllBy {A} (f : A -> A -> bool) ls
    : Permutation (List.concat (groupAllBy f ls)) ls.
  Proof using Type.
    remember (List.length ls) as n eqn:H.
    revert ls H.
    induction n as [n IH] using lt_wf_ind; intros ls H'; subst.
    destruct ls as [|x xs].
    { constructor. }
    { rewrite expand_groupAllBy.
      destruct (partition (f x) xs) as [xs' ys] eqn:H.
      pose proof H as H'.
      apply partition_length in H'.
      apply List.partition_permutation in H; cbn [concat List.app].
      rewrite IH; [ | try reflexivity .. ]; [ | cbn [List.length]; lia .. ].
      constructor; assumption. }
  Qed.

  Lemma Forall_groupAllBy_full A f ls
    : list_rect (fun _ => Prop)
                True
                (fun xs xss P
                 => match xs with
                    | [] => False
                    | x :: xs => Forall (fun x' => f x x' = true) xs
                                 /\ Forall (Forall (fun y => f x y = false)) xss
                    end
                    /\ P)
                (@groupAllBy A f ls).
  Proof.
    remember (List.length ls) as n eqn:H.
    revert ls H.
    induction n as [n IH] using lt_wf_ind; intros ls H'; subst.
    destruct ls as [|x xs].
    { constructor. }
    { rewrite expand_groupAllBy.
      destruct (partition (f x) xs) as [xs' ys] eqn:H.
      pose proof H as H'.
      apply partition_length in H'.
      apply List.Forall_partition in H; cbn [concat List.app].
      cbn [list_rect].
      constructor;
        [ split; rewrite <- ?Forall_concat, ?concat_groupAllBy; apply H
        | eapply IH; [ | reflexivity ] ].
      cbn [List.length].
      lia. }
  Qed.

  Lemma Forall_groupAllBy A f ls
    : Forall (fun xs => match xs with
                        | [] => False
                        | x :: xs => Forall (fun x' => f x x' = true) xs
                        end)
             (@groupAllBy A f ls).
  Proof.
    generalize (@Forall_groupAllBy_full A f ls).
    induction (groupAllBy f ls) as [|[] xs IH]; cbn; constructor; intuition.
  Qed.
End List.


Require Import FloydSeq.proofauto.
Require Import Coq.Program.Tactics.

Example strcat_preloop2_new : forall {cs : compspecs} n ld,
  n > Zlength ld ->
  data_subsume (tarray tschar n)
    (map Vbyte (ld ++ [Byte.zero]) ++ list_repeat (Z.to_nat (n - (Zlength ld + 1))) Vundef)
    (map Vbyte ld ++ list_repeat (Z.to_nat (n - Zlength ld)) Vundef).
Proof.
  intros.
  list_form. apply_list_ext. Znth_solve.
Qed.

Lemma split_data_at_app_tschar:
 forall {cs : compspecs} sh n (al bl: list val) p ,
   n = Zlength (al++bl) ->
   data_at sh (tarray tschar n) (al++bl) p =
         data_at sh (tarray tschar (Zlength al)) al p
        * data_at sh (tarray tschar (n - Zlength al)) bl
                 (field_address0 (tarray tschar n) [ArraySubsc (Zlength al)] p).
Proof.
  intros.
  apply (split2_data_at_Tarray_app _ n  sh tschar al bl ); auto.
  rewrite Zlength_app in H.
  change ( Zlength bl = n - Zlength al); omega.
Qed.

Example strcat_preloop2_old : forall {cs : compspecs} n ld,
  n > Zlength ld ->
  data_subsume (tarray tschar n)
    (map Vbyte (ld ++ [Byte.zero]) ++ list_repeat (Z.to_nat (n - (Zlength ld + 1))) Vundef)
    (map Vbyte ld ++ list_repeat (Z.to_nat (n - Zlength ld)) Vundef).
Proof.
  unfold data_subsume; intros.
  autorewrite with sublist.
  rewrite !map_app. rewrite <- app_assoc.
  rewrite split_data_at_app_tschar by list_solve.
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  autorewrite with sublist.
  cancel.
Qed.

Example strcat_retutn_new : forall n (ld ls : list byte),
  Zlength ld + Zlength ls < n ->
  map Vbyte (ld ++ ls) ++
  upd_Znth 0 (list_repeat (Z.to_nat (n - (Zlength ld + Zlength ls))) Vundef) (Vint (Int.repr (Byte.signed (Znth 0 [Byte.zero])))) =
  map Vbyte ((ld ++ ls) ++ [Byte.zero]) ++ list_repeat (Z.to_nat (n - (Zlength ld + Zlength ls + 1))) Vundef.
Proof.
  intros.
  list_form. apply_list_ext. Znth_solve.
Qed.

(* Example using list_deduce *)
(*
Example strcat_retutn_alt : forall n (ld ls : list byte),
  Zlength ld + Zlength ls < n ->
  map Vbyte (ld ++ ls) ++
  upd_Znth 0 (list_repeat (Z.to_nat (n - (Zlength ld + Zlength ls))) Vundef) (Vint (Int.repr (Byte.signed (Znth 0 [Byte.zero])))) =
  map Vbyte ((ld ++ ls) ++ [Byte.zero]) ++ list_repeat (Z.to_nat (n - (Zlength ld + Zlength ls + 1))) Vundef.
Proof.
  intros. list_normalize. repeat list_deduce. f_equal. Zlength_solve.
Qed.
*)

Example strcat_return_old : forall n (ld ls : list byte),
  Zlength ld + Zlength ls < n ->
  map Vbyte (ld ++ ls) ++
  upd_Znth 0 (list_repeat (Z.to_nat (n - (Zlength ld + Zlength ls))) Vundef) (Vint (Int.repr (Byte.signed (Znth 0 [Byte.zero])))) =
  map Vbyte ((ld ++ ls) ++ [Byte.zero]) ++ list_repeat (Z.to_nat (n - (Zlength ld + Zlength ls + 1))) Vundef.
Proof.
  intros.
  replace (n - (Zlength ld + Zlength ls))
    with (1 + (n - (Zlength ld + Zlength ls+1))) by rep_omega.
  rewrite <- list_repeat_app' by rep_omega.
  rewrite upd_Znth_app1 by list_solve.
  rewrite app_assoc.
  simpl.
  rewrite !map_app.
  reflexivity.
Qed.

Example strcat_loop2_new : forall {cs : compspecs} sh n x ld ls dest,
  Zlength ls + Zlength ld < n ->
  0 <= x < Zlength ls ->
  data_at sh (tarray tschar n)
  (map Vbyte (ld ++ sublist 0 x ls) ++
   upd_Znth 0 (list_repeat (Z.to_nat (n - (Zlength ld + x))) Vundef) (Vint (Int.repr (Byte.signed (Znth x (ls ++ [Byte.zero])))))) dest
|-- data_at sh (tarray tschar n) (map Vbyte (ld ++ sublist 0 (x + 1) ls) ++ list_repeat (Z.to_nat (n - (Zlength ld + (x + 1)))) Vundef)
      dest.
Proof.
  intros.
  apply derives_refl'. f_equal.
  apply_list_ext. list_form. Znth_solve.
  fold_Vbyte. do 2 f_equal. omega.
Qed.

Example strcat_loop2_alt : forall {cs : compspecs} sh n x ld ls dest,
  Zlength ls + Zlength ld < n ->
  0 <= x < Zlength ls ->
  data_at sh (tarray tschar n)
  (map Vbyte (ld ++ sublist 0 x ls) ++
   upd_Znth 0 (list_repeat (Z.to_nat (n - (Zlength ld + x))) Vundef) (Vint (Int.repr (Byte.signed (Znth x (ls ++ [Byte.zero])))))) dest
|-- data_at sh (tarray tschar n) (map Vbyte (ld ++ sublist 0 (x + 1) ls) ++ list_repeat (Z.to_nat (n - (Zlength ld + (x + 1)))) Vundef)
      dest.
Proof.
  intros. fold_Vbyte.
  apply_list_ext. list_form. Znth_solve.
  apply data_subsume_refl'.
  do 2 f_equal. omega.
Qed.

Example strcat_loop2_old : forall {cs : compspecs} sh n x ld ls dest,
  Zlength ls + Zlength ld < n ->
  0 <= x < Zlength ls ->
  data_at sh (tarray tschar n)
  (map Vbyte (ld ++ sublist 0 x ls) ++
   upd_Znth 0 (list_repeat (Z.to_nat (n - (Zlength ld + x))) Vundef) (Vint (Int.repr (Byte.signed (Znth x (ls ++ [Byte.zero])))))) dest
|-- data_at sh (tarray tschar n) (map Vbyte (ld ++ sublist 0 (x + 1) ls) ++ list_repeat (Z.to_nat (n - (Zlength ld + (x + 1)))) Vundef)
      dest.
Proof.
  intros. rename x into j.
  rewrite (sublist_split 0 j (j+1)) by rep_omega.
  rewrite (app_assoc ld). rewrite !map_app.
  rewrite <- (app_assoc (_ ++ _)).
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  replace (n - (Zlength ld + j))
    with (1 + (n - (Zlength ld + (j + 1)))) by rep_omega.
  rewrite <- list_repeat_app' by rep_omega.
  cancel.
  rewrite upd_Znth_app1 by (autorewrite with sublist; rep_omega).
  rewrite app_Znth1 by list_solve.
  rewrite sublist_len_1 by rep_omega.
  cancel.
Qed.

Example strcpy_return_new : forall {cs : compspecs} sh n ls dest,
  Zlength ls < n ->
  data_at sh (tarray tschar n)
  (map Vbyte ls ++ upd_Znth 0 (list_repeat (Z.to_nat (n - Zlength ls)) Vundef) (Vint (Int.repr (Byte.signed Byte.zero)))) dest
|-- data_at sh (tarray tschar n) (map Vbyte (ls ++ [Byte.zero]) ++ list_repeat (Z.to_nat (n - (Zlength ls + 1))) Vundef) dest.
Proof.
  intros.
  list_form. apply_list_ext. Znth_solve.
Qed.

Example strcpy_return_old : forall {cs : compspecs} sh n ls dest,
  Zlength ls < n ->
  data_at sh (tarray tschar n)
  (map Vbyte ls ++ upd_Znth 0 (list_repeat (Z.to_nat (n - Zlength ls)) Vundef) (Vint (Int.repr (Byte.signed Byte.zero)))) dest
|-- data_at sh (tarray tschar n) (map Vbyte (ls ++ [Byte.zero]) ++ list_repeat (Z.to_nat (n - (Zlength ls + 1))) Vundef) dest.
Proof.
  intros.
  autorewrite with sublist.
  rewrite !map_app.
  rewrite <- app_assoc.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   autorewrite with sublist.
   replace (n - Zlength ls) with (1 + (n - (Zlength ls + 1))) at 2 by list_solve.
  rewrite <- list_repeat_app' by omega.
  autorewrite with sublist.
  rewrite !split_data_at_app_tschar by list_solve.
  cancel.
Qed.

Example strcpy_loop_new : forall {cs : compspecs} sh n x ls dest,
  Zlength ls < n ->
  0 <= x < Zlength ls + 1 ->
  Znth x (ls ++ [Byte.zero]) <> Byte.zero ->
  data_at sh (tarray tschar n)
  (map Vbyte (sublist 0 x ls) ++
   upd_Znth 0 (list_repeat (Z.to_nat (n - x)) Vundef) (Vint (Int.repr (Byte.signed (Znth x (ls ++ [Byte.zero])))))) dest
|-- data_at sh (tarray tschar n) (map Vbyte (sublist 0 (x + 1) ls) ++ list_repeat (Z.to_nat (n - (x + 1))) Vundef) dest.
Proof.
  intros.
  list_form. Znth_solve2.
  fold_Vbyte. apply_list_ext. Znth_solve.
  apply data_subsume_refl'. do 2 f_equal. omega.
Qed.

Example strcpy_loop_old : forall {cs : compspecs} sh n x ls dest,
  Zlength ls < n ->
  0 <= x < Zlength ls + 1 ->
  Znth x (ls ++ [Byte.zero]) <> Byte.zero ->
  ~ In Byte.zero ls ->
  data_at sh (tarray tschar n)
  (map Vbyte (sublist 0 x ls) ++
   upd_Znth 0 (list_repeat (Z.to_nat (n - x)) Vundef) (Vint (Int.repr (Byte.signed (Znth x (ls ++ [Byte.zero])))))) dest
|-- data_at sh (tarray tschar n) (map Vbyte (sublist 0 (x + 1) ls) ++ list_repeat (Z.to_nat (n - (x + 1))) Vundef) dest.
Proof.
  intros. rename x into i.
  assert (i < Zlength ls) by cstring.
  rewrite (sublist_split 0 i (i+1)) by list_solve.
  rewrite !map_app. rewrite <- app_assoc.
  autorewrite with sublist.
  rewrite !(split_data_at_app_tschar _ n) by list_solve.
  autorewrite with sublist.
   replace (n - i) with (1 + (n-(i+ 1))) at 2 by list_solve.
  rewrite <- list_repeat_app' by omega.
  autorewrite with sublist.
  cancel.
  rewrite !split_data_at_app_tschar by list_solve.
  autorewrite with sublist.
  rewrite sublist_len_1 by omega.
  simpl. cancel.
Qed.

(* This is a very hard case, a lot of deductions are needed *)
(* cool automation now! *)
Example strcmp_loop_new : forall i ls1 ls2,
  ~ In Byte.zero ls1 ->
  ~ In Byte.zero ls2 ->
  0 <= i < Zlength ls1 + 1 ->
  0 <= i < Zlength ls2 + 1 ->
  (forall j : Z, 0 <= j < i -> Znth j ls1 = Znth j ls2) ->
  i <> Zlength ls1 \/ i <> Zlength ls2 ->
  Znth i (ls1 ++ [Byte.zero]) = Znth i (ls2 ++ [Byte.zero]) ->
  i + 1 < Zlength ls1 + 1 /\
  i + 1 < Zlength ls2 + 1 /\
  forall j : Z, 0 <= j < i + 1 -> Znth j ls1 = Znth j ls2.
Proof.
  intros.
  list_form. range_form.
  Time split3; intros; Znth_solve2; try omega; range_saturate; try congruence; fassumption.
  (* New version : Finished transaction in 2.253 secs (2.25u,0.s) (successful) *)
  (* Old version : Finished transaction in 1.383 secs (1.375u,0.s) (successful) *)
Qed.

Example strcmp_loop_old : forall i ls1 ls2,
  ~ In Byte.zero ls1 ->
  ~ In Byte.zero ls2 ->
  0 <= i < Zlength ls1 + 1 ->
  0 <= i < Zlength ls2 + 1 ->
  sublist 0 i ls1 = sublist 0 i ls2 ->
  i <> Zlength ls1 \/ i <> Zlength ls2 ->
  Znth i (ls1 ++ [Byte.zero]) = Znth i (ls2 ++ [Byte.zero]) ->
  (Znth i (ls1 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls1) -> (* these two are not needed as they can be derived *)
  (Znth i (ls2 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls2) -> (* it makes proof easier to put them here *)
  i + 1 < Zlength ls1 + 1 /\
  i + 1 < Zlength ls2 + 1 /\
  sublist 0 (i+1) ls1 = sublist 0 (i+1) ls2.
Proof.
  intros.
  destruct (zlt i (Zlength ls1)).
  2:{
         assert (i = Zlength ls1) by omega. subst.
         destruct H4; [congruence | ].
         assert (Zlength ls1 < Zlength ls2) by omega.
         rewrite app_Znth2 in H5 by rep_omega.
         rewrite app_Znth1 in H5 by rep_omega.
         rewrite Z.sub_diag in H5. contradiction H0.
         change (Znth 0 [Byte.zero]) with Byte.zero in H5.
         rewrite H5. apply Znth_In. omega.
   }
  destruct (zlt i (Zlength ls2)).
  2:{
         assert (i = Zlength ls2) by omega. subst.
         destruct H4; [ | congruence].
         assert (Zlength ls1 > Zlength ls2) by omega.
         rewrite app_Znth1 in H5 by rep_omega.
         rewrite app_Znth2 in H5 by rep_omega.
         rewrite Z.sub_diag in H5. contradiction H.
         change (Znth 0 [Byte.zero]) with Byte.zero in H5.
         rewrite <- H5.  apply Znth_In. omega.
   }
  rewrite (sublist_split 0 i (i+1)) by omega.
  rewrite (sublist_split 0 i (i+1)) by omega.
  f_equal; auto.
  rewrite !sublist_len_1 by omega.
  autorewrite with sublist in H5.
  split. rep_omega. split. rep_omega.
  f_equal; auto. f_equal. auto.
Qed.


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

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype fintype.
From mathcomp Require Import ssralg ssrfun choice seq bigop ssrint.
From mathcomp Require Import generic_quotient.

Require Import xseq fraction fracfield polyall polydec ec.
Require Import ssrring.

Import GRing.Theory.
Import fraction.FracField.
Import fracfield.FracField.

Open Local Scope ring_scope.
Open Local Scope quotient_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(* -------------------------------------------------------------------- *)
Local Notation simp := Monoid.simpm.
Local Notation sizep := (size : {poly _} -> _).

Local Hint Extern 0 (is_true (Xpoly _ != 0)) => exact: XpolyN0.

(* -------------------------------------------------------------------- *)
Reserved Notation "[ 'ecp' a *Y + b ]"
  (at level 0, format "[ 'ecp'  a  *Y  +  b ]").

Reserved Notation "[ 'ecp' a *Y - b ]"
  (at level 0, format "[ 'ecp'  a  *Y  -  b ]").

Reserved Notation "p %:E" (at level 2, format "p %:E").

Reserved Notation "p .[ x , y ]" (at level 2, format "p .[ x ,  y ]").

Reserved Notation "{ 'ecpoly' E }"   (at level 0, format "{ 'ecpoly'  E }").

Section ECPolySub.
  Variable K : ringType.

  Inductive ecpoly (E : ecuType K) : predArgType := ECPoly of {poly K} * {poly K}.

  Coercion pair_val E (p : ecpoly E) := let: ECPoly p := p in p.

  Coercion poly_val E (p : ecpoly E) :=
    let: ECPoly p := p in (p.1 *: 'X + p.2%:P : {poly {poly K}}).

  Canonical ecpoly_subType E := Eval hnf in [newType for (@pair_val E) by (@ecpoly_rect E)].

  Definition ecpoly_eqMixin E := [eqMixin of ecpoly E by <:].
  Canonical  ecpoly_eqType  E := Eval hnf in EqType (ecpoly E) (ecpoly_eqMixin E).

  Variable E : ecuType K.

  Definition ecpoly_of of phant K := ecpoly E.
  Identity Coercion type_ecpoly_of : ecpoly_of >-> ecpoly.
End ECPolySub.

Notation "{ 'ecpoly' E }" := (@ecpoly_of _ E (Phant _)).

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

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

  Definition ecpoly_code (p : {ecpoly E}) :=
    let: ECPoly (p1, p2) := p in [:: p1; p2].

  Definition ecpoly_decode (p: seq {poly K}) : option {ecpoly E} :=
    if p is [:: p1; p2] then Some (ECPoly E (p1, p2)) else None.

  Definition ecpoly_codeK : pcancel ecpoly_code ecpoly_decode.
  Proof. by case=> [[]]. Qed.

  Definition ecpoly_choiceMixin := PcanChoiceMixin ecpoly_codeK.
  Canonical  ecpoly_choiceType  := Eval hnf in ChoiceType (ecpoly E) ecpoly_choiceMixin.

  Notation "[ 'ecp' a *Y + b ]" := (ECPoly E (a,  b) : {ecpoly E}).
  Notation "[ 'ecp' a *Y - b ]" := [ecp a *Y + (-b)].

  Definition ecX p := [ecp 0 *Y + p].

  Notation "p %:E" := (ecX p).

  Implicit Types p q r : {ecpoly E}.

  Lemma ecpolyE: forall p, [ecp p.1 *Y + p.2] = p.
  Proof. by case=> [[p1 p2]] /=. Qed.

  Definition zero := [ecp 0 *Y + 0].

  Definition opp  p   := locked [ecp -p.1 *Y - p.2].
  Definition add  p q := locked [ecp (p.1 + q.1) *Y + (p.2 + q.2)].

  Lemma eczeroE : zero = [ecp 0 *Y + 0].
  Proof. by rewrite /zero; unlock. Qed.

  Lemma ecoppE p : opp p = [ecp -p.1 *Y - p.2].
  Proof. by rewrite /opp; unlock. Qed.

  Lemma ecaddE p q : add p q = [ecp (p.1 + q.1) *Y + (p.2 + q.2)].
  Proof. by rewrite /add; unlock. Qed.

  Lemma addC: commutative add.
  Proof.
    case=> [[p1 p2]] [[q1 q2]].
    by rewrite !ecaddE /= [p1 + _]addrC [p2 + _]addrC.
  Qed.

  Lemma addA: associative add.
  Proof.
    case=> [[p1 p2]] [[q1 q2]] [[r1 r2]].
    by rewrite !ecaddE !addrA.
  Qed.

  Lemma add0p: left_id zero add.
  Proof.
    by case=> [[p1 p2]]; rewrite !(ecaddE, eczeroE, add0r).
  Qed.

  Lemma addNp: left_inverse zero opp add.
  Proof.
    by case=> [[p1 p2]]; rewrite !(ecaddE, ecoppE, eczeroE, addNr).
  Qed.

  Definition ecpoly_zmodMixin := ZmodMixin addA addC add0p addNp.
  Canonical  ecpoly_zmodType  := Eval hnf in ZmodType (ecpoly E) ecpoly_zmodMixin.

  Lemma zeroE: 0 = [ecp 0 *Y + 0] :> ecpoly E.
  Proof. by rewrite /GRing.zero /= eczeroE. Qed.

  Lemma oppE: forall p, -p = [ecp -p.1 *Y - p.2].
  Proof. by move=> p; rewrite /GRing.opp /= ecoppE. Qed.

  Lemma addE: forall p q, p + q = [ecp (p.1 + q.1) *Y + (p.2 + q.2)].
  Proof. by move=> p q; rewrite /GRing.add /= ecaddE. Qed.

  Definition dotp p q : {poly K} := p.2 * q.2 + (p.1 * q.1) * (Xpoly E).

  Definition one := [ecp 0 *Y + 1].

  Definition mul p q := locked [ecp (p.1 * q.2 + p.2 * q.1) *Y + (dotp p q)].

  Lemma econeE : one = [ecp 0 *Y + 1].
  Proof. by rewrite /one; unlock. Qed.

  Lemma ecmulE p q :
    mul p q = [ecp (p.1 * q.2 + p.2 * q.1) *Y + (dotp p q)].
  Proof. by rewrite /mul; unlock. Qed.

  Definition mulC: commutative mul.
  Proof.
    case=> [[p1 p2]] [[q1 q2]]; rewrite !ecmulE /dotp /=.
    congr (ECPoly _ (_, _)); rewrite ![q2 * _]mulrC ![p2 * _]mulrC.
    by rewrite addrC. by rewrite [p1 * _]mulrC.
  Qed.

  Lemma mulA: associative mul.
  Proof.
    case=> [[p1 p2]] [[q1 q2]] [[r1 r2]].
    rewrite !ecmulE /dotp /=; congr (ECPoly _ (_, _)).
    * rewrite !mulrDr !mulrDl -!mulrA -!addrA.
      by rewrite [X in _ + X]addrCA [X in _ + (_ + X)]addrC [(Xpoly _) * _]mulrC.
    * rewrite !mulrDr !mulrDl -!mulrA -!addrA.
      by rewrite [X in _ + X]addrCA [X in _ + (_ + X)]addrC [(Xpoly _) * _]mulrC.
  Qed.

  Lemma mul1p: left_id one mul.
  Proof.
    case=> [[p1 p2]]; rewrite !(econeE, ecmulE) /dotp /=.
    by rewrite !mul0r !mul1r addr0 add0r.
  Qed.

  Lemma mul_addl: left_distributive mul +%R.
  Proof.
    case=> [[p1 p2]] [[q1 q2]] [[r1 r2]].
    rewrite !addE /= !ecmulE /dotp /= !mulrDl.
    congr (ECPoly _ (_, _)); by rewrite addrAC !addrA addrAC //.
  Qed.

  Lemma nonzero1p: (one != 0).
  Proof.
    by rewrite econeE /= !eqE /= negb_and oner_neq0 orbT.
  Qed.

  Definition ecq_comRingMixin :=
    ComRingMixin mulA mulC mul1p mul_addl nonzero1p.

  Canonical ecq_Ring    := Eval hnf in RingType (ecpoly E)  ecq_comRingMixin.
  Canonical ecq_comRing := Eval hnf in ComRingType (ecpoly E) mulC.

  Lemma oneE: 1 = [ecp 0 *Y + 1] :> ecpoly E.
  Proof. by rewrite /GRing.one /= econeE. Qed.

  Lemma mulE: forall p q, p * q = [ecp (p.1 * q.2 + p.2 * q.1) *Y + (dotp p q)].
  Proof. by move=> p q; rewrite /GRing.mul /= ecmulE. Qed.

  Lemma mul_eqpolyC:
    forall (p1 q1 p2 q2 : {poly K}) c,
         p1 * q2 + p2 * q1 = 0
      -> p2 * q2 + p1 * q1 * (Xpoly E) = c%:P
      -> (p2 * q2 == c%:P) && (p1 * q1 == 0).
  Proof.
    move=> p1 q1 p2 q2 c.
    have [-> | nz_p1] := eqVneq p1 0; first by rewrite !simp eqxx simp=> _ /eqP.
    have [-> | nz_q1] := eqVneq q1 0; first by rewrite !simp eqxx simp=> _ /eqP.
    have [-> | nz_p2] := eqVneq p2 0.
    + move/eqP; rewrite !simp mulf_eq0 (negbTE nz_p1) /= => _.
      move/(congr1 sizep); rewrite !size_proper_mul;
        try by rewrite ?(mulf_neq0, lead_coef_eq0).
      by rewrite size_Xpoly addnC /= size_polyC; case: (c == 0).
    have [-> | nz_q2] := eqVneq q2 0.
    + move/eqP; rewrite !simp mulf_eq0 (negbTE nz_p2) /= => _.
      move/(congr1 sizep); rewrite !size_proper_mul;
        try by rewrite ?(mulf_neq0, lead_coef_eq0).
      by rewrite size_Xpoly addnC /= size_polyC; case: (c == 0).
    move/eqP; rewrite addr_eq0 => /eqP; move/(congr1 sizep).
    move/eqP; rewrite size_opp !size_proper_mul;
      try by rewrite ?(mulf_neq0, lead_coef_eq0).
    rewrite -eqSS !prednK ?lt0n; first last.
    + by rewrite addn_eq0 !size_poly_eq0 (negbTE nz_p1) (negbTE nz_q2).
    + by rewrite addn_eq0 !size_poly_eq0 (negbTE nz_p2) (negbTE nz_q1).
    move/eqP=> Hsz1 H; have Hsz2: size (p2 * q2) = size (p1 * q1 * Xpoly E).
    + apply size_addr; rewrite H size_polyC.
      rewrite !size_proper_mul ?(mulf_neq0, lead_coef_eq0) //.
      by rewrite size_Xpoly addnC /=; case: (c != 0).
    move: {H} Hsz2; rewrite !size_proper_mul ?(mulf_neq0, lead_coef_eq0) //.
    rewrite size_Xpoly [(_ + 4)%N]addnC /= prednK; last first.
    + by rewrite lt0n addn_eq0 !size_poly_eq0 (negbTE nz_p1) (negbTE nz_q1).
    move/eqP; rewrite -eqSS prednK ?lt0n; last first.
      by rewrite addn_eq0 !size_poly_eq0 (negbTE nz_p2) (negbTE nz_q2).
    rewrite -(eqn_add2r (size p1 + size q2)%N) {2}Hsz1.
    rewrite /= [(_.+3 + _)%N]addnC -!addnA eqn_add2l.
    rewrite addnCA -!addnS [(size q1 + _)%N]addnCA eqn_add2l.
    move/eqP; move/(congr1 odd); rewrite !addnS !addnn.
    by rewrite /= !odd_double.
  Qed.

  Lemma idomainAxiom: forall p q, p * q = 0 -> (p == 0) || (q == 0).
  Proof.
    move=> [[p1 p2]] [[q1 q2]] /eqP; rewrite mulE /= /dotp /=.
    move/eqP; case; rewrite !eqE /= !eqE /= => H1 H2.
    move: (mul_eqpolyC H1 H2); rewrite !mulf_eq0; case/andP.
    case/orP=> Hx2; case/orP=> Hx1; rewrite Hx1 Hx2 !simp //=.
    + by move/eqP: H1; rewrite (eqP Hx1) !simp mulf_eq0.
    + by move/eqP: H1; rewrite (eqP Hx1) !simp mulf_eq0.
  Qed.

  Definition unit : pred _ := fun p => (p.1 == 0) && (p.2 \is a GRing.unit).

  Definition inv p := if unit p then [ecp 0 *Y + p.2^-1] else p.

  Lemma mulVp : {in unit, left_inverse 1 inv *%R}.
  Proof.
    move=> [[p1 p2]]; rewrite /unit {1}/in_mem /=; case/andP.
    move/eqP=> -> Hp2; rewrite /inv /= /unit /= eqxx Hp2 /=.
    by rewrite mulE /= /dotp /= !simp mulVr.
  Qed.

  Lemma intro_unit : forall p q, q * p = 1 -> unit p.
  Proof.
    move=> [[p1 p2]] [[q1 q2]]; rewrite mulE /= /dotp /=; case=> H1 H2.
    move: (mul_eqpolyC H1 H2); case/andP=> H.
    have Hnz0: q2 * p2 != 0 by rewrite (eqP H) oner_neq0.
    move: Hnz0; rewrite mulf_eq0; case/norP=> Hq2N0 Hp2N0 Hpq1.
    apply/andP; split=> //=; last first.
    + by apply/unitrP; exists q2; split; rewrite ?[p2 * q2]mulrC (eqP H).
    move: Hpq1; rewrite mulf_eq0; case/orP=> //.
    move/eqP=> Hq1; move/eqP: H1; rewrite Hq1 !simp mulf_eq0.
    by rewrite (negbTE Hq2N0) /= => Hp1.
  Qed.

  Lemma inv_out : {in predC unit, inv =1 id}.
  Proof. by rewrite /inv => p /negbTE->. Qed.

  Definition ecq_comUnitMixin :=
    ComUnitRingMixin mulVp intro_unit inv_out.

  Canonical ecq_unitRingType :=
    Eval hnf in UnitRingType (ecpoly E) ecq_comUnitMixin.

  Canonical ecq_comUnitRingType :=
    Eval hnf in [comUnitRingType of ecpoly E].

  Canonical ecq_idomainType :=
    Eval hnf in IdomainType (ecpoly E) idomainAxiom.

  (* ---------------------------------------------------------------------- *)
  (* FIXME: L-module ? *)
  Lemma ec_scalel:
    forall (p q r : {poly K}), r%:E * [ecp p *Y + q] = [ecp r * p *Y + r * q].
  Proof.
    by move=> p q r; rewrite mulE /dotp /= !simp.
  Qed.

  Lemma ec_scaler:
    forall (p q r : {poly K}), r%:E * [ecp p *Y + q] = [ecp p * r *Y + q * r].
  Proof.
    by move=> p q r; rewrite ![_ * r]mulrC ec_scalel.
  Qed.

  Lemma ec_eq0 : forall p, (p == 0) = (p.1 == 0) && (p.2 == 0).
  Proof. by case. Qed.

  Lemma ec_neq0 : forall p, (p != 0) = (p.1 != 0) || (p.2 != 0).
  Proof. by move=> p; rewrite ec_eq0 negb_and. Qed.

  Lemma ecX_eq0 : forall (p : {poly K}), (p%:E == 0) = (p == 0).
  Proof. by move=> p; rewrite ec_eq0 /= eqxx. Qed.

  Lemma ecX_neq0: 'X%:E != 0.
  Proof. by rewrite ecX_eq0 polyX_eq0. Qed.

  Lemma ecY_neq0: [ecp 1 *Y + 0] != 0.
  Proof. by rewrite ec_eq0 /= oner_eq0. Qed.

  Lemma ecX_additive: additive ecX.
  Proof. by move=> p q; rewrite /ecX oppE addE /= subrr. Qed.

  Canonical ecX_is_additive := Additive ecX_additive.

  Lemma ecX_multiplicative: multiplicative ecX.
  Proof. by split=> // p q; rewrite /ecX mulE /dotp /= !simp. Qed.

  Canonical ecX_rmorphism := AddRMorphism ecX_multiplicative.

  Lemma ecX0     : 0%:E = 0. Proof. exact: rmorph0. Qed.
  Lemma ecXN     : {morph ecX: x / - x}. Proof. exact: rmorphN. Qed.
  Lemma ecXD     : {morph ecX: x y / x + y}. Proof. exact: rmorphD. Qed.
  Lemma ecXB     : {morph ecX: x y / x - y}. Proof. exact: rmorphB. Qed.
  Lemma ecXMn  n : {morph ecX: x / x *+ n}. Proof. exact: rmorphMn. Qed.
  Lemma ecXMNn n : {morph ecX: x / x *- n}. Proof. exact: rmorphMNn. Qed.
  Lemma ecX1     : 1%:E = 1. Proof. exact: rmorph1. Qed.
  Lemma ecXM     : {morph ecX: x y  / x * y}. Proof. exact: rmorphM. Qed.
  Lemma ecXX   n : {morph ecX: x / x ^+ n}. Proof. exact: rmorphX. Qed.

  Lemma ecX_inj: injective ecX.
  Proof. by move=> p1 p2 []. Qed.

  Canonical ecX_rimorphism := AddInjRMorphism ecX_inj.

  Lemma ecX_natr: forall n, n%:R = n%:R%:E.
  Proof.
    by elim=> [|n IH] //=; rewrite -addn1 !natrD IH ecXD.
  Qed.

  Lemma ecY_sqr:
    forall (p : {poly K}),
      [ecp p *Y + 0]^+2 = (p^+2 * (Xpoly E))%:E.
  Proof.
    by move=> p; rewrite expr2 mulE /dotp /= !simp expr2.
  Qed.

  Lemma ecY_exp_double:
    forall (p : {poly K}) n,
      [ecp p *Y + 0]^+n.*2 = ((p^+n.*2) * (Xpoly E)^+n)%:E.
  Proof.
    move=> p n; rewrite -!mul2n !exprM ecY_sqr.
    by rewrite -ecXX exprMn.
  Qed.

  Lemma ecY_exp_doubleS:
    forall (p : {poly K}) n,
      [ecp p *Y + 0]^+(n.*2.+1) = [ecp ((p^+n.*2.+1) * (Xpoly E)^+n) *Y + 0].
  Proof.
    move=> p n; rewrite !exprS ecY_exp_double mulE.
    by rewrite /dotp /= !simp /=.
  Qed.

  Lemma ecY_ecX_mul:
    forall (p q : {poly K}), [ecp p *Y + 0] * q%:E = [ecp p * q *Y + 0].
  Proof. by move=> p q; rewrite mulE /dotp /= !simp. Qed.

  (* ---------------------------------------------------------------------- *)
  Definition eceval p (x y : K) := p.1.[x] * y + p.2.[x].

  Notation "p .[ x , y ]" := (eceval p x y).

  Lemma ecevalE: forall p x y, p.[x, y] = p.[y%:P].[x].
  Proof.
    case=> [[p1 p2]] x y; rewrite /eceval //=.
    rewrite hornerD hornerC hornerZ hornerX.
    by rewrite hornerD hornerM hornerC.
  Qed.

  Lemma ecX_eceval :
    forall (p : {poly K}) x y, [ecp 0 *Y + p].[x, y] = p.[x].
  Proof.
    by move=> p x y; rewrite /eceval /= horner0 !simp.
  Qed.

  Lemma ecY_eceval :
    forall (p : {poly K}) x y, [ecp p *Y + 0].[x, y] = y * p.[x].
  Proof.
    by move=> p x y; rewrite /eceval /= horner0 !simp mulrC.
  Qed.

  Lemma eceval0 : forall x y, (0 : ecpoly E).[x, y] = 0.
  Proof.
    by move=> x y; rewrite ecevalE /= !simp scale0r !horner0.
  Qed.

  Lemma eceval1 : forall x y, (1 : ecpoly E).[x, y] = 1.
  Proof.
    by move=> x y; rewrite ecevalE /= !hornerE.
  Qed.

  Lemma eceval_neq0:
    forall p x y, p.[x, y] != 0 -> p != 0 :> ecpoly E.
  Proof.
    move=> p x y nz_pxy; apply/negP=> /eqP z_p.
    by rewrite z_p eceval0 eqxx in nz_pxy.
  Qed.

  Lemma eceval_add:
    forall (p q : ecpoly E) x y,
      (p + q).[x, y] = p.[x, y] + q.[x, y].
  Proof.
    move=> [[p1 p2]] [[q1 q2]] x y ; rewrite addE /=.
    rewrite /eceval /= !hornerD mulrDl.
    by rewrite addrAC addrA [q1.[x]*y + q2.[x]]addrC addrA.
  Qed.

  Lemma eceval_opp (p : ecpoly E) x y: (- p).[x, y] = - p.[x, y].
  Proof.
    case: p => [[p1 p2]]; rewrite oppE /= /eceval /=.
    by rewrite !hornerE opprD mulNr.
  Qed.

  Lemma eceval_mul:
    forall (p q : ecpoly E) x y, oncurve E (| x, y |) ->
      (p * q).[x, y] = p.[x, y] * q.[x, y].
  Proof.
    move=> [[p1 p2]] [[q1 q2]] x y cv; rewrite mulE /dotp /=.
    rewrite /eceval /= !(hornerM, hornerE) /= ![_ * y + _]addrC.
    move: cv; rewrite /oncurve -horner_Xpoly => /eqP <-.
    rewrite !(mulrDr, mulrDl) !addrA !mulrA.
    by rewrite ![(_ * y) * _]mulrAC.
  Qed.

  Lemma eceval_prod:
    forall (ps : seq (ecpoly E)) x y, oncurve E (|x, y|) ->
      (\prod_(p <- ps) p).[x, y] = \prod_(p <- ps) (p.[x, y]).
  Proof.
    move=> ps x y oncve; elim: ps => [|p ps IH].
    + by rewrite !big_nil eceval1.
    + by rewrite !big_cons eceval_mul // IH.
  Qed.

  Lemma eceval_exp :
    forall (p : ecpoly E) x y n,  oncurve E (| x, y |) ->
      (p ^+ n).[x, y] = p.[x, y] ^+ n.
  Proof.
    move=> p x y n cve; elim: n => [|n IH].
    + by rewrite !expr0 eceval1.
    by rewrite !exprS eceval_mul // IH.
  Qed.

  Definition ecmap (f : {poly K} -> {poly K}) :=
    fun p => [ecp (f p.1) *Y + (f p.2)].

  Local Notation "p %// r" := (ecmap (divp^~ r) p) (at level 40).

  (* ---------------------------------------------------------------------- *)
  Definition conjp p : {ecpoly E} := [ecp -p.1 *Y + p.2].
  Definition normp p : {poly   K} := dotp p (conjp p).

  Lemma conjp_normp:
    forall p, p * (conjp p) = [ecp 0 *Y + (normp p)].
  Proof.
    case=> [[p1 p2]]; rewrite mulE /normp /dotp /=.
    by rewrite mulrN mulrC subrr !mulrN mulNr addrC.
  Qed.

  Lemma normp_conjp:
    forall p, normp p = (p * (conjp p)).2.
  Proof. by move=> p; rewrite conjp_normp. Qed.

  Lemma conjp_is_additive: additive conjp.
  Proof.
    move=> p q; rewrite /conjp !(addE, oppE) /=.
    by rewrite opprK opprB addrC.
  Qed.

  Canonical conjp_additive := Additive conjp_is_additive.

  Lemma conjp_is_multiplicative: multiplicative conjp.
  Proof.
    split; last by rewrite /conjp oppr0.
    move=> p q; rewrite /conjp !mulE /dotp /=.
    by rewrite mulrNN mulrN opprD mulNr.
  Qed.

  Canonical conjp_rmorphism := AddRMorphism conjp_is_multiplicative.

  Lemma conjp0     : conjp 0 = 0                . Proof. exact: rmorph0. Qed.
  Lemma conjpN     : {morph conjp: x / - x}     . Proof. exact: rmorphN. Qed.
  Lemma conjpD     : {morph conjp: x y / x + y} . Proof. exact: rmorphD. Qed.
  Lemma conjpB     : {morph conjp: x y / x - y} . Proof. exact: rmorphB. Qed.
  Lemma conjpMn  n : {morph conjp: x / x *+ n}  . Proof. exact: rmorphMn. Qed.
  Lemma conjpMNn n : {morph conjp: x / x *- n}  . Proof. exact: rmorphMNn. Qed.
  Lemma conjp1     : conjp 1 = 1                . Proof. exact: rmorph1. Qed.
  Lemma conjpM     : {morph conjp: x y  / x * y}. Proof. exact: rmorphM. Qed.
  Lemma conjpX   n : {morph conjp: x / x ^+ n}  . Proof. exact: rmorphX. Qed.

  Lemma conjp_inj: injective conjp.
  Proof.
    case=> [[p1 p2]] [[q1 q2]] /=; rewrite /conjp /=.
    by case=> /eqP; rewrite eqr_opp=> /eqP -> ->.
  Qed.

  Canonical conjp_rimorphism := AddInjRMorphism conjp_inj.

  Lemma conjp_eq0: forall p, (conjp p == 0) = (p == 0).
  Proof.
    move=> p; apply/eqP/eqP; last by move=> ->; rewrite conjp0.
    by rewrite -{1}[0]conjp0=> /conjp_inj.
  Qed.

  Lemma conjpK: involutive conjp.
  Proof. by move=> p; rewrite /conjp /= opprK ecpolyE. Qed.

  Lemma conjp1E: forall p, (conjp p).1 = -p.1.
  Proof. by case. Qed.

  Lemma conjp2E: forall p, (conjp p).2 = p.2.
  Proof. by case. Qed.

  Definition conjpE := (conjp1E, conjp2E).

  Lemma conjp_ecX:
    forall (p : {poly K}), conjp p%:E = p%:E.
  Proof. by move=> p; rewrite /conjp oppr0. Qed.

  Lemma conjp_ecY:
    forall (p : {poly K}), conjp [ecp p *Y + 0] = -[ecp p *Y + 0].
  Proof. by move=> p; rewrite /conjp oppE oppr0. Qed.

  Lemma eceval_conjp (p : ecpoly E) x y: (conjp p).[x, -y] = p.[x, y].
  Proof.
    case: p=> [[p1 p2]]; rewrite /conjp /= /eceval /=.
    by rewrite hornerN mulrNN.
  Qed.

  Lemma dotpC: forall p q, dotp p q = dotp q p.
  Proof.
    by move=> p q; rewrite /dotp /= [p.1 * _]mulrC [p.2 * _]mulrC.
  Qed.

  Lemma dotp_addl: forall r, {morph (dotp^~ r) : p q / p + q}.
  Proof.
    move=> r p q; rewrite addE /dotp /= !mulrDl.
    by rewrite addrAC !addrA addrAC.
  Qed.

  Lemma dotp_addr: forall r, {morph (dotp r) : p q / p + q}.
  Proof.
    by move=> r ??; rewrite dotpC dotp_addl ![dotp _ r]dotpC.
  Qed.

  Lemma dotp_conjp: forall p q, dotp (conjp p) (conjp q) = (dotp p q).
  Proof.
    by move=> p q; rewrite /dotp !conjpE mulNr mulrN opprK.
  Qed.

  Lemma norm0: normp 0 = 0.
  Proof.
    by rewrite /normp /dotp /= !mul0r add0r.
  Qed.

  Lemma norm1 : normp 1 = 1.
  Proof. by rewrite /normp /dotp /= !simp. Qed.

  Lemma normpE: forall p, normp p = (p.2)^+2 - (p.1)^+2 * (Xpoly E).
  Proof.
    by case=> [[p1 p2]] /=; rewrite /normp /dotp /= mulrN mulNr.
  Qed.

  Lemma normp_conjp_eq: forall p, normp (conjp p) = normp p.
  Proof.
    by move=> p; rewrite /normp conjpK dotpC.
  Qed.

  Lemma normpM: {morph normp : p q / p * q}.
  Proof.
    move=> p q; rewrite normp_conjp conjpM mulrCA.
    rewrite -mulrA conjp_normp mulrA [_ * p]mulrC conjp_normp.
    by rewrite mulE /= /dotp /= !mul0r addr0.
  Qed.

  Lemma normpX: forall p k, normp (p^+k) =  (normp p)^+k.
  Proof.
    move=> p; elim=> [|k IH].
    + by rewrite !expr0 norm1.
    + by rewrite !exprS normpM IH.
  Qed.

  Lemma norm_eq0:
    forall p, (normp p == 0) = (p == 0).
  Proof.
    move=> p; apply: (sameP idP); apply: (iffP idP).
    + by move/eqP=> ->; rewrite norm0.
    case: p => [[p q]]; rewrite /normp /dotp /= => /eqP.
    have [-> | nz_p] := eqVneq p 0; rewrite ?simp.
    + by move/eqP; rewrite mulf_eq0; case/orP=> /eqP ->.
    move/eqP; rewrite mulrN mulNr subr_eq0.
    have [-> | nz_q] := eqVneq q 0; rewrite ?simp.
    + by rewrite eq_sym !mulf_eq0 (negbTE nz_p) // ?(negbTE (XpolyN0 _)).
    move/eqP=> /(congr1 sizep).
    rewrite [size (_ * Xpoly _)]size_proper_mul; last first.
    + by rewrite mulf_neq0 // lead_coef_eq0 // mulf_neq0.
    rewrite size_Xpoly addnC /=; move/(congr1 odd).
    by rewrite -!expr2 /= !odd_size_id_exp.
  Qed.

  Lemma normp_ecX (p : {poly K}): normp p%:E = p ^+ 2.
  Proof.
    by rewrite normp_conjp conjp_ecX -ecXM.
  Qed.

  (* ---------------------------------------------------------------------- *)
  Definition degree p := size (normp p).

  Lemma degree0: degree 0 = 0%N.
  Proof. by rewrite /degree norm0 size_poly0. Qed.

  Lemma degree_eq0: forall p, (degree p == 0%N) = (p == 0).
  Proof.
    by move=> p; rewrite /degree size_poly_eq0 norm_eq0.
  Qed.

  Lemma degree_pX:
    forall (p : {poly K}), degree (p%:E) = (2 * (size p)).-1.
  Proof.
    move=> p; have [->|nz_p] := eqVneq p 0.
    + by rewrite degree0 size_poly0 muln0.
    rewrite /degree normpE /= !expr2 !simp subr0.
    rewrite size_proper_mul ?(mul2n, addnn) //.
    + by rewrite mulf_neq0 // lead_coef_eq0.
  Qed.

  Lemma degree_pY:
    forall (p : {poly K}),
      p != 0 -> degree [ecp p *Y + 0] = (2 * (size p).+1)%N.
  Proof.
    move=> p nz_p; rewrite /degree normpE /= expr2 !simp size_opp.
    rewrite size_proper_mul ?(mulf_neq0, lead_coef_eq0) // size_Xpoly.
    rewrite addnC /= expr2 size_proper_mul ?addnn //; last first.
    + by rewrite mulf_neq0 // lead_coef_eq0.
    rewrite prednK ?(double_gt0, lt0n, size_poly_eq0) //.
    by rewrite mul2n doubleS.
  Qed.

  Lemma degreeC (c : K): c != 0 -> degree ((c%:P)%:E) = 1%N.
  Proof.
    by move=> cnz; rewrite degree_pX size_polyC cnz.
  Qed.

  Lemma degree_exp:
    forall p k, p != 0 -> degree (p ^+ k) = ((degree p).-1 * k).+1.
  Proof.
    move=> p k nz_p; rewrite /degree normpX size_id_exp ?norm_eq0 //.
    by rewrite -subn1 mulnBl mul1n [(k * _)%N]mulnC.
  Qed.

  Lemma degree_mul_id:
    forall p q, p * q != 0 -> degree (p * q) = (degree p + degree q).-1.
  Proof.
    move=> p q; rewrite mulf_eq0 => /norP [nz_p nz_q].
    rewrite /degree normpM size_proper_mul //.
    by rewrite mulf_neq0 // lead_coef_eq0 norm_eq0.
  Qed.

  Lemma degreeX : degree 'X%:E = 3.
  Proof. by rewrite degree_pX size_polyX. Qed.

  Lemma degreeY : degree [ecp 1 *Y + 0] = 4.
  Proof. by rewrite degree_pY ?(size_polyC, oner_neq0). Qed.

  Lemma degree_expX : forall k, degree (('X%:E)^+k) = (2 * k).+1.
  Proof.
    move=> k; rewrite degree_exp ?degreeX //.
    by rewrite ecX_eq0 -size_poly_eq0 size_polyX.
  Qed.

  Lemma degree_expY : forall k, degree ([ecp 1 *Y + 0]^+k) = (3 * k).+1.
  Proof.
    move=> k; rewrite degree_exp ?degreeY //.
    by rewrite ec_neq0 /= oner_neq0.
  Qed.

  Lemma degree_conjp : forall p, degree (conjp p) = degree p .
  Proof.
    by move=> p; rewrite /degree normp_conjp_eq.
  Qed.

  Lemma degree_opp : forall p, degree (-p) = degree p.
  Proof.
    by move=> p; rewrite /degree normpE oppE !sqrrN -normpE.
  Qed.

  Lemma degree_normp:
    forall p, degree (normp p)%:E = (2 * (degree p)).-1%N.
  Proof. by move=> p; rewrite degree_pX. Qed.

  Lemma degreeE (p : ecpoly E) :
    degree p = (maxn (2 * size p.2).-1 ((2 * (size p.1).+1) * (p.1 != 0))).
  Proof.
    case: p => [[p1 p2]] /=; have [->|nz_p1] := eqVneq p1 0.
      by rewrite eqxx muln0 maxn0 degree_pX.
    rewrite nz_p1 muln1; have [->|nz_p2] := eqVneq p2 0.
      by rewrite degree_pY // size_poly0 muln0 max0n.
    rewrite /degree /normp /dotp /= size_add_max; last first.
      rewrite mulrN mulNr size_opp !size_mul ?mulf_neq0 ?XpolyN0 //.
      rewrite !addnn size_Xpoly addn4 /= prednK; last first.
        by rewrite lt0n double_eq0 size_poly_eq0.
      apply/negP=> /eqP /(congr1 S); rewrite prednK; last first.
        by rewrite lt0n double_eq0 size_poly_eq0.
      by move/(congr1 odd); rewrite /= !odd_double.
    rewrite mulrN mulNr size_opp !size_mul ?mulf_neq0 ?XpolyN0 //.
    rewrite !addnn -!mul2n size_Xpoly addn4 /= prednK; last first.
      by rewrite lt0n muln_eq0 /= size_poly_eq0.
    by rewrite -[(size p1).+1]addn1 mulnDr muln1 addn2.
  Qed.

  Lemma degree_add_max (p q : ecpoly E):
    degree p != degree q -> degree (p + q) = maxn (degree p) (degree q).
  Proof.
    have maxn_neqR_le n m1 m2:
      maxn n m1 != maxn n m2 -> (n < maxn m1 m2).
    + rewrite leq_max /maxn;
        case: (ltnP n m1); case: (ltnP n m2) => //;
        by rewrite eqxx.
    wlog: p q / (size q.1 <= size p.1).
      move=> wlog ne_deg_pq; case: (leqP (size q.1) (size p.1)).
        by move=> le_sz_qp; apply: wlog.
      move=> lt_sz_pq; rewrite addrC maxnC; apply: wlog => //.
        by apply: ltnW. by rewrite eq_sym.
    move=> leq_piq; rewrite !degreeE !addE /=.
    have [z_p1|nz_p1] := eqVneq p.1 0.
      have z_q1: q.1 = 0.
        apply/eqP; rewrite -size_poly_eq0 -leqn0 (leq_trans leq_piq) //.
        by rewrite leqn0 z_p1 size_poly0.
      rewrite z_q1 z_p1 // addr0 eqxx !muln0 !maxn0.
      rewrite maxn_pred !mul2n -map_maxn; last exact: leq_double.
      have predn_neq n m: n.-1 != m.-1 -> n != m.
        by case: n m => [|n] [|m].
      move/predn_neq; rewrite (inj_eq double_inj)=> ne_sz_pq2.
      by rewrite -size_add_max.
    have [z_q1|nz_q1] := eqVneq q.1 0.
      rewrite z_q1 addr0 nz_p1 !eqxx !(muln1, muln0) !maxn0.
      rewrite maxnAC maxn_pred !mul2n -map_maxn; last exact: leq_double.
      case: (size p.2 =P size q.2); last first.
        by move=> /eqP ne_sz_pq2 _; rewrite -size_add_max.
      move=> eq_sz_pq2; rewrite eq_sz_pq2 maxnn {1}/maxn.
      case: ltnP; last (by rewrite eqxx); rewrite {2}/maxn=> lt.
      move=> ne; rewrite lt; apply/maxn_idPr; rewrite (leq_trans _ lt) //.
      have ltn_pred n m: n <= m -> n.-1 <= m.-1.
        by case: n m => [|n] [|m].
      apply: ltnW; rewrite ltnS ltn_pred // leq_double.
      by rewrite (leq_trans (size_add _ _)) // eq_sz_pq2 maxnn.
    rewrite nz_p1 nz_q1 !muln1; move: leq_piq; rewrite leq_eqVlt; case/orP.
      move/eqP=> eq_sz_pq1; rewrite eq_sz_pq1 2![maxn _.-1 _]maxnC.
      rewrite !mul2n => ne; have/eqP/(_ (congr1 _ _)) := ne => /eqP.
      have predn_neq n m: n.-1 != m.-1 -> n != m.
        by case: n m => [|n] [|m].
      move/predn_neq; rewrite (inj_eq double_inj) => ne_sz_pq2.
      rewrite maxnACA maxnn maxnC maxn_pred -map_maxn; last first.
        by exact: leq_double.
      rewrite -size_add_max //; have/maxn_neqR_le := ne.
      rewrite maxn_pred -(map_maxn _); last exact: leq_double.
      rewrite -size_add_max // {2}/maxn => le; rewrite le.
      apply/maxn_idPr; apply: (leq_trans _ (ltnW le)).
      case: (_ != 0); last by rewrite muln0 leq0n.
      rewrite muln1 leq_double ltnS -[X in _ <= X]maxnn.
      by rewrite -{2}eq_sz_pq1; apply: size_add.
    move=>lt_sz_qp1; have nz_pDq1: p.1 + q.1 != 0.
      rewrite -size_poly_eq0 size_add_max; last first.
        by move: lt_sz_qp1; rewrite ltn_neqAle eq_sym; case/andP.
      by rewrite maxnC /maxn lt_sz_qp1 size_poly_eq0.
    rewrite nz_pDq1 muln1 => ne; apply/esym; rewrite maxnACA maxnC.
    rewrite !mul2n -map_maxn; last exact: leq_double.
    rewrite maxnSS -size_add_max; last first.
      by move: lt_sz_qp1; rewrite ltn_neqAle eq_sym; case/andP.
    rewrite maxnC; case: (eqVneq (size p.2) (size q.2)); last first.
      move=> ne_sz_pq2; rewrite maxn_pred -map_maxn; last first.
        exact: leq_double.
      by rewrite -size_add_max.
    move=> eq_sz_pq2; move: ne; rewrite eq_sz_pq2 maxnn.
    rewrite !mul2n => /maxn_neqR_le; rewrite -map_maxn; last first.
      exact: leq_double.
    rewrite maxnSS -size_add_max; last first.
      by move: lt_sz_qp1; rewrite ltn_neqAle eq_sym; case/andP.
    move=> lt; rewrite {1}/maxn lt; apply/esym/maxn_idPr.
    apply: (leq_trans _ (ltnW lt)); rewrite -!subn1 leq_sub2r //.
    rewrite leq_double -[X in _ <= X]maxnn -{2}eq_sz_pq2.
    by rewrite maxnC size_add.
  Qed.

  Lemma degree_add (p q : {ecpoly E}):
    degree (p + q) <= maxn (degree p) (degree q).
  Proof.
    have leq_predn n m: n <= m -> n.-1 <= m.-1.
      by case: n m => [|n] [|m].
    wlog: p q / (size q.1 <= size p.1).
      move=> wlog; case: (leqP (size q.1) (size p.1)).
        by move=> le_sz_qp; apply: wlog.
      move=> lt_sz_pq; rewrite addrC maxnC; apply: wlog => //.
        by apply: ltnW.
    move=> leq_piq; rewrite !degreeE !addE /=.
    have [z_p1|nz_p1] := eqVneq p.1 0.
      have z_q1: q.1 = 0.
        apply/eqP; rewrite -size_poly_eq0 -leqn0 (leq_trans leq_piq) //.
        by rewrite leqn0 z_p1 size_poly0.
      rewrite z_q1 z_p1 // addr0 eqxx !muln0 !maxn0.
      rewrite maxn_pred !mul2n -map_maxn; last exact: leq_double.
      by apply: leq_predn; rewrite leq_double size_add.
    have [z_q1|nz_q1] := eqVneq q.1 0.
      rewrite z_q1 addr0 nz_p1 !eqxx !(muln1, muln0) !maxn0.
      rewrite maxnAC maxn_pred !mul2n -map_maxn; last exact: leq_double.
      rewrite geq_max [X in _&&X]leq_max leqnn orbT andbT.
      rewrite leq_max; apply/orP; left; apply/leq_predn.
      by rewrite leq_double size_add.
    rewrite nz_p1 nz_q1 !muln1; set n := maxn _ _.
    have: n <= maxn (2 * size (p.2 + q.2)).-1 (2 * (size (p.1 + q.1)).+1).
      rewrite {}/n; case: (_ =P 0); rewrite !(muln0, muln1) //.
      by rewrite maxn0 leq_maxl.
    move=> le; apply/(leq_trans le); rewrite !mul2n.
    rewrite maxnA [X in _<= maxn X _]maxnAC -[X in _<= X]maxnA.
    rewrite geq_max; apply/andP; split; rewrite leq_max;
      apply/orP; [left | right]; rewrite ?maxn_pred.
    + apply/leq_predn; rewrite -map_maxn; last exact: leq_double.
      by rewrite leq_double size_add.
    + rewrite -map_maxn; last exact: leq_double; rewrite leq_double.
      by rewrite maxnSS ltnS size_add.
  Qed.

  Lemma degree_addl (p q : ecpoly E):
    degree q < degree p -> degree (p + q) = degree p.
  Proof.
    move=> lt; rewrite degree_add_max; last first.
      by move: lt; rewrite ltn_neqAle eq_sym; case/andP.
    by rewrite maxnC /maxn lt.
  Qed.

  Lemma odd_degree_lt (p : ecpoly E): p.1 != 0 -> p.2 != 0 ->
    odd (degree p) = ~~ (size p.2 <= (size p.1).+1)%N.
  Proof.
    move=> nz_p1 nz_p2; rewrite degreeE nz_p1 muln1.
    have <-: forall n, ~~ odd n.+1 = odd n by move=> ?; rewrite negbK.
    rewrite -maxnSS prednK ?muln_gt0 /= ?lt0n ?size_poly_eq0 //.
    rewrite maxnC /maxn ltnNge; case: leqP.
    + rewrite !mul2n /= odd_double /= leq_eqVlt; case/orP.
        by move/eqP/(congr1 odd); rewrite /= !odd_double.
      by rewrite ltnS leq_double => ->.
    + rewrite !mul2n odd_double -doubleS leq_double /=.
      by rewrite ltnNge => ->.
  Qed.

  Lemma degree_odd_nzpX (p : ecpoly E): odd (degree p) -> p.2 != 0.
  Proof.
    rewrite degreeE /maxn; case: ltnP => _.
    + rewrite mul2n; case: eqP; first by rewrite muln0.
      by rewrite muln1 doubleS /= odd_double.
    + rewrite -size_poly_eq0; case: (size p.2) => [//|n].
      by rewrite mul2n doubleS /= odd_double.
  Qed.

  Lemma degree_even_nzpY (p : ecpoly E):
    p != 0 -> ~~ odd (degree p) -> p.1 != 0.
  Proof.
    case: p => [[p1 p2]]; do 2! rewrite eqE /=.
    case/nandP => // nz_p2; rewrite degreeE /=.
    case: eqP => [->|//]; rewrite size_poly0 !Monoid.simpm.
    move: nz_p2; rewrite -size_poly_eq0; case: (size p2) => [//|n] _.
    by rewrite mul2n doubleS /= odd_double.
  Qed.

  Lemma odd_degreeE (n : ecpoly E):
    odd (degree n) -> degree n = (2 * (size n.2)).-1.
  Proof.
    rewrite degreeE /maxn; case: ltnP => //=.
    by move=> _; rewrite -mulnA mul2n odd_double.
  Qed.

  Lemma even_degreeE (n : ecpoly E):
    ~~ (odd (degree n)) -> degree n = (2 * (size n.1).+1 * (n.1 != 0%R))%N.
  Proof.
    rewrite degreeE; have [->|nz_n2] := eqVneq n.2 0.
      by move=> _; rewrite size_poly0 max0n.
    rewrite /maxn; case: ltnP => //=.
    move=> _; case sz: (size n.2) => [|k].
    + by move/eqP: sz; rewrite size_poly_eq0 (negbTE nz_n2).
    + by rewrite mul2n /= odd_double.
  Qed.

  (* ------------------------------------------------------------------ *)
  Definition fdegree_r (f : {ratio {ecpoly E}}) :=
    if \n_f == 0 then 0 else (degree \n_f)%:Z - (degree \d_f)%:Z.

  Definition fdegree :=
    lift_fun1 {fraction {ecpoly E}} fdegree_r.

  Lemma pi_fdegree:
    {mono \pi_{fraction {ecpoly E}} : f / fdegree_r f >-> fdegree f}.
  Proof.
    move=> f2; unlock fdegree; set f1 := (repr _).
    have: (f1 = f2 %[mod {fraction _}]) by rewrite reprK.
    case: f2 f1 => [[n2 d2] /= nz_d2] [[n1 d1] /= nz_d1] /=.
    move/eqmodP => /=; rewrite FracField.equivfE /= => eqE.
    have/eqP/(congr1 (fun x => x == 0)) := eqE.
      rewrite !mulf_eq0 (negbTE nz_d1) (negbTE nz_d2) !(orbF, orFb) => nz.
    rewrite /fdegree_r /= -nz; case: (n1 =P 0) => [//|/eqP nz_n1].
    have := nz_n1; rewrite nz => {nz} nz_n2.
    move/eqP/(congr1 degree): eqE; rewrite !degree_mul_id ?mulf_neq0 // => /eqP.
    rewrite -eqSS !prednK ?lt0n ?addn_eq0 1?negb_and; first last.
      by rewrite !degree_eq0 nz_n1. by rewrite !degree_eq0 nz_d1.
    by rewrite -eqz_nat !PoszD [X in _==X]addrC -addr_cross => /eqP ->.
  Qed.

  Canonical pi_fdegree_morph := PiMono1 pi_fdegree.

  Lemma fdegreeF (f : {ecpoly E}): fdegree f%:F = (degree f).-1.
  Proof.
    rewrite !piE /fdegree_r !numden_Ratio ?oner_neq0 //.
    have [->|nz_f] := eqVneq f 0; first by rewrite eqxx degree0.
    rewrite (negbTE nz_f) degreeC ?oner_eq0 // predn_int //.
    by rewrite lt0n degree_eq0.
  Qed.

  Lemma fdegreeE (n d : {ecpoly E}): n * d != 0 ->
    fdegree (n // d) = (degree n)%:Z - (degree d)%:Z.
  Proof.
    rewrite mulf_eq0 => /norP [nz_n nz_d].
    rewrite !piE /fdegree_r !numden_Ratio //.
    by rewrite (negbTE nz_n).
  Qed.

  Lemma fdegreeM (f g : {fraction {ecpoly E}}): f * g != 0 ->
    fdegree (f * g) = (fdegree f) + (fdegree g).
  Proof.
    elim/fracW: f => [nf df nz_df]; elim/fracW: g => [ng dg nz_dg].
    rewrite !mulf_eq0 !invr_eq0 !tofrac_eq0 !negb_or -!andbA.
    case/and4P => nz_nf _ nz_ng _; rewrite mulf_div -!tofracM.
    rewrite !fdegreeE ?degree_mul_id ?mulf_neq0 //.
    rewrite !predn_int ?(lt0n, addn_eq0) ?degree_eq0;
      try by rewrite negb_and; apply/orP; left.
    by rewrite !PoszD addrAC !opprD -!addrA opprK subrr; ssring.
  Qed.

  Lemma fdegreeC (c : K): fdegree ((c%:P)%:E)%:F = 0.
  Proof.
    rewrite fdegreeF; have [->|nz_c] := eqVneq c 0.
      by rewrite degree0. by rewrite degreeC.
  Qed.

  Lemma fdegreeXn (f : {fraction {ecpoly E}}) n:
    fdegree (f ^+ n) = (fdegree f) *+ n.
  Proof.
    have [->|nz_f] := eqVneq f 0.
      rewrite expr0n fdegreeC mul0rn;
        by case: (_ == _); rewrite fdegreeC.
    elim: n => [|n IH]; first by rewrite expr0 fdegreeC mulr0n.
    by rewrite exprS fdegreeM ?(mulf_neq0, expf_neq0) // IH mulrS.
  Qed.

  Lemma fdegreeV (f : {fraction {ecpoly E}}): fdegree f^-1 = -(fdegree f).
  Proof.
    have [->|nz_f] := eqVneq f 0; first by rewrite invr0 fdegreeC oppr0.
    elim/fracW: f nz_f => n d nz_d; rewrite mulf_eq0 tofrac_eq0.
    by case/norP=> nz_n _; rewrite invfE !fdegreeE ?mulf_neq0 // opprB.
  Qed.
End ECPolySubTheory.

(* -------------------------------------------------------------------- *)
Notation "[ 'ecp' a *Y + b ]" := (ECPoly _ (a, b)).
Notation "[ 'ecp' a *Y - b ]" := (ECPoly _ (a, -b)).
Notation "p %:E" := (ECPoly _ (0, p)).

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

  Variable L : fieldType.
  Variable f : {rmorphism K -> L}.

  Lemma chi2: 2%:R != 0 :> L.
  Proof.
    rewrite -[0](rmorph0 f) eq_sym rmorph_eq_nat 1?eq_sym.
      by rewrite ecu_chi2. by apply: fmorph_inj.
  Qed.

  Lemma chi3: 3%:R != 0 :> L.
  Proof.
    rewrite -[0](rmorph0 f) eq_sym rmorph_eq_nat 1?eq_sym.
      by rewrite ecu_chi3. by apply: fmorph_inj.
  Qed.

  Definition ecmorph_ECUFieldMixin := ECUFieldMixin chi2 chi3.
  Canonical ecmorph_ECUFieldType := Eval hnf in (ECUFieldType _ ecmorph_ECUFieldMixin).

  Local Notation pA := (f (E #a)).
  Local Notation pB := (f (E #b)).

  Lemma discr_neq0: 4%:R * pA ^+ 3 + 27%:R * pB ^+ 2 != 0 :> L.
  Proof.
    move: (ecu_DN0 E); rewrite -(inj_eq (fmorph_inj (F := K) f)).
    pose R := (rmorphMn, rmorphX, rmorphM, rmorphD).
    by rewrite !(rmorph0, rmorph1, R).
  Qed.

  Definition ec_of_ecmorph := Build_ecuType discr_neq0.
End ECPolyMorph.

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

  Import GRing FracField.

  (* ------------------------------------------------------------------ *)
  Definition embed := (@tofrac _ \o ((ecX E) \o polyC)).

  Definition embed_rmorphism :=
    comp_rmorphism
      (comp_rmorphism (tofrac_rmorphism _) (ecX_rmorphism E))
      (polyC_rmorphism _).

  Canonical ecfrac_ECUFieldType := (ecmorph_ECUFieldType embed_rmorphism).
End ECPolyChi.


Require Import Crypto.Algebra.Field.
Require Import Crypto.Util.Sum Crypto.Util.Prod Crypto.Util.LetIn.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Tactics.SetoidSubst.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Spec.MontgomeryCurve Crypto.Curves.Montgomery.Affine.
Require Import Crypto.Curves.Montgomery.AffineInstances.
Require Import Crypto.Curves.Montgomery.XZ BinPos.
Require Import Coq.Classes.Morphisms.

Module M.
  Section MontgomeryCurve.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:Decidable.DecidableRel Feq}
            {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 3}
            {char_ge_5:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 5}
            {char_ge_12:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 12}
            {char_ge_28:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 28}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Notation "'∞'" := (inr tt) : core_scope.
    Local Notation "( x , y )" := (inl (pair x y)).

    Context {a b: F} {b_nonzero:b <> 0}.
    Context {a24:F} {a24_correct:(1+1+1+1)*a24 = a-(1+1)}.
    Local Notation Madd := (M.add(a:=a)(b_nonzero:=b_nonzero)(char_ge_3:=char_ge_3)).
    Local Notation Mopp := (M.opp(a:=a)(b_nonzero:=b_nonzero)).
    Local Notation Mpoint := (@M.point F Feq Fadd Fmul a b).
    Local Notation xzladderstep := (M.xzladderstep(a24:=a24)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul)).
    Local Notation donnaladderstep := (M.donnaladderstep(a24:=a24)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul)).
    Local Notation to_xz := (M.to_xz(Fzero:=Fzero)(Fone:=Fone)(Feq:=Feq)(Fadd:=Fadd)(Fmul:=Fmul)(a:=a)(b:=b)).

    Lemma donnaladderstep_ok x1 Q Q' :
      let eq := fieldwise (n:=2) (fieldwise (n:=2) Feq) in
      eq (xzladderstep x1 Q Q') (donnaladderstep x1 Q Q').
    Proof. cbv; break_match; repeat split; fsatz. Qed.

    Definition projective (P:F*F) :=
      if dec (snd P = 0) then fst P <> 0 else True.
    Definition eq (P Q:F*F) := fst P * snd Q = fst Q * snd P.

    Local Ltac do_unfold :=
      cbv [eq projective fst snd M.coordinates M.add M.zero M.eq M.opp proj1_sig xzladderstep M.to_xz Let_In Proper respectful] in *.

    Ltac t_step _ :=
      match goal with
      | _ => solve [ contradiction | trivial ]
      | _ => progress intros
      | _ => progress subst
      | _ => progress specialize_by_assumption
      | [ H : ?x = ?x |- _ ] => clear H
      | [ H : ?x <> ?x |- _ ] => specialize (H (reflexivity _))
      | [ H0 : ?T, H1 : ~?T -> _ |- _ ] => clear H1
      | _ => progress destruct_head'_prod
      | _ => progress destruct_head'_and
      | _ => progress Sum.inversion_sum
      | _ => progress Prod.inversion_prod
      | _ => progress cbv [fst snd proj1_sig projective eq] in * |-
      | _ => progress cbn [to_xz M.coordinates proj1_sig] in * |-
      | _ => progress destruct_head' @M.point
      | _ => progress destruct_head'_sum
      | [ H : context[dec ?T], H' : ~?T -> _ |- _ ]
        => let H'' := fresh in
           destruct (dec T) as [H''|H'']; [ clear H' | specialize (H' H'') ]
      | _ => progress break_match_hyps
      | _ => progress break_match
      | |- _ /\ _ => split
      | _ => progress do_unfold
      end.
    Ltac t := repeat t_step ().

    (* happens if u=0 in montladder, all denominators remain 0 *)
    Lemma add_0_numerator_r A B C D
      :  snd (fst (xzladderstep 0 (pair C 0) (pair 0 A))) = 0
      /\ snd (snd (xzladderstep 0 (pair D 0) (pair 0 B))) = 0.
    Proof. t; fsatz. Qed.
    Lemma add_0_denominators A B C D
      :  snd (fst (xzladderstep 0 (pair A 0) (pair C 0))) = 0
      /\ snd (snd (xzladderstep 0 (pair B 0) (pair D 0))) = 0.
    Proof. t; fsatz. Qed.

    (** This tactic is to work around deficiencies in the Coq 8.6
        (released) version of [nsatz]; it has some heuristics for
        clearing hypotheses and running [exfalso], and then tries to
        solve the goal with [tac].  If [tac] fails on a goal, this
        tactic does nothing. *)
    Local Ltac exfalso_smart_clear_solve_by tac :=
      try lazymatch goal with
          | [ fld : Hierarchy.field (T:=?F) (eq:=?Feq), Feq_dec : DecidableRel ?Feq |- _ ]
            => lazymatch goal with
               | [ H : ?x * 1 = ?y * ?z, H' : ?x <> 0, H'' : ?z = 0 |- _ ]
                 => clear -H H' H'' fld Feq_dec; exfalso; tac
               | [ H : ?x * 0 = 1 * ?y, H' : ?y <> 0 |- _ ]
                 => clear -H H' fld Feq_dec; exfalso; tac
               | _
                 => match goal with
                    | [ H : ?b * ?lhs = ?rhs, H' : ?b * ?lhs' = ?rhs', Heq : ?x = ?y, Hb : ?b <> 0 |- _ ]
                      => exfalso;
                         repeat match goal with H : Ring.char_ge _ |- _ => revert H end;
                         let rhs := match (eval pattern x in rhs) with ?f _ => f end in
                         let rhs' := match (eval pattern y in rhs') with ?f _ => f end in
                         unify rhs rhs';
                         match goal with
                         | [ H'' : ?x = ?Fopp ?x, H''' : ?x <> ?Fopp (?Fopp ?y) |- _ ]
                           => let lhs := match (eval pattern x in lhs) with ?f _ => f end in
                              let lhs' := match (eval pattern y in lhs') with ?f _ => f end in
                              unify lhs lhs';
                              clear -H H' Heq H'' H''' Hb fld Feq_dec; intros
                         | [ H'' : ?x <> ?Fopp ?y, H''' : ?x <> ?Fopp (?Fopp ?y) |- _ ]
                           => let lhs := match (eval pattern x in lhs) with ?f _ => f end in
                              let lhs' := match (eval pattern y in lhs') with ?f _ => f end in
                              unify lhs lhs';
                              clear -H H' Heq H'' H''' Hb fld Feq_dec; intros
                         end;
                         tac
                    | [ H : ?x * (?y * ?z) = 0 |- _ ]
                      => exfalso;
                         repeat match goal with
                                | [ H : ?x * 1 = ?y * ?z |- _ ]
                                  => is_var x; is_var y; is_var z;
                                     revert H
                                end;
                         generalize fld;
                         let lhs := match type of H with ?lhs = _ => lhs end in
                         repeat match goal with
                                | [ x : F |- _ ] => lazymatch type of H with
                                                    | context[x] => fail
                                                    | _ => clear dependent x
                                                    end
                                end;
                         intros _; intros;
                         tac
                    end
               end
          end.

    Lemma to_xz_add (x1:F) (xz x'z':F*F)
          (Hxz:projective xz) (Hz'z':projective x'z')
          (Q Q':Mpoint)
          (HQ:eq xz (to_xz Q)) (HQ':eq x'z' (to_xz Q'))
          (difference_correct:match M.coordinates (Madd Q (Mopp Q')) with
                              | ∞ => False                  (* Q <> Q' *)
                              | (x,y) => x = x1 /\ x1 <> 0  (* Q-Q' <> (0, 0) *)
                              end)
      :  eq (to_xz (Madd Q Q )) (fst (xzladderstep x1 xz xz))
      /\ eq (to_xz (Madd Q Q')) (snd (xzladderstep x1 xz x'z'))
      /\ projective (snd (xzladderstep x1 xz x'z')).
    Proof.
      fsatz_prepare_hyps.
      Time t.
      Time par: abstract (exfalso_smart_clear_solve_by fsatz || fsatz).
    Time Qed.

    Context {a2m4_nonsquare:forall r, r*r <> a*a - (1+1+1+1)}.

    Lemma projective_fst_xzladderstep x1 Q (HQ:projective Q)
      :  projective (fst (xzladderstep x1 Q Q)).
    Proof.
      specialize (a2m4_nonsquare (fst Q/snd Q  - fst Q/snd Q)).
      destruct (dec (snd Q = 0)); t; specialize_by assumption; fsatz.
    Qed.

    Let a2m4_nz : a*a - (1+1+1+1) <> 0.
    Proof. specialize (a2m4_nonsquare 0). fsatz. Qed.

    Lemma difference_preserved Q Q' :
          M.eq
            (Madd (Madd Q Q) (Mopp (Madd Q Q')))
            (Madd Q (Mopp Q')).
    Proof.
      pose proof (let (_, h, _, _) := AffineInstances.M.MontgomeryWeierstrassIsomorphism b_nonzero (a:=a) a2m4_nz in h) as commutative_group.
      rewrite Group.inv_op.
      rewrite <-Hierarchy.associative.
      rewrite Group.cancel_left.
      rewrite Hierarchy.commutative.
      rewrite <-Hierarchy.associative.
      rewrite Hierarchy.left_inverse.
      rewrite Hierarchy.right_identity.
      reflexivity.
    Qed.

    Lemma to_xz_add'
          (x1:F)
          (xz x'z':F*F)
          (Q Q':Mpoint)

          (HQ:eq xz (to_xz Q))
          (HQ':eq x'z' (to_xz Q'))
          (Hxz:projective xz)
          (Hx'z':projective x'z')
          (difference_correct:match M.coordinates (Madd Q (Mopp Q')) with
                              | ∞ => False                  (* Q <> Q' *)
                              | (x,y) => x = x1 /\ x1 <> 0  (* Q-Q' <> (0, 0) *)
                              end)
      :
           eq (to_xz (Madd Q Q )) (fst (xzladderstep x1 xz xz))
        /\ eq (to_xz (Madd Q Q')) (snd (xzladderstep x1 xz x'z'))
        /\ projective (fst (xzladderstep x1 xz x'z'))
        /\ projective (snd (xzladderstep x1 xz x'z'))
        /\ match M.coordinates (Madd (Madd Q Q) (Mopp (Madd Q Q'))) with
                              | ∞ => False                  (* Q <> Q' *)
                              | (x,y) => x = x1 /\ x1 <> 0  (* Q-Q' <> (0, 0) *)
                              end.
    Proof.
      destruct (to_xz_add x1 xz x'z' Hxz Hx'z' Q Q' HQ HQ' difference_correct) as [? [? ?]].
      split; [|split; [|split;[|split]]]; eauto.
      {
        pose proof projective_fst_xzladderstep x1 xz Hxz.
        destruct_head prod.
        cbv [projective fst xzladderstep] in *; eauto. }
      {
        pose proof difference_preserved Q Q' as HQQ;
        destruct (Madd (Madd Q Q) (Mopp (Madd Q Q'))) as [[[xQ yQ]|[]]pfQ];
        destruct (Madd Q (Mopp Q')) as [[[xD yD]|[]]pfD];
        cbv [M.coordinates proj1_sig M.eq] in *;
        destruct_head' and; try split;
          try contradiction; try etransitivity; eauto.
      }
    Qed.

    Definition to_x (xz:F*F) : F :=
      if dec (snd xz = 0) then 0 else fst xz / snd xz.

    Lemma to_x_to_xz Q : to_x (to_xz Q) = match M.coordinates Q with
                                          | ∞ => 0
                                          | (x,y) => x
                                          end.
    Proof.
      cbv [to_x]; t; fsatz.
    Qed.

    Lemma proper_to_x_projective xz x'z'
           (Hxz:projective xz) (Hx'z':projective x'z')
           (H:eq xz x'z') : Feq (to_x xz) (to_x x'z').
    Proof.
      destruct (dec (snd xz = 0)), (dec(snd x'z' = 0));
        cbv [to_x]; t;
        specialize_by (assumption||reflexivity);
        try fsatz.
    Qed.

    Lemma to_x_zero x : to_x (pair x 0) = 0.
    Proof. cbv; t; fsatz. Qed.

    Lemma projective_to_xz Q : projective (to_xz Q).
    Proof. t; fsatz. Qed.
  End MontgomeryCurve.
End M.


(************************************************************
* Lambda-calculus with references                           *
* Syntax                                                    *
*************************************************************)

Set Implicit Arguments.
Require Export Common LibHeap.
Module Heap := LibHeap.HeapList.
Notation "x ~~ a" := (single x a)
  (at level 27, left associativity) : env_scope.

(************************************************************)
(* * Definition of the language *)

(** Representation of locations *)

Definition loc := nat.

(** Grammar of values and terms *)

Inductive val : Type :=
  | val_int : int -> val
  | val_clo : env val -> var -> trm -> val
  | val_loc : loc -> val

with trm : Type :=
  | trm_val : val -> trm
  | trm_var : var -> trm
  | trm_abs : var -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_new : trm -> trm
  | trm_get : trm -> trm
  | trm_set : trm -> trm -> trm.

Coercion trm_val : val >-> trm.

(** Contexts *)

Definition ctx := env val.

(** Memory store *)

Definition mem := Heap.heap loc val.


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

- Frederic Blanqui, 2009-03-19 (setoid)
- Adam Koprowski and Johannes Waldmann, 2008-01
*)

Set Implicit Arguments.

From CoLoR Require Import AMonAlg Matrix OrdSemiRing VecUtil SN RelUtil
     LogicUtil AMatrixBasedInt.
From Coq Require Import Setoid Morphisms.

(** Module type for proving termination with matrix interpretations *)
Module Type TArcticBasedInt.

  Declare Module Export OSR : OrdSemiRingType.
  Module Export M := Matrix OSR.

  Parameter sig : Signature.
  Parameter dim : nat.
  Parameter dim_pos : dim > 0.
  Parameter trsInt : forall f : sig, matrixInt A matrix dim (arity f).

End TArcticBasedInt.

Module ArcticBasedInt (ABI : TArcticBasedInt).

  Export ABI.

  Module Conf <: MatrixMethodConf.

    Module Export M := ABI.M.
    Module Export OSRT := ABI.OSR.

    Definition sig := sig.
    Definition dim := dim.
    Definition dim_pos := dim_pos.

    Definition trsInt := trsInt.
    Notation vec := (vec dim).
    Definition vec_at0 (v : vec) := Vnth v dim_pos.

    Definition vec_invariant (v : vec) := vec_at0 v >>= A1.

    Lemma inv_id_matrix :
      vec_invariant (Vreplace (Vconst A0 dim) dim_pos A1).

    Proof.
      unfold vec_invariant, vec_at0. rewrite Vnth_replace. apply ge_refl.
    Qed.

  End Conf.

  Module Export MBI := MatrixBasedInt Conf.

  Section ABI.

    Notation matrixInt := (matrixInt A matrix).
    Notation mint := (matrixInt dim).
    Notation mat := (matrix dim dim).

    Definition Sig := sig.
    Notation MinusInf := A0.

    Variable A0_min : forall x, x >>= MinusInf.
    Variable ge_gt_eq : forall x y, x >>= y -> x >> y \/ x =A= y.

    Definition gtx x y := x >> y \/ (x =A= MinusInf /\ y =A= MinusInf).
    Notation "x >_0 y" := (gtx x y) (at level 70).

    Global Instance gtx_mor : Proper (eqA ==> eqA ==> iff) gtx.

    Proof.
      intros x x' xx' y y' yy'. unfold gtx. intuition.
      left. rewrite <- xx', <- yy'. hyp. right.
      split. trans x; hyp. trans y; hyp.
      left. rewrite xx', yy'. hyp. right. split.
      trans x'; hyp. trans y'; hyp.
    Qed.

    Instance gtx_trans : Transitive gtx.

    Proof.
      unfold gtx. intros x y z. intuition.
      left. apply OSR.gt_trans with y; hyp.
      rewrite H2. rewrite H0 in H1. auto.
      rewrite H. rewrite H2 in H1. auto.
    Qed.

    Definition succ_vec {n} := Vforall2 gtx (n:=n).
    Definition succ (x y : dom) := succ_vec (dom2vec x) (dom2vec y).
    Notation "x >v y" := (succ x y) (at level 70).

    Instance trans_succ : Transitive succ.

    Proof.
      change (Transitive (Rof succ_vec dom2vec)). apply Rof_trans.
      apply Vforall2_trans. class.
    Qed.

    (*FIXME: Proper*)
    Lemma ge_gtx_compat : forall x y z, x >>= y -> y >_0 z -> x >_0 z.

    Proof.
      unfold gtx. intuition. left. apply ge_gt_compat with y; hyp.
      rewrite H2. rewrite H0 in H. destruct (ge_gt_eq H); intuition.
    Qed.

    Variable succ_wf : WF succ.

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

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

    Lemma succ_succeq_compat : absorbs_left succ succeq.

    Proof.
      intros x z xz. destruct xz as [y [xy yz] ].
      unfold succ, succ_vec. apply Vforall2_intro_nth. intros.
      apply ge_gtx_compat with (Vnth (dom2vec y) ip).
      apply Vforall2_elim_nth. hyp.
      apply Vforall2_elim_nth. hyp.
    Qed.

    Lemma gtx_dec : rel_dec gtx.

    Proof.
      intros x y. destruct (gt_dec x y).
      left. left. hyp.
      destruct (eqA_dec x MinusInf).
      destruct (eqA_dec y MinusInf).
      left. right. auto.
      right. unfold gtx. intuition.
      right. unfold gtx. intuition.
    Defined.

    Lemma succ_dec : rel_dec succ.

    Proof.
      intros x y. unfold succ.
      apply (Vforall2_dec gtx_dec (dom2vec x) (dom2vec y)).
    Defined.

    Variable mi_eval_ok : forall f v,
      vec_invariant (mi_eval_aux (trsInt f) (Vmap dom2vec v)).

    Notation I := (MBI.I mi_eval_ok).
    Notation IR_succ := (IR I succ).

    Definition mat_gt := mat_forall2 gtx (m:=dim) (n:=dim).
    Definition vec_gt := Vforall2 gtx (n:=dim).

    Definition mint_gt n (l r : mint n) :=
      Vforall2 mat_gt (args l) (args r) /\ vec_gt (const l) (const r).

    Definition term_gt := MBI.term_gt mint_gt.

    Lemma mat_gt_dec : rel_dec mat_gt.

    Proof.
      unfold mat_gt. apply mat_forall2_dec. exact gtx_dec.
    Defined.

    Lemma vec_gt_dec : rel_dec vec_gt.

    Proof.
      unfold vec_gt, rel_dec. apply Vforall2_dec. exact gtx_dec.
    Defined.

    Lemma mint_gt_dec : forall n, rel_dec (@mint_gt n).

    Proof.
      intros n x y. unfold mint_gt.
      destruct (Vforall2_dec mat_gt_dec (args x) (args y));
        intuition.
      destruct (vec_gt_dec (const x) (const y)); intuition.
    Defined.

    Lemma Vfold_left_rev_gtx_compat : forall n (v v' : vector A n),
      (forall i (ip: i < n), Vnth v ip >_0 Vnth v' ip) ->
      Vfold_left_rev Aplus A0 v >_0 Vfold_left_rev Aplus A0 v'.

    Proof.
      induction v; simpl; intros.
      VOtac. simpl. right. intuition.
      VSntac v'. simpl. apply gtx_plus_compat.
      apply IHv. intros.
      apply Vforall2_elim_nth. change v with (Vtail (Vcons h v)).
      apply Vforall2_tail. apply Vforall2_intro_nth. hyp.
      change h with (Vhead (Vcons h v)). rewrite !Vhead_nth.
      apply (H _ (Lt.lt_O_Sn n)).
    Qed.

    Section Matrix.

      Variables (m n p : nat) (M M' : matrix m n) (N N' : matrix n p).

      Notation vge := (Vforall2 ge).
      Notation vgt := (Vforall2 gtx).
      Notation mge := mat_ge.
      Notation mgt := (mat_forall2 gtx).

      Lemma arctic_dot_product_mon : forall i (v v' w w' : vector A i),
        vgt v v' -> vge w w' -> dot_product v w >_0 dot_product v' w'.

      Proof.
        unfold dot_product. induction v; intros; simpl.
        right. intuition.
        apply gtx_plus_compat.
        apply IHv.
        change v with (Vtail (Vcons h v)). apply Vforall2_tail. hyp.
        apply Vforall2_tail. hyp.
        apply gtx_mult_compat. change h with (Vhead (Vcons h v)).
        rewrite !Vhead_nth. apply Vforall2_elim_nth. hyp.
        rewrite !Vhead_nth. apply Vforall2_elim_nth. hyp.
      Qed.

      Lemma mat_arctic_mult_mon :
        mgt M M' -> mge N N' -> mgt (M <*> N) (M' <*> N').

      Proof.
        intros. unfold mat_forall2. intros.
        rewrite !mat_mult_spec. apply arctic_dot_product_mon.
        apply Vforall2_intro_nth. intros.
        exact (H i i0 ip ip0).
        apply Vforall2_intro_nth. intros.
        rewrite <- !get_elem_swap. exact (H0 i0 j ip0 jp).
      Qed.

    End Matrix.

    Lemma mat_vec_prod_gt_compat : forall (M M' : mat) m m',
      mat_gt M M' -> m >=v m' ->
      vec_gt (mat_vec_prod M m) (mat_vec_prod M' m').

    Proof.
      intros. unfold mat_vec_prod, vec_gt. apply Vforall2_intro_nth.
      intros. rewrite !Vnth_col_mat.
      apply mat_arctic_mult_mon. hyp.
      intros k l pk pl. rewrite !vec_to_col_mat_spec.
      apply Vforall2_elim_nth. hyp.
    Qed.

    Lemma mint_eval_mon_succ : forall (val : valuation I) k
      (mi mi' : mint k), mint_gt mi mi' ->
      succ_vec (mint_eval val mi) (mint_eval val mi').

    Proof.
      intros. unfold succ_vec. apply Vforall2_intro_nth. intros. destruct H.
      eapply gtx_mor. eapply Vforall2_elim_nth; rewrite mint_eval_split; refl.
      eapply Vforall2_elim_nth. rewrite mint_eval_split. refl.
      rewrite !vector_plus_nth.
      apply gtx_plus_compat.
      apply Vforall2_elim_nth. hyp.
      rewrite !add_vectors_nth.
      apply Vfold_left_rev_gtx_compat. intros.
      rewrite !Vnth_map, !Vnth_map2.
      set (eval := Vnth (Vbuild (fun i (_ : i < k) => val i)) ip0).
      apply Vforall2_elim_nth. apply mat_vec_prod_gt_compat.
      apply Vforall2_elim_nth. hyp. refl.
    Qed.

    Lemma term_gt_incl_succ : term_gt << IR_succ.

    Proof.
      intros l r lr v. destruct (mint_eval_equiv l r v). simpl in *.
      unfold succ. unfold succ_vec. symmetry in H. symmetry in H0.
      rewrite (Vforall2_aux_Proper gtx_mor _ _ H _ _ H0).
      apply mint_eval_mon_succ. hyp.
    Qed.

    Definition succ' := term_gt.
    Definition succ'_sub := term_gt_incl_succ.
    Definition succ'_dec := term_gt_dec mint_gt mint_gt_dec.

  End ABI.

End ArcticBasedInt.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition rigidbody1_bmap_list := [Build_varinfo Tdouble 1%positive (-15) (15);Build_varinfo Tdouble 2%positive (-15) (15);Build_varinfo Tdouble 3%positive (-15) (15)].

Definition rigidbody1_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list rigidbody1_bmap_list) in exact z).

Definition rigidbody1 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) :=
  cast Tdouble (((((-(x1 * x2)%F64) - (((2)%F64 * x2)%F64 * x3)%F64)%F64 - x1)%F64 - x3)%F64).

Definition rigidbody1_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) rigidbody1 in exact e').

Derive rigidbody1_b
SuchThat (forall vmap, prove_roundoff_bound rigidbody1_bmap vmap rigidbody1_expr rigidbody1_b)
As rigidbody1_bound.
Proof.
idtac "Starting rigidbody1".
time "rigidbody1" (
try (subst rigidbody1_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)).
Qed.

Lemma check_rigidbody1_bound: ltac:(CheckBound rigidbody1_b 3.1e-13%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e190m11_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e212m29_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e191m19_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e489m21_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e165m25_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.