Require Import List.
Require Import ZArith.
Require Import String.
Open Scope string_scope.

Ltac inv H := inversion H; subst.

Ltac break_match :=
  match goal with
    | _ : context [ if ?cond then _ else _ ] |- _ =>
     destruct cond as [] eqn:?
    | |- context [ if ?cond then _ else _ ] =>
      destruct cond as [] eqn:?
    | _ : context [ match ?cond with _ => _ end ] |- _ =>
     destruct cond as [] eqn:?
    | |- context [ match ?cond with _ => _ end ] =>
      destruct cond as [] eqn:?
  end.

(** syntax *)

Inductive expr : Set :=
| Bool : bool -> expr
| Int  : Z -> expr
| Var  : string -> expr
| App  : expr -> expr -> expr
| Lam  : string -> expr -> expr.

Coercion Bool : bool >-> expr.
Coercion Int  : Z >-> expr.
Coercion Var  : string >-> expr.

Notation "X @ Y" := (App X Y) (at level 49).
Notation "\ X , Y" := (Lam X Y) (at level 50).

(** substitution *)

(** e1[e2/x] = e3 *)
Inductive Subst : expr -> expr -> string ->
                  expr -> Prop :=
| SubstBool:
    forall b e x,
      Subst (Bool b) e x
            (Bool b)
| SubstInt:
    forall i e x,
      Subst (Int i) e x
            (Int i)
| SubstVar_same:
    forall e x,
      Subst (Var x) e x
            e
| SubstVar_diff:
    forall e x1 x2,
      x1 <> x2 ->
      Subst (Var x1) e x2
            (Var x1)
| SubstApp:
    forall e1 e2 e x e1' e2',
      Subst e1 e x e1' ->
      Subst e2 e x e2' ->
      Subst (App e1 e2) e x
            (App e1' e2')
| SubstLam_same:
    forall e1 x e,
      Subst (Lam x e1) e x
            (Lam x e1)
| SubstLam_diff:
    forall e1 x1 x2 e e1',
      x1 <> x2 ->
      Subst e1 e x2 e1' ->
      Subst (Lam x1 e1) e x2
            (Lam x1 e1').

(** careful to make IH sufficiently strong *)
Lemma subst_det:
  forall e1 e2 x e3,
    Subst e1 e2 x e3 ->
    forall e3',
      Subst e1 e2 x e3' ->
      e3 = e3'.
Proof.
  induction 1; intros; auto.
  - inv H; auto.
  - inv H; auto.
  - inv H; auto. congruence.
  - inv H0; auto. congruence.
  - inv H1.
    erewrite IHSubst1; eauto.
    erewrite IHSubst2; eauto.
  - inv H; auto. congruence.
  - inv H1; auto. congruence.
    erewrite IHSubst; eauto.
Qed.

Lemma can_subst:
  forall e1 e2 x,
    exists e3, Subst e1 e2 x e3.
Proof.
  induction e1; intros.
  - econstructor; constructor.
  - econstructor; constructor.
  - case (string_dec x s); intros.
    + subst. econstructor; constructor.
    + econstructor; constructor; auto.
  - edestruct IHe1_1; edestruct IHe1_2.
    econstructor; econstructor; eauto.
  - edestruct IHe1.
    case (string_dec x s); intros.
    + subst. econstructor; constructor.
    + econstructor; constructor; eauto.
Qed.

(** define free variables *)
Inductive free : expr -> string -> Prop :=
| FreeVar:
    forall x,
      free (Var x) x
| FreeApp_l:
    forall x e1 e2,
      free e1 x ->
      free (App e1 e2) x
| FreeApp_r:
    forall x e1 e2,
      free e2 x ->
      free (App e1 e2) x
| FreeLam:
    forall x1 x2 e,
      free e x1 ->
      x1 <> x2 ->
      free (Lam x2 e) x1.

Lemma subst_only_free:
  forall e1 e2 x e3,
    Subst e1 e2 x e3 ->
    ~ free e1 x ->
    e1 = e3.
Proof.
  induction 1; intros; auto.
  - destruct H. constructor.
  - f_equal.
    + apply IHSubst1; intuition.
      apply H1; apply FreeApp_l; auto.
    + apply IHSubst2; intuition.
      apply H1; apply FreeApp_r; auto.
  - rewrite IHSubst; auto.
    intuition. apply H1.
    constructor; auto.
Qed.

(** closed terms have no free variables *)
Definition closed (e: expr) : Prop :=
  forall x, ~ free e x.

Lemma closed_app_intro:
  forall e1 e2,
    closed e1 ->
    closed e2 ->
    closed (e1 @ e2).
Proof.
  unfold closed, not; intros.
  inv H1.
  - eapply H; eauto.
  - eapply H0; eauto.
Qed.

Lemma closed_app_inv:
  forall e1 e2,
    closed (e1 @ e2) ->
    closed e1 /\ closed e2.
Proof.
  unfold closed, not; split; intros.
  - eapply H; eauto.
    apply FreeApp_l; eauto.
  - eapply H; eauto.
    apply FreeApp_r; eauto.
Qed.

Lemma closed_lam_intro:
  forall x e,
    (forall y, y <> x -> ~ free e y) ->
    closed (\x, e).
Proof.
  unfold closed, not; intros.
  inv H0. eapply H; eauto.
Qed.

Lemma closed_lam_inv:
  forall x e,
    closed (\x, e) ->
    (forall y, y <> x -> ~ free e y).
Proof.
  unfold closed, not; intros.
  cut (free (\x, e) y); intros.
  - eapply H; eauto.
  - constructor; auto.
Qed.

(** closed-ness preserved by substitution *)
Lemma subst_pres_closed:
  forall e1 e2 x e3,
    Subst e1 e2 x e3 ->
    closed e1 ->
    closed e2 ->
    closed e3.
Proof.
  induction 1; intros; auto.
  - apply closed_app_inv in H1.
    apply closed_app_intro; intuition.
  - apply subst_only_free in H0; subst; auto.
    unfold closed in *; intuition.
    eapply H1; eauto.
    econstructor; eauto.
Qed.

(**
Call By Name
<<
       e1 --> e1'
  ---------------------
    e1 e2 --> e1' e2

  -----------------------------
    (\x. e1) e2 --> e1[e2/x]
>>
*)

Inductive step_cbn : expr -> expr -> Prop :=
| CBN_crunch:
    forall e1 e1' e2,
      step_cbn e1 e1' ->
      step_cbn (App e1 e2) (App e1' e2)
| CBN_subst:
    forall x e1 e2 e1',
      Subst e1 e2 x e1' ->
      step_cbn (App (Lam x e1) e2) e1'.

Notation "e1 ==> e2" := (step_cbn e1 e2) (at level 51).

Inductive star_cbn : expr -> expr -> Prop :=
| scbn_refl:
    forall e,
      star_cbn e e
| scbn_step:
    forall e1 e2 e3,
      step_cbn e1 e2 ->
      star_cbn e2 e3 ->
      star_cbn e1 e3.

Notation "e1 ==>* e2" := (star_cbn e1 e2) (at level 51).

Definition stuck (e: expr) : Prop :=
  forall e', ~ e ==> e'.

Lemma step_cbn_det:
  forall e e1,
  e ==> e1 ->
  forall e2,
  e ==> e2 ->
  e1 = e2.
Proof.
  induction 1; intros.
  - inv H0.
    + f_equal. apply IHstep_cbn; auto.
    + inv H.
  - inv H0.
    + inv H4.
    + eapply subst_det; eauto.
Qed.

(** values *)

Inductive value : expr -> Prop :=
| VBool:
    forall b,
      value (Bool b)
| VInt:
    forall i,
      value (Int i)
| VLam:
    forall x e,
      value (Lam x e).

Lemma value_stuck:
  forall e,
    value e ->
    stuck e.
Proof.
  unfold stuck, not; intros;
    inv H; inv H0.
Qed.

(** types and typing *)

Inductive typ : Set :=
| TBool : typ
| TInt  : typ
| TFun  : typ -> typ -> typ.

Notation "X ~> Y" := (TFun X Y) (at level 60).

Definition env : Type :=
  string -> option typ.

Definition E0 : env :=
  fun _ => None.

Definition extend (e: env) x t : env :=
  fun y =>
    if string_dec y x then
      Some t
    else
      e y.

Inductive typed : env -> expr -> typ -> Prop :=
| WTBool:
    forall env b,
      typed env (Bool b) TBool
| WTInt:
    forall env i,
      typed env (Int i) TInt
| WTVar:
    forall env x t,
      env x = Some t ->
      typed env (Var x) t
| WTApp:
    forall env e1 e2 tA tB,
      typed env e1 (tA ~> tB) ->
      typed env e2 tA ->
      typed env (e1 @ e2) tB
| WTLam:
    forall env x e tA tB,
      typed (extend env x tA) e tB ->
      typed env (\x, e) (tA ~> tB).

(** env must bind all free vars to type *)
Lemma typed_free_env:
  forall env e t,
    typed env e t ->
    forall x,
      free e x ->
      exists tx, env x = Some tx.
Proof.
  induction 1; intros.
  - inv H.
  - inv H.
  - inv H0; eauto.
  - inv H1.
    + apply IHtyped1; auto.
    + apply IHtyped2; auto.
  - inv H0. apply IHtyped in H3.
    destruct H3 as [tx Htx].
    exists tx. unfold extend in Htx.
    break_match; congruence.
Qed.

(** therefore, typing in empty env
    implies term is closed *)
Lemma typed_E0_closed:
  forall e t,
    typed E0 e t ->
    closed e.
Proof.
  unfold closed, not; intros.
  eapply typed_free_env in H0; eauto.
  destruct H0. discriminate.
Qed.

(** canonical forms *)

Lemma cannon_bool:
  forall env e,
    value e ->
    typed env e TBool ->
    exists b, e = Bool b.
Proof.
  intros.
  inv H; inv H0; eauto.
Qed.

Lemma cannon_int:
  forall env e,
    value e ->
    typed env e TInt ->
    exists i, e = Int i.
Proof.
  intros.
  inv H; inv H0; eauto.
Qed.

Lemma cannon_fun:
  forall env e tA tB,
    value e ->
    typed env e (tA ~> tB) ->
    exists x, exists b, e = \x, b.
Proof.
  intros.
  inv H; inv H0; eauto.
Qed.

(** progress *)

Lemma progress:
  forall e t,
    typed E0 e t ->
    (exists e', e ==> e') \/ value e.
Proof.
  remember E0.
  induction 1; subst; intros.
  - right; constructor.
  - right; constructor.
  - unfold E0 in H; congruence.
  - left. destruct IHtyped1; auto.
    + destruct H1 as [e1']. exists (e1' @ e2).
      constructor; auto.
    + eapply cannon_fun in H1; eauto.
      destruct H1 as [x [e1' He1']]; subst.
      destruct (can_subst e1' e2 x) as [e3].
      exists e3. constructor; auto.
  - right; constructor.
Qed.

(** preservation *)

Definition env_equiv (e1 e2: env) : Prop :=
  forall s, e1 s = e2 s.

Lemma env_equiv_refl:
  forall env,
    env_equiv env env.
Proof.
  unfold env_equiv; auto.
Qed.

Lemma env_equiv_sym:
  forall e1 e2,
    env_equiv e1 e2 ->
    env_equiv e2 e1.
Proof.
  unfold env_equiv; auto.
Qed.

Lemma env_equiv_trans:
  forall e1 e2 e3,
    env_equiv e1 e2 ->
    env_equiv e2 e3 ->
    env_equiv e1 e3.
Proof.
  unfold env_equiv; intros.
  congruence.
Qed.

Lemma env_equiv_extend:
  forall env1 env2 x t,
    env_equiv env1 env2 ->
    env_equiv (extend env1 x t) (extend env2 x t).
Proof.
  unfold env_equiv, extend; intros.
  break_match; auto.
Qed.

Lemma env_equiv_overwrite:
  forall env x t1 t2,
    env_equiv (extend (extend env x t1) x t2)
              (extend env x t2).
Proof.
  unfold env_equiv, extend; intros.
  break_match; auto.
Qed.

Lemma env_equiv_neq:
  forall env1 env2 x1 t1 x2 t2,
    x1 <> x2 ->
    env_equiv env1 env2 ->
    env_equiv (extend (extend env1 x1 t1) x2 t2)
              (extend (extend env2 x2 t2) x1 t1).
Proof.
  unfold env_equiv, extend; intros.
  break_match; break_match; congruence.
Qed.

Lemma env_equiv_typed:
  forall env1 e t,
    typed env1 e t ->
    forall env2,
      env_equiv env1 env2 ->
      typed env2 e t.
Proof.
  unfold env_equiv.
  induction 1; intros.
  - constructor.
  - constructor.
  - constructor; congruence.
  - econstructor; eauto.
  - econstructor; eauto.
    apply IHtyped; auto.
    intros; apply env_equiv_extend; auto.
Qed.

Lemma strengthen:
  forall e env t x t',
    typed (extend env x t') e t ->
    ~ free e x ->
    typed env e t.
Proof.
  induction e; intros; inv H.
  - constructor.
  - constructor.
  - constructor. unfold extend in H3.
    break_match; subst; auto.
    destruct H0. constructor.
  - econstructor; eauto.
    + eapply IHe1; eauto. intuition.
      apply H0; apply FreeApp_l; auto.
    + eapply IHe2; eauto. intuition.
      apply H0; apply FreeApp_r; auto.
  - constructor.
    case (string_dec s x); intros; subst.
    + eapply env_equiv_typed; eauto.
      apply env_equiv_overwrite.
    + cut (~ free e x); intros.
      * eapply IHe; eauto.
        eapply env_equiv_typed; eauto.
        apply env_equiv_neq; auto.
        apply env_equiv_refl.
      * intuition. apply H0.
        constructor; auto.
Qed.

Lemma weaken:
  forall env e t,
    typed env e t ->
    forall x t',
      ~ free e x ->
      typed (extend env x t') e t.
Proof.
  induction 1; intros.
  - constructor.
  - constructor.
  - constructor. unfold extend.
    break_match; subst; auto.
    destruct H0. constructor.
  - econstructor; eauto.
    + apply IHtyped1. intuition.
      apply H1; apply FreeApp_l; auto.
    + apply IHtyped2. intuition.
      apply H1; apply FreeApp_r; auto.
  - constructor.
    case (string_dec x x0); intros; subst.
    + eapply env_equiv_typed; eauto.
      apply env_equiv_sym.
      apply env_equiv_overwrite.
    + cut (~ free e x0); intros.
      * apply IHtyped with (t' := t') in H1; auto.
        eapply env_equiv_typed; eauto.
        apply env_equiv_neq; auto.
        apply env_equiv_refl.
      * intuition. apply H0.
        constructor; auto.
Qed.

Definition free_env_equiv (E: expr) (e1 e2: env) : Prop :=
  forall x,
    free E x ->
    e1 x = e2 x.

Lemma free_env_equiv_refl:
  forall E env,
    free_env_equiv E env env.
Proof.
  unfold free_env_equiv; auto.
Qed.

Lemma free_env_equiv_sym:
  forall E e1 e2,
    free_env_equiv E e1 e2 ->
    free_env_equiv E e2 e1.
Proof.
  unfold free_env_equiv; intros.
  symmetry. apply H; auto.
Qed.

Lemma free_env_equiv_trans:
  forall E e1 e2 e3,
    free_env_equiv E e1 e2 ->
    free_env_equiv E e2 e3 ->
    free_env_equiv E e1 e3.
Proof.
  unfold free_env_equiv; intros.
  apply eq_trans with (y := e2 x); auto.
Qed.

Lemma free_env_equiv_extend:
  forall E env1 env2 x t,
    free_env_equiv E env1 env2 ->
    free_env_equiv E (extend env1 x t) (extend env2 x t).
Proof.
  unfold free_env_equiv, extend; intros.
  break_match; auto.
Qed.

Lemma free_env_equiv_overwrite:
  forall E env x t1 t2,
    free_env_equiv E (extend (extend env x t1) x t2)
                     (extend env x t2).
Proof.
  unfold free_env_equiv, extend; intros.
  break_match; auto.
Qed.

Lemma free_env_equiv_neq:
  forall E env1 env2 x1 t1 x2 t2,
    x1 <> x2 ->
    free_env_equiv E env1 env2 ->
    free_env_equiv E (extend (extend env1 x1 t1) x2 t2)
                     (extend (extend env2 x2 t2) x1 t1).
Proof.
  unfold free_env_equiv, extend; intros.
  break_match; break_match; subst; auto.
  congruence.
Qed.

Lemma free_env_equiv_typed:
  forall env1 e t,
    typed env1 e t ->
    forall env2,
      free_env_equiv e env1 env2 ->
      typed env2 e t.
Proof.
  unfold free_env_equiv.
  induction 1; intros.
  - constructor.
  - constructor.
  - constructor. symmetry.
    rewrite <- H. apply H0.
    constructor.
  - econstructor; eauto.
    + apply IHtyped1; intuition.
      apply H1; apply FreeApp_l; auto.
    + apply IHtyped2; intuition.
      apply H1; apply FreeApp_r; auto.
  - econstructor; eauto.
    apply IHtyped; auto.
    unfold extend; intros.
    break_match; auto.
    apply H0. constructor; auto.
Qed.

Lemma typed_closed:
  forall env e t,
    typed env e t ->
    closed e ->
    typed E0 e t.
Proof.
  induction 1; intros.
  - constructor.
  - constructor.
  - unfold closed in H0.
    destruct H0 with (x0 := x).
    constructor.
  - apply closed_app_inv in H1; intuition.
    econstructor; eauto.
  - constructor.
    eapply free_env_equiv_typed; eauto.
    unfold free_env_equiv; intros.
    unfold extend. break_match; auto.
    apply closed_lam_inv with (y := x0) in H0; auto.
    contradiction.
Qed.

Lemma subst_pres_typed:
  forall e1 e2 x e3,
    Subst e1 e2 x e3 ->
    closed e2 ->
    forall env tA tB,
      typed (extend env x tA) e1 tB ->
      typed env e2 tA ->
      typed env e3 tB.
Proof.
  induction 1; intros; auto.
  - inv H0. constructor.
  - inv H0. constructor.
  - inv H0. unfold extend in H4.
    break_match; congruence.
  - inv H1. unfold extend in H5.
    break_match; try congruence.
    constructor; auto.
  - inv H2. econstructor; eauto.
  - eapply free_env_equiv_typed; eauto.
    unfold free_env_equiv, extend; intros.
    break_match; auto; subst.
    inv H2; congruence.
  - inv H2. constructor.
    eapply IHSubst; eauto.
    + eapply env_equiv_typed; eauto.
      apply env_equiv_neq; auto.
      apply env_equiv_refl.
    + apply weaken; auto.
Qed.

Lemma preserve:
  forall e e',
    e ==> e' ->
    closed e ->
    forall env t,
      typed env e t ->
      typed env e' t.
Proof.
  induction 1; intros.
  - apply closed_app_inv in H0; intuition.
    inv H1. apply H0 in H7.
    econstructor; eauto.
  - apply closed_app_inv in H0; intuition.
    inv H1. inv H6.
    eapply subst_pres_typed in H; eauto.
Qed.

(** type soundness *)

Lemma soundness:
  forall e t e',
    typed E0 e t ->
    e ==>* e' ->
    (exists e'', e' ==> e'') \/ value e'.
Proof.
  intros. induction H0.
  - eapply progress; eauto.
  - apply IHstar_cbn.
    eapply preserve; eauto.
    eapply typed_E0_closed; eauto.
Qed.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq  choice fintype.
Require Import binomial  bigop ssralg poly ssrnum ssrint rat.

Require Import polydiv polyorder path interval polyrcf.

(** Descates method 2 *)

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

Import GRing.Theory.
Import Num.Theory Num.Def.
Local Open Scope ring_scope.
(** ** Sign changes *)

Section SignChange.

Variable R :realDomainType.
Implicit Type l: (seq R).
Implicit Type p: {poly R}.

Definition all_eq0 l := all (fun x => x == 0) l.
Definition all_ge0 l:= all (fun x => 0 <= x) l.
Definition all_le0 l := all (fun x => x <= 0) l.
Definition all_ss a l := all (fun x => 0 <= x * a) l.
Definition opp_seq l := [seq - z | z <- l].
Definition filter0 l := [seq z <- l | z != 0].

(** Some helper lemmas *)

Lemma product_neg (a b : R): a * b < 0 -> a != 0 /\ b != 0.
Proof.
case (eqVneq a 0) => ->; first by rewrite mul0r ltrr.
case (eqVneq b 0) => -> //; by rewrite mulr0 ltrr.
Qed.

Lemma square_pos (a: R): a != 0 -> 0 < a * a.
Proof. by move => anz; rewrite lt0r sqr_ge0 sqrf_eq0 anz. Qed.

Lemma prodNsimpl_ge (a b x: R): b * a < 0 -> 0 <= x * b -> x * a <= 0.
Proof.
move => pa; move: (square_pos (proj1 (product_neg pa))) => pb.
by rewrite - (nmulr_lle0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lle0.
Qed.

Lemma prodNsimpl_gt (a b x: R): b * a < 0 -> 0 < x * b -> x * a < 0.
Proof.
move => pa; move: (square_pos (proj1 (product_neg pa))) => pb.
by rewrite - (nmulr_llt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_llt0.
Qed.

Lemma prodNsimpl_lt (a b x: R): b * a < 0 -> x * b < 0 -> 0 < x * a.
Proof.
move => pa; move: (square_pos (proj1 (product_neg pa))) => pb.
by rewrite - (nmulr_lgt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lgt0.
Qed.

Lemma all_rev l q: all q l = all q (rev l).
Proof. by elim:l => [// | a l hr]; rewrite rev_cons all_rcons /= hr. Qed.

Lemma has_split q l: has q l ->
     exists l1 a l2, [/\ l = l1 ++ a :: l2, q a & all (fun z => ~~(q z)) l1].
Proof.
elim:l => // a l Hrec /=; case ha: (q a) => /=.
  by move => _; exists [::], a, l; split => //.
move /Hrec => [l1 [b [l2 [-> pb pc]]]].
by exists (a::l1),b,l2; split => //=; rewrite ha pc.
Qed.

Lemma has_split_eq l: has (fun z => z != 0) l ->
  exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l1].
Proof.
move/has_split => [l1 [a [l2 [-> pa pb]]]]; exists l1,a,l2; split => //.
by apply /allP => x; move /(allP pb); case (x==0).
Qed.

Lemma has_split_eq_rev l: has (fun z => z != 0) l ->
  exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l2].
Proof.
have <- : (has (fun z : R => z != 0)) (rev l) = has (fun z : R => z != 0) l.
  by elim:l => [// | a l hr]; rewrite rev_cons has_rcons /= hr.
move/has_split_eq => [l1 [a [l2 [lv pa pb]]]]; exists (rev l2),a,(rev l1).
by rewrite -(cat1s a) catA cats1 -rev_cons -rev_cat -lv revK /all_eq0 -all_rev.
Qed.

Lemma opp_seqK l: opp_seq (opp_seq l) = l.
Proof.
by rewrite/opp_seq -map_comp; apply map_id_in => a /=; rewrite opprK.
Qed.

Definition tail_coef p := p `_(\mu_0 p).
Definition lead_tail_coef p := (tail_coef p) * (lead_coef p).

Lemma tail_coef0a p: ~~ (root p 0) ->  tail_coef  p = p`_0.
Proof. by move /muNroot; rewrite /tail_coef => ->. Qed.

Lemma tail_coef0b p: p`_0 != 0 ->  tail_coef  p = p`_0.
Proof. rewrite - {1} horner_coef0; apply: tail_coef0a. Qed.

Lemma tail_coefM (p q: {poly R}):
   tail_coef (p*q) = (tail_coef p) * (tail_coef q).
Proof.
rewrite /tail_coef.
case pnz: (p!=0); last by rewrite (eqP(negbFE pnz)) mul0r mu0 coef0 mul0r.
case qnz: (q!=0); last by rewrite (eqP(negbFE qnz)) mulr0 mu0 coef0 mulr0.
rewrite (mu_mul 0 (mulf_neq0 pnz qnz)).
move: (mu_spec 0 pnz) (mu_spec 0 qnz); rewrite subr0.
set a := (\mu_0 p); set b:= (\mu_0 q); move => [pa v1 ->] [qa v2 ->].
by rewrite mulrACA -exprD 3! coefMXn ! ltnn ! subnn  - ! horner_coef0 hornerM.
Qed.

Lemma lead_tail_coefM (p q: {poly R}):
  lead_tail_coef (p*q) = (lead_tail_coef p)  * (lead_tail_coef q).
Proof. by rewrite /lead_tail_coef -mulrACA -tail_coefM lead_coefM. Qed.

Lemma lead_tail_coef_opp p: lead_tail_coef (- p) = (lead_tail_coef p).
Proof.
rewrite - mulrN1 lead_tail_coefM; set one := (X in _ * lead_tail_coef(X)).
suff : lead_tail_coef one = 1 by  move ->; rewrite mulr1.
have ->: one = ((-1)%:P) by rewrite polyC_opp.
by rewrite /lead_tail_coef /tail_coef lead_coefC mu_polyC coefC mulN1r opprK.
Qed.

Lemma mu_spec_supp p: p != 0 ->
   exists q, [/\  p = q * 'X^ (\mu_0 p), (~~ root q 0),
     lead_coef p = lead_coef q, tail_coef p = tail_coef q &
     tail_coef q = q`_0].
Proof.
move /(mu_spec 0) => [q pa]; set n := (\mu_0 p) => ->; exists q.
rewrite lead_coefM tail_coefM {1 2} subr0 (eqP (monicXn R n)) mulr1 /tail_coef.
by rewrite mu_exp mu_XsubC mul1n subr0 coefXn eqxx mulr1 (muNroot pa).
Qed.

Lemma tail_coefE p: tail_coef p = (head 0 (filter0 p)).
Proof.
have [-> |] := (eqVneq p 0); first by rewrite /tail_coef mu0 coef0 polyseq0 /=.
move /(mu_spec_supp) => [q [pa pb pc pd pe]]; rewrite  /filter0.
case (eqVneq q 0) => qnz; first by move: pb; rewrite qnz root0.
have q0nz: q`_0 != 0 by rewrite - horner_coef0.
rewrite pd pe pa polyseqMXn// -cat_nseq filter_cat (eq_in_filter (a2 := pred0)).
  by rewrite filter_pred0 cat0s nth0; move: q0nz; case q; case => //= a l _ ->.
have /allP h: all (pred1 (0:R)) (nseq (\mu_0 p) 0)
   by rewrite all_pred1_nseq eqxx orbT.
by move => x /h /= ->.
Qed.

Fixpoint changes (s : seq R) : nat :=
  (if s is a :: q then (a * (head 0 q) < 0)%R + changes q else 0)%N.
Definition schange (l: seq R) := changes (filter0 l).

Lemma schange_sgr l: schange l = schange [seq sgr z | z <- l].
Proof.
rewrite /schange /filter0 filter_map; set s1 := [seq z <- l | z != 0].
set s := (filter (preim _ _)); have -> : s l = s1.
  apply: eq_in_filter => x xl /=.
  by rewrite sgr_def; case xz: (x!=0); rewrite ?mulr0n ?eqxx ?mulr1n ?signr_eq0.
elim: s1 => [ // | a l1 /= ->]; case l1 => /=; first by rewrite !mulr0.
by move => b l2; rewrite - sgrM sgr_lt0.
Qed.

Lemma schange_deriv p (s := (schange p)) (s':=  schange p^`()):
   (s = s' \/ s = s'.+1).
Proof.
rewrite /s/s'.
have [-> | pnz] := (eqVneq p 0); first by  rewrite deriv0; left.
move: pnz; rewrite - size_poly_gt0 => pz.
have eq: polyseq p = p`_0 :: behead p by move: pz; case p => q /=; case q => //.
have aux: forall i,  p^`()`_i = (nth 0 (behead p)) i  *+ i.+1.
  by move => i; rewrite coef_deriv nth_behead.
rewrite schange_sgr (schange_sgr p^`()).
have <-: [seq Num.sg z | z <- (behead p)] =  [seq Num.sg z | z <- p^`()].
  have aux1: size (behead p) = size p^`() by rewrite size_deriv {2} eq.
  apply: (eq_from_nth (x0 :=0)); first by rewrite !size_map.
  move => i; rewrite size_map => iz;rewrite (nth_map 0)// (nth_map 0) -?aux1//.
  by rewrite coef_deriv nth_behead sgrMn mul1r.
rewrite eq /= /schange/filter0/filter;case h: (Num.sg p`_0 != 0); last by left.
simpl; case h': (_ < 0); [ by rewrite addSn; right | by left].
Qed.

Lemma schange0_odd l: last 0 l != 0 ->
   odd (schange l + (0 < head 0 (filter0 l) * last 0 l)%R).
Proof.
rewrite /schange.
have -> : filter0 l = [seq z <- 0::l | z != 0].
  by rewrite /filter0 {2}  /filter eqxx.
rewrite (lastI 0 l); set b := (last 0 l) => bnz; rewrite filter_rcons bnz.
set s := [seq z <- belast 0 l | z != 0].
have: all (fun z => z != 0) s by apply : filter_all.
elim: s; first by rewrite /= mulr0 ltrr square_pos //.
move => c s /=; set C:= changes _; set d:= head 0 _ => hr /andP [cnz etc].
have dnz: d != 0 by move: etc; rewrite /d; case s => // s' l' /= /andP [].
rewrite addnC addnA addnC; move: (hr etc).
rewrite -sgr_gt0 - (sgr_gt0 (c*b)) - sgr_lt0 ! sgrM.
rewrite /sgr - if_neg   - (if_neg (c==0))- (if_neg (b==0)) bnz dnz cnz.
by case (d<0); case (b<0); case (c<0); rewrite ?mulrNN ? mulr1 ?mul1r ?ltr01
    ?ltrN10 ? ltr10 ? ltr0N1 ?addn0 ? addnS ?addn0//=; move => ->.
Qed.

Lemma schange_odd p: p != 0 -> odd (schange p + (0 < lead_tail_coef p)%R).
Proof.
rewrite - lead_coef_eq0 /lead_tail_coef tail_coefE /schange lead_coefE nth_last.
by move => h; rewrite schange0_odd.
Qed.
End SignChange.

Section SignChangeRcf.
Variable R :rcfType.
Implicit Type (p:{poly R}).

Lemma noproots_cs p:  (forall x, 0 <x -> ~~ root p x) -> 0 < lead_tail_coef p.
Proof.
move => h.
have [pz |pnz]:= (eqVneq p 0); first by move: (h _ ltr01); rewrite pz root0.
move: (mu_spec_supp pnz) => [q [pa pb pc pd pe]].
have: {in `[0, +oo[, (forall x, ~~ root q x)}.
  move => x; rewrite inE andbT; rewrite le0r; case/orP; first by move=>/eqP ->.
  by move /h; rewrite pa rootM negb_or  => /andP [].
move/sgp_pinftyP => ha; move: (ha 0); rewrite inE lerr andbT /= => H.
rewrite /lead_tail_coef pc pd pe - sgr_gt0 sgrM -/(sgp_pinfty q).
by rewrite - horner_coef0 - H // - sgrM sgr_gt0 lt0r sqr_ge0 mulf_neq0.
Qed.

Definition fact_list p s q :=
 [/\  p = (\prod_(z <- s) ('X - z.1%:P) ^+ (z.2)) * q,
      (all (fun z => 0 < z) [seq z.1 | z <- s]),
      (sorted >%R [seq z.1 | z <- s]) &
      (all (fun z => (0<z)%N ) [seq z.2 | z <- s])].

Lemma poly_split_fact p : { sq : (seq (R * nat) * {poly R}) |
  fact_list p (sq.1) (sq.2) &
    ( (p != 0 -> (forall x, 0 <x -> ~~ root (sq.2) x))
   /\ (p = 0 -> sq.1 = [::] /\ sq.2 = 0)) }.
Proof.
case pnz: (p != 0); last  first.
  by exists ([::],p) => //; split => //; rewrite big_nil mul1r.
pose sa := [seq z <- rootsR p |  0 <z ].
pose sb := [seq  (z, \mu_z p) | z <- sa].
have sav: sa = [seq z.1 | z <- sb].
   by rewrite /sb - map_comp; symmetry; apply map_id_in => a.
have pa: (all (fun z => 0 < z) [seq z.1 | z <- sb]).
  by rewrite - sav; apply /allP => x; rewrite mem_filter => /andP [].
have pb : (sorted >%R [seq z.1 | z <- sb]).
  rewrite - sav.
  apply: sorted_filter => //; [apply: ltr_trans |apply: sorted_roots].
have pc: (all (fun z => (0<z)%N ) [seq z.2 | z <- sb]).
  apply /allP => x /mapP [t] /mapP [z]; rewrite mem_filter => /andP [z0 z2].
  move => -> -> /=; rewrite mu_gt0 //; apply: (root_roots z2).
suff: { q | p = (\prod_(z <- sa) ('X - z%:P) ^+ (\mu_z p))  * q &
  forall x : R, 0 < x -> ~~ root q x}.
  move => [q qa qb]; exists (sb,q) => //.
    by split => //;rewrite qa /= big_map; congr (_ * _); apply eq_big.
  by split => // pz; move: pnz; rewrite pz eqxx.
clear sb sav pa pb pc.
have: all (root p) sa.
    apply/allP=> x;rewrite mem_filter =>/andP [_]; apply /root_roots.
have: uniq sa by apply:filter_uniq; apply: uniq_roots.
have: forall x, root p x -> 0 < x -> (x \in sa).
  by move=> x rx xp;rewrite mem_filter xp -(roots_on_rootsR pnz) rx.
move: sa=> s.
elim: s p pnz=>[p _ H _ _| ].
   exists p; first by by rewrite big_nil mul1r.
   move => x xp;apply/negP =>nr; by move: (H _ nr xp).
move => a l Hrec /= p p0 rp /andP [nal ul] /andP [ap rap].
have [q rqa pv] := (mu_spec a p0).
case q0: (q != 0); last by move:p0; rewrite pv (eqP(negbFE q0)) mul0r eqxx.
have q1 x: root q x -> 0 < x -> x \in l.
  move=> rx xp; case xa: (x == a); first by rewrite -(eqP xa) rx in rqa.
  by rewrite -[_ \in _]orFb -xa -in_cons rp // pv rootM rx.
have q2: all (root q) l.
  apply/allP=> x xl.
  case xa: (x ==a); first by move: nal; rewrite - (eqP xa) xl.
  move /(allP rap): xl.
  by rewrite  pv rootM -[\mu__ _]prednK ?mu_gt0 // root_exp_XsubC xa orbF.
have [r qv rq]:= (Hrec q  q0  q1 ul q2).
exists r => //; rewrite {1} pv {1} qv mulrAC; congr (_ * _).
rewrite big_cons mulrC; congr (_ * _).
rewrite 2! (big_nth 0) 2! big_mkord; apply: eq_bigr => i _.
set b := l`_i;congr (_ ^+ _).
have rb: root q b by apply /(allP q2); rewrite mem_nth //.
have nr: ~~ root (('X - a%:P) ^+ \mu_a p) b.
   rewrite /root horner_exp !hornerE expf_neq0 // subr_eq0; apply /eqP => ab.
   by move: rqa; rewrite - ab rb.
rewrite pv mu_mul ? (muNroot nr) //.
by rewrite  mulf_neq0 // expf_neq0 // monic_neq0 // monicXsubC.
Qed.

Definition pos_roots p := (s2val (poly_split_fact p)).1.
Definition pos_cofactor p := (s2val (poly_split_fact p)).2.
Definition npos_roots p :=  (\sum_(i <- (pos_roots p)) (i.2)) %N.

Lemma pos_split1 p (s := pos_roots p) (q:= pos_cofactor p):
  p != 0 -> [/\ fact_list p s q, (forall x, 0 <x -> ~~ root q x) &  q != 0].
Proof.
move => h; rewrite /s/q /pos_roots / pos_cofactor.
move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [h1 _] h2.
split => //; first by apply: h1.
by apply/eqP => qz; move:h2 => [] pv; move: h; rewrite {1} pv qz mulr0 eqxx.
Qed.

Lemma monicXsubCe (c:R) i : ('X - c%:P) ^+ i  \is monic.
Proof. apply:monic_exp; exact: monicXsubC. Qed.

Lemma monic_prod_XsubCe I rI (P : pred I) (F : I -> R) (G : I -> nat):
  \prod_(i <- rI | P i) ('X - (F i)%:P )^+ (G i) \is monic.
Proof. by apply: monic_prod => i _; exact: monicXsubCe. Qed.

Lemma npos_root_parity p: p != 0 ->
  odd (npos_roots p + (0< lead_tail_coef p)%R).
Proof.
move => pnz; move: (pos_split1 pnz) => [[pv pb pc] pd qp qnz].
rewrite {2} pv;set r := \prod_(z <- _) _.
have rm: r \is monic by apply:monic_prod_XsubCe.
rewrite lead_tail_coefM (pmulr_lgt0 _ (noproots_cs qp)) /lead_tail_coef.
move: (refl_equal (sgr r`_0)); rewrite - {2} horner_coef0 horner_prod.
set X := \prod_(z <- _) _; have ->: X = \prod_(i <- pos_roots p) (- i.1)^+ i.2.
  by apply: eq_big => // i _; rewrite horner_exp hornerXsubC sub0r.
have ->: Num.sg (\prod_(i <- pos_roots p) (- i.1) ^+ i.2) =
 (-1) ^+ \sum_(i <-  pos_roots p) (i.2).
  move: pb; elim (pos_roots p) => [ _ | i rr /= Hr /andP [pa pb]].
    by rewrite !big_nil sgr1.
  by rewrite !big_cons sgrM sgrX Hr // sgrN  (gtr0_sg pa) exprD.
move => aux.
case (eqVneq r`_0 0) => nr0.
  by move: aux; rewrite nr0 sgr0 => /eqP; rewrite eq_sym signr_eq0.
rewrite (eqP rm) mulr1 (tail_coef0b nr0) -sgr_gt0 aux - signr_odd signr_gt0.
by case h: (odd(npos_roots p)); [  rewrite addn0 | rewrite addn1 /= h].
Qed.

Lemma size_prod_XsubCe I rI (F : I -> R) (G : I -> nat)  :
  size (\prod_(i <- rI) ('X - (F i)%:P)^+ (G i)) =
  (\sum_(i <- rI) (G i)).+1.
Proof.
elim: rI => [| i r /=]; rewrite ? big_nil ? size_poly1 // !big_cons.
rewrite size_monicM ? monicXsubCe  ? monic_neq0 // ?monic_prod_XsubCe //.
by rewrite size_exp_XsubC => ->; rewrite addSn addnS.
Qed.

Lemma schange_parity p:  p != 0 -> odd (npos_roots p) = odd (schange p).
Proof.
move => pnz.
move: (npos_root_parity pnz) (schange_odd pnz).
case h: (0 < lead_tail_coef p)%R; last by rewrite  !addn0 => ->.
by rewrite ! addn1 /= => /negbTE -> /negbTE ->.
Qed.

Lemma pos_split_deg p: p != 0 ->
   size p = ((npos_roots p) + (size (pos_cofactor p))) %N.
Proof.
move /pos_split1 => [[pa _ _ ] _ _  pb].
by rewrite {1} pa size_monicM // ? monic_prod_XsubCe // size_prod_XsubCe addSn.
Qed.

Lemma npos_roots0 p: (p != 0 /\ p^`() != 0)  \/  (npos_roots p = 0)%N.
Proof.
case (eqVneq p 0) => pnz.
  right; rewrite /npos_roots /pos_roots.
  move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [_ h1] _.
  by rewrite (proj1 (h1 pnz)) // big_nil.
move: (pos_split1 pnz) => [[pa pb pc pd] pe pf].
case (leqP (size p) 1%N) => sp; [right | left].
  move: pf  sp; rewrite (pos_split_deg pnz) - size_poly_gt0.
  case: (size (pos_cofactor p)) => //.
  by move =>  m _; rewrite addnS ltnS leqn0 addn_eq0 => /andP [/eqP -> _].
split => //.
by rewrite -size_poly_eq0 (size_deriv p); move: sp;case: (size p)=> //; case.
Qed.

Lemma coprimep_prod p I l (F: I-> {poly R}):
   (all (fun z => coprimep p (F z)) l) -> coprimep p (\prod_(z <- l) (F z)).
Proof.
elim l; first by rewrite big_nil /= coprimep1.
by move => b m Hrec /andP [ap /Hrec]; rewrite big_cons coprimep_mulr ap => ->.
Qed.

Lemma Gauss_dvdp_prod p (I:eqType) (l: seq I) (F: I-> {poly R}):
   (all (fun i => (F i)  %| p) l) ->
   (uniq [seq F i | i <- l]) ->
   (forall i j, i \in l -> j \in l -> (i == j) || coprimep (F i) (F j)) ->
   \prod_(i <- l) (F i) %| p.
Proof.
move: p; elim: l.
   by move => p _ _ _; rewrite big_nil dvd1p.
move => a l Hrec p /= /andP [ap dr] /andP [al ul] etc.
have aa: coprimep (F a) (\prod_(j <- l) F j).
   apply: coprimep_prod; apply /allP => x xl.
   have xal: x \in a :: l by rewrite inE xl orbT.
   have aa: F x \in [seq F i | i <- l] by apply/mapP; exists x.
   by move: al;case/orP: (etc _ _  (mem_head a l) xal)=> // /eqP ->; rewrite aa.
rewrite big_cons Gauss_dvdp // ap /= Hrec // => i j il jl.
by apply: etc; rewrite inE ? il ? jl orbT.
Qed.

Lemma Gauss_dvdp_prod2 p (l: seq (R * nat)):
   (all (fun z => ('X - z.1%:P)^+ (z.2)  %| p) l) ->
   (uniq [seq z.1 | z <- l]) ->
   \prod_(i <- l) ('X - i.1%:P)^+ (i.2) %| p.
Proof.
move => pa pb.
set l2:= [seq z <- l | z.2 != 0%N].
have qc: all (fun z => z.2 !=0%N) l2 by apply: filter_all.
have qa:all (fun z => ('X - (z.1)%:P) ^+ z.2 %| p) l2.
 by apply /allP => x; rewrite mem_filter => /andP [_] /(allP pa).
have qb:  uniq [seq z.1 | z <- l2].
   move: pb;rewrite /l2; elim l => [|x s IHs] //= /andP [Hx Hs].
   case (x.2 == 0%N); rewrite /= IHs // andbT; apply /negP.
   move /mapP => [y]; rewrite mem_filter => /andP [_ ys] xy.
   move: Hx; rewrite xy; move/negP;case; apply /mapP; exists y => //.
have ->: \prod_(i <- l) ('X - (i.1)%:P) ^+ i.2 =
   \prod_(i <- l2) ('X - (i.1)%:P) ^+ i.2.
  rewrite big_filter [X in _ = X] big_mkcond /=; apply: eq_bigr => i _.
  by case h: (i.2 == 0%N) => //=; rewrite (eqP h) expr0.
apply:Gauss_dvdp_prod => //.
   rewrite map_inj_in_uniq. apply: (map_uniq qb).
   move => i j il jl /= eq1.
   rewrite (surjective_pairing i) (surjective_pairing j).
   move: (size_exp_XsubC i.2  (i.1)); rewrite eq1 size_exp_XsubC.
   move /eq_add_S => ->.
   have: root  (('X - (i.1)%:P) ^+ i.2) (i.1).
     move: (allP qc _ il); rewrite -lt0n => /prednK <-.
     by rewrite root_exp_XsubC eqxx.
   rewrite eq1; move: (allP qc _ jl); rewrite -lt0n => /prednK <-.
   by rewrite root_exp_XsubC => /eqP ->.
move => i j il2 jl2.
pose zz:(R * nat) :=  (0, 0%N).
move: (nth_index zz il2)(nth_index zz jl2).
move: il2 jl2; rewrite -(index_mem) -(index_mem).
set i1 := index i l2; set j1 := index j l2 => ra rb rc rd.
set l3 :=  [seq z.1 | z <- l2].
have ss: size l2 = size l3 by rewrite /l3 size_map.
move: (ra) (rb);rewrite ss => ra' rb'.
move: (nth_uniq 0 ra' rb' qb) => aux.
case eqq: (i1 == j1). by rewrite - rc - rd (eqP eqq) eqxx.
apply /orP; right.
rewrite coprimep_expl // coprimep_expr //  coprimep_XsubC root_XsubC.
by rewrite - rc - rd -(nth_map zz 0) // -(nth_map zz 0) // -/l3 eq_sym aux eqq.
Qed.

Lemma sorted_prop (s: seq R)  i j: sorted >%R s ->
   (i < size s)%N -> (j < size s)%N -> (i < j)%N -> s`_i < s`_j.
Proof.
move: i j; elim: s => // a l Hrec i j /= pal; case: i; last first.
  move => i il; case: j => // j jl /=; rewrite ltnS; apply: Hrec => //.
  apply: (path_sorted pal).
clear Hrec; case: j => // j _ jl _;move: a j jl pal.
elim:l => // a l Hrec b j /=;case: j => [_ | j jl]; move /andP => [pa pb] //=.
by apply:(ltr_trans pa); apply /Hrec.
Qed.

Lemma pos_root_deriv p: ((npos_roots p) <= (npos_roots p^`()).+1) %N.
Proof.
case (npos_roots0 p); last by move => ->.
move => [pnz dnz].
move: (pos_split1 pnz) => [[pa pb pc pd] pe pf].
set s := pos_roots p; set q := pos_cofactor p.
move: (erefl (pos_roots p)); rewrite -{2} /s; case s.
    by rewrite /npos_roots;move => ->; rewrite big_nil.
move=> a l eq1.
set r:= [seq z.1 | z <- s]; set r1:= a.1; set rs:= [seq z.1 | z <- l].
set rd:= [seq z.2 | z <- pos_roots p].
have ss: size s = (size l).+1 by  rewrite /s eq1.
pose zz:(R * nat) :=  (0, 0%N).
have p0: forall i, (i < size s)%N -> (nth zz s i).2 \in rd.
  move => i qis; apply /mapP; exists (nth zz s i)=> //.
  by apply /(nthP zz); exists i.
have p1: forall i: 'I_(size l)%N,
    {c : R | c \in `] ((r1::rs)`_i), (rs`_i)[ & (p^`()).[c] = 0}.
  move: pc;rewrite eq1 /=; move /(pathP 0); rewrite size_map => h.
  move => [i isl]; move: (h _ isl); rewrite -/r1 -/rs => lt1.
  have ha: forall j, (j< size s)%N -> (root p (r1 :: rs)`_j).
    move => j js; rewrite pa rootM /root horner_prod; apply /orP; left.
    rewrite (big_nth zz) big_mkord -/s (bigD1 (Ordinal js)) //= {1} /s eq1 /=.
    rewrite horner_exp hornerXsubC -(nth_map _ 0) /= -?ss // subrr expr0n.
    by rewrite (gtn_eqF (allP pd _ (p0 _ js))) mul0r eqxx.
  have rp: p.[(a.1 :: rs)`_i] = p.[rs`_i].
    have ->: rs`_i = (r1 :: rs)`_(i.+1) by [].
    by rewrite (eqP (ha _ _ )) ?  (eqP (ha _ _ )) //; rewrite ss ltnS // ltnW.
  exact: (rolle lt1 rp).
set l2 := [seq (s2val (p1 i), 1%N) | i <- (enum 'I_(size l)) ].
set l3 := [seq (z.1, z.2.-1) | z <-  pos_roots p].
set f2 := \prod_(z <- l2) ('X - (z.1)%:P) ^+ (z.2).
set f3 := \prod_(z <- l3) ('X - (z.1)%:P) ^+ (z.2).
have p2: forall t, (t < size s)%N -> (r1 :: rs)`_t = (nth zz s t).1.
  by move => t ts; rewrite - (nth_map zz 0) //  /s eq1.
have ->: (npos_roots p = (\sum_(i <- l2++l3)i.2).+1)%N.
  rewrite big_cat - addSn /l3 /l2 ! big_map sum1_card cardE size_enum_ord - ss.
  rewrite - (sum1_size s) -/s - big_split /=.
  rewrite /npos_roots ! (big_nth zz) ! big_mkord; apply: eq_bigr.
  by move => [i iv] _; rewrite  add1n (prednK (allP pd _ (p0 _ iv))).
have p4: (all (fun z => 0 < z) [seq z0.1 | z0 <- l2 ++ l3]).
  have aa: forall t, t \in s -> 0 < t.1.
    by move => t ts; apply: (allP pb); apply /mapP; exists t.
  apply /allP => x /mapP [y]; rewrite mem_cat => /orP []; last first.
    by move/mapP => [t /aa h -> ->].
  move/mapP => [t] _ -> -> /=; move: (s2valP (p1 t)).
  rewrite itv_boundlr => /= /andP [lt1 _]; apply: ltr_trans lt1.
  have ts: (t < size s)%N by rewrite /s eq1 /= ltnS ltnW.
  by rewrite (p2 _ ts); apply: aa;rewrite mem_nth.
have pcc: forall i j, (i <size s)%N -> (j <size s)%N
    -> (nth zz s i).1 <  (nth zz s j).1 ->  (i < j)%N.
  move => i j il jl;case (ltngtP j i) => //; last by move => ->; rewrite ltrr.
  rewrite - (ltr_asym (nth zz s i).1 (nth zz s j).1); move => ij -> /=.
  move: pc;rewrite -p2 // - p2 // eq1; set s1 := [seq z.1 | z <- a::l] => ha.
  have ss1 : size s = size s1 by rewrite /s1 ss size_map.
  rewrite ss1 in il jl; exact: (sorted_prop ha jl il ij).
have p5: f3 %| p^`().
  apply:Gauss_dvdp_prod2.
    apply /allP => x /mapP [y ys -> /=].
    have:  (('X - (y.1)%:P) ^+ y.2) %| p.
      rewrite pa; apply:dvdp_mulr.
      move: (nth_index zz ys) => h;  move: ys; rewrite - index_mem => ys.
      by rewrite (big_nth zz) big_mkord (bigD1 (Ordinal ys)) //= h dvdp_mulIl.
    move /dvdpP => [q1 ->]; rewrite derivM; apply:dvdp_add;apply:dvdp_mull.
      set e := y.2; case e => // n /=; rewrite exprS; apply : dvdp_mulIr.
    rewrite deriv_exp - mulrnAl; apply : dvdp_mulIr.
  rewrite /l3 -/s -map_comp; apply: (sorted_uniq (@ltr_trans R) (@ltrr R) pc).
have xx: forall i: 'I_ (size l),
   [/\  (i <= size l)%N, (i < size s)%N & (i.+1 < size s)%N].
  by move => i; rewrite ss !ltnS ltnW.
have p6: f2 %| p^`().
  apply:Gauss_dvdp_prod2.
     apply/allP => x /mapP [t] _ -> /=; move: (s2valP' (p1 t)).
      by rewrite dvdp_XsubCl /root=> ->; rewrite eqxx.
  have ->:[seq z.1 | z <- l2] = [seq s2val (p1 i)| i <- enum 'I_(size l)].
    by rewrite /l2 - map_comp.
  rewrite map_inj_uniq; first by apply: enum_uniq.
  move => i j /= h.
  move: (xx i) (xx j)=> [isl1 isl isl2] [jsl1 jsl jsl2].
  apply: val_inj => /=; apply: anti_leq.
  move: (s2valP (p1 i)) (s2valP (p1 j)); rewrite !itv_boundlr => /=.
  rewrite h; move/andP => [lt1 lt2] /andP [lt3 lt4].
  move: (ltr_trans lt1 lt4)  (ltr_trans lt3 lt2).
  have ->: rs`_i = (r1 :: rs)`_(i.+1) by [].
  have ->: rs`_j = (r1 :: rs)`_(j.+1) by [].
  rewrite !p2 // ? ss ? ltnS //.
  move /(pcc _ _ isl jsl2) => sa /(pcc _ _ jsl isl2).
  by rewrite ltnS => ->; rewrite -ltnS sa.
have p7: coprimep f2 f3.
   apply: coprimep_prod; apply /allP => x xl3.
   rewrite coprimep_sym; apply /coprimep_prod; apply /allP => y yl2.
   apply:coprimep_expl; apply: coprimep_expr.
   rewrite coprimep_XsubC root_XsubC; apply /negP => /eqP.
   move: xl3 => /mapP [k ks] -> /=.
   rewrite - (nth_index zz ks) -/s; set kis := (index k s).
   move: yl2; move /mapP => [i] _ -> /= h1.
   move: (s2valP (p1 i)); rewrite !itv_boundlr => /=; rewrite h1; clear h1.
   have ->: rs`_i = (r1 :: rs)`_(i.+1) by [].
   move: (xx i) => [il0 il1 il2].
   have il3: (kis < size s)%N by rewrite index_mem.
   rewrite ! p2 // => /andP [la lb].
   move: (pcc _ _ il1 il3 la) (pcc _ _ il3 il2 lb).
   by rewrite ltnS => lc ld; move: (leq_trans lc ld); rewrite ltnn.
have : (f2 * f3) %|  p^`() by rewrite Gauss_dvdp // p6 p5.
move /dvdpP => [q1]; rewrite mulrC => sd.
have sa:  p^`() = \prod_(z <- l2++l3) ('X - (z.1)%:P) ^+ z.2 * q1.
  by rewrite big_cat.
move: (pos_split1 dnz) => [[qa qb qc qd] qe qf].
set Fa := \prod_(z <- l2 ++l3) ('X - (z.1)%:P) ^+ z.2.
set Fb := \prod_(z <- pos_roots p^`()) ('X - (z.1)%:P) ^+ z.2.
set q2:=  pos_cofactor p^`().
have Fbm: Fb \is monic by apply:monic_prod_XsubCe.
suff cp: coprimep Fa q2.
  move: (Gauss_dvdpl Fb cp); rewrite - qa {1} sa dvdp_mulIl => h.
  move: (dvdp_leq (monic_neq0 Fbm) (esym h)).
  by rewrite /npos_roots ! size_prod_XsubCe.
rewrite/Fa coprimep_sym;apply/coprimep_prod /allP => x xl.
rewrite coprimep_expr// coprimep_XsubC qe //.
by apply (allP p4); apply /mapP; exists x.
Qed.

Lemma descartes_bis p:  p != 0 ->
  (odd (npos_roots p) = odd (schange p) /\
  ((npos_roots p) <= (schange p)) %N).
Proof.
move => pa; split; first by apply:schange_parity.
move: p {2}(size p) (leqnn (size p)) pa => p n; move:p; elim:n.
  by move => p;rewrite size_poly_leq0 => ->.
move => n Hrec p spn pnz.
move: (schange_parity pnz) => od.
case (npos_roots0 p); [move => [_ dnz] |  by move => ->].
move: (leq_trans (lt_size_deriv pnz) spn); rewrite ltnS=> spln.
move:(Hrec _ spln dnz); rewrite - ltnS => /(leq_trans (pos_root_deriv p)) eq3.
move: od; case (schange_deriv p); move => -> //; move: eq3;set s := schange _.
by rewrite leq_eqVlt ltnS;case /orP => // /eqP -> /=;case (odd _).
Qed.

End SignChangeRcf.


Require Import Coq.Classes.RelationClasses.
Require Import Setoid Relation_Definitions.
Require Import Coq.Reals.RIneq.
Require Import Coq.Reals.Rtrigo_def.

Global Instance Reflexive_Rge : Reflexive Rge.
Proof.
  red. intro. apply Req_ge. reflexivity.
Qed.

Global Instance Reflexive_Rle : Reflexive Rle.
Proof.
  red. intro. apply Req_ge. reflexivity.
Qed.
Global Instance Transitive_Rge : Transitive Rge.
Proof.
  red. intros. eapply Rge_trans; eauto.
Qed.

Global Instance Transitive_Rle : Transitive Rle.
Proof.
  red. intros. eapply Rle_trans; eauto.
Qed.

Local Open Scope R.

Add Parametric Relation : R Rle
reflexivity proved by Rle_refl
transitivity proved by Rle_trans
as Rle_setoid_relation.

Add Parametric Morphism : Rplus with
signature Rle ++> Rle ++> Rle as Rplus_Rle_mor.
intros ; apply Rplus_le_compat ; assumption.
Qed.

Add Parametric Morphism : Rminus with
signature Rle ++> Rle --> Rle as Rminus_Rle_mor.
intros ; unfold Rminus ;
apply Rplus_le_compat;
[assumption | apply Ropp_le_contravar ; assumption].
Qed.

Lemma x_plus_1_le_exp :
  forall (x : R), x + 1 <= exp x.
Admitted.


Require Export Limits.
Require Import Common Notations DiscreteCategory DiscreteCategoryFunctors.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Products.
  Context `{C : @SpecializedCategory objC}.
  Variable I : Type.
  Variable f : I -> C.

  Definition Product := Limit (InducedDiscreteFunctor C f).
  Definition Coproduct := Colimit (InducedDiscreteFunctor C f).
End Products.

(* XXX: [Reserved Notation] doesn't work here? *)
Notation "∏_{ x } f" := (@Product _ _ _ (fun x => f)) (at level 0, x at level 99).
Notation "∏_{ x : A } f" := (@Product _ _ A (fun x : A => f)) (at level 0, x at level 99).
Notation "∐_{ x } f" := (@Coproduct _ _ _ (fun x => f)) (at level 0, x at level 99).
Notation "∐_{ x : A } f" := (@Coproduct _ _ A (fun x : A => f)) (at level 0, x at level 99).


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intro s. unfold eqb_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - exfalso. unfold not in Hs. apply Hs. reflexivity.
Qed.

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
  intros x y. split.
  - intro H. unfold eqb_string in H. destruct (string_dec x y).
    + apply e.
    + discriminate H.
  - intro H. rewrite H. rewrite <- eqb_string_refl. reflexivity.
Qed.

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. split.
  - intro H. unfold eqb_string in H. destruct (string_dec x y).
    + discriminate H.
    + apply n.
  - intro H. unfold eqb_string. destruct (string_dec x y).
    + contradiction.
    + reflexivity.
Qed.

Theorem false_eqb_string : forall x y : string,
    x <> y -> eqb_string x y = false.
Proof. apply eqb_string_false_iff. Qed.

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A) (k : string) (v : A) :=
  fun k' => if eqb_string k k' then v else m k'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true) "bar" true.

Notation "'_' '!->' v" := (t_empty v) (at level 100, right associativity).

Example example_empty := (_ !-> false).

Notation "x '!->' v ';' m" := (t_update m x v)
                                (at level 100, v at next level, right associativity).

Definition examplemap' := "bar" !-> true; "foo" !-> true; _ !-> false.

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof. reflexivity. Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v; m) x = v.
Proof.
  intros A m x v. unfold t_update.
  rewrite <- eqb_string_refl. reflexivity.
Qed.

Lemma t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 -> (x1 !-> v; m) x2 = m x2.
Proof.
  intros A m x1 x2 v H. unfold t_update.
  rewrite <- eqb_string_false_iff in H.
  rewrite H. reflexivity.
Qed.

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2; x !-> v1; m) = (x !-> v2; m).
Proof.
  intros A m x v1 v2.
  apply functional_extensionality.
  intro x0. destruct (string_dec x x0).
  - rewrite e. rewrite t_update_eq. rewrite t_update_eq. reflexivity.
  - assert (Heq : (x !-> v2; x !-> v1; m) x0 = (x !-> v1; m) x0).
    { apply t_update_neq. apply n. }
    rewrite Heq.
    assert (Heq1 : forall v, (x !-> v; m) x0 = m x0).
    { intro v. apply t_update_neq. apply n. }
    rewrite Heq1. rewrite Heq1. reflexivity.
Qed.

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros x y. apply iff_reflect.
  rewrite eqb_string_true_iff. reflexivity.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x; m) = m.
Proof.
  intros A m x.
  apply functional_extensionality.
  intro x0. unfold t_update.
  assert (Heq: reflect (x = x0) (eqb_string x x0)).
  { apply eqb_stringP. }
  destruct (eqb_string x x0).
  - inversion Heq. rewrite H. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute :
  forall (A : Type) (m : total_map A) v1 v2 x1 x2,
    x2 <> x1 ->
    ( x1 !-> v1; x2 !-> v2; m) = (x2 !-> v2; x1 !-> v1; m).
Proof.
  intros A m v1 v2 x1 x2 H.
  apply functional_extensionality.
  intro x. unfold t_update.
  assert (Heq1 : reflect (x1 = x) (eqb_string x1 x)).
  { apply eqb_stringP. }
  assert (Heq2 : reflect (x2 = x) (eqb_string x2 x)).
  { apply eqb_stringP. }
  destruct (eqb_string x1 x) eqn:E1.
  - destruct (eqb_string x2 x) eqn:E2.
    + inversion Heq1. inversion Heq2. rewrite H0 in H. rewrite H1 in H.
      exfalso. apply H. reflexivity.
    + reflexivity.
  - reflexivity.
Qed.

(** Partial maps *)
Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A := t_empty None.

Definition update {A : Type} (m : partial_map A) (x : string) (v : A) :=
  (x !-> Some v; m).

Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v) (at level 100).

Example examplepmap := ("Church" |-> true; "Turing" |-> false).

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof. intros A x. reflexivity. Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v; m) x = Some v.
Proof. intros A m x v. unfold update. apply t_update_eq. Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 -> (x2 |-> v; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H. unfold update. apply t_update_neq. apply H.
Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2; x |-> v1; m) = (x |-> v2; m).
Proof.
  intros A m x v1 v2. unfold update. apply t_update_shadow.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v -> (x |-> v; m) = m.
Proof.
  intros V m x v H. unfold update. rewrite <- H. apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A) x1 x2 v1 v2,
    x2 <> x1 ->
    ( x1 |-> v1; x2 |-> v2; m) = (x2 |-> v2; x1 |-> v1; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update. apply t_update_permute.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_11.

Coq < Goal forall d s c t:Prop, (((d /\ s) \/ (c /\ t)) /\ ~t) -> (s).
1 subgoal

  ============================
   forall d s c t : Prop, (d /\ s \/ c /\ t) /\ ~ t -> s

Unnamed_thm < intros.
1 subgoal

  d : Prop
  s : Prop
  c : Prop
  t : Prop
  H : (d /\ s \/ c /\ t) /\ ~ t
  ============================
   s

Unnamed_thm < elim H.
1 subgoal

  d : Prop
  s : Prop
  c : Prop
  t : Prop
  H : (d /\ s \/ c /\ t) /\ ~ t
  ============================
   d /\ s \/ c /\ t -> ~ t -> s

Unnamed_thm < intro.
1 subgoal

  d : Prop
  s : Prop
  c : Prop
  t : Prop
  H : (d /\ s \/ c /\ t) /\ ~ t
  H0 : d /\ s \/ c /\ t
  ============================
   ~ t -> s

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
firstorder .

Unnamed_thm is defined

Coq <
*)

Require Import Classical.
Section Exercise_10.
Goal forall d s c t:Prop, (((d /\ s) \/ (c /\ t)) /\ ~t) -> (s).
intros.
elim H.
intro.
firstorder.
Qed.


(** author Yves Bertot, Inria  *)

Require Import Extraction.
Require Import ZArith Lia.

From mathcomp Require Import all_ssreflect all_algebra.

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

Fixpoint fib (n : nat) :=
  if n is S (S p as p') then fib p + fib p' else 1.

Fixpoint fibt (n : nat) (acc1 acc2 : nat) : nat :=
  if n is S p then fibt p (acc2 + acc1) acc1 else acc1.

Fixpoint Zfibt (n : nat) (acc1 acc2 : Z) : Z :=
  if n is S p then Zfibt p (Z.add acc2 acc1) acc1 else acc1.

Lemma fibt_aux (n k: nat) : fibt n (fib k.+1) (fib k) = fib (n + k).+1.
Proof.
elim: n k => [ | n Ih] k.
  by [].
rewrite -[fibt n.+1 _ _]/(fibt n (fib k.+2) (fib k.+1)).
rewrite Ih.
by rewrite addnS addSn.
Qed.

Lemma fibtP (n : nat) : fibt n 1 0 = fib n.
Proof.
case: n => [ | p].
  by [].
rewrite [LHS]/= add0n -[in RHS](addn0 p).
by rewrite -fibt_aux.
Qed.

Fixpoint bits p acc : list bool :=
  match p with
  | xH => true :: acc
  | xI p => bits p (true :: acc)
  | xO p => bits p (false :: acc)
  end.

Lemma bits_cat p a : bits p a = bits p [::] ++ a.
Proof.
elim: p a => [ p Ih | p Ih | ] /= a;
  rewrite ?(Ih (_ :: a)) ?(Ih (_ :: nil)) -?catA //.
Qed.

Lemma bitsP p :
  Pos.to_nat p =
  \sum_(i < size (bits p [::])) nth false (bits p [::])
      (size (bits p [::]) - 1 - i) * 2 ^ i.
Proof.
have body_simp p' b:
  forall i : 'I_(size (bits p' [::])),
    true ->
    nth false (bits p' [::] ++ [:: b]) (size (bits p' [::]) - bump 0 i) *
    2 ^ bump 0 i =
    2 * (nth false (bits p' [::]) (size (bits p' [::]) - 1 - i) * 2 ^ i).
  move=> i _; rewrite /bump leq0n add1n (mulnC 2) -mulnA -expnSr -subnDA.
  rewrite add1n nth_cat.
  set e := (X in if X then _ else _).
  have -> // : e.
  rewrite /e {e}; case: i => [ i] /=; case: (size _) => // n _.
  by rewrite subSS ltnS leq_subr.
elim:p => [ p IH | p IH | ].
    rewrite /= Pos2Nat.inj_xI multE bits_cat size_cat /= addn1.
    rewrite [RHS]big_ord_recl subSS 2!subn0 expn0 muln1.
    rewrite nth_cat ltnn subnn /= add1n; congr (_.+1).
    rewrite (eq_bigr _ (body_simp p true)).
    by rewrite IH -big_distrr.
  rewrite /= Pos2Nat.inj_xO multE bits_cat size_cat /= addn1.
  rewrite [RHS]big_ord_recl subSS 2!subn0 expn0 muln1.
  rewrite nth_cat ltnn subnn /=.
  rewrite (eq_bigr _ (body_simp p false)).
  by rewrite IH -big_distrr.
by rewrite /= big_ord_recl big_ord0.
Qed.

Section with_matrices.

Variable R : comUnitRingType.

Import GRing.Theory.
Open Scope ring_scope.

Definition ZtoR (x : Z) : R :=
  if (Z.ltb x 0) then
    -(Z.abs_nat (-x))%:R else (Z.abs_nat x)%:R.

Lemma ZtoRD (x y : Z) : ZtoR (x + y) = ZtoR x + ZtoR y.
Proof.
rewrite /ZtoR.
case: ifP => [/Z.ltb_lt lt0 | /Z.ltb_ge ge0].
  case: ifP => [/Z.ltb_lt xlt0 | /Z.ltb_ge xge0 ].
    case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
      rewrite -!mulNrn -mulrnDr; congr (_ *+ _).
      rewrite Z.opp_add_distr Zabs2Nat.inj_add ?plusE //.
        rewrite Z.opp_nonneg_nonpos.
        by apply: Z.lt_le_incl.
      by apply /Z.opp_nonneg_nonpos/Z.lt_le_incl.
    rewrite -!mulNrn -[X in _ + X *+ _]opprK.
    rewrite (mulNrn (-1)).
    rewrite -mulrnBr; last by apply/leP; lia.
    rewrite -minusE.
    rewrite -Zabs2Nat.inj_sub; last by lia.
    by rewrite Z.opp_add_distr.
  case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
    rewrite -!mulNrn -[X in X *+ _ + _]opprK.
    rewrite (mulNrn (-1)).
    rewrite addrC -mulrnBr; last by apply/leP; lia.
    rewrite -minusE.
    rewrite -Zabs2Nat.inj_sub; last by lia.
    by rewrite Z.add_comm Z.opp_add_distr.
  suff : False by [].
  lia.
case: ifP => [/Z.ltb_lt xlt0 | /Z.ltb_ge xge0 ].
  case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
    suff : False by [].
    lia.
  rewrite addrC -mulrnBr; last by apply/leP; lia.
  rewrite -minusE -Zabs2Nat.inj_sub; last by lia.
  by rewrite Z.sub_opp_r Z.add_comm.
case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
  rewrite -mulrnBr; last by apply/leP; lia.
  rewrite -minusE -Zabs2Nat.inj_sub; last by lia.
  by rewrite Z.sub_opp_r Z.add_comm.
rewrite -mulrnDr.
by rewrite -plusE -Zabs2Nat.inj_add.
Qed.

Lemma ZtoRM x y : ZtoR (x * y) = ZtoR x * ZtoR y.
Proof.
rewrite /ZtoR.
case: ifP => [/Z.ltb_lt lt0 | /Z.ltb_ge ge0].
  case: ifP => [/Z.ltb_lt xlt0 | /Z.ltb_ge xge0].
    case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
      suff : Z.lt 0 (x * y) by lia.
      by apply Z.mul_neg_neg.
    rewrite !mulNr mulr_natl.
    rewrite -mulrnA.
    rewrite !Zabs2Nat.abs_nat_spec !Z.abs_opp Z.abs_mul.
    rewrite Z2Nat.inj_mul; auto with zarith.
    by rewrite multE mulnC.
  case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
    rewrite mulr_natl.
    rewrite mulNrn -mulrnA.
    rewrite !Zabs2Nat.abs_nat_spec !Z.abs_opp Z.abs_mul.
    rewrite Z2Nat.inj_mul; auto with zarith.
    by rewrite multE mulnC.
  suff : Z.le 0 (x * y) by lia.
  by apply Z.mul_nonneg_nonneg.
case: ifP => [/Z.ltb_lt xlt0 | /Z.ltb_ge xge0].
  case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
    rewrite !mulNr mulr_natl.
    rewrite mulNrn opprK.
    rewrite -mulrnA.
    rewrite !Zabs2Nat.abs_nat_spec !Z.abs_opp Z.abs_mul.
    rewrite Z2Nat.inj_mul; auto with zarith.
    by rewrite multE mulnC.
  have [/Z.ltb_lt ygt0 | /negbTE/Z.ltb_ge yeq0] := boolP (Z.ltb 0 y).
    suff : Z.lt (x * y) 0 by lia.
    by apply Z.mul_neg_pos.
  have ->/= : y = Z0 by lia.
  by rewrite mulr0 Z.mul_0_r.
have [/Z.ltb_lt ygt0 | /negbTE/Z.ltb_ge yeq0] := boolP (Z.ltb 0 x); last first.
  have -> /= : x =Z0 by lia.
  by rewrite mul0r.
case: ifP => [/Z.ltb_lt ylt0 | /Z.ltb_ge yge0].
  suff : Z.lt (x * y) 0 by lia.
  by apply Z.mul_pos_neg.
rewrite mulr_natl.
rewrite -mulrnA.
rewrite !Zabs2Nat.abs_nat_spec Z.abs_mul.
rewrite Z2Nat.inj_mul; auto with zarith.
by rewrite multE mulnC.
Qed.

Lemma iter_mul (n : nat) (m v : 'M[R]_2) :
  iter n [eta *%R m] v = m ^+ n * v.
Proof.
elim: n => [ | n Ih].
  by rewrite /= expr0 mul1r.
by rewrite /= Ih mulrA exprS.
Qed.

(* 1 1
   1 0 *)
Definition fibm : 'M[R]_2 :=
  \matrix_(i, j) if (val i == 1%N) && (val j == 1%N) then 0%R else 1%R.

Lemma fibmP n : fibm ^+ n.+2 =
  \matrix_(i, j)
     if (val i == 0%N) && (val j == 0%N) then (fib n.+2)%:R else
     if ((val i + val j == 1)%N) then (fib n.+1)%:R else
      (fib n)%:R.
Proof.
elim: n => [ | n Ih].
  rewrite /=.
  by apply/matrixP=> [][[ | [ | i]] b_i][[ | [ | j]] b_j] //=;
  rewrite mxE /= expr2 mxE /fibm 2!big_ord_recr /= big_ord0;
    rewrite !mxE /= ?(add0r, addr0, mulr1, mul1r, mul0r).
  rewrite exprS Ih.
  have [fn1 fn1P] : exists fn1, fn1 = fib n.+1 by exists (fib n.+1).
  have [fn2 fn2P] : exists fn2, fn2 = fib n.+2 by exists (fib n.+2).
  have [fn3 fn3P] : exists fn3, fn3 = fib n.+3 by exists (fib n.+3).
  rewrite -!(fn1P, fn2P, fn3P).
  apply/matrixP=> [][[ | [ | i]] b_i][[ | [ | j]] b_j] //=;
 rewrite !mxE /= 2!big_ord_recr /= big_ord0 add0r /= !mxE /=
 ?(add0r, addr0, mulr1, mul1r, mul0r) -?natrD //.
 by rewrite fn2P fn1P fn3P addnC.
by rewrite fn2P fn1P addnC.
Qed.

(* Represent 2x2 matrices by lists of 4 coefficients, given line by line *)

Definition m4lval (l : seq Z) (i j : nat) :=
  nth Z0 l (j + 2 * i).

Definition m4lmx (l : seq Z) : 'M[R]_2 :=
  \matrix_(i, j) (ZtoR (m4lval l i j)).

Definition m4lmul (l1 l2 : seq Z) :=
  (Z.add (m4lval l1 0 0 * m4lval l2 0 0) (m4lval l1 0 1 * m4lval l2 1 0)) ::
  (Z.add (m4lval l1 0 0 * m4lval l2 0 1) (m4lval l1 0 1 * m4lval l2 1 1)) ::
  (Z.add (m4lval l1 1 0 * m4lval l2 0 0) (m4lval l1 1 1 * m4lval l2 1 0)) ::
  (Z.add (m4lval l1 1 0 * m4lval l2 0 1) (m4lval l1 1 1 * m4lval l2 1 1)) :: nil.

Open Scope Z_scope.
Definition m4lfib :=
  [:: 1; 1;
      1; 0].

Close Scope Z_scope.

(* Represent symetric 2x2 matrices by list of 3 coefficients, given in order
  (0,0), (1,1), (0,1). *)

Definition m3lmx (l : seq Z) : 'M[R]_2 :=
  \matrix_(i, j)
   if (i == j) then
     ZtoR (nth Z0 l i)
   else
     ZtoR (nth Z0 l 2).

Definition m3lmul (l1 l2 : seq Z) :=
  (Z.add (nth Z0 l1 0 * nth Z0 l2 0) (nth Z0 l1 2 * nth Z0 l2 2)) ::
  (Z.add (nth Z0 l1 2 * nth Z0 l2 2) (nth Z0 l1 1 * nth Z0 l2 1)) ::
(Z.add (nth Z0 l1 0 * nth Z0 l2 2) (nth Z0 l1 2 * nth Z0 l2 1)) :: nil.

Definition m3lfib := [:: Z.pos xH ; Z0; Z.pos xH].

(* This code is correct, but hot tail recursive. *)
Fixpoint fastexp (m : list Z) (p : positive) : list Z :=
  match p with
  | xH => m
  | xI p =>
    let r := fastexp m p in
    m3lmul (m3lmul r r) m
  | xO p =>
    let r := fastexp m p in
      m3lmul r r
  end.

(* This code is wrong, the bits are not processed in the right order. *)
Fixpoint fastexp2 (m : list Z) (p : positive) (acc : list Z) : list Z :=
  match p with
  | xH => acc
  | xO p => fastexp2 m p (m3lmul acc acc)
  | xI p => fastexp2 m p (m3lmul m (m3lmul acc acc))
  end.

(* This is my best solution. *)
Definition fastexp3 {A : Type} (mul : A -> A -> A)
  (m : A) :=
  fix f (l : list bool) (acc : A) : A :=
  match l with
  | nil => acc
  | true :: l => f l (mul (mul acc acc) m)
  | false :: l => f l (mul acc acc)
  end.

Definition my_pow {A : Type} (mul : A -> A -> A) (m : A)
  (p : positive)
  : A :=
  fastexp3 mul m (behead (bits p nil)) m.

Definition m3lid := [:: Z.pos xH; Z0; Z0; Z.pos xH].

Definition slowexp (m : list Z) p :=
  Pos.iter (m3lmul m) m3lid p.

Compute slowexp m3lfib 12.

Compute my_pow m3lmul m3lfib 12.

Compute Zfibt 12 1 0.
Compute all id
  (map (fun x => Z.eqb (Z.of_nat (fib x)) (Zfibt x 1 0)) (iota 1 12)).

Definition binary_power_mult (mul : list Z -> list Z -> list Z) :
  list Z -> list Z -> positive -> list Z :=
  fix f (x a : list Z) (p : positive) : list Z :=
  match p with
  | xH => mul a x
  | xO q => f (mul x x) a q
  | xI q => f (mul x x) (mul a x) q
end.

Definition fastexp4 (mul : list Z -> list Z -> list Z)
  : list Z -> positive -> list Z :=
  fix f (x : list Z) (p : positive) :=
  match p with
  | xH => x
  | xO q => f (mul x x) q
  | xI q => binary_power_mult mul (mul x x) x q
  end.

Lemma m3lmulP l1 l2:
  GRing.comm (m3lmx l1) (m3lmx l2) ->
  m3lmx (m3lmul l1 l2) = m3lmx l1 * m3lmx l2.
Proof.
move=> hcomm.
apply/matrixP=> [][ [ | [| i]] ip] [ [ | [| j]] jp] //=;
  rewrite /m3lmx /m3lmul !mxE;
  set a1 := nth Z0 l1 0;
  set b1 := nth Z0 l1 2;
  set d1 := nth Z0 l1 1;
  set a2 := nth Z0 l2 0;
  set b2 := nth Z0 l2 2;
  set d2 := nth Z0 l2 1;
  rewrite /=;
  rewrite !big_ord_recr /= big_ord0 /= add0r /=;
  rewrite !mxE; cbn -[nth];
  rewrite -/a1 -/a2 -/b1 -/b2 -/d1 -/d2 /=;
  rewrite ?(ZtoRD, ZtoRM).
apply erefl.
apply erefl.
move: hcomm => /matrixP/(_ ord0 (inord 1)).
  rewrite !mxE 2!big_ord_recr big_ord0 /= add0r.
  rewrite /m3lmx !mxE -/a1 -/a2 -/b1 -/b2 -/d1 -/d2 /=.
  rewrite -!(inj_eq val_inj) /= inordK //=.
  rewrite 2!big_ord_recr big_ord0 /= add0r.
  rewrite /m3lmx !mxE -/a1 -/a2 -/b1 -/b2 -/d1 -/d2 /=.
  rewrite -!(inj_eq val_inj) /= inordK //= => ->.
  by congr (_ + _); rewrite mulrC.
apply erefl.
Qed.

Lemma m3lfibP : m3lmx m3lfib = fibm.
Proof.
by apply/matrixP=> [][[ | [ | i]] iP] [[ | [ | j]] jP] //; rewrite !mxE.
Qed.

Lemma iter_comm {A : Type} (op : A -> A -> A) (e1 e2 : A)
  (assoc: associative op)(cm : op e1 e2 = op e2 e1) n :
  op e1 (iter n (op e1) e2) = op (iter n (op e1) e2) e1.
Proof.
elim: n => [ | n Ih] //.
by rewrite [in RHS]iterS -assoc -Ih -iterS.
Qed.

Lemma iter_combine  {A : Type} (op : A -> A -> A) (e1 e2 : A)
  (assoc: associative op)(cm : op e1 e2 = op e2 e1) n m :
  op (iter n (op e1) e2) (iter m (op e1) e2) =
  (iter (n + m) (op e1) (op e2 e2)).
Proof.
elim: m n => [ | m Ih] n.
  rewrite addn0 /=.
  elim:n => [| n Ih] //=.
  by rewrite -assoc; congr op.
by rewrite !iterS assoc -iter_comm // -iterS Ih addnS addSn.
Qed.

Lemma fastexp3P {A : Type} (op : A -> A -> A) (id e : A) (h l : nat)
  (v : list bool) (assoc : associative op) (cm : op id e = op e id)
  (idn : forall a, op id a = a):
  l = (\sum_(i < size v) nth false v (size v - 1 - i) * 2 ^ i)%N ->
  iter (h * 2 ^ size v + l) (op e) id =
  fastexp3 op e v (iter h (op e) id).
Proof.
elim: v h l => [| b v Ih] h l.
  rewrite /= big_ord0 => ->.
  by rewrite expn0 muln1 addn0.
rewrite /= big_ord_recr /=.
rewrite -subnDA subnn /=.
have body_simp : forall i : 'I_(size v), true ->
   (nth false (b :: v) ((size v).+1 - 1 - i) * 2 ^ i =
   nth false v (size v - 1 - i) * 2 ^ i)%N.
  move=> i _; congr (_ * _)%N.
  have -> // : ((size v).+1 - 1 - i = ((size v) - 1 - i).+1)%N.
  case: i =>[i]; case:(size v)=> // n ip /=.
  by rewrite subSS subn0 -subnDA add1n subSS subSn.
rewrite (eq_bigr _ body_simp) {body_simp}.
set l' := (l - b * 2 ^ size v)%N.
move=> lq.
have lq' : l' = (\sum_(i < size v) nth false v (size v - 1 - i) * 2 ^ i)%N.
  by rewrite /l' lq addnK.
have hlq : (h * 2 ^ (size v).+1 + l = (2 * h + b) * 2 ^ (size v) + l')%N.
  by rewrite expnS mulnA lq addnA addnAC -mulnDl -lq' (mulnC h).
rewrite hlq Ih; last by [].
clear -assoc cm idn.
case: b.
  congr (fastexp3 op e v).
  rewrite -!assoc -iter_comm // assoc -iter_comm // -assoc.
  by rewrite iter_combine // idn -iterS addn1 mulSn mul1n.
congr fastexp3.
by rewrite iter_combine // idn addn0 mulSn mul1n.
Qed.

Lemma headbits p l : bits p l = true :: behead (bits p l).
Proof.
by elim: p l => [ p Ih | p Ih | ] l /=; rewrite 1?Ih.
Qed.

Lemma my_powP m p :
  @my_pow 'M[R]_2 *%R m p = m ^ Pos.to_nat p.
Proof.
have cm : 1 * m = m * 1.
  by rewrite mulr1 mul1r.
have:= @fastexp3P 'M[R]_2 *%R 1%R m 0 (Pos.to_nat p) (bits p [::])
   (@mulrA _) cm (fun a => mul1r a) (bitsP _).
rewrite /my_pow mul0n add0n /=.
rewrite [in RHS]headbits /= !mul1r => <-.
by rewrite iter_mul mulr1.
Qed.

Lemma my_pow_m3lmul m p :
  m3lmx (my_pow m3lmul m p) = my_pow *%R (m3lmx m) p.
Proof.
rewrite /my_pow.
have : GRing.comm (m3lmx m) (m3lmx m) by [].
elim: (behead (bits p [::])) {1 4 6}m => [ | b bits Ih] acc comh //.
rewrite /=.
have comma2m : GRing.comm (m3lmx acc * m3lmx acc) (m3lmx m).
  by rewrite /GRing.comm -mulrA comh !mulrA comh.
case: b; rewrite Ih !m3lmulP //.
  by rewrite /GRing.comm comma2m -(mulrA (m3lmx m)) comma2m.
Qed.

Definition m2lmul : list Z -> list Z -> list Z :=
 fun l1 l2 =>
 let a := nth Z0 l1 0 in
 let b := nth Z0 l1 1 in
 let c := nth Z0 l2 0 in
 let d := nth Z0 l2 1 in
   [:: Z.add (a * (c + d)) (b * c) ; Z.add (a * c) (b * d)].

Definition m2lmx (l : list Z) : 'M[R]_2 :=
  let a := nth Z0 l 0 in
  let b := nth Z0 l 1 in
  \matrix_(i, j)
      if ((val i == 0%N) && (val j == 0%N)) then
         ZtoR (a + b)
      else if (i == j) then
         ZtoR b
      else ZtoR a.

Definition m2lfib := [:: Zpos xH; Z0].

Lemma m2lfibP : m2lmx m2lfib = fibm.
Proof.
by apply/matrixP=> [] [[ | [ | i]] ip] [[ | [ | j]] jp] //;
 rewrite /m2lmx /m2lfib !mxE.
Qed.

Lemma m2lmulP m1 m2 :
  m2lmx (m2lmul m1 m2) = m2lmx m1 * m2lmx m2.
Proof.
rewrite /m2lmul /m2lmx.
set a := nth Z0 m1 0.
set b := nth Z0 m1 1.
set c := nth Z0 m2 0.
set d := nth Z0 m2 1.
apply/matrixP=> [][[ | [ | i]] ip] // [[ | [ | j]] jp] //.
      rewrite !mxE /= 2!big_ord_recr /= big_ord0 add0r !mxE /=.
      rewrite !(ZtoRM, ZtoRD) !(mulrDr, mulrDl) !addrA.
      rewrite !(addrAC _ (ZtoR a * ZtoR c)); congr (_ + _ + _).
      by rewrite addrAC.
    rewrite !mxE /= 2!big_ord_recr /= big_ord0 add0r !mxE /=.
    rewrite !(ZtoRM, ZtoRD) !(mulrDr, mulrDl).
    by rewrite addrAC.
  rewrite !mxE /= 2!big_ord_recr /= big_ord0 add0r !mxE /=.
  by rewrite !(ZtoRM, ZtoRD) !(mulrDr, mulrDl).
rewrite !mxE /= 2!big_ord_recr /= big_ord0 add0r !mxE /=.
by rewrite !(ZtoRM, ZtoRD).
Qed.

Lemma my_pow_m2lmul m p :
  m2lmx (my_pow m2lmul m p) = my_pow *%R (m2lmx m) p.
Proof.
rewrite /my_pow.
elim: (behead (bits p [::])) {2 4}m => [ | b bits Ih] acc //=.
by case: b; rewrite Ih !m2lmulP.
Qed.

Lemma fibZ3P p :
  ZtoR (nth Z0 (my_pow m3lmul m3lfib p) 0) = (fib (Pos.to_nat p))%:R.
Proof.
rewrite [LHS](_ : _ = m3lmx (my_pow m3lmul m3lfib p) 0 0); last first.
  by rewrite /m3lmx mxE eqxx.
rewrite my_pow_m3lmul my_powP.
have : (1 <= Pos.to_nat p)%N.
  by apply/leP; rewrite -(Pos2Nat.inj_le xH); apply: Pos.le_1_l.
rewrite leq_eqVlt=> /orP[/eqP <- | pge2].
  by rewrite expr1z mxE eqxx.
case: (Pos.to_nat p) pge2 => [ | [ | {}p]] // _.
by rewrite m3lfibP /exprz fibmP mxE.
Qed.

Lemma fibZ2P p :
  ZtoR (nth Z0 (my_pow m2lmul m2lfib p) 0 +
        nth Z0 (my_pow m2lmul m2lfib p) 1) = (fib (Pos.to_nat p))%:R.
Proof.
rewrite [LHS](_ : _ = m2lmx (my_pow m2lmul m2lfib p) 0 0); last first.
  by rewrite /m3lmx mxE !eqxx andbT.
rewrite my_pow_m2lmul my_powP.
have : (1 <= Pos.to_nat p)%N.
  by apply/leP; rewrite -(Pos2Nat.inj_le xH); apply: Pos.le_1_l.
rewrite leq_eqVlt=> /orP[/eqP <- | pge2].
  by rewrite expr1z mxE eqxx.
case: (Pos.to_nat p) pge2 => [ | [ | {}p]] // _.
by rewrite m2lfibP /exprz fibmP mxE.
Qed.

Definition m3lpow (m : list Z) (n : positive) :=
  fastexp3 m3lmul m (behead (bits n nil)) m.

Definition m2lpow (m : list Z) (n : positive) :=
  fastexp3 m2lmul m (behead (bits n nil)) m.

End with_matrices.

Definition bigarg := 30000%positive.

Extraction "bigfib" Z.ltb Z.div_eucl Pos.iter Z.log2 fastexp4
  my_pow m4lmul m3lmul m2lmul m4lfib m3lfib m2lfib bigarg.


(** * Functor **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import COC.Base.Category.

Class IsFunctor (C D: Category)
      (fobj: C -> D)
      (fmap: forall {X Y: C}, C X Y -> D (fobj X) (fobj Y)) :=
  {
    fmap_proper:>
              forall X Y: C, Proper ((==) ==> (==)) (@fmap X Y);
    fmap_comp:
      forall (X Y Z: C)(f: C X Y)(g: C Y Z),
        fmap (g \o f) == fmap g \o fmap f;
    fmap_id:
      forall X: C, fmap (Id X) == Id (fobj X)
  }.

Structure Functor (C D: Category): Type :=
  {
    fobj:> C -> D;
    fmap: forall {X Y: C}, C X Y -> D (fobj X) (fobj Y);

    fun_prf:> IsFunctor (@fmap)
  }.
Existing Instance fun_prf.

Notation "C --> D" := (Functor C D).
Arguments fmap_comp {C D fobj fmap F}{X Y Z}(f g): rename.
Arguments fmap_id {C D fobj fmap F}(X): rename.

Notation "[ 'Functor' 'by' fmap 'with' fobj ; C 'to' D ]" := (@Build_Functor C D fobj fmap _).
Notation "[ 'Functor' 'by' fmap 'with' fobj ]" := [Functor by fmap with fobj ; _ to _].
Notation "[ 'Functor' 'by' fmap ]" := [Functor by fmap with _].
Notation "[ 'Functor' 'by' f :-> Ff 'with' X :-> FX ; C 'to' D ]" := [Functor by (fun _ _ f => Ff) with (fun X => FX) ; C to D].
Notation "[ 'Functor' 'by' f :-> Ff 'with' X :-> FX ]" := [Functor by f :-> Ff with X :-> FX ; _ to _].
Notation "[ 'Functor' 'by' f :-> Ff ; C 'to' D ]" :=
  [Functor by f :-> Ff with _ :-> _ ; _ to _].
Notation "[ 'Functor' 'by' f :-> Ff ]" := [Functor by f :-> Ff with _ :-> _ ; _ to _].

Program Definition Functor_compose (C D E: Category)(F: C --> D)(G: D --> E): C --> E :=
  [Functor by f :-> fmap G (fmap F f)].
Next Obligation.
  - intros f f' Heqf; simpl.
    now rewrite Heqf.
  - now rewrite !(fmap_comp _).
  - now rewrite !(fmap_id _).
Qed.

Program Definition Functor_id (C: Category): C --> C :=
  [Functor by f :-> f].

(** *** 1.2.2 Category of Category **)
(** homogenous equality on Hom **)
Inductive hom_eq (C : Category)(X Y: C)(f: C X Y):
  forall (Z W: C), C Z W -> Prop :=
  hom_eq_def:
    forall (g: C X Y), f == g -> hom_eq f g.
Notation "f =H g 'in' C" := (@hom_eq C _ _ f _ _ g) (at level 70, g at next level).
Infix "=H" := hom_eq (at level 70, only parsing).

Lemma hom_eq_refl:
  forall (C: Category)(df cf: C)(bf: C df cf),
    bf =H bf.
Proof.
  intros C df cf bf; apply hom_eq_def; reflexivity.
Qed.

Lemma hom_eq_sym:
  forall (C: Category)
         (df cf: C)(bf: C df cf)
         (dg cg: C)(bg: C dg cg),
    bf =H bg -> bg =H bf.
Proof.
  intros C df cf bf dg cg bg [g Heq].
  apply hom_eq_def; apply symmetry; assumption.
Qed.

Lemma hom_eq_trans:
  forall (C : Category)
         (df cf: C)(bf: C df cf)
         (dg cg: C)(bg: C dg cg)
         (dh ch: C)(bh: C dh ch),
    bf =H bg -> bg =H bh -> bf =H bh.
Proof.
  intros C df cf bf dg cg bg dh ch bh [g Heqg] [h Heqh].
  apply hom_eq_def.
  transitivity g; assumption.
Qed.

Program Definition Functor_setoid (C D: Category): Setoid :=
  [Setoid by `(forall (X Y: C)(f: C X Y), fmap F f =H fmap G f) on C --> D].
Next Obligation.
  - intros F G Heq X Y f.
    now apply hom_eq_sym, Heq.
  - intros F G H HeqFG HeqGH X Y f.
    eapply hom_eq_trans.
    + now apply HeqFG.
    + now apply HeqGH.
Qed.
Canonical Structure Functor_setoid.

Program Definition Cat: Category :=
  [Category by Functor_setoid with Functor_compose, Functor_id].
Next Obligation.
  rename X into C, Y into D, Z into E.
  intros F F' HeqF G G' HeqG X Y f; simpl in *.
  destruct (HeqF _ _ f).
  destruct (HeqG _ _ g).
  apply hom_eq_def.
  now rewrite H, H0.
Qed.
Canonical Structure Cat.

(** constant functor **)
Program Definition constant_functor (C D: Category)(d: D): C --> D :=
  [Functor by f :-> Id d with c :-> d].
Next Obligation.
  now rewrite cat_comp_id_dom.
Qed.
Notation "[ * 'in' D |-> c 'in' C ]" := (constant_functor D C c).

(** Hom(X,-): C -> Setoids **)
Program Definition covariant_hom_functor (C: Category)(X: C)
  : C --> Setoids :=
  [Functor by (fun (Y Z: C)(g: C Y Z) => [ f in C X Y :-> g \o f])
   with (fun Y => C X Y)].
Next Obligation.
  now intros f f' Heq; rewrite Heq.
Qed.
Next Obligation.
  - rename X0 into Y, Y into Z.
    intros g g' Heqg f; simpl.
    now rewrite Heqg.
  - now rewrite cat_comp_assoc.
  - now rewrite cat_comp_id_cod.
Qed.
Notation "'Hom' ( X , - )" := (covariant_hom_functor _ X) (format "'Hom' ( X ,  - )").

(** Hom(-,Y): C^op -> Setoids **)
Program Definition contravariant_hom_functor (C: Category)(Y: C)
  : C^op --> Setoids :=
  [Functor by (fun (X W: C)(f: C W X) => [g in C X Y :-> g \o f] )
   with (fun X => C X Y)].
Next Obligation.
  now intros g g' Heq; rewrite Heq.
Qed.
Next Obligation.
  - rename Y0 into W.
    intros f f' Heqf g; simpl.
    now rewrite Heqf.
  - now rewrite cat_comp_assoc.
  - now rewrite cat_comp_id_dom.
Qed.
Notation "'Hom' ( - , Y )" := (contravariant_hom_functor _ Y) (format "'Hom' ( - ,  Y )").


Require Import GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.
Require Import GeoCoq.Tarski_dev.Ch13_1.
Require Import GeoCoq.Meta_theory.Continuity.grad.

(** This development is inspired by The Foundations of Geometry and the Non-Euclidean Plane, by George E Martin, chapter 22 *)

Section Archimedes.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** For every m, there exists n such that A0Dm = A0An - E0En = n(A0A1 - E0E1) (m=n) *)
Lemma t22_18_aux1 : forall A0 A1 E0 E1 D1 D,
  Bet A0 D1 A1 -> Cong E0 E1 A1 D1 ->
  Grad A0 D1 D ->
  exists A E, Grad2 A0 A1 A E0 E1 E /\ Cong E0 E A D /\ Bet A0 D A.
Proof.
  intros A0 A1 E0 E1 D1 D HBet HCong HG.
  induction HG.
    exists A1; exists E1; repeat split; auto; apply grad2_init.
  rename A into A0.
  rename B into C1.
  destruct IHHG as [A [E [HG2 [HCong2 HBet2]]]]; auto.
  destruct (segment_construction A0 A A0 A1) as [A' [HBet3 HCong3]].
  destruct (segment_construction E0 E E0 E1) as [E' [HBet4 HCong4]].
  exists A'; exists E'.
  assert(HBet5 : Bet A0 C' A').
  { assert(HBet5 : Bet A0 C A') by eBetween.
    assert(Bet C C' A'); [|eBetween].
    apply grad2__grad123 in HG2.
    apply grad__bet in HG.
    apply grad__bet in HG2.
    elim(eq_dec_points A0 C).
      intro; treat_equalities; Between.
    intro.
    elim(eq_dec_points C C').
      intro; treat_equalities; Between.
    intro.
    elim(eq_dec_points A' C).
      intro; subst A'; assert (A=C) by (apply (between_equality _ _ A0); Between); treat_equalities; Between.
    intro.
    apply l6_13_1.
      destruct (l6_2 C' A' A0 C); Between.
    apply (le_transitivity _ _ A A').
      apply (l5_6 A0 C1 A0 A1); Cong; exists C1; split; Cong.
    destruct(l5_12_a C A A'); eBetween.
  }
  repeat split; auto.
    apply grad2_stab with A E; Cong.
  assert (HD : Le E0 E1 A A').
    apply (l5_6 E0 E1 A1 A0); Cong; exists C1; split; Between.
  destruct HD as [D [HBet6 HCong6]].
  apply (cong_transitivity _ _ C D).
    apply (l2_11 _ E _ _ A); Cong; eBetween; apply cong_transitivity with E0 E1; trivial.
  assert (Bet C D A') by eBetween.
  apply (l4_3 _ _ A' _ _ C); Cong; eBetween.
  apply (cong_transitivity _ _ A0 C1); Cong.
  apply cong_left_commutativity; apply (l4_3 _ _ A _ _ A1); Between; Cong.
  apply cong_transitivity with E0 E1; Cong.
Qed.

(** For every n, B0Bn is lower than or equal to n times B0B1 *)
Lemma t22_18_aux2 : forall A0 A1 B0 B1 A B E,
  Saccheri A0 B0 B1 A1 ->
  Grad2 A0 A1 A B0 B1 E -> Saccheri A0 B0 B A -> Le B0 B B0 E.
Proof.
  intros A0 A1 B0 B1 A B E HSac1 HG.
  revert B.
  induction HG; rename A into A0; rename B into A1; rename D into B0; rename E into B1.
  { intros B HSac.
    assert(B = B1); [|subst B; Le].
    assert(Hdiff := sac_distincts A0 B0 B1 A1 HSac1); unfold Saccheri in *; spliter.
    apply (l6_11_uniqueness A1 A0 B0 B1); Cong; [|apply out_trivial; auto].
    apply (col_one_side_out _ A0).
      apply col_permutation_2, cop_per2__col with A0; Perp.
      apply coplanar_perm_3, coplanar_trans_1 with B0; Cop.
      apply not_col_permutation_2, one_side_not_col123 with B1; assumption.
    apply (one_side_transitivity _ _ _ B0); Side.
  }
  rename C into A; rename F into E; rename C' into A'; rename F' into E'.
  intros B' HSac'.
  assert (A0 <> A).
  { intro; treat_equalities.
    assert (A0 = A1) by (apply between_identity, grad__bet, (grad2__grad123 _ _ _ B0 B1 E); auto).
    treat_equalities.
    apply sac_distincts in HSac1; spliter; auto.
  }
  assert (HB : exists B, Saccheri A0 B0 B A).
  { clear dependent A'; clear dependent B'; clear IHHG.
    apply grad2__grad123 in HG.
    apply grad__bet in HG.
    destruct (l10_15 A0 A1 A B0) as [P [HPerp HOS]]; Col.
      apply par_strict_not_col_1 with B1, sac__pars1423, HSac1.
    destruct (l6_11_existence A A0 B0 P) as [B [HOut Hcong5]].
      assert_diffs; auto.
      assert(Hdiff := sac_distincts A0 B0 B1 A1 HSac1); spliter; auto.
    exists B.
    unfold Saccheri in *; spliter; assert_diffs.
    repeat split; Cong.
    - apply (per_col _ _ A1); Col.
    - apply perp_per_2, (perp_col1 _ _ _ P); Col.
      apply perp_comm; apply (perp_col _ A1); Col.
    - apply invert_one_side.
      apply (out_out_one_side _ _ _ P); [|apply l6_6; auto].
      apply invert_one_side.
      apply (col_one_side _ A1); Col.
  }
  destruct HB as [B HSac].
  assert (HLe := HSac).
  apply IHHG in HLe; auto.
  clear IHHG.
  destruct (segment_construction B0 B E E') as [C [HBet HCong]].
  assert (Cong B0 B1 B B').
    apply (cong2_sac2__cong A0 B0 B1 A1 A _ _ A'); auto; [|unfold Saccheri in *; spliter; Cong].
    apply cop_sac2__sac with A0 B0; Cop.
    intro; treat_equalities; apply sac_distincts in HSac1; spliter; auto.
  apply (le_transitivity _ _ B0 C).
    apply (triangle_inequality B0 B B' C); trivial.
    apply cong_transitivity with E E'; Cong.
    apply cong_transitivity with B0 B1; Cong.
  apply (bet2_le2__le1346 _ B _ _ E); Le.
Qed.

Lemma t22_18 :
  archimedes_axiom ->
  forall A0 B0 B1 A1, Saccheri A0 B0 B1 A1 -> ~ Lt B0 B1 A1 A0.
Proof.
  intros Harchi A0 B0 B1 A1 HSac.
  intro Hlt.
  destruct Hlt as [Hle HNcong].
  destruct Hle as [D1 [Hbet Hcong]].
  destruct (segment_construction A0 D1 A0 B0) as [C0 [Hbet2 Hcong2]].
  destruct (segment_construction A0 C0 A0 B0) as [C [Hbet3 Hcong3]].
  assert(H : forall D, Grad A0 D1 D -> Lt A0 D A0 C).
  { intros D HG.
    destruct (t22_18_aux1 A0 A1 B0 B1 D1 D) as [A [E [HG2 [Hcong4 Hbet4]]]]; Between.
    assert (Hbet5 := grad2__grad123 A0 A1 A B0 B1 E HG2).
    apply grad__bet in Hbet5.
    destruct (l10_15 A0 A1 A B0) as [P [HPerp HOS]].
      Col.
      apply par_strict_not_col_1 with B1, sac__pars1423, HSac.
    destruct (l6_11_existence A A0 B0 P) as [B [HOut Hcong5]].
      assert_diffs; auto.
      assert(Hdiff := sac_distincts A0 B0 B1 A1 HSac); spliter; auto.
    assert(HSac2 : Saccheri A0 B0 B A).
    { unfold Saccheri in *; spliter; assert_diffs; assert(A0 <> A) by (intro; treat_equalities; auto).
      repeat split; Cong.
      - apply (per_col _ _ A1); Col.
      - apply perp_per_2, (perp_col1 _ _ _ P); Col.
        apply perp_comm, (perp_col _ A1); Col.
      - apply invert_one_side.
        apply (out_out_one_side _ _ _ P); [|apply l6_6; auto].
        apply invert_one_side.
        apply (col_one_side _ A1); Col.
    }
    assert(HLe : Le B0 B B0 E) by (apply (t22_18_aux2 A0 A1 B0 B1 A); auto).
    assert (HLe2 : Le B0 B A A0).
      apply (le_transitivity _ _ B0 E); auto.
      apply (l5_6 A D A A0); Cong.
      destruct (l5_12_a A D A0); Between.
    assert (HLe2' := HLe2).
    destruct HLe2' as [Q [Hbet6 Hcong6]].
    apply (le1234_lt__lt _ _ A0 Q).
      apply (bet2_le2__le1245 _ _ A _ _ A); Between; Le.
      apply (l5_6 B0 B B0 E); Cong.
    clear dependent D; clear dependent E.
    destruct (l6_11_existence A0 A0 B0 A) as [B0' [HOut2 Hcong4]];
      try (assert_diffs; intro; treat_equalities; auto).
    destruct (segment_construction A0 B0' B0 B) as [B' [Hbet7 Hcong7]].
    destruct (segment_construction B0' B' B A) as [A' [Hbet8 Hcong8]].
    assert (Le A0 A A0 A'). (** A0A' = A0B0 + B0B + BA *)
    { destruct (segment_construction A0 B0' B0 A) as [B'' [Hbet9 Hcong9]].
      apply (le_transitivity _ _ A0 B'').
        apply (triangle_inequality_2 _ B0 _ _ B0'); Cong.
      apply (bet2_le2__le1346 _ B0' _ _ B0'); Le.
        apply (outer_transitivity_between _ _ B'); auto.
        intro; treat_equalities; apply sac_distincts in HSac2; spliter; auto.
      apply (l5_6 B0 A B0' A'); Cong.
      apply (triangle_inequality_2 _ B _ _ B'); Cong.
    }
    assert (HLe3 : Le B0 B A' B0').
      apply (l5_6 B0' B' B0' A'); Cong; destruct (l5_12_a B0' B' A'); auto.
    destruct HLe3 as [Q' [Hbet9 Hcong9]].
    assert (HBet10 : Bet A0 B0' A').
      apply sac_distincts in HSac2; spliter; assert_diffs.
      apply (outer_transitivity_between _ _ B'); Between.
    apply (le1234_lt__lt _ _ A0 Q').
      apply (bet2_le2__le1245 _ _ A' _ _ A); eBetween.
      apply cong__le; apply (cong_transitivity _ _ B0 B); Cong.
    assert (Cong B0' Q' A0 B0).
    { apply (cong_transitivity _ _ A B); Cong.
      apply (cong_transitivity _ _ A' B'); Cong.
      assert(Hcong10 : Cong B0' B' A' Q') by (apply (cong_transitivity _ _ B0 B); auto).
      elim(bet_dec B0' Q' B').
        intro; apply (l4_3 _ _ B' _ _ Q'); Cong; eBetween.
      intro HNBet.
      apply sac_distincts in HSac2; spliter; assert_diffs.
      assert (Q' <> B0') by (intro; subst; apply HNBet; Between).
      assert (A' <> B0') by (intro; treat_equalities; auto).
      assert (HOut3 : Out B0' B' Q').
       apply (l6_7 _ _ A'); [| apply l6_6]; apply bet_out; Between.
      assert (Hbet11 : Bet B0' B' Q').
        apply out2__bet; auto.
        apply not_bet_out; Col.
      apply (l2_11 _ B' _ _ Q'); Cong; eBetween.
    }
    assert (Hbet10 : Bet A0 D1 C) by eBetween.
    apply (cong2_lt__lt D1 C A0 C); Cong; [split|].
      destruct (l5_12_a A0 D1 C); auto.
      intro; assert (D1 = A0) by (apply (between_cong C); Between; Cong); treat_equalities; Cong.
    apply (l2_11 _ C0 _ _ B0'); eBetween; apply cong_transitivity with A0 B0; Cong.
  }
  unfold archimedes_axiom in *.
  specialize Harchi with A0 D1 A0 C.
  destruct Harchi as [D [HG Hle]].
    intro; treat_equalities; auto.
  assert(HLt := HG).
  apply H in HLt.
  apply grad__le in HG.
  apply (le__nlt A0 C A0 D); auto.
Qed.

Lemma t22_19 :
  archimedes_axiom ->
  forall A B C D, Saccheri A B C D -> ~ Obtuse A B C.
Proof.
  intros archi A B C D HSac HObt.
  assert (H := t22_18 archi _ _ _ _ (sac_perm _ _ _ _ HSac)).
  apply H.
  apply lt_left_comm; apply <- lt_sac__obtuse; auto.
Qed.

Lemma archi__obtuse_case_elimination :
  archimedes_axiom ->
  ~ hypothesis_of_obtuse_saccheri_quadrilaterals.
Proof.
  intros archi obtuse.
  destruct ex_saccheri as [A [B [C [D HSac]]]].
  absurd(Obtuse A B C).
    apply t22_19 with D; trivial.
    apply obtuse with D; trivial.
Qed.

Lemma t22_23_aux :
  forall A B C M N L,
    ~ Col A M N -> Per B C A -> A <> C -> Midpoint M A B ->
    Per M N A -> Col A C N ->
    Midpoint M N L -> Bet A N C /\ Lambert N L B C /\ Cong B L A N.
Proof.
  intros A B C M N L HNCol HPerC HAC HM HPerN HColN HN.
  assert_diffs.
  assert (HBet : Bet A N C) by (apply per23_preserves_bet with M B; Perp; Col; Between).
  destruct (l11_49 A M N B M L) as [HCong1 [HCongA1 HCongA2]]; auto with cong.
    apply l11_14; Between.
  assert(B <> L) by (intro; treat_equalities; auto).
  repeat split; Cong.
  - intro; treat_equalities; apply HNCol; ColR.
  - intro; treat_equalities; apply H6.
    apply (l6_21 A M N M); Col.
    apply col_permutation_3, cop_per2__col with A; Col; Cop.
  - apply per_col with A; Col.
    apply l8_2, per_col with M; Col; Perp.
  - apply l8_2, per_col with A; Col.
  - apply l11_17 with M N A; auto.
    apply (l11_10 M N A M L B); auto; try (apply out_trivial; auto).
    apply l6_6, bet_out; Between.
  - apply coplanar_perm_16, col_cop__cop with M; Col.
    apply coplanar_perm_12, col_cop__cop with A; Col; Cop.
Qed.

Lemma t22_23 :
  ~ hypothesis_of_obtuse_saccheri_quadrilaterals ->
  forall A B C M N L,
    ~ Col A M N -> Per B C A -> A <> C -> Midpoint M A B ->
    Per M N A -> Col A C N -> Midpoint M N L ->
    Bet A N C /\ Le N C A N /\ Le L N B C.
Proof.
  intros HNob A B C M N L HNCol HPerC HAC HM HPerN HColN HN.
  destruct (t22_23_aux A B C M N L) as [HBet [HLam HCong]]; auto.
  split; auto.
  assert (HLBC : ~ Obtuse L B C) by (intro; apply HNob, (lam_obtuse__oah N L B C); trivial).
  assert (Hos1 : OS N L B C) by (apply lam__os; trivial).
  assert (Hos2 : OS N C B L) by (apply lam__os, lam_perm; trivial).
  unfold Lambert in HLam; spliter.
  destruct (angle_partition L B C) as [HAcute | [HPer | HObtuse]]; trivial; [ | | exfalso; auto].
  - split; apply lt__le; [apply (cong2_lt__lt N C B L); Cong | ].
      apply lta_os_per2__lt; Perp; Side; apply lta_left_comm, acute_per__lta; auto.
    apply lt_left_comm, lta_os_per2__lt; Side; apply acute_per__lta; auto.
  - split; apply cong__le; [apply cong_transitivity with B L; trivial | apply cong_left_commutativity];
    apply conga_per2_os__cong; Perp; Side; apply l11_16; Perp.
Qed.

(** For every n, 2^n times B0C0 is lower than or equal to BnCn *)
(** B0 is introduced twice for the induction tactic to work properly *)
Lemma t22_24_aux :
  ~ hypothesis_of_obtuse_saccheri_quadrilaterals ->
  forall A B0 B00 C0 B C E,
    ~ Col A B0 C0 -> Perp A C0 B0 C0 -> B0 = B00 ->
    GradExp2 A B0 B B00 C0 E -> Perp A C0 B C -> Col A C0 C ->
    Le B0 E B C.
Proof.
  intros HNob A B0 B00 C0 B C E HNCol HPerp0 Heq HGE.
  revert C.
  induction HGE; rename B into B0; rename D into B00; rename E into C0; subst B00.
    intros C HPerp HCol; assert (C = C0) by (apply (l8_18_uniqueness A C0 B0); Col); subst C; Le.
  rename C into B; rename C' into B'; rename F into E; rename F' into E'.
  intros C' HPerp' HCol'.
  apply gradexp2__gradexp123, gradexp__grad, grad__bet in HGE.
  destruct (l8_18_existence A C0 B) as [C [HCol HPerp]].
    intro; assert_diffs; apply HNCol; ColR.
  assert (HLe : Le B0 E B C) by (apply IHHGE; trivial).
  clear IHHGE.
  destruct (symmetric_point_construction C B) as [D HD].
  apply le_transitivity with D C.
    apply bet2_le2__le1346 with E B; Between; apply (l5_6 B0 E B C); auto with cong.
  assert (HAC : A <> C).
  { intro; subst C; assert_diffs; assert (A = C0); auto.
    apply (l8_18_uniqueness A C0 B0); Col.
    apply perp_right_comm, perp_col1 with B; Perp; Col.
  }
  assert (HAC' : A <> C').
  { intro; subst C'; assert_diffs; assert (A = C0); auto.
    apply (l8_18_uniqueness A C0 B0); Col.
    apply perp_right_comm, perp_col1 with B'; Perp; ColR.
  }
  assert (HPer : Per A C B) by (apply perp_per_1, perp_left_comm, perp_col with C0; assumption).
  destruct (t22_23 HNob A B' C' B C D) as [_ []]; Perp.
  - assert_diffs; apply per_not_col in HPer; Col.
  - apply perp_per_1, perp_col1 with C0; Perp.
  - split; auto.
  - ColR.
Qed.

(** For every n, it is possible to get Bn and Cn *)
Lemma t22_24_aux1 : forall A B0 C0 E,
  ~ Col A B0 C0 -> Perp A C0 B0 C0 -> GradExp B0 C0 E ->
  exists B C, GradExp2 A B0 B B0 C0 E /\ Perp A C0 B C /\ Col A C0 C.
Proof.
  intros A B0 C0 E HNCol HPerp0 HGE.
  induction HGE; rename A0 into B0; rename B into C0.
    exists B0; exists C0; repeat (split; Col); apply gradexp2_init.
  rename C into E; rename C' into E'.
  destruct IHHGE as [B [C [HGE2 [HPerp HCol]]]]; trivial.
  destruct (segment_construction A B A B) as [B' [HBet HCong]].
  exists B'.
  destruct (l8_18_existence A C0 B') as [C' [HCol' HPerp']].
    apply gradexp2__gradexp123, gradexp__grad, grad__bet in HGE2; intro; assert_diffs; apply HNCol; ColR.
  exists C'; repeat (split; trivial); apply gradexp2_stab with B E; Cong.
Qed.

Lemma t22_24 : archimedes_axiom -> aristotle_s_axiom.
Proof.
  intros Harchi P Q D A B0 HNCol HACute0.
  destruct (l8_18_existence A D B0) as [C0 [HColD HPerpD]]; Col.
  assert (HAC0 : A <> C0) by (intro; subst C0; apply (acute_not_per D A B0); Perp).
  assert (HNCol0 : ~ Col A B0 C0) by (intro; apply HNCol; ColR).
  assert (HPerp0 := perp_col A D B0 C0 C0 HAC0 HPerpD HColD).
  elim (eq_dec_points P Q); intro HPQ.
  { subst Q; exists C0; exists B0; split; assert_diffs.
      apply l6_6, acute_col_perp__out with B0; trivial; apply acute_sym; trivial.
    split.
      apply out_trivial; auto.
    repeat split; Perp; Le.
    intro; treat_equalities; auto.
  }
  destruct (segment_construction P Q P Q) as [Q' [HBetQ HCongQ]].
  destruct (reach__ex_gradexp_le B0 C0 P Q') as [E [HGE HLe]].
    assert_diffs; apply Harchi; trivial.
  destruct (t22_24_aux1 A B0 C0 E) as [B [C [HGE2 [HPerp HCol]]]]; trivial.
  assert(HOut : Out A B0 B).
    apply gradexp2__gradexp123, gradexp__grad, grad__bet in HGE2; assert_diffs; apply bet_out; auto.
  assert(HAcute : Acute D A B).
    apply (acute_conga__acute D A B0); trivial.
    apply l6_6 in HOut.
    assert_diffs; apply out2__conga; auto; apply out_trivial; auto.
  assert (HAC : A <> C) .
    intro; subst C; assert_diffs; apply (acute_not_per D A B); trivial.
    apply perp_per_1, perp_col with C0; Col.
  exists C, B; split.
    assert_diffs; apply l6_6, acute_col_perp__out with B; [apply acute_sym; trivial|ColR|apply perp_col with C0; Col].
  split; trivial; split.
    apply perp_per_1, perp_left_comm, perp_col with C0; trivial.
  apply le3456_lt__lt with P Q'.
  split.
    apply bet__le1213; trivial.
    intro; assert (Q = Q'); [|treat_equalities; auto].
    apply between_cong with P; assumption.
  apply le_transitivity with B0 E; trivial.
  apply le_right_comm.
  apply t22_24_aux with A B0 C0; trivial.
  apply archi__obtuse_case_elimination; assumption.
Qed.

End Archimedes.


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

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

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

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem len_append: forall (l1 l2: lst), len (append l1 l2) = plus (len l1) (len l2).
Proof.
  induction l1; induction l2; simpl.
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { reflexivity. }
  { reflexivity. }
Qed.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem len_rev: forall (l: lst), len (rev l) = len l.
Proof.
  induction l; simpl.
  +
lfind.
Admitted.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (rev (append x y))) (plus (len x) (len y)).
Proof.
  intros.
  rewrite len_rev.
  apply len_append.
Qed.


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

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

Print Assumptions carry.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

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

Print Assumptions carry.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import PeanoNat.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Arith.Wf_nat.
Require Import Coq.Wellfounded.Inverse_Image.
Require Import Coq.Wellfounded.Lexicographic_Product.
From mathcomp Require Import all_ssreflect.
Require Import PreOrders.
Require Import Types.
Require Import Cover.
Require Import FCL.

Set Bullet Behavior "Strict Subproofs".

Delimit Scope it_scope with IT.
Open Scope it_scope.

Import EqNotations.

Section Runtime.
  Variable Combinator: finType.
  Variable Constructor: ctor.

  Fixpoint length (A: @IT Constructor) :=
    match A with
    | A1 -> A2 => (length A2).+1
    | A1 \cap A2 => maxn (length A1) (length A2)
    | _ => 1
    end.

  Lemma lengthS: forall A, 0 < length A.
  Proof.
    elim => //= A1 IH1 A2 IH2.
    apply: (@leq_trans (length A1)) => //.
      by apply: leq_maxl.
  Qed.

  Lemma size_merge: forall (mss1 mss2: seq (seq (@MultiArrow Constructor))),
      seq.size (merge _ mss1 mss2) = maxn (seq.size mss1) (seq.size mss2).
  Proof.
    elim.
    - move => mss2 /=.
        by rewrite max0n.
    - move => // ms1 mss1 IH mss2.
      rewrite /=.
      case: mss2 => //= ms2 mss2.
      rewrite maxnSS.
      apply: f_equal.
        by apply: IH.
  Qed.

  Lemma splitsLength: forall (A: @IT Constructor), seq.size (splitTy A) <= length A.
  Proof.
    move => A.
    rewrite splitTy_slow_splitTy.
    elim: A => //.
    - move => A1 _ A2 IH /=.
      case: (isOmega A2) => //=.
        by rewrite size_map.
    - move => A IH__A B IH__B /=.
      case: (isOmega A && isOmega B) => //=.
      rewrite size_behead size_merge.
      apply: (@leq_ltn_trans (maxn (length A) (length B)).-1).
      + do 2 rewrite -subn1.
        apply: leq_sub2r.
        rewrite geq_max.
        apply /andP.
        split.
        * apply: (@leq_trans (length A)) => //.
            by apply: leq_maxl.
        * apply: (@leq_trans (length B)) => //.
            by apply: leq_maxr.
      + rewrite prednK => //.
        apply: (@leq_trans (length A)).
        * by apply: lengthS.
        * by apply: leq_maxl.
  Qed.

  Lemma sumn_bound {A: eqType}:
    forall (measure: A -> nat) (xs: seq A) (bound: nat),
      (forall x, x \in xs -> measure x <= bound) ->
      sumn (map measure xs) <= seq.size xs * bound.
  Proof.
    move => measure xs bound.
    elim: xs => //= x xs IH boundprf.
    move: (boundprf x (mem_head _ _)) => bound_head.
    rewrite mulSn.
    apply: leq_add => //.
    apply: IH.
    move => y inprf.
    apply: boundprf.
      by rewrite in_cons inprf orbT.
  Qed.

  Lemma splitsSize: forall (A: @IT Constructor) ms, ms \in (splitTy A) -> seq.size ms <= (size _ A).
  Proof.
    move => A.
    rewrite splitTy_slow_splitTy.
    elim: A => //=.
    - move => c A _ ms.
        by rewrite mem_seq1 => /eqP -> /=.
    - move => A IH__A B IH__B ms.
      case: (isOmega B) => //.
      rewrite in_cons => /orP [].
      + by move => /eqP -> /=.
      + move => /mapP [] ms2 /IH__B ms2_size ->.
        rewrite size_map.
        apply: leq_trans; first by apply: ms2_size.
          by apply: leq_addl.
    - move => A IH__A B IH__B ms.
        by rewrite mem_seq1 => /eqP -> /=.
    - move => A IH__A B IH__B ms.
      case: (isOmega A && isOmega B) => //.
      rewrite in_cons => /orP [].
      + by move => /eqP ->.
      + move => /mem_behead inprf.
        have: exists ms1 ms2, (ms1 \in splitTy_slow _ A \/ ms1 = [::]) /\
                         (ms2 \in splitTy_slow _ B \/ ms2 = [::]) /\
                         ms = ms1 ++ ms2.
        { clear IH__A IH__B.
          move: inprf.
          move: (splitTy_slow _ B).
          elim: (splitTy_slow _ A).
          - move => mss2 inprf.
            exists [::], ms.
            split; last split => //.
            + by right.
            + by left.
          - move => ms1 mss1 IH.
            case.
            + move => /= inprf.
              exists ms, [::].
              split; last split.
              * by left.
              * by right.
              * by rewrite cats0.
            + move => ms2 mss2 /=.
              rewrite in_cons.
              case /orP.
              * move => /eqP ->.
                exists ms1, ms2.
                split; last split => //.
                ** by left; apply mem_head.
                ** by left; apply mem_head.
              * move => /IH [] ms11 [] ms22 [] prf_ms11 [] prf_ms22 ms__eq.
                exists ms11, ms22.
                split; last split => //.
                ** case: prf_ms11; last by right.
                   rewrite in_cons => ->.
                     by left; rewrite orbT.
                ** case: prf_ms22; last by right.
                   rewrite in_cons => ->.
                     by left; rewrite orbT. }
        move => [] ms1 [] ms2 [] prf_ms1 [] prf_ms2 ->.
        rewrite size_cat.
        rewrite -addnA.
        apply: leq_trans; last by apply: leq_addl.
        apply: leq_add.
        * case: prf_ms1; last by move => ->.
            by move => /IH__A.
        * case: prf_ms2; last by move => ->.
            by move => /IH__B.
  Qed.

  Lemma size1: forall (A: @IT Constructor), 0 < size _ A.
  Proof. by case => //. Qed.

  Lemma splitsFlattenSize: forall (A: @IT Constructor), seq.size (flatten (splitTy A)) <= (length A) * (size _ A).
  Proof.
    move => A.
    rewrite splitTy_slow_splitTy.
    elim: A => //.
    - move => A IH__A B IH__B.
      rewrite /=.
      case: (isOmega B).
      + done.
      + rewrite /=.
        rewrite size_flatten /shape.
        apply: leq_ltn_trans; first apply: (sumn_bound _ _ (size _ B).+1).
        * move => _ /mapP [] ms inprf ->.
          rewrite size_map.
          apply: leq_trans; last by apply: leqnSn.
          apply: splitsSize.
            by rewrite splitTy_slow_splitTy.
        * rewrite size_map.
          apply: ltn_mul.
          ** rewrite -splitTy_slow_splitTy.
               by apply: splitsLength.
          ** rewrite -[(size _ B).+1]add1n.
             rewrite -addnA ltn_add2l.
             rewrite -add1n.
             apply: leq_add => //.
               by apply: size1.
    - move => A IH__A B IH__B.
      rewrite size_flatten /shape.
      apply: leq_trans; first apply: (sumn_bound _ _ (size _ (A \cap B))).
      * rewrite -splitTy_slow_splitTy.
          by move => ms /splitsSize.
      * apply: leq_mul => //.
        rewrite -splitTy_slow_splitTy.
          by apply: splitsLength.
  Qed.
End Runtime.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.