Require Import Coq.Classes.RelationClasses.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.

Require Import HJ.Tid.
Require Import HJ.Vars.
Require Import HJ.Phasers.Regmode.
Require Import HJ.Phasers.Taskview.
Require Import HJ.Phasers.Phaser.
Require Import HJ.Phasers.WellFormed.
Require Import HJ.Phasers.PhaseOrdering.Taskview.
Import WellFormed.Taskview.
Import WellFormed.Phaser.
Import PhaseOrdering.Taskview.

Set Implicit Arguments.

Section Defs.
  Inductive Forall (R: taskview -> taskview -> Prop) (ph1 ph2:phaser) : Prop :=
    ph_rel_def:
      (forall t1 t2 v1 v2,
        Map_TID.MapsTo t1 v1 ph1 ->
        Map_TID.MapsTo t2 v2 ph2 ->
        R v1 v2) ->
      Forall R ph1 ph2.

  Definition Facilitates := Forall Taskview.Facilitates.

  Inductive HappensBefore (ph1 ph2:phaser) : Prop :=
    ph_happens_before_def:
      forall t1 t2 v1 v2,
      Map_TID.MapsTo t1 v1 ph1 ->
      Map_TID.MapsTo t2 v2 ph2 ->
      Taskview.HappensBefore v1 v2 ->
      HappensBefore ph1 ph2.

  Definition BlockedBy x y := HappensBefore x y.

  Inductive WellOrdered x : Prop :=
    well_ordered_def:
      Facilitates x x ->
      WellOrdered x.

  Inductive Par x y: Prop :=
    par_def:
      Facilitates x y ->
      Facilitates y x ->
      Par x y.

End Defs.

Module Notations.
  Infix "<" := HappensBefore : phaser_scope.
  Infix ">" := BlockedBy : phaser_scope.
  Infix "<=" := (fun x y => Facilitates y x) : phaser_scope.
  Infix ">=" := Facilitates : phaser_scope.
  Infix "||" := Par : phaser_scope.
End Notations.

Section Facts.

  Lemma ph_rel_inv:
    forall R ph1 ph2 t1 t2 v1 v2,
    Map_TID.MapsTo t1 v1 ph1 ->
    Map_TID.MapsTo t2 v2 ph2 ->
    Forall R ph1 ph2 ->
    R v1 v2.
  Proof.
    intros.
    inversion H1.
    eauto.
  Qed.

  Lemma well_ordered_to_facilitates:
    forall v1 v2 t1 t2 ph,
    WellOrdered ph ->
    Map_TID.MapsTo t1 v1 ph ->
    Map_TID.MapsTo t2 v2 ph ->
    Taskview.Facilitates v1 v2.
  Proof.
    intros.
    destruct H as (Hx).
    inversion Hx.
    eauto.
  Qed.

  Lemma ph_hb_to_not_chb:
    forall ph1 ph2,
    HappensBefore ph1 ph2 ->
    ~ Facilitates ph1 ph2.
  Proof.
    intros.
    intuition.
    inversion H.
    inversion H0.
    assert (Taskview.Facilitates v1 v2) by eauto.
    assert (~ Taskview.Facilitates v1 v2) by auto using tv_hb_to_not_ge.
    contradiction H6.
  Qed.

  Lemma ph_chb_to_not_hb:
    forall ph1 ph2,
    Facilitates ph1 ph2 ->
    ~ HappensBefore ph1 ph2.
  Proof.
    intros.
    intuition.
    inversion H.
    inversion H0.
    assert (Taskview.Facilitates v1 v2) by eauto.
    assert (~ Taskview.Facilitates v1 v2) by auto using tv_hb_to_not_ge.
    contradiction H6.
  Qed.

  Lemma ph_hb_trans:
    forall ph1 ph2 ph3,
    HappensBefore ph1 ph2 ->
    HappensBefore ph2 ph3 ->
    WellOrdered ph2 ->
    HappensBefore ph1 ph3.
  Proof.
    intros.
    destruct H1.
    inversion H.
    inversion H0.
    clear H H0.
    assert (Taskview.Facilitates v0 v2) by (inversion H1; eauto).
    eauto using lt_trans_ex, ph_happens_before_def.
  Qed.

  Lemma ph_hb_irreflexive:
    forall ph,
    WellOrdered ph ->
    ~ (HappensBefore ph ph).
  Proof.
    intros.
    inversion H.
    auto using ph_chb_to_not_hb.
  Qed.

  Section Antisym.
  Variable x y:phaser.

  Variable wx: WellFormed x.
  Variable wy: WellFormed y.
  Variable gx: WellOrdered x.
  Variable gy: WellOrdered y.

  Lemma ph_hb_antisym:
    HappensBefore x y ->
    ~ (HappensBefore y x).
  Proof.
    intros.
    apply ph_chb_to_not_hb.
    apply ph_rel_def.
    intros.
    destruct (tv_hb_ge_dec v1 v2); auto.
    inversion H.
    assert (Taskview.HappensBefore v1 v3). {
      inversion gx as (gx').
      inversion gx'.
      assert (Taskview.Facilitates v0 v2) by eauto.
      eauto using lt_trans_ex.
    }
    assert (~ Taskview.Facilitates v1 v3) by eauto using tv_hb_to_not_ge.
    assert (Taskview.Facilitates v1 v3) by (inversion gy as (gy'); inversion gy'; eauto).
    contradiction.
  Qed.
  End Antisym.

  Let ph_ge_refl_preserves_reduces_some:
    forall ph ph' t o o',
    WellFormed ph ->
    WellOrdered ph ->
    Reduces ph (t, o) ph' ->
    as_tv_op o = Some o' ->
    Facilitates ph' ph'.
  Proof.
    intros.
    assert (Hin : Map_TID.In t ph) by eauto using register_inv_in.
    apply Map_TID_Extra.in_to_mapsto in Hin.
    destruct Hin as (v, Hmt).
    assert (Taskview.Reduces v o' (Taskview.reduces o' v)) by
        eauto using ph_reduces_to_tv_reduce.
      assert (ph' = Map_TID.add t (Taskview.reduces o' v) ph) by
        eauto using ph_to_tv_correct.
      subst.
      apply ph_rel_def.
      intros.
      apply Map_TID_Facts.add_mapsto_iff in H4.
      destruct H4 as [(?,?)|(?,?)].
      + subst.
        apply Map_TID_Facts.add_mapsto_iff in H5.
        destruct H5 as [(?,?)|(?,?)].
        * subst.
          eauto using
            tv_reduces_preserves_well_formed,
            ph_well_formed_to_tv_well_formed,
            tv_well_formed_to_ge_refl.
        * apply tv_lhs_eval_ge with (v2:=v2) in H3;
          eauto using ph_well_formed_to_tv_well_formed, well_ordered_to_facilitates.
      + apply Map_TID_Facts.add_mapsto_iff in H5.
        destruct H5 as [(?,?)|(?,?)].
        * subst.
          assert (R : Taskview.Facilitates v1 v) by
          eauto using well_ordered_to_facilitates.
          inversion R; clear R.
          - destruct o'; simpl in *.
            {
              rewrite <- signal_preserves_wait_phase in *.
              auto using tv_nhb_ge.
            }
            apply as_tv_op_inv_wait in H2.
            subst.
            inversion H1; simpl in *; subst; clear H1.
            inversion H3; simpl in *; subst; clear H3.
            inversion H7; subst; clear H7.
            inversion H8; subst; clear H8.
            simpl_red.
            rename v0 into v2.
            destruct (Regmode.can_signal_wo (mode v1)). {
              apply tv_nhb_ge.
              rewrite wait_wait_phase.
              eauto.
            }
            auto using tv_nhb_wo.
          - apply tv_nhb_so.
            rewrite reduces_preserves_mode.
            assumption.
          - auto using tv_nhb_wo.
        * eauto using well_ordered_to_facilitates.
  Qed.

  Let ph_ge_refl_preserves_reduces_drop:
    forall ph ph' t,
    WellOrdered ph ->
    Reduces ph (t, DROP) ph' ->
    WellOrdered ph'.
  Proof.
    intros.
    inversion H0; subst; clear H0.
    inversion H4; subst; clear H4; simpl in *.
    unfold drop in *.
    apply well_ordered_def.
    apply ph_rel_def.
    intros; simpl in *.
    apply Map_TID.remove_3 in H1.
    apply Map_TID.remove_3 in H2.
    eauto using well_ordered_to_facilitates.
  Qed.

  Definition wo_phaser := { ph: phaser | WellOrdered ph }.

  Instance HappensBefore_StrictOrder : StrictOrder
    (fun (x y:wo_phaser) => HappensBefore (proj1_sig x) (proj1_sig y)).
  Proof.
    apply Build_StrictOrder.
    - unfold Irreflexive, Reflexive, complement.
      intros.
      destruct x; simpl in *.
      apply ph_hb_irreflexive in H; auto.
    - unfold Transitive.
      intros.
      destruct x as (x, ?), y as (y, ?), z as (z, ?);
      simpl in *.
      eauto using ph_hb_trans.
  Qed.

  Let exists_dec := Map_TID_Extra.exists_dec (elt:=taskview) tid_eq_rw.

  Let tv_hb x y := if tv_hb_dec x y then true else false.

  Let hb x y :=
  exists_dec
  (fun _ v1 =>
    match exists_dec (fun _ v2 => tv_hb v1 v2) y with
    | inl _ => true
    | inr _ => false
    end
  )
  x.

  Lemma hb_dec x y:
    { HappensBefore x y}
    +
    { Facilitates x y }.
  Proof.
    destruct (hb x y). {
      left.
      destruct s as ((?,v1), (?,?)); simpl in *.
      destruct (exists_dec _ y). {
        destruct s as ((?,v2),(?,?)); simpl in *.
        unfold tv_hb in H2.
        destruct (tv_hb_dec v1 v2). {
          eauto using ph_happens_before_def.
        }
        inversion H2.
      }
      inversion H0.
    }
    right.
    destruct s.
    apply ph_rel_def.
    intros.
    apply e in H.
    destruct (exists_dec _ y). {
      inversion H.
    }
    destruct s.
    apply e0 in H0.
    unfold tv_hb in *.
    destruct (tv_hb_dec v1 v2). {
      inversion H0.
    }
    auto using tv_not_lt_to_ge.
  Defined.

  Lemma par_dec x y:
    { Par x y } + { ~ Par x y }.
  Proof.
    destruct (hb_dec x y). {
      right.
      unfold not; intros.
      destruct H, h.
      destruct H.
      apply tv_hb_to_not_ge in H3.
      contradiction H3; eauto.
    }
    destruct (hb_dec y x). {
      right.
      unfold not; intros.
      destruct H, h.
      destruct H0.
      apply tv_hb_to_not_ge in H3.
      contradiction H3; eauto.
    }
    auto using par_def.
  Defined.

  Lemma well_ordered_dec x:
    { WellOrdered x } + { ~ WellOrdered x }.
  Proof.
    destruct (hb_dec x x). {
      right.
      unfold not; intros.
      destruct H.
      apply ph_hb_to_not_chb in h.
      contradiction.
    }
    auto using well_ordered_def.
  Defined.

  Lemma hb_to_not_mhp:
    forall x y,
    HappensBefore x y ->
    ~ Facilitates x y.
  Proof.
    intros.
    inversion H.
    unfold not; intros N.
    inversion N.
    assert (Taskview.Facilitates v1 v2) by eauto.
    apply tv_hb_to_not_ge in H2.
    contradiction.
  Qed.

  Lemma not_mhp_to_hb:
    forall x y,
    ~ Facilitates x y ->
    HappensBefore x y.
  Proof.
    intros.
    destruct (hb_dec x y); auto.
    contradiction.
  Qed.

  Lemma mhp_to_not_hb:
    forall x y,
    Facilitates y x ->
    ~ HappensBefore y x.
  Proof.
    unfold not; intros.
    destruct H0, H.
    assert (Taskview.Facilitates v1 v2) by eauto.
    apply tv_hb_to_not_ge in H2.
    contradiction.
  Qed.

  Lemma not_hb_to_mhp:
    forall x y,
    ~ HappensBefore x y ->
    Facilitates x y.
  Proof.
    intros.
    apply ph_rel_def; intros.
    destruct (Taskview.tv_hb_ge_dec v1 v2). {
      contradiction H.
      eauto using ph_happens_before_def.
    }
    assumption.
  Qed.

  Let tv_nhb_register_left:
    forall r v1 v2,
    r_le (get_mode r) (mode v1) ->
    Taskview.Facilitates v1 v2 ->
    Taskview.Facilitates (set_mode v1 (get_mode r)) v2.
  Proof.
    intros ? ? ? Hle Hge.
    inversion Hge.
    * apply tv_nhb_ge.
      rewrite set_mode_preserves_signal_phase.
      assumption.
    * auto using tv_nhb_so.
    * rewrite H in Hle.
      inversion Hle.
      rewrite <- H.
      rewrite set_mode_ident.
      assumption.
  Qed.

  Let tv_nhb_register_both:
    forall r v,
    r_le (get_mode r) (mode v) ->
    Taskview.Facilitates v v ->
    Taskview.Facilitates (set_mode v (get_mode r)) (set_mode v (get_mode r)).
  Proof.
    intros.
    destruct (get_mode r); auto using tv_nhb_so, tv_nhb_wo.
    inversion H.
    subst.
    rewrite H3.
    rewrite set_mode_ident.
    assumption.
  Qed.

  Let tv_nhb_register_right:
    forall v1 v2 r,
    r_le (get_mode r) (mode v2) ->
    Taskview.Facilitates v1 v2 ->
    Taskview.Facilitates v1 (set_mode v2 (get_mode r)).
  Proof.
    intros ? ? r Hle Hge.
    inversion Hge.
    * apply tv_nhb_ge.
      rewrite set_mode_preserves_wait_phase.
      assumption.
    * rewrite H in Hle.
      inversion Hle.
      rewrite H1 in *.
      rewrite <- H.
      rewrite set_mode_ident.
      assumption.
    * auto using tv_nhb_wo.
  Qed.

  Let ph_ge_refl_preserves_reduces_register:
    forall t r ph ph',
    WellOrdered ph ->
    Reduces ph (t, (REGISTER r)) ph' ->
    WellOrdered ph'.
  Proof.
    intros ? ? ? ? Hge R.
    inversion R; subst; simpl in *; clear R.
    inversion H2; subst; clear H2.
    assert (R:=H0).
    apply register_rw with (r:=r) in R; auto.
    rewrite R; clear R.
    apply well_ordered_def.
    apply ph_rel_def.
    intros ? ? ? ? Hmt1 Hmt2.
    apply Map_TID_Facts.add_mapsto_iff in Hmt1;
    destruct Hmt1 as [(?,?)|(?,?)].
    - subst.
      apply Map_TID_Facts.add_mapsto_iff in Hmt2;
      destruct Hmt2 as [(?,?)|(?,?)].
      + subst.
        eauto using well_ordered_to_facilitates, tv_nhb_register_both.
      + eauto using well_ordered_to_facilitates, tv_nhb_register_left.
    - apply Map_TID_Facts.add_mapsto_iff in Hmt2;
      destruct Hmt2 as [(?,?)|(?,?)].
      + subst.
        eauto using well_ordered_to_facilitates, tv_nhb_register_right.
      + eauto using well_ordered_to_facilitates.
  Qed.

  Theorem ph_ge_refl_preserves_reduce:
    forall ph t o ph',
    WellFormed ph ->
    WellOrdered ph ->
    Phaser.Reduces ph (t, o) ph' ->
    WellOrdered ph'.
  Proof.
    intros.
    remember (as_tv_op o) as o'.
    symmetry in Heqo'.
    destruct o' as [o'|].
    - apply well_ordered_def; inversion H0; eauto using ph_ge_refl_preserves_reduces_some.
    - destruct o; try (simpl in Heqo'; inversion Heqo'); clear Heqo'.
      + eauto using ph_ge_refl_preserves_reduces_drop.
      + eauto using ph_ge_refl_preserves_reduces_register.
  Qed.

  Let ph_ge_reduces_some:
    forall ph t o o' ph',
    WellFormed ph ->
    WellOrdered ph ->
    Reduces ph (t, o) ph' ->
    as_tv_op o = Some o' ->
    Facilitates ph' ph.
  Proof.
    intros.
    assert (Hin : Map_TID.In t ph) by eauto using register_inv_in.
    apply Map_TID_Extra.in_to_mapsto in Hin.
    destruct Hin as (v, Hmt).
    assert (Taskview.Reduces v o' (Taskview.reduces o' v)) by
    eauto using ph_reduces_to_tv_reduce.
    assert (ph' = Map_TID.add t (Taskview.reduces o' v) ph) by
    eauto using ph_to_tv_correct.
    subst.
    apply ph_rel_def.
    intros.
    apply Map_TID_Facts.add_mapsto_iff in H4;
    destruct H4 as [(?,?)|(?,?)].
    - subst.
      assert (Taskview.WellFormed v) by (inversion H; eauto).
      assert (Taskview.Facilitates v v2) by eauto using well_ordered_to_facilitates.
      eauto using tv_lhs_eval_ge.
    - eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_ge_reduce:
    forall ph t o ph',
    WellFormed ph ->
    WellOrdered ph ->
    Reduces ph (t, o) ph' ->
    Facilitates ph' ph.
  Proof.
    intros ? ? ? ? WF Hge R.
    remember(as_tv_op o) as o'.
    symmetry in Heqo'.
    destruct o' as [o'|]; eauto using ph_ge_reduces_some.
    (destruct o; simpl in Heqo'; inversion Heqo'); clear Heqo';
    inversion R; subst;  simpl in *; clear R;
    inversion H2; subst; clear H2.
    - unfold drop in *.
      apply ph_rel_def.
      intros.
      apply Map_TID.remove_3 in H0.
      eauto using well_ordered_to_facilitates.
    - assert (R:= H0).
      apply register_rw with (r:=r) in H0; auto.
      rewrite H0 in *; clear H0.
      apply ph_rel_def; intros.
      apply Map_TID_Facts.add_mapsto_iff in H0;
      destruct H0 as [(?,?)|(?,?)].
      + subst.
        eauto using well_ordered_to_facilitates, tv_nhb_register_left.
      + eauto using well_ordered_to_facilitates.
  Qed.

  Section Trans.
    Inductive Update : op -> Prop :=
      | update_signal:
        Update SIGNAL
      | update_wait:
        Update WAIT
      | update_register:
        forall r,
        Update (REGISTER r).

    Hint Constructors Update.

    (** Reduces for update-operations *)

    Inductive ReducesUpdates p1 : event -> phaser -> Prop :=
      reduces_updates_def:
        forall t o p2,
        Update o ->
        Reduces p1 (t, o) p2 ->
        ReducesUpdates p1 (t, o) p2.

    Hint Constructors ReducesUpdates.

    Inductive ReducesDestructs p1 : event -> phaser -> Prop :=
      reduces_destructs_def:
        forall p2 t,
        Reduces p1 (t, DROP) p2 ->
        ReducesDestructs p1 (t, DROP) p2.

    Hint Constructors ReducesDestructs.

    Lemma case_reduces:
      forall ph1 e ph2,
      Reduces ph1 e ph2 ->
      { ReducesUpdates ph1 e ph2 } + { ReducesDestructs ph1 e ph2 }.
    Proof.
      intros.
      destruct e as (?,[]); try (solve [left; auto | right; auto]).
    Qed.

    Lemma reduces_mapsto_neq:
      forall t v ph1 t' o ph2,
      Map_TID.MapsTo t v ph1 ->
      t' <> t ->
      Reduces ph1 (t', o) ph2 ->
      Map_TID.MapsTo t v ph2.
    Proof.
      intros.
      assert (Hin : Map_TID.In t' ph1) by eauto using register_inv_in.
      apply Map_TID_Extra.in_to_mapsto in Hin.
      destruct Hin as (v', Hmt').
      assert (R:=Hmt').
      inversion H1; subst; clear H1.
      destruct o; simpl in *;
      inversion H5; subst; clear H5.
      - apply signal_rw in R. rewrite R.
        auto using Map_TID.add_2.
      - apply wait_rw in R; rewrite R.
        auto using Map_TID.add_2.
      - unfold drop in *.
        auto using Map_TID.remove_2.
      - apply register_rw with (r:=r) in R. rewrite R.
        apply Map_TID.add_2; auto.
        intuition.
        subst.
        contradiction H1.
        eauto using Map_TID_Extra.mapsto_to_in.
    Qed.

    Lemma reduces_mapsto_neq_rtl:
      forall t v ph1 t' o ph2,
      Map_TID.MapsTo t v ph2 ->
      t' <> t ->
      Reduces ph1 (t', o) ph2 ->
      Map_TID.MapsTo t v ph1 \/ exists r, o = REGISTER r /\ t = (get_task r).
    Proof.
      intros.
      assert (Hin : Map_TID.In t' ph1) by eauto using register_inv_in.
      apply Map_TID_Extra.in_to_mapsto in Hin.
      destruct Hin as (v', Hmt').
      inversion H1; subst; clear H1.
      assert (R:=Hmt').
      destruct o; simpl in *;
      inversion H5; subst; simpl in *; clear H5.
      - left.
        apply signal_rw in R.
        rewrite R in H.
        eauto using Map_TID.add_3.
      - apply wait_rw in R; rewrite R in H.
        left; eauto using Map_TID.add_3.
      - unfold drop in *.
        left; eauto using Map_TID.remove_3.
      - destruct (TID.eq_dec t (get_task r)).
        + eauto.
        + left.
          apply register_rw with (r:=r) in R; auto; rewrite R in *.
          rewrite Map_TID_Facts.add_mapsto_iff in H.
          destruct H.
          * destruct H.
            symmetry in H.
            contradiction.
          * destruct H; assumption.
    Qed.

    Lemma reduces_update_inv:
      forall t v ph1 t' o ph2,
      Map_TID.MapsTo t v ph1 ->
      ReducesUpdates ph1 (t', o) ph2 ->
      { Map_TID.MapsTo t v ph2 } + { exists o', (as_tv_op o = Some o' /\ t' = t /\ Map_TID.MapsTo t (Taskview.reduces o' v) ph2) }.
    Proof.
      intros.
      destruct (TID.eq_dec t' t). {
        rewrite tid_eq_rw in *; subst.
        assert (rw:=H).
        destruct o; simpl in *; try destruct H1.
        - right.
          exists Taskview.SIGNAL.
          intuition.
          inversion H0; subst; clear H0.
          simpl_red.
          auto using signal_1.
        - right; exists Taskview.WAIT; intuition.
          inversion H0; subst; clear H0.
          simpl_red.
          auto using wait_1.
        - left.
          inversion H0; inversion H3.
        - left.
          inversion H0; subst; clear H0.
          simpl_red.
          auto using register_1.
      }
      left.
      inversion H0; subst; clear H0.
      eauto using reduces_mapsto_neq.
    Qed.
  End Trans.

  Lemma ph_reduces_updates_preserves_ge_left:
    forall x y z t o,
    WellFormed y ->
    Facilitates y x ->
    ReducesUpdates y (t, o) z ->
    Facilitates z x.
  Proof.
    intros.
    apply ph_rel_def.
    intros tz tx vz vx; intros.
    destruct (TID.eq_dec t tz). {
      rewrite tid_eq_rw in *; subst.
      rename H1 into r.
      assert (i: Map_TID.In tz y) by (inversion r; eauto using register_inv_in).
      apply Map_TID_Extra.in_to_mapsto in i.
      destruct i as (v, mt).
      assert (R:=r).
      apply reduces_update_inv with (t:=tz) (v:=v) in r; auto.
      destruct r. {
        assert (v = vz) by eauto using Map_TID_Facts.MapsTo_fun.
        subst.
        inversion H0; eauto.
      }
      destruct e as (o', (Hv, (_, Hmt))).
      assert (vz = Taskview.reduces o' v) by eauto using Map_TID_Facts.MapsTo_fun.
      subst.
      assert (Taskview.Reduces v o' (Taskview.reduces o' v))
      by (inversion R; eauto using ph_reduces_to_tv_reduce).
      assert (Taskview.Facilitates v vx) by (inversion H0; eauto).
      assert (Taskview.WellFormed v) by (inversion H; eauto).
      eauto using tv_nhb_eval_lhs.
    }
    inversion H1; subst; clear H1.
    assert (R := H8).
    apply reduces_mapsto_neq_rtl with (t:=tz) (v:=vz) in R; auto.
    destruct R as [?|R]. { inversion H0; eauto. }
    destruct R as (r, (?, ?)).
    subst.
    simpl_red.
    assert (R: vz = set_mode v (get_mode r)). {
      eapply register_inv_1; eauto.
    }
    rewrite R in *; clear R.
    assert (Taskview.Facilitates v vx)
    by (inversion H0; eauto).
    eauto using tv_nhb_register_left.
  Qed.

  Lemma ph_reduces_drop_preserves_ge_left:
    forall x y z t,
    Facilitates y x ->
    Reduces y (t, DROP) z ->
    Facilitates z x.
  Proof.
    intros.
    apply ph_rel_def; intros tz tx vz vx; intros.
    simpl_red.
    apply drop_mapsto_inv in H1.
    destruct H1.
    inversion H; eauto.
  Qed.

  Require Import Coq.Relations.Relation_Operators.
  Require Import Coq.Relations.Operators_Properties.

  Lemma ph_s_reduces_preserves_ge_left:
    forall x y z,
    WellFormed y ->
    Facilitates y x ->
    SReduces y z ->
    Facilitates z x.
  Proof.
    intros.
    destruct H1.
    apply case_reduces in H1.
    destruct H1.
    - eauto using ph_reduces_updates_preserves_ge_left.
    - destruct r; eauto using ph_reduces_drop_preserves_ge_left.
  Qed.

  Lemma ph_s_reduces_trans_refl_well_formed:
    forall x y,
    WellFormed x ->
    clos_refl_trans phaser SReduces x y ->
    WellFormed y.
  Proof.
    intros.
    induction H0; auto.
    destruct H0.
    eauto using ph_reduces_preserves_well_formed.
  Qed.

  Lemma ph_s_reduces_trans_refl_ge_refl:
    forall x y,
    WellFormed x ->
    WellOrdered x ->
    clos_refl_trans phaser SReduces x y ->
    WellOrdered y.
  Proof.
    intros.
    induction H1; auto.
    - destruct H1.
      eauto using ph_ge_refl_preserves_reduce.
    - assert (WellFormed y) by eauto using ph_s_reduces_trans_refl_well_formed.
      eauto.
  Qed.

  Lemma ph_s_reduces_trans_refl_ge:
    forall x y,
    WellFormed x ->
    WellOrdered x ->
    clos_refl_trans phaser SReduces x y ->
    Facilitates y x.
  Proof.
    intros.
    rewrite clos_rt_rtn1_iff in H1.
    induction H1.
    - inversion H0; auto.
    - assert (WellFormed y). {
        rewrite <- clos_rt_rtn1_iff in H2.
        eauto using ph_s_reduces_trans_refl_well_formed.
      }
      eauto using ph_s_reduces_preserves_ge_left.
  Qed.

  Import Notations.
  Open Scope phaser_scope.

  Lemma ph_signal_lhs_ge_rhs:
    forall x t,
    WellOrdered x ->
    SignalPre t x ->
    x >= signal t x.
  Proof.
    intros.
    inversion H0.
    apply ph_rel_def.
    intros.
    apply signal_mapsto_inv in H4.
    destruct H4 as [(?,(v',(?,?)))|(?,?)].
    - subst.
      assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst; clear H6.
      eauto using well_ordered_to_facilitates, signal_preserves_rhs.
    - eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_wait_lhs_ge_rhs:
    forall x t,
    WellOrdered x ->
    WaitPre t x ->
    x >= wait t x.
  Proof.
    intros.
    inversion H0; clear H0.
    apply ph_rel_def.
    intros.
    apply wait_mapsto_inv in H4.
    destruct H4 as [(?,(v',(?,?)))|(?,?)].
    - subst.
      assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst; clear H6.
      assert (Taskview.Facilitates v1 v) by eauto using well_ordered_to_facilitates.
      rename v into v2.
      destruct H3.
      apply wait_preserves_rhs; eauto.
    - eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_register_lhs_ge_rhs:
    forall x r t,
    WellOrdered x ->
    RegisterPre r t x ->
    x >= register r t x.
  Proof.
    intros.
    inversion H0; clear H0.
    apply ph_rel_def.
    intros.
    apply register_inv_mapsto in H4 as [?|(?,(v',(?,?)))]. {
      eauto using well_ordered_to_facilitates.
    }
    subst.
    assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst; clear H5.
    apply tv_nhb_register_right; auto.
    eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_drop_lhs_ge_rhs:
    forall x t,
    WellOrdered x ->
    DropPre t x ->
    x >= drop t x.
  Proof.
    intros.
    inversion H0.
    apply ph_rel_def.
    intros.
    apply drop_mapsto_inv in H3.
    destruct H3 as (?,?).
    eauto using well_ordered_to_facilitates.
  Qed.

  Lemma reduces_ne:
    forall x y,
    WellOrdered x ->
    SReduces x y ->
    x >= y.
  Proof.
    intros.
    inversion H0; clear H0.
    inversion H1.
    destruct o; simpl in *; subst; clear H1.
    - auto using ph_signal_lhs_ge_rhs.
    - auto using ph_wait_lhs_ge_rhs.
    - auto using ph_drop_lhs_ge_rhs.
    - auto using ph_register_lhs_ge_rhs.
  Qed.

  Lemma reduces_par:
    forall x y,
    WellFormed x ->
    WellOrdered x ->
    SReduces x y ->
    x || y.
  Proof.
    intros.
    inversion H1.
    apply par_def.
    - eauto using reduces_ne.
    - eauto using ph_ge_reduce.
  Qed.

  Lemma ph_par_symm:
    forall x y,
    x || y <-> y || x.
  Proof.
    split; intros;
    inversion H; eauto using par_def.
  Qed.
End Facts.


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

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

Print Assumptions sub.


(*
This file consists of several sections:
- nonnegative lists, polynomials with nonnegative coefs, proof of Proposition 2.39 of [bpr], monic_roots_changes_eq0
- complements for scaleX_poly
- complements for transformations in R and roots
- complements for transformations and equality
- complements for transformations in C and roots
- proof of 3 circles i)
- proof of 3 circles ii)
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype prime.
Require Import div bigop ssralg poly polydiv polyorder ssrnum zmodp.
Require Import polyrcf qe_rcf_th complex poly_normal pol.

Set Implicit Arguments.
Unset Strict Implicit.

Import GRing.Theory Num.Theory Num.Def.
Import Pdiv.Idomain.

Section about_nonneg.

Variable R : rcfType.

Local Notation C := (complex R).

Definition nonneg := fun (s : seq R) => all (fun x => 0 <= x) s.

Lemma nonnegP (s : seq R) : reflect
  (forall k, (k < size s)%N -> 0 <= s`_k) (nonneg s).
Proof. by apply/all_nthP. Qed.

Lemma nonneg_poly_deg1 (a : R) :
   nonneg ('X - a%:P) = (a <= 0).
Proof.
by rewrite polyseqXsubC /= ler01 oppr_ge0 !andbT.
Qed.

Lemma nonneg_poly_deg2 (z : C) :
   nonneg ('X^2 + (1 *- 2 * Re z) *: 'X + (Re z ^+ 2 + Im z ^+ 2)%:P)
    = ((Re z) <= 0).
Proof.
rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 /= ?oner_neq0 // ler01 !andbT.
rewrite nmulr_rge0 ?oppr_lt0 ?ltr0n //.
by rewrite addr_ge0 // sqr_ge0.
Qed.

Lemma nonneg_mulr (p q : {poly R}) :
   (nonneg p) -> (nonneg q) -> (nonneg (p * q)).
Proof.
case Hpsize : (p == 0).
  by rewrite (eqP Hpsize) mul0r => Hp Hq.
move/eqP/eqP : Hpsize => Hpsize.
case Hqsize : (q == 0).
  by rewrite (eqP Hqsize) mulr0.
move/eqP/eqP : Hqsize=> Hqsize Hp Hq.
apply/nonnegP => k Hk.
rewrite coef_mul_poly /= sumr_ge0 //.
case=> i Hi _ /=.
apply: mulr_ge0.
  case Hi2 : (i < size p)%N.
    by apply/nonnegP; rewrite ?Hi2.
  by rewrite -(coefK p) coef_poly Hi2.
case Hi2 : (k - i < size q)%N.
   by apply/nonnegP.
by rewrite -(coefK q) coef_poly Hi2.
Qed.

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

Lemma nonneg_root_nonpos : forall (p : {poly R}),
   (p \is monic) ->
   (forall z : C, root (toC p) z -> ((Re z) <= 0)) -> nonneg p.
Proof.
move=> p Hpmonic.
move: {2}(size p) (leqnn (size p)) => n.
elim: n p Hpmonic=> [p Hpmonic Hpsize Hproot | n IH p Hpmonic Hpsize Hproots].
(* size p <= 0 *)
  rewrite size_poly_leq0 in Hpsize.
  by rewrite (eqP Hpsize) monicE lead_coef0 eq_sym oner_eq0 in Hpmonic.
(* size p <= n.+1 *)
case: (altP (size (toC p) =P 1%N)) => Hpsize2.
(* size p = 1 *)
  rewrite size_map_poly_id0 in Hpsize2;
    last by rewrite eq_sym negbT // ltr_eqF // ltcR (eqP Hpmonic) ltr01.
  have Hp := (size1_polyC (eq_leq Hpsize2)).
  rewrite Hp in Hpsize2.
  rewrite Hp monicE lead_coefE Hpsize2 -pred_Sn polyseqC in Hpmonic.
  rewrite size_polyC in Hpsize2.
  rewrite Hpsize2 /= in Hpmonic.
  by rewrite Hp /= (eqP Hpmonic) polyseqC oner_neq0 /= ler01.
(* size p != 1 *)
move/closed_rootP : Hpsize2.
case=> x Hrootx.
case: (altP (Im x =P 0)) => Himx.
(* real root *)
  have H := monicXsubC (Re x).
  have Hp := real_root_div_poly_deg1 Himx Hrootx.
  rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp.
  rewrite (eqP Hp) nonneg_mulr //.
    apply: IH=> [ | | z Hz].
    + by rewrite monicE -(@lead_coef_Mmonic _ (p %/ ('X - (Re x)%:P))
          ('X - (Re x)%:P)) // -(eqP Hp) -monicE.
    - rewrite size_divp; last by apply: monic_neq0.
      by rewrite size_XsubC leq_subLR addnC addn1.
    + rewrite Hproots // (eqP Hp) rmorphM rootM.
      apply/orP; by left.
  by rewrite nonneg_poly_deg1 (Hproots x Hrootx).
(* pair of complex roots *)
have H : 'X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P \is monic.
  by rewrite -(mul1r 'X^2) mul_polyC monicE lead_coefE polyseq_deg2 // oner_neq0.
have H2 : size ('X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P) = 3.
  by rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 // oner_neq0.
have Hp := complex_root_div_poly_deg2 Himx Hrootx.
rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp.
rewrite (eqP Hp) nonneg_mulr //.
  apply: IH=> [ | | z Hz].
 + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X^2 + (1 *- 2 * Re x) *: 'X +
    (Re x ^+ 2 + Im x ^+ 2)%:P)) // -(eqP Hp) -monicE.
  - rewrite size_divp; last by apply: monic_neq0.
    by rewrite H2 leq_subLR addnC addn2 (@leq_trans n.+1).
  + rewrite Hproots // (eqP Hp) rmorphM rootM.
    apply/orP; by left.
by rewrite nonneg_poly_deg2 (Hproots _ Hrootx).
Qed.

Lemma nonneg_changes0 : forall (s : seq R),
   (nonneg s) -> (changes s = 0%N).
Proof.
elim=> [ |a ] //.
case=> [_ _ |b l IHbl /andP [] Ha Hblnonneg].
  by rewrite /= mulr0 addn0 ltrr.
have/andP [Hb Hlnonneg] := Hblnonneg.
apply/eqP; rewrite addn_eq0 eqb0 -lerNgt mulr_ge0 //=.
apply/eqP; by apply: IHbl.
Qed.

(* Proposition 2.39 *)
Lemma monic_roots_changes_eq0 (p : {poly R}) :
   p \is monic ->
   (forall (z : C), (root (toC p) z) -> (Re z <= 0)) ->
   changes p = 0%N.
Proof.
move=> Hpmonic H.
by rewrite nonneg_changes0 // nonneg_root_nonpos.
Qed.

End about_nonneg.

Section about_scaleX_poly. (* move this section to pol.v*)

Variable (R : comRingType).

Lemma scaleX_poly_is_linear (c : R) : linear (scaleX_poly c).
Proof. by move=> a u v; rewrite /scaleX_poly comp_polyD comp_polyZ. Qed.

Lemma scaleX_poly_multiplicative (c : R) : multiplicative (scaleX_poly c).
Proof.
split. move=> x y; exact: comp_polyM. by rewrite /scaleX_poly comp_polyC.
Qed.

Canonical scaleX_poly_additive (c : R) := Additive (scaleX_poly_is_linear c).
Canonical scaleX_poly_linear c := Linear (scaleX_poly_is_linear c).
Canonical scaleX_poly_rmorphism c := AddRMorphism (scaleX_poly_multiplicative c).

Lemma scaleX_polyC (c a : R) : a%:P \scale c = a%:P.
Proof. by rewrite /scaleX_poly comp_polyC. Qed.

End about_scaleX_poly.

Section about_transformations.

Variable (R : fieldType).
(*
Lemma root_shift_1 (p : {poly R}) (a x : R) :
   (root p x) = root (p \shift a) (x-a).
Proof. by rewrite !rootE -horner_shift_poly1. Qed.
*)
Lemma root_shift_2 (p : {poly R}) (a x : R) :
   root p (x + a) = root (p \shift a) x.
Proof.
by rewrite !rootE -{2}(@addrK _ a x) -horner_shift_poly1.
Qed.
(*
Lemma root_scale_1 (p : {poly R}) (a x : R) : (a != 0) ->
   root p x = root (p \scale a) (x / a).
Proof.
move=> Ha.
by rewrite !rootE horner_scaleX_poly mulrC (@mulrVK _ a _ x) // unitfE.
Qed.
*)
Lemma root_scale_2 (p : {poly R}) (a x : R) :
   root p (a * x) = root (p \scale a) x.
Proof.
by rewrite !rootE horner_scaleX_poly.
Qed.
(*
Lemma root_reciprocal_1 (p : {poly R}) (x : R) : (x != 0) ->
   root p x = root (reciprocal_pol p) (x^-1).
Proof.
move=> Hx.
rewrite !rootE horner_reciprocal1; last by rewrite unitfE.
rewrite GRing.mulrI_eq0 //; apply: GRing.lregX.
by apply/lregP.
Qed.
*)
Lemma root_reciprocal_2 (p : {poly R}) (x : R) : (x != 0) ->
   root p (x^-1) = root (reciprocal_pol p) x.
Proof.
move=> Hx.
rewrite !rootE horner_reciprocal; last by rewrite unitfE.
rewrite GRing.mulrI_eq0 //; apply: GRing.lregX.
by apply/lregP.
Qed.
(*
Lemma root_Mobius_1 (p : {poly R}) (x : R) (l r : R) :
   (l != r) -> (x != l) -> (x != r) ->
   root p x = root (Mobius p l r) ((r - x) / (x - l)).
Proof.
move=> Hlr Hxl Hxr.
rewrite /Mobius.
rewrite -root_shift_2 -(@mulrK _ (x - l) _ 1); last by rewrite unitfE subr_eq0.
rewrite mul1r -mulrDl addrA -(@addrA _ _ (-x) x) (@addrC _ (-x) x) addrA addrK.
rewrite -root_reciprocal_2.
  rewrite invrM; last by rewrite unitfE invr_eq0 subr_eq0.
    rewrite invrK -root_scale_2 mulrC divrK;
      last by rewrite unitfE subr_eq0 eq_sym.
    by rewrite -root_shift_2 -addrA (@addrC _ _ l) addrA addrK.
  by rewrite unitfE subr_eq0 eq_sym.
apply: GRing.mulf_neq0.
  by rewrite subr_eq0 eq_sym.
by rewrite invr_eq0 subr_eq0.
Qed.
*)
Lemma root_Mobius_2 (p : {poly R}) (x : R) (l r : R) :
   (x + 1 != 0) ->
   root p ((r + l * x) / (x + 1)) = root (Mobius p l r) x.
Proof.
move=> Hx.
rewrite /Mobius -root_shift_2 -root_reciprocal_2 //.
rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (x + 1) _ l).
  by rewrite -mulrDl {2}(@addrC _ x 1) mulrDr mulr1 addrA
       -(addrA r (- l) l) (addrC (-l) l) addrA addrK.
by rewrite unitfE.
Qed.

Lemma MobiusM (p q : {poly R}) (l r : R) :
   Mobius (p * q) l r = (Mobius p l r) * (Mobius q l r).
Proof.
by rewrite /Mobius !rmorphM /= reciprocalM rmorphM.
Qed.

Lemma Mobius_Xsubc (c l r : R) : (l != r) ->
   Mobius ('X - c%:P) l r = (l - c) *: 'X + (r - c)%:P.
Proof.
move=> Hlr.
rewrite /Mobius rmorphB /= shift_polyC rmorphB /= scaleX_polyC
   /shift_poly comp_polyX rmorphD /= scaleX_polyC /scaleX_poly
   comp_polyX -addrA -(rmorphB _ l c) /= reciprocal_monom.
  by rewrite rmorphD rmorphM /= comp_polyX !comp_polyC
    mulrDl polyC1 mul1r mulrC mul_polyC -addrA (addrC (l - c)%:P _)
    -rmorphD /= addrA addrNK.
by rewrite subr_eq0 eq_sym.
Qed.

Lemma Mobius_Xsubc_monic (c l r : R) :
   (l != r) -> (l != c) ->
   (lead_coef (Mobius ('X - c%:P) l r))^-1 *: (Mobius ('X - c%:P) l r)
         = 'X + ((r - c) / (l - c))%:P.
Proof.
move=> Hlr Hlc.
rewrite Mobius_Xsubc //  lead_coefE.
have Hlc2 : ((l - c) != 0).
  by rewrite subr_eq0.
have HlcP : ((l - c)%:P == 0) = false.
  apply/eqP/eqP.
  by rewrite polyC_eq0 subr_eq0.
have Hsize : size ((l - c) *: 'X + (r - c)%:P) = 2.
  by rewrite -(mul_polyC (l - c) 'X) size_MXaddC HlcP /= size_polyC Hlc2.
have Hcoef1 : ((l - c) *: 'X + (r - c)%:P)`_1 = (l - c).
  by rewrite coefD coefC addr0 -mul_polyC coefMX coefC /=.
by rewrite Hsize -mul_polyC Hcoef1 mulrDr mul_polyC -rmorphM
   mulrC -!mul_polyC mulrA (mulrC _ 'X) -rmorphM (mulrC _ (l - c))
   mulfV //= polyC1 mulr1.
Qed.

End about_transformations.

Section about_transformations_and_equality.

Variable (R : idomainType).

Lemma shift_poly_eq (p q : {poly R}) (a : R) :
   (p == q) = (p \shift a == q \shift a).
Proof.
by rewrite /shift_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p-q) ('X + a%:P))
  ?size_XaddC // rmorphB subr_eq add0r.
Qed.

Lemma scale_poly_eq (p q : {poly R}) (a : R) : (a != 0) ->
   (p == q) = (p \scale a == q \scale a).
Proof.
move=> Ha.
by rewrite /scaleX_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p-q) ('X * a%:P))
  ?size_XmulC // rmorphB subr_eq add0r.
Qed.

Lemma reciprocal_Xn n :
   reciprocal_pol ('X^n) = (GRing.one R)%:P.
Proof.
rewrite /reciprocal_pol size_polyXn poly_def big_ord_recl.
rewrite subSS subn0 coefXn expr0 eqxx scale1r big1 ?addr0 // => i _.
rewrite lift0 subSS coefXn /=.
have H : (((n - i.+1)%N == n) = false).
  apply: negbTE.
  rewrite neq_ltn.
  apply/orP; left.
  rewrite -(ltn_add2r i.+1) subnK; last by case: i.
  by rewrite -addSnnS ltn_addr.
by rewrite H /= -mul_polyC mul0r.
Qed.

Lemma reciprocal_Xn_root0 (p : {poly R}) :
   reciprocal_pol p = reciprocal_pol (p %/ 'X^(\mu_0 p)).
Proof.
rewrite -(addr0 'X) -oppr0.
have Hmu0 := (root_mu p 0).
rewrite Pdiv.IdomainMonic.dvdp_eq in Hmu0.
  by rewrite {1}(eqP Hmu0) reciprocalM {2}oppr0 addr0 reciprocal_Xn
    polyC1 mulr1 polyC0.
by rewrite polyC0 oppr0 addr0 monicXn.
Qed.

Lemma pdivmu0_0th_neq0 : forall p : {poly R}, (p != 0) ->
   (p %/ 'X^(\mu_0 p))`_0 != 0.
Proof.
move=> p Hp.
have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0).
  rewrite -mu_gt0.
    rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 (poly_zmodType R)) -polyC0 mu_div
      ?subn_eq0; by rewrite leqnn.
  rewrite Pdiv.CommonIdomain.divp_eq0 negb_or Hp /= negb_or.
  rewrite -size_poly_gt0 {1}size_polyXn /= -leqNgt dvdp_leq //.
  by rewrite -(addr0 'X) -oppr0 -polyC0 root_mu.
rewrite -horner_coef0. apply: negbT.
by move/rootPf : H0noroot.
Qed.

Lemma reciprocal_reciprocal (p : {poly R}) :
   reciprocal_pol (reciprocal_pol p) = p %/ ('X^(\mu_0 p)).
Proof.
case Hp0 : (p == 0).
  move/eqP : Hp0 => ->.
  by rewrite !reciprocalC div0p polyC0.
rewrite (@reciprocal_Xn_root0 p) reciprocal_idempotent //.
apply: pdivmu0_0th_neq0.
by apply: negbT.
Qed.

Lemma reciprocal0 (p : {poly R}) :
   (reciprocal_pol p == 0) = (p == 0).
Proof.
apply/idP/idP => Hp.
  have H : (p %/ ('X^(\mu_0 p)) == 0).
    by rewrite -reciprocal_reciprocal -polyC0 -reciprocalC (eqP Hp).
  rewrite Pdiv.CommonIdomain.divp_eq0 in H.
  move/orP : H; case => [| /orP [] H] //.
    by rewrite -size_poly_eq0 size_polyXn -(Bool.negb_involutive (_.+1 == 0%N))
      -lt0n /= in H.
  have H2 := (root_mu p 0).
  case Hp0 : (p == 0) => //.
  rewrite gtNdvdp // in H2.
    by apply: negbT.
  by rewrite oppr0 addr0.
by rewrite (eqP Hp) -polyC0 reciprocalC.
Qed.

(*
Lemma reciprocal_nth : forall (p : {poly R}) k, (k < size p)%N ->
   (reciprocal_pol p)`_k = p`_((size p) - k.+1).
Proof.
move=> p k Hk.
by rewrite /reciprocal_pol coef_poly Hk.
Qed.
*)
Lemma reciprocal_nth_2 : forall (p : {poly R}) k, (k < size p)%N ->
   (reciprocal_pol p)`_(size p - k.+1) = p`_k.
Proof.
move=> p k Hk.
rewrite /reciprocal_pol coef_poly.
have Hk2 : (size p - k.+1 < size p)%N.
  by rewrite -(ltn_add2r k.+1) subnK // -addSnnS ltn_addr.
rewrite Hk2 !subnS -!subn1 !subnBA; last by rewrite subn_gt0.
  by rewrite addn1 -subnDA addn1 addnC addnK.
by apply: ltnW.
Qed.

Lemma reciprocal_eq (p q : {poly R}) : (p`_0 != 0) -> (q`_0 != 0) ->
   (p == q) = (reciprocal_pol p == reciprocal_pol q).
Proof.
move=> Hp0 Hq0.
apply/idP/idP => Hpq.
  by move/eqP : Hpq => ->.
apply/eqP.
apply: poly_inj.
have Hsize : (size p = size q).
  by rewrite -reciprocal_size // -(@reciprocal_size _ q) // (eqP Hpq).
apply: eq_from_nth => // i Hi.
rewrite -reciprocal_nth_2 // -(@reciprocal_nth_2 q) //.
  by rewrite (eqP Hpq) Hsize.
by rewrite -Hsize.
Grab Existential Variables.
exact: 0.
Qed.

Lemma Mobius0 : forall (p : {poly R}) (a b : R),
   (a != b) ->
   (p == 0) = ((Mobius p a b) == 0).
Proof.
move=> p a b Hab.
apply/idP/idP => Hp; move/eqP : Hp => Hp.
  by rewrite /Mobius Hp /shift_poly /scaleX_poly !comp_polyC
     reciprocalC comp_polyC.
rewrite /Mobius in Hp.
rewrite (shift_poly_eq p 0 a) shift_polyC (@scale_poly_eq _ _  (b - a)).
  by rewrite /scaleX_poly comp_polyC -reciprocal0 (shift_poly_eq _ _ 1)
     shift_polyC Hp.
by rewrite subr_eq0 eq_sym.
Qed.

End about_transformations_and_equality.

Section transformations_in_C.

Variable (R : rcfType).
Local Notation C:= (complex R).

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

Lemma shift_toC (p : {poly R}) (a : R) :
   toC (p \shift a) = (toC p) \shift a%:C.
Proof.
by rewrite /shift_poly (map_comp_poly _ p ('X + a%:P)) rmorphD /=
   map_polyX map_polyC.
Qed.

Lemma scale_toC (p : {poly R}) (a : R) :
   toC (p \scale a) = (toC p) \scale a%:C.
Proof.
by rewrite /scaleX_poly (map_comp_poly _ p ('X * a%:P)) rmorphM /=
   map_polyX map_polyC.
Qed.

Lemma reciprocal_toC (p : {poly R}) :
   toC (@reciprocal_pol _ p) = reciprocal_pol (toC p).
Proof.
rewrite /reciprocal_pol poly_def rmorph_sum /= poly_def size_map_inj_poly.
    apply: eq_bigr => i _.
    rewrite -mul_polyC rmorphM /= map_polyXn /=.
    by rewrite !coef_map /= map_polyC /= mul_polyC.
  by apply: complexI.
by rewrite -complexr0.
Qed.

Lemma Mobius_toC (p : {poly R}) (l r : R) :
   toC (Mobius p l r) = Mobius (toC p) l%:C r%:C.
Proof.
by rewrite {2}/Mobius -shift_toC /= -rmorphB -scale_toC
   -reciprocal_toC -shift_toC /Mobius.
Qed.

(*
Lemma root_Mobius_C_1 :  forall (p : {poly R}) (z : C) (l r : R),
   (l != r) -> (z != l%:C) -> (z != r%:C) ->
      root (toC p) z =
      root (toC (Mobius p l r)) ((r%:C - z) / (z - l%:C)).
Proof.
move=> p z l r Hlr Hzl Hzr.
have HlrC : (l%:C != r%:C).
  by rewrite -!complexr0 eq_complex /= negb_and eq_refl orbF.
rewrite !rootE Mobius_toC /Mobius -!rootE -@root_shift_2
   -(@mulrK _ (z - l%:C) _ 1).
  rewrite mul1r -mulrDl addrA -(@addrA _ _ (-z) z) (@addrC _ (-z) z) addrA
     addrK -root_reciprocal_2.
    rewrite invrM.
        rewrite invrK -root_scale_2 mulrC divrK.
          by rewrite -root_shift_2 -addrA (@addrC _ _ l%:C) addrA addrK.
        by rewrite unitfE subr_eq0 eq_sym.
      by rewrite unitfE subr_eq0 eq_sym.
    by rewrite unitfE invr_eq0 subr_eq0.
  apply: GRing.mulf_neq0.
    by rewrite subr_eq0 eq_sym.
  by rewrite invr_eq0 subr_eq0.
by rewrite unitfE subr_eq0.
Qed.
*)

Lemma root_Mobius_C_2 : forall (p : {poly R}) (z : C) (l r : R),
   (z + 1 != 0) ->
      root (toC p) ((r%:C + l%:C * z) / (z + 1)) =
      root (toC (Mobius p l r)) z.
Proof.
move=> p z l r Hz.
rewrite !rootE Mobius_toC /Mobius -!rootE -root_shift_2 -root_reciprocal_2 //.
rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (z + 1) _ l%:C).
  by rewrite -mulrDl {2}(@addrC _ z 1) mulrDr mulr1 addrA
   -(addrA r%:C (- l%:C) l%:C) (addrC (-l%:C) l%:C) addrA addrK.
by rewrite unitfE.
Qed.

End transformations_in_C.

Lemma mul_polyC_seqmul : forall (R : rcfType) (p : {poly R}) (a : R),
   (a != 0) ->
   polyseq (a *: p) = seqmul (nseq (size p) a) p.
Proof.
move=> R p a Ha.
elim/poly_ind : p => [ | p c IHp].
  by rewrite size_poly0 /= seqmul0 -mul_polyC mulr0 -polyC0 polyseq0.
rewrite -{2}(cons_poly_def) -mul_polyC mulrDr mulrA mul_polyC -polyC_mul.
rewrite -!cons_poly_def !polyseq_cons.
case Hp : (~~ (nilp p)).
  have Hp2 : (~~ (nilp (a *: p))).
    rewrite nil_poly in Hp.
    by rewrite nil_poly -mul_polyC mulf_neq0 // ?Hp // polyC_eq0.
  rewrite Hp2.
  by rewrite seqmul_cons IHp.
have Hp2 : (nilp (a *: p)).
  rewrite nil_poly in Hp.
  rewrite nil_poly -mul_polyC mulf_eq0.
  apply/orP; right.
  by apply: negbFE.
rewrite Hp2 /= size_polyC.
case/altP : (c =P 0) => Hc /=.
  by rewrite Hc mulr0 seqmul0 polyseqC eq_refl.
have Hac : (a * c != 0).
  by apply: mulf_neq0.
by rewrite !polyseqC Hac Hc /= seqmul_cons.
Qed.

Lemma changes_mulC : forall (R : rcfType) (p : {poly R}) (a : R), (a != 0) ->
   changes p = changes (a *: p).
Proof.
move=> R p a Ha.
rewrite mul_polyC_seqmul //=.
case: p => s Hs.
elim: s Hs => [Hs |b l IHl Hs] //=.
case: l IHl Hs => [_ _ |c l IHcl Hs] //=.
  by rewrite !addn0 !mulr0.
rewrite /= in IHcl.
rewrite IHcl //= /seqmul.
apply/eqP.
rewrite eqn_add2r !mulrA (mulrC a) -(mulrA b) -expr2 (mulrC _ (a^+2)) -mulrA
   eq_sym.
apply/eqP.
rewrite (@pmulr_rlt0 _ (a ^+2) (b * c)) //.
by rewrite ltr_def // ?sqrf_eq0 // sqr_ge0 Ha.
Qed.

Section thm_3_cercles_partie1.

Variables (R : rcfType) (l r : R) (Hlr_le : l < r).

Local Notation C := (complex R).

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

Lemma Hlr : l != r.
Proof.
rewrite eq_sym.
apply: (@proj1 (r != l) (l <= r)).
apply/andP.
by rewrite -ltr_def.
Qed.

Lemma HlrC : (l%:C != r%:C).
Proof.
by rewrite -!complexr0 eq_complex /= negb_and Hlr eq_refl.
Qed.

Definition notinC (z : C) :=
   0 <= (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + r * l.

Lemma notinC_Re_lt0_1 : forall (z : C), (z != l%:C) ->
   (notinC z) = (Re ((r%:C - z) / (z - l%:C)) <= 0).
Proof.
case => a b Hab.
rewrite /notinC /=.
simpc.
rewrite !mulrA -(mulNr (b * b) _) -mulrDl
  -expr2 (mulrDl r (-a) _) (mulrC r (a - l)) (mulrC (-a) _) (mulrDl _ _ r)
  (mulrDl _ _ (-a)) mulrNN mulrN -expr2 !addrA (addrC (a * r) _)
  -(addrA _ (a * r) _ ) (addrC (a * r) _ ) (mulrC a r) addrA
  (addrC (- l * r) _ ) -(addrA _ (r * a) (l * a)) -(mulrDl _ _ a)
  -(addrA (- a ^+2) _ _) (addrC (- l * r)) -!addrA (addrC _ (- b^+2))
  !addrA mulNr (mulrC l r) (addrC r l) -oppr_ge0 -[X in (_ = (0 <= X))]mulNr
  !opprD !opprK pmulr_lge0 //.
rewrite invr_gt0 ltr_def addr_ge0 ?sqr_ge0 // andbT paddr_eq0 ?sqr_ge0 //
   negb_and !sqrf_eq0 subr_eq0.
by rewrite -complexr0 eq_complex negb_and /= in Hab.
Qed.

Lemma notinC_Re_lt0_2 : forall (z : C), (z + 1 != 0) ->
   (notinC ((r%:C + l%:C * z) / (z + 1))) = (Re z <= 0).
Proof.
move=> z Hz.
rewrite (@notinC_Re_lt0_1 ((r%:C + l%:C * z) / (z + 1))) /=.
  rewrite -{1}(@mulrK _ (z+1) _ r%:C); last by rewrite unitfE.
  rewrite -(mulNr (r%:C + l%:C * z) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1
     opprD !addrA addrK -{3}(@mulrK _ (z+1) _ l%:C); last by rewrite unitfE.
  rewrite -(mulNr (l%:C * (z+1)) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1
     opprD !addrA addrK invrM.
      rewrite invrK !mulrA -(mulrA _ _ (z+1)) (mulrC _ (z+1)) !mulrA mulrK;
          last by rewrite unitfE.
      rewrite -mulNr -mulrDl (mulrC _ z) mulrK //.
      by rewrite unitfE subr_eq0 eq_sym HlrC.
    by rewrite unitfE subr_eq0 eq_sym HlrC.
  by rewrite -unitrV invrK unitfE.
rewrite -subr_eq0 -{2}(@mulrK _ (z + 1) _ l%:C); last by rewrite unitfE.
rewrite -mulNr -mulrDl mulrDr mulr1 opprD addrA addrK mulf_neq0 //.
  by rewrite subr_eq add0r eq_sym HlrC.
by rewrite invr_eq0.
Qed.

(* Theorem 10.47 i. *)
Theorem three_circles_1 : forall (p : {poly R}),
   (forall (z : C), root (toC p) z -> (notinC z)) ->
   changes (Mobius p l r) = 0%N.
Proof.
move=> p H.
have Hlr := Hlr.
case Hp0 : (p == 0).
  rewrite (Mobius0 p Hlr) in Hp0.
  move/eqP : Hp0 => ->.
  by rewrite polyseq0.
rewrite (@changes_mulC R (Mobius p l r) (lead_coef (Mobius p l r))^-1).
  apply: monic_roots_changes_eq0 => [ | z Hz].
    by rewrite monicE lead_coefZ mulrC -unitrE unitfE lead_coef_eq0
       -Mobius0 // Hp0.
  case/altP : (z+1 =P 0) => [/eqP Hz2 | Hz2].
    rewrite addr_eq0 eq_complex in Hz2.
    move/andP : Hz2; case => /eqP Hrez _.
    by rewrite Hrez raddfN lerN10.
  rewrite map_polyZ rootZ /= -?root_Mobius_C_2 // in Hz.
    rewrite -notinC_Re_lt0_2 //.
    apply: H => //.
  rewrite -complexr0 eq_complex /= negb_and eq_refl orbF.
  by rewrite invr_eq0 lead_coef_eq0 -Mobius0 // negbT.
by rewrite invr_eq0 lead_coef_eq0 -Mobius0 // negbT.
Qed.

End thm_3_cercles_partie1.

Section thm_3_cercles_partie2.

Variable (R : rcfType).

Local Notation C := (complex R).

Definition inC1 := fun (l r : R) (z : C) =>
   (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 -
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0.

Definition inC2 := fun (l r : R) (z : C) =>
   (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 +
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0.

Definition inC12 := fun (l r : R) (z : C) =>
   ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 -
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0) ||
   ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 +
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0).

Lemma inC1_or_inC2 : forall (l r : R) (z : C),
   (inC1 l r z) || (inC2 l r z) = (inC12 l r z).
Proof. by done. Qed.

Definition inB1 := fun (z : C) =>
   ((Re z) - 1 <= 0) && ((Im z)^+2 <= 3%:R * ((Re z) - 1) ^+2).

Lemma inB_inB1 : forall (z : C), (inB z) = (inB1 (z + 1)).
Proof.
case => a b.
by rewrite /inB1 /= addrK addr0 /inB.
Qed.

Lemma inB1_help : forall (z : C), (inB1 z) =
   (((Num.sqrt 3%:R) * ((Re z) - 1) - Im(z) <= 0) &&
     (0 <= - (Num.sqrt 3%:R * ((Re z) - 1)) - Im(z))).
Proof.
case=> a b.
rewrite /inB1 /=.
case/altP : (a - 1 =P 0) => Ha.
  rewrite Ha /= mulr0 oppr0 add0r lerr Bool.andb_true_l (expr2 0) !mulr0.
  by rewrite -eqr_le oppr_eq0 -sqrf_eq0 eqr_le sqr_ge0 andbT.
rewrite -{1}(sqr_sqrtr (a:=3%:R)); last by apply: ler0n.
rewrite -(ComplexField.exprM _ (a-1)) -(ler_sqrt (b^+2)).
  rewrite !sqrtr_sqr normrM (ger0_norm (x := Num.sqrt 3%:R));
    last by apply: sqrtr_ge0.
  apply/idP/idP => /andP [] => H1 H2.
    rewrite -(normrN (a-1)) (gtr0_norm (x:= - (a - 1))) in H2.
      by rewrite ler_norml mulrN opprK -subr_le0
         -[X in (_ && X)]subr_ge0 in H2.
    by rewrite oppr_gt0 ltr_def H1 eq_sym Ha.
  have Hb : `|b| <= Num.sqrt 3%:R * -(a - 1).
    by rewrite ler_norml mulrN opprK -subr_le0 -[X in (_ && X)]subr_ge0 H1 H2.
  have Ha2 : (0 <= - (a - 1)).
    rewrite -(pmulr_lge0 (x:=Num.sqrt 3%:R)); last by rewrite sqrtr_gt0 ltr0n.
    by rewrite mulrC (ler_trans (y:=`|b|)).
  by rewrite -oppr_ge0 Ha2 /= -(normrN (a-1)) (ger0_norm (x:= -(a-1))).
rewrite ComplexField.exprM mulr_gt0 // ltr_def sqr_ge0.
  by rewrite sqrf_eq0 sqrtr_eq0 -ltrNge ltr0n.
by rewrite sqrf_eq0 Ha.
Qed.

Lemma Re_invc : forall (z : C), Re z^-1 = Re z / ((Re z) ^+ 2 + (Im z) ^+2).
Proof. by case. Qed.

Lemma Im_invc : forall (z : C), Im z^-1 = (- Im z) / ((Re z) ^+ 2 + (Im z) ^+2).
Proof. case => a b. by rewrite mulNr. Qed.

Lemma inB1_notinC1201 : forall (z : C), (z != 0) ->
   (inB1 z) = ~~(inC12 0 1 (z ^-1)).
Proof.
case=> a b Hz.
rewrite -inC1_or_inC2 negb_or inB1_help /=.
have H : a ^+ 2 + b ^+ 2 \is a GRing.unit.
  rewrite eq_complex /= negb_and in Hz.
  case/orP: Hz=> H;
    by rewrite unitfE paddr_eq0 ?sqr_ge0 // negb_and !sqrf_eq0 H ?orbT.
have H3 : (Num.ExtraDef.sqrtr (GRing.natmul (V:=R) (GRing.one R) (3)))
          \is a GRing.unit.
  by rewrite unitfE sqrtr_eq0 -ltrNge ltr0n.
rewrite /inC1 /= -lerNgt add0r oppr0 mul0r !addr0 !mul1r.
rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA
   ComplexField.exprM -(mulNr b) ComplexField.exprM sqrrN -mulrDl
   (expr2 ((a^+2 + b^+2)^-1)) -{2}(mulr1 (a^+2 + b^+2)) -invrM //
   -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) //
   -[in x in _ = x]mulNr -mulrDl -{5}(opprK 1) -(opprD a (- 1)) -mulrA -invrM //.
rewrite -[in x in _ = x]mulNr -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2)))
   -{5}(@mulrK _ (Num.sqrt 3%:R) _ 1) //.
rewrite mul1r mulf_div -mulrDl mulrN -[in x in (_ = x)]opprD.
rewrite /inC2 /= -lerNgt add0r oppr0 mul0r !addr0 !mul1r.
rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA
   ComplexField.exprM -(mulNr b) ComplexField.exprM sqrrN -mulrDl
   (expr2 ((a^+2 + b^+2)^-1)) -{3}(mulr1 (a^+2 + b^+2)) -invrM //
   -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) //
   -[in x in (_ = _ && x)]mulNr -mulrDl -{8}(opprK 1) -(opprD a (- 1)) -mulrA
   -invrM //.
rewrite -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2)))
    -{8}(@mulrK _ (Num.sqrt 3%:R) _ 1) //.
rewrite mul1r mulf_div -mulrDl mulNr oppr_ge0 pmulr_lge0.
  rewrite pmulr_lle0 ?mulrN //.
  by rewrite invr_gt0 ltr_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 //
     addr_ge0 // sqr_ge0.
by rewrite invr_gt0 ltr_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 //
     addr_ge0 // sqr_ge0.
Qed.

Lemma notinC1201_lr_scale (l r : R) : forall (z : C), (l != r) ->
   ~~(inC12 0 1 z) = ~~(inC12 0 (r - l) ((r - l)%:C * z)).
Proof.
case=> a b Hlr.
rewrite !/inC12. simpc. rewrite /=.
rewrite !ComplexField.exprM !(mulrA (r - l) _ a) !(mulrA (r - l) _ b)
   -expr2 -(mulrN _ a) -mulrA -(mulrN _ (b / Num.sqrt 3%:R))
    -!(mulrDr ((r - l)^+2)) !negb_or -!lerNgt.
by rewrite !pmulr_rge0 // ltr_def sqr_ge0 sqrf_eq0 subr_eq0 eq_sym Hlr.
Qed.

Lemma notinC12lr_shift (l r : R) : forall (z : C), (l != r) ->
   ~~(inC12 0 (r - l) z) = ~~(inC12 l r (z + l%:C)).
Proof.
case=> a b Hlr.
rewrite !/inC12. simpc. rewrite /= !negb_or -!lerNgt.
by rewrite (expr2 (a+l)) (mulrDl a l) !mulrDr (mulrDl l r)
   (mulrDl l  r) -!expr2 !opprD
   [l * a + _]addrC !addrA addrK -(addrA _ (- (r * a)) _)
   (addrC (- (r * a)) _) !addrA addrK -(addrA _ (a * l) _)
   (addrC (a * l)) (mulrC a l) -{5 9}(opprK l) mulNr -opprD
   -mulrDl [X in (_ = (0 <= X) && _)]addrC [X in (_ = _ && (0 <= X))]addrC
   !addrA (addrC (l * r)) -(addrA _ (l * r) _)
   (addrC (l * r)) (mulrC l r) !addrA addrK.
Qed.

Lemma inB_notinC12 : forall (l r : R) (z : C), (l != r) -> (z + 1 != 0) ->
   (inB z) = ~~(inC12 l r ((r%:C + l%:C * z) / (z + 1))).
Proof.
move=> l r z Hlr Hz.
have H : ((r%:C + l%:C * z) / (z + 1) = ((r - l)%:C / (z + 1) + l%:C)).
  rewrite -{2}[l%:C](@mulrK _ (z + 1)); last by rewrite unitfE.
  by rewrite -mulrDl {2}[z+1]addrC mulrDr mulr1 rmorphB /= !addrA addrNK.
by rewrite H -notinC12lr_shift // -notinC1201_lr_scale //
   -inB1_notinC1201 // -inB_inB1.
Qed.

Lemma changes_nseq : forall (s : seq R) (a : R), (a != 0) ->
   changes (seqmul (nseq (size s) a) s) = changes s.
elim => [ | c l IHl a Ha] //.
case : l IHl => [IH |b l IHbl ] //.
  by rewrite /= !mulr0 addn0.
have Helpme : ((changes [::c, b & l]) = ((c * b < 0)%R + changes [:: b & l])%N).
  by done.
rewrite Helpme -(IHbl a) //.
have Helpme2 : (((a * c) * (a * b) < 0) == (c * b < 0)).
  rewrite (mulrC a b) -mulrA (mulrC a) -!mulrA -expr2 mulrA.
  by rewrite pmulr_llt0 // ltr_def sqrf_eq0 Ha sqr_ge0.
by move/eqP : Helpme2 => <-.
Qed.

Lemma seqn0_nseq : forall (s : seq R) (a : R), (a != 0) ->
   seqmul (nseq (size (seqn0 s)) a) (seqn0 s) =
   seqn0 (seqmul (nseq (size s) a) s).
Proof.
elim => [ | c l IHl a Ha] //.
case Hc : (c != 0).
  have Hac : (a * c != 0).
    by apply: mulf_neq0.
  by rewrite seqmul_cons /= Hac /= Hc /= seqmul_cons /= -IHl.
have Hac : ((a * c != 0) = false).
  by rewrite mulf_eq0 negb_or Ha Hc.
by rewrite seqmul_cons /= Hc /= Hac /= IHl.
Qed.

Lemma inBneg1 : (@inB R (-1)).
Proof.
by rewrite /inB !raddfN lerN10 /= oppr0 sqrrN !expr2 mulr0 !mulr1 ler0n.
Qed.

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

(* (~~ root p r) because of (~~ root (Mobius p l r) 0) *)
Theorem three_circles_2 : forall  (l r : R) (p : {poly R})
   (a : R), (~~ root p r) -> (l < a < r) -> (~~ root p a) ->
   (forall z : C, root (toC p) z -> ~~ (inC12 l r z) ) ->
   (changes (seqn0 (Mobius (p * ('X - a%:P)) l r)) = 1%N).
Proof.
move=> l r p a Hpnorootr /andP [] Hal Har Hpnoroota H.
have Hlr : l != r.
  by rewrite negbT // ltr_eqF // (@ltr_trans _ a)//;
  move/andP : Hlar; case.
have Hal2 : l != a.
  by rewrite negbT // ltr_eqF.
case Hp : (p == 0).
  have : false => //.
    by rewrite -(andbN (root p a)) Hpnoroota (eqP Hp) root0.
move/eqP/eqP : Hp => Hp.
have Hlc1 : (lead_coef (Mobius (R:=R) (p * ('X - a%:P)) l r))^-1 != 0.
  rewrite invr_neq0 // MobiusM lead_coefM mulf_neq0 //;
  rewrite lead_coef_eq0 -Mobius0 // negbT //.
  by apply: polyXsubC_eq0.
have Hlc2 : (lead_coef (Mobius p l r) != 0).
  by rewrite lead_coef_eq0 -Mobius0.
rewrite -(@changes_nseq _
   (lead_coef (Mobius (p * ('X - a%:P)) l r)) ^-1) //
    seqn0_nseq // -mul_polyC_seqmul //.
rewrite MobiusM lead_coefM -mul_polyC invrM ?unitfE; [ | done |].
  rewrite rmorphM /= mulrA mulrC !mulrA
       (mulrC (Mobius ('X - a%:P) _ _) _)
       mul_polyC -mulrA mul_polyC mulrC
       [in X in (changes (R:=R) (seqn0 (polyseq (_ * X))))]
       (@Mobius_Xsubc_monic R a l r Hlr Hal2)
       -(opprK ((r - a) / (l - a))%:P) -polyC_opp.
    apply: normal_changes.
      by rewrite oppr_gt0 pmulr_rlt0 ?invr_lt0 ?subr_lt0 // subr_gt0.
    apply: normal_root_inB => [ | z Hz].
      rewrite monicE lead_coef_lreg.
        by rewrite mulrC -unitrE unitfE.
      apply/lregP; by apply: invr_neq0.
    case/altP : (z+1 =P 0) => [/eqP Hz2 | Hz2].
      rewrite addr_eq0 in Hz2.
      by rewrite (eqP Hz2) inBneg1.
    rewrite (inB_notinC12 Hlr) //.
    rewrite -mul_polyC rmorphM /= map_polyC mul_polyC rootZ in Hz.
    apply: H.
      by rewrite root_Mobius_C_2.
    rewrite /= eq_complex negb_and.
    apply/orP; left. by apply: invr_neq0.
  rewrite rootZ.
    rewrite -root_Mobius_2; last by rewrite add0r oner_neq0.
    by rewrite mulr0 addr0 add0r invr1 mulr1.
  by apply: invr_neq0.
by rewrite lead_coef_eq0 -Mobius0 // negbT // polyXsubC_eq0.
Qed.

End thm_3_cercles_partie2.


Require
  MathClasses.categories.varieties.
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms.

Definition op := False.

Definition sig: Signature := Build_Signature unit op (False_rect _).

Definition Laws: EqEntailment sig → Prop := λ _, False.

Definition theory: EquationalTheory := Build_EquationalTheory sig Laws.

(* Constructing an object in the variety from an instance of the class: *)

Section from_instance.
  Context A `{Setoid A}.

  Notation carriers := (λ _, A).

  Instance: AlgebraOps sig carriers := λ o, False_rect _ o.

  Instance: Algebra sig carriers.
  Proof. constructor; intuition. Qed.

  Instance: InVariety theory carriers.
  Proof. constructor; intuition. Qed.

  Definition object: varieties.Object theory := varieties.object theory (λ _, A).

End from_instance.

(* Constructing an instance of the class from an object in the variety: *)

Section from_variety.

  Context `{InVariety theory A}.

  Instance: Setoid (A tt) := {}.

End from_variety.

Lemma mor_from_sr_to_alg `{InVariety theory A} `{InVariety theory B}
  (f: ∀ u, A u → B u) `{!Setoid_Morphism (f tt)}: HomoMorphism sig A B f.
Proof with try apply _.
 constructor.
    intros []...
   intros [].
  change (Algebra theory A)...
 change (Algebra theory B)...
Qed.

#[global]
Instance decode_variety_and_ops `{InVariety theory A}: Setoid (A tt) := {}.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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

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

Print Assumptions add.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Class PropositionalVariables: Type := {
  Var: Type
}.

Inductive expr {Sigma: PropositionalVariables}: Type :=
  | andp : expr -> expr -> expr
  | orp : expr -> expr -> expr
  | impp : expr -> expr -> expr
  | falsep : expr
  | varp : Var -> expr.

Arguments expr Sigma: clear implicits.

Instance L {Sigma: PropositionalVariables}: Language :=
  Build_Language (expr Sigma).

Instance minL {Sigma: PropositionalVariables}: MinimumLanguage L :=
  Build_MinimumLanguage L impp.

Instance pL {Sigma: PropositionalVariables}: PropositionalLanguage L :=
  Build_PropositionalLanguage L andp orp falsep.

Definition rank {Sigma: PropositionalVariables}: expr Sigma -> nat :=
  fix rank (x: expr Sigma): nat :=
    match x with
    | andp y z => 1 + rank y + rank z
    | orp y z => 1 + rank y + rank z
    | impp y z => 1 + rank y + rank z
    | falsep => 0
    | varp p => 0
    end.

Definition formula_countable: forall {Sigma}, Countable Var -> Countable (expr Sigma).
  intros.
  assert (forall n, Countable (sig (fun x: expr Sigma => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ (Var + unit)%type); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun x =>
               match x with
               | inl p => exist (fun x: expr Sigma => rank x <= 0) (varp p) (le_n 0)
               | inr _ => exist (fun x: expr Sigma => rank x <= 0) falsep (le_n 0)
               end)).
      * hnf; intros.
        destruct a1 as [? | []], a2 as [? | []]; inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        1: exists (inr tt); eauto; f_equal; apply proof_irrelevance.
        1: exists (inl v); eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Sigma => rank x <= n)).
      apply (@injection_Countable _ (s * s + s * s + s * s + unit + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (inl (inl (inl (exist _ y _, exist _ z _)))) => proj1_sig x = andp y z
        | inl (inl (inl (inr (exist _ y _, exist _ z _)))) => proj1_sig x = orp y z
        | inl (inl (inr (exist _ y _, exist _ z _))) => proj1_sig x = impp y z
        | inl (inr _) => proj1_sig x = falsep
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | y z | y z | | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (exist _ y H0, exist _ z H1))))); auto.
        (* 2 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inr (exist _ y H0, exist _ z H1))))); auto.
        (* 3 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inr (exist _ y H0, exist _ z H1)))); auto.
        (* 4 *) exists (inl (inr tt)); auto.
        (* 5 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | y z | y z | | p] ?H];
        destruct b1 as [[[[[[y1 ?H] [z1 ?H]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] |] | p1]; try solve [inversion H];
        destruct b2 as [[[[[[y2 ?H] [z2 ?H]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] |] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) destruct u, u0; auto.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[[[[y ?H] [z ?H]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] |] | p];
        destruct a1 as [[y1 z1 | y1 z1 | y1 z1 | | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | y2 z2 | y2 z2 | | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) f_equal; apply proof_irrelevance.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Sigma => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed. (* 20 seconds *)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import bigops ssralg poly polydiv orderedalg zmodp polydiv.

Reserved Notation "a ^`"(at level 3, format "a ^`").
(* Reserved Notation "a ^`( n )" (at level 3, format "a ^`( n )"). *)
(* Reserved Notation "a ^`N( n )" (at level 3, format "a ^`N( n )"). *)

Import GRing.Theory.
Import OrderedRing.Theory.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope ring_scope.

Section ExtraRelative.

Variable R : oFieldType.

Implicit Types a b c : R.
Implicit Types x y z t : R.

Import GRing.Theory.
Import OrderedRing.Theory.

End ExtraRelative.

Section PolyOrder.

Variable F : oFieldType.

Implicit Types a b c : F.
Implicit Types x y z t : F.
Implicit Types p q r : {poly F}.

Notation "a ^`( n )" := (derivn a n).
Notation "a ^`" := (deriv a).

End PolyOrder.

Section PolyReal.

Variable R : oFieldType.

Implicit Types a b c : R.
Implicit Types x y z t : R.
Implicit Types p q r : {poly R}.

Hypothesis ivt : poly_ivt R.

Lemma polyrealN0_sign : forall p a b,
  (forall x, a <= x <= b -> ~~ root p x) ->
  exists s, (forall x, a <= x <= b -> \s (p.[x]) = s).
Proof.
rewrite /root=> p a b np0; exists (\s p.[a]); move=> x laxb; move:(np0 _ laxb).
case: (ltrgtP p.[x] 0)=> [spx npx0|spx npx0|]; last by move->; rewrite eqxx.
  case: (ltrP p.[a] 0)=> spa; first by rewrite !ltr0_sign.
  case/andP:laxb=>lax lxb; case:(@ivt (-p) a x)=> //.
    by rewrite !horner_opp !oppr_cp0 spa ltrE.
  move=> y; case/andP=> lay lyx; rewrite /root horner_opp oppr_eq0.
  by rewrite (negPf (np0 _ _))// lay/= (ler_trans lyx).
case: (lerP p.[a] 0)=> spa; last by rewrite !gtr0_sign.
case/andP:laxb=>lax lxb; case:(@ivt p a x)=> //; first by rewrite spa ltrE.
move=> y; case/andP=> lay lyx; rewrite /root.
by rewrite (negPf (np0 _ _))// lay/= (ler_trans lyx).
Qed.

Lemma divpf_spec : forall p q,
  p = (((scalp p q)^-1)%:P * (p %/ q)) * q + ((scalp p q)^-1)%:P * (p %% q).
Proof.
move=> p q; apply/eqP.
rewrite -(inj_eq (@mulfI _ (scalp p q)%:P  _)); last first.
  by rewrite polyC_eq0 scalp_id.
rewrite mulr_addr !mulrA -!polyC_mul divff ?scalp_id// polyC1 !mul1r.
by rewrite divp_spec.
Qed.

Lemma maxdivpf : forall p a, p != 0 ->
  exists q : {poly R},
    exists2 n,  (q.[a] != 0) & (p = q * ('X - a%:P)^+n).
Proof.
move=> p; move: {-2}p (erefl (size p)); elim: (size p)=> {p} [p sp|n ihn p sp].
  by move=> a; move/eqP: sp; rewrite size_poly_eq0; move/eqP->; rewrite eqxx.
move=> a p0.
case pa0: (root p a); first last.
  by exists p; exists 0%N; rewrite /root in pa0; rewrite ?pa0// expr0 mulr1.
move: pa0; rewrite root_factor_theorem.
move/dvdpPc=> [c] [q] [c0]; move/eqP.
rewrite -(inj_eq (@mulfI _ c^-1%:P  _)); last by rewrite polyC_eq0 invr_eq0.
rewrite mulrA -polyC_mul [_^-1*_]mulrC divff// polyC1 mul1r mulrA=> hp.
case q0 : (q == 0); first by move: hp p0; rewrite (eqP q0) mulr0 mul0r=> ->.
move:sp; rewrite (eqP hp) size_mul_id; last 2 first.
- by rewrite mulf_neq0// ?polyC_eq0 ?invr_eq0 ?c0// q0.
- by rewrite -size_poly_eq0 size_XMa.
rewrite size_XMa size_mul_id ?polyC_eq0 ?invr_eq0 ?c0// ?q0//.
rewrite size_polyC invr_eq0 c0 add1n addnS addn1 //=.
move/eqP; rewrite eqSS; move/eqP; move/ihn=> ihnq.
case: (ihnq a)=> [|r [m ra0 Pq]]; first by rewrite q0.
exists ((c^-1)%:P * r); exists m.+1.
  by rewrite horner_lin mulf_neq0 // invr_eq0.
by rewrite Pq -!mulrA -exprSr.
Qed.

Lemma divpf_eq0 : forall p q, q != 0 -> (p %/ q == 0) = (size p < size q)%N.
Proof.
move=> p q q0; apply/idP/idP=> hpq; last by rewrite divp_size.
case p0: (p == 0); first by rewrite (eqP p0) size_poly0 lt0n size_poly_eq0.
case: (divp_spec p q); rewrite (eqP hpq) mul0r add0r=> hpmpq.
apply: leq_ltn_trans (modp_spec p _); rewrite // -hpmpq size_mul_id ?p0//.
   by rewrite size_polyC scalp_id //=.
by rewrite polyC_eq0 scalp_id.
Qed.

Lemma poly_divXMa : forall (a:R) (P : {poly R} -> Prop),
  (forall k, P k%:P) ->
  (forall p n k, p.[a] != 0 -> P p ->
    P (p * ('X - a%:P)^+(n.+1) + k%:P)%R)
  -> forall p, P p.
Proof.
move=> a P Pk Pq p.
move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn.
  move: spn; rewrite leqn0 size_poly_eq0; move/eqP->; rewrite -polyC0.
  exact: Pk.
case: (leqP (size p) 1)=> sp1; first by rewrite [p]size1_polyC ?sp1//.
case: (@divpf_spec p ('X - a%:P))=> ->.
set q := (_%:P * _); set c := (_%:P * _).
rewrite [c]size1_polyC; first last.
  rewrite (leq_trans (size_mul _ _))// size_polyC invr_eq0 scalp_id.
  rewrite addnC addn1 /= -ltnS (leq_trans (modp_spec _ _)) // ?size_XMa//.
  by rewrite -size_poly_eq0 size_XMa.
case: (@maxdivpf q a (mulf_neq0 _ _)).
- by rewrite polyC_eq0 invr_eq0 scalp_id.
- by rewrite divpf_eq0 -?size_poly_eq0 size_XMa// -leqNgt sp1.
move=> r [m ra0 hqr]; rewrite hqr -mulrA -exprSr.
apply: Pq=> //; apply: ihn.
rewrite (leq_trans (_ : size r <= size q)%N)//.
  have xam : ('X - a%:P) ^+ m != 0.
    elim:m {hqr}=>[|m ihm]; rewrite ?expr0 ?oner_eq0//.
    by rewrite exprS mulf_neq0// -size_poly_eq0 size_XMa.
  rewrite hqr size_mul_id //; last first.
    by move: ra0; apply: contra; move/eqP->; rewrite horner0.
  rewrite -[size (('X-_)^+_)]prednK; last by rewrite lt0n size_poly_eq0.
  by rewrite addnC leq_addl.
rewrite (leq_trans (size_mul _ _))// size_polyC invr_eq0 scalp_id //=.
by rewrite size_divp -?size_poly_eq0 size_XMa//= subn1 -ltnS (ltn_predK sp1).
Qed.

Lemma nth_root : forall x n, x > 0 -> exists2 y, y>0 & y^+(n.+1) = x.
Proof.
move=> x n l0x.
case: (ltrgtP x 1)=> hx; last by exists 1; rewrite ?hx ?ltr01// exp1rn.
  case: (@ivt ('X ^+ n.+1 - x%:P) 0 1); first by rewrite ler01.
    rewrite ?(horner_lin,horner_exp).
    by rewrite exprS mul0r sub0r exp1rn oppr_cp0 subr_ge0 ltrE// ltrE.
  move=> y; case/andP=> [l0y ly1]; rewrite /root ?(horner_lin,horner_exp).
  rewrite subr_eq0; move/eqP=> hyx; exists y=> //; rewrite ltr_neqAle l0y.
  rewrite eq_sym andbT; apply/eqP=> y0; move: hyx; rewrite y0.
  by rewrite exprS mul0r=> x0; move: l0x; rewrite -x0 lerr.
case: (@ivt ('X ^+ n.+1 - x%:P) 0 x); first by rewrite ltrE.
  rewrite ?(horner_lin,horner_exp) exprS mul0r sub0r.
  by rewrite oppr_cp0 subr_ge0 ltrE//= lef_exprS// ltrE.
move=> y; case/andP=> l0y lyx; rewrite /root ?(horner_lin,horner_exp).
rewrite subr_eq0; move/eqP=> hyx; exists y=> //; rewrite ltr_neqAle l0y.
rewrite eq_sym andbT; apply/eqP=> y0; move: hyx; rewrite y0.
by rewrite exprS mul0r=> x0; move: l0x; rewrite -x0 lerr.
Qed.

Lemma poly_cont : forall x p e, e > 0 -> exists2 d,
  d > 0 & forall y, |y - x| < d -> |p.[y] - p.[x]| < e.
Proof.
move=> x; elim/(@poly_divXMa x).
  move=> e ep; exists 1; rewrite ?ltr01// => y hy.
  by rewrite !hornerC subrr absr0.
move=> p n k pxn0 Pp e ep.
case: (Pp (|p.[x]|/2%:R)).
  by rewrite mulf_cp0p// -?invf_le0 ?gtf0Sn// absrE.
move=> d' d'p He'.
case: (@nth_root (e / ((3%:R/2%:R)*|p.[x]|)) n).
  by rewrite mulf_cp0p// -invf_le0 ?mulf_cp0p// -?invf_le0 ?gtf0Sn// absrE.
move=> d dp rootd.
exists (minr d d'); first by rewrite ltr_minr dp.
move=> y. rewrite ltr_minr. case/andP=> hxye hxye'.
move: (ler_lt_trans (subr_abs_le _ _) (He' _ hxye')).
rewrite ler_subr absr_opp.
rewrite (_:forall x, x / 2%:R + x = (3%:R / 2%:R)*x); last first.
  move=> a; apply/eqP; rewrite -(inj_eq (@mulfI _ 2%:R _))// ?charor//.
  rewrite mulr_addr mulrA mulrAC divff ?charor// -mulr_addl -{1}[1]mulr1n.
  by rewrite -natr_add add1n !mulrA [2%:R*_*_]mulrAC divff ?charor// mul1r.
move=> hpypx.
have:= (He' _ hxye'); rewrite addrC.
move/(ler_lt_trans (subr_abs_le _ _)).
rewrite absr_opp -subr_ge0 addrAC subr_ge0.
rewrite (_:forall x, x - x / 2%:R = x / 2%:R); last first.
  move=> a; apply/eqP.
  rewrite -(inj_eq (@mulfI _ 2%:R _))// ?charor//.
  rewrite mulr_addr mulrN mulrA mulrAC divff ?charor//.
  rewrite mulr_natl mul1r -subr_eq0 -addrA -oppr_add -{2}[a]mulr1n.
  by rewrite -mulrSr subrr.
move=> hpxpy.
rewrite !(horner_lin,horner_exp). rewrite subrr [0^+_]exprS mul0r mulr0 add0r.
rewrite -addrA subrr addr0 !absf_mul mulrC.
move: hxye; rewrite absf_exp (lef_expS2 n)// ?absrE//; last by rewrite ltrE.
rewrite -(@ltf_mulpr _ (|p.[y]|)); last first.
  apply: ler_lt_trans hpxpy; rewrite mulr_cp0p// ?absrE//.
  by rewrite -invf_ge0 ltrE// gtf0Sn.
move/ltr_trans=> -> //; rewrite rootd mulrC mulrA mulrAC -{1}[e]mul1r.
rewrite ltf_mulp// lef_divpr; first by rewrite mul1r.
by rewrite !mulf_cp0p// -?invf_le0 ?lt0fSn// ?absrE// gtf0Sn.
Qed.

Notation "a ^`( n )" := (derivn a n).
Notation "a ^`" := (deriv a).

Lemma derivPn : forall n p, (p ^+ n.+1)^` = (p^+n) * (p^`) *+ n.+1.
Proof.
elim=> [|n ihn] p; first by rewrite expr1 expr0 mul1r mulr1n.
by rewrite exprS deriv_mul ihn !mulrnAr mulrA -exprS mulrC -mulrS.
Qed.

Lemma deriv_opp: forall p, (-p)^` = -(p^`).
Proof.
move=> p; rewrite -mulN1r deriv_mul mulN1r.
by rewrite [-1]size1_polyC ?size_opp ?size_poly1// derivC mul0r add0r.
Qed.

Definition derivE :=  (derivC,derivX,deriv_amulX,deriv_mul,deriv_add,
  deriv_mulr,deriv_opp,derivXn,derivPn).

(* Lemma size_poly_ind : forall K : {poly R} -> Prop, *)
(*   K 0 ->  *)
(*   (forall p sp, size p = sp.+1 ->   *)
(*     forall q, (size q <= sp)%N -> K q -> K p) *)
(*   -> forall p, K p. *)
(* Proof. *)
(* move=> K K0 ihK p. *)
(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *)
(*   by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *)
(* case spSn: (size p == n.+1). *)
(*   move/eqP:spSn; move/ihK=> ihKp; apply: (ihKp 0)=>//. *)
(*   by rewrite size_poly0. *)
(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn.  *)
(* Qed. *)

(* Lemma size_poly_indW : forall K : {poly R} -> Prop, *)
(*   K 0 ->  *)
(*   (forall p sp, size p = sp.+1 ->   *)
(*     forall q, size q = sp -> K q -> K p) *)
(*   -> forall p, K p. *)
(* Proof. *)
(* move=> K K0 ihK p. *)
(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *)
(*   by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *)
(* case spSn: (size p == n.+1). *)
(*   move/eqP:spSn; move/ihK=> ihKp; case: n ihn spn ihKp=> [|n] ihn spn ihKp. *)
(*     by apply: (ihKp 0)=>//; rewrite size_poly0. *)
(*   apply: (ihKp 'X^n)=>//; first by rewrite size_polyXn. *)
(*   by apply: ihn; rewrite size_polyXn. *)
(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn.  *)
(* Qed. *)

Definition has_lt_roots_in p n a b :=
  forall (t : seq R), size t == n -> uniq t ->
    (forall x, x \in t -> (a < x < b) && (p.[x] == 0))
    -> p == 0.

Lemma poly_ltsp_roots : forall p a b, has_lt_roots_in p (size p) a b.
Proof.
rewrite /has_lt_roots_in.
move=> p; move: {-2}p (erefl (size p)); elim: (size p)=> {p} [|n ihn] p spSn.
  by move/eqP: spSn; rewrite size_poly_eq0; move/eqP->.
move=> a b t; rewrite spSn=> st /=.
case: t st=> // x s /=.
rewrite eqSS => ss /=; case/andP=> xins us hs.
move: (hs x); rewrite inE eqxx /= => hx.
case/andP: (hx is_true_true)=> haxb hpx.
case: (ltngtP (size p) 1)=> p1; first 2 last.
- by rewrite [p]size1_polyC ?p1// hornerC -polyC_eq0 -size1_polyC// p1 in hpx.
- by move: p1; rewrite ltnS leqn0 size_poly_eq0.
case: (divpf_spec p ('X - x%:P)).
move: (hpx); rewrite [_==_]root_factor_theorem=> dvdxp.
move: (dvdxp); rewrite /dvdp; move/eqP ->.
rewrite mulr0 addr0; set q : {poly R} := _*(_ %/ _)=> hpq.
rewrite hpq mulf_eq0 -[_-_==_]size_poly_eq0 size_XMa orbF.
have sqn : size q = n.
  rewrite size_mul_id.
  - rewrite size_polyC invr_eq0 scalp_id /=.
    by rewrite size_divp -?size_poly_eq0 size_XMa//= spSn subn1.
  - by rewrite -size_poly_eq0 size_polyC invr_eq0 scalp_id.
  - by rewrite divpf_eq0  -?size_poly_eq0 size_XMa//= -leqNgt.
apply: (ihn _ _ a b s)=> //; first by rewrite sqn.
move=> y yins.
case exy: (y == x); first by move: xins; rewrite -(eqP exy) yins.
have := (hs y); rewrite inE exy /= yins hpq.
rewrite horner_mul horner_add horner_opp hornerX hornerC mulf_eq0.
by rewrite subr_eq0 exy orbF=> hq; apply: hq.
Qed.

Lemma ivt_sign : forall (p : {poly R}) (a b : R),
  a <= b -> \s p.[a] * \s p.[b] == -1 -> exists2 x : R, a < x < b & root p x.
Proof.
move=> p a b hab.
rewrite muls_eqA// mulrN1; case/andP; move/eqP=> hpapb pb0.
case: (@ivt (((\s p.[b]) ?* 1)%:P *p) a b)=> //.
   rewrite -{1}hpapb !horner_lin -!smulr_mul !mul1r -smulNr.
   by rewrite -!absrP oppr_cp0 !absrE.
move=> c; case/andP=> lac lcb; rewrite /root.
rewrite !horner_lin mulf_eq0 smul1_eq0 (negPf pb0) /= => pc0.
exists c=> //. rewrite !ltr_neqAle lac lcb !andbT.
apply/andP; split.
  move: pb0; rewrite -hpapb -eqr_oppC oppr0; apply: contra.
  by move/eqP->; rewrite (eqP pc0) signr0.
by move: pb0; apply: contra; move/eqP<-; rewrite (eqP pc0) signr0.
Qed.

Lemma rolle_weak : forall a b p, a < b ->
  (p.[a] == 0) && (p.[b] == 0) ->
  exists2 c, a < c < b & (p^`.[c] == 0 \/ p.[c] == 0).
Proof.
move=> a b p lab; case/andP=> pa0 pb0.
case p0: (p == 0).
  rewrite (eqP p0); exists ((a+b)/2%:R); first exact: midf_lt.
  by left; rewrite derivC horner0 eqxx.
case: (@maxdivpf p a)=> [|p' []]; first by rewrite p0.
case; first by rewrite expr0 mulr1=> p'a0 pp'; rewrite -pp' pa0 in p'a0.
move=> n p'a0 hpp'.
case: (@maxdivpf p' b)=> [|q []].
  by move:p'a0; apply: contra; move/eqP->; rewrite hornerC.
case; first rewrite expr0 mulr1=> qb0 p'q.
  move: (pb0); rewrite hpp' p'q ?(horner_lin,horner_exp) mulf_eq0.
  by rewrite orbC expf_eq0 subr_eq0 eq_sym ltrWN// andbF orFb (negPf qb0).
move=> m qb0 hp'q; rewrite hpp' hp'q.
case: (inF3P (\s q.[a] * \s q.[b])); first 2 last.
- move/eqP=> sqasb; case: (@ivt_sign q a b)=> //; first exact: ltrW.
  move=> c lacb rqc; exists c=> //; right.
  by rewrite !(horner_lin,horner_exp) (eqP rqc) !mul0r.
- move/eqP; rewrite mulf_eq0 !signr_cp0 (negPf qb0) orbF; move/eqP=> qa0.
  by move: p'a0; rewrite hp'q ?(horner_lin,horner_exp) qa0 mul0r eqxx.
- move/eqP; rewrite muls_eqA// mulr1; case/andP; move/eqP=> sab sbn0.
  rewrite !derivE subr0 !mulr1 mulr_addl !exprS.
  set xan := (_^+n); set xbm := (_^+m).
  rewrite !mulrnAr !mulrA ![_*xbm]mulrC -!mulrA [q*_]mulrC -!mulrnAr.
  rewrite ![_*(_*xan)]mulrA ![_*xan]mulrC !mulrA [xbm*_]mulrC.
  rewrite -![(_*_)*_*_]mulrA [_*(q*+_)]mulrC -![(_*_)*_+(_*_)*_]mulr_addr.
  set r := _ + _ + _.
  case: (@ivt_sign (((\s q.[b]) ?* 1)%:P * r) a b); first exact: ltrW.
  rewrite !horner_mul !hornerC !signr_mul !signr_smul !signr1 !mulr1.
  rewrite mulrAC !mulrA mulss signr_cp0 qb0 mul1r.
  rewrite /r !horner_add !horner_mul.
  rewrite !horner_add !hornerX !horner_opp !hornerC.
  rewrite !subrr !(mul0r,mulr0,add0r,addr0).
  rewrite !horner_mulrn !signr_mul !signr_mulrn sab.
  rewrite mulrAC !mulrA mulss signr_cp0 qb0 mul1r.
  rewrite -oppr_sub signr_opp mulNr mulss signr_cp0.
  by rewrite subr_eq0 [b == _]eq_sym ltrE.
move=> c lacb; rewrite /root horner_mul hornerC mulf_eq0.
rewrite smul1_eq0 signr_cp0 (negPf qb0) orFb=> rc0.
by exists c=> //; left; rewrite !horner_mul !mulf_eq0 rc0 !orbT.
Qed.

Lemma rolle : forall a b p, a < b ->
  (p.[a] == 0) && (p.[b] == 0) ->
  exists2 c, a < c < b & (p^`.[c] == 0).
Proof.
move=> a b p lab; case/andP=> pa0 pb0.
have := @poly_ltsp_roots p a b.
elim: (size p) a b lab pa0 pb0=> [|n ihn] a b lab pa0 pb0 max_roots;
  first rewrite (eqP (@max_roots [::] _ _ _)) //=.
  by exists ((a+b)/2%:R); first exact: midf_lt; rewrite derivC horner0.
case: (@rolle_weak a b p); rewrite // ?pa0 ?pb0 //=.
move=> c; case/andP=>lac lcb [] pc0; first by exists c; rewrite // lac.
suff: exists2 d : R, a < d < c & (p^`).[d] == 0.
  case=> [d]; case/andP=> lad ldc p'd0.
  by exists d; rewrite // lad andTb (ltr_trans ldc).
apply: ihn=> //.
move=> t stn ut Pt; apply: (max_roots (c::t))=> //=.
  rewrite ut andbT; apply/negP=> cint.
  by move: (Pt c cint); rewrite lerr andbF.
move=> x; rewrite inE; case/orP; first by move/eqP->; rewrite lac lcb.
by move/Pt; case/andP; case/andP=> -> lxc ->; rewrite (ltr_trans  lxc).
Qed.

Lemma mvt : forall a b p, a < b ->
  exists2 c, a < c < b & p.[b] - p.[a] = p^`.[c] * (b - a).
Proof.
move=> a b p lab.
pose q := (p.[b] - p.[a])%:P*('X - a%:P) - (b - a)%:P*(p - p.[a]%:P).
case: (@rolle a b q)=> //.
  by rewrite /q !horner_lin !(subrr,mulr0) mulrC subrr eqxx.
move=> c lacb q'x0; exists c=> //.
move: q'x0; rewrite /q !derivE !(mul0r,add0r,subr0,mulr1).
by rewrite !horner_lin mulrC subr_eq0; move/eqP.
Qed.

Lemma deriv_sign : forall a b p,
  (forall x, a < x < b -> p^`.[x] >= 0)
  -> (forall x y, (a < x < b) && (a < y < b)
    ->  x < y -> p.[x] <= p.[y] ).
Proof.
move=> a b p Pab x y; case/and3P; case/andP=> lax lxb lay lyb lxy.
rewrite -subr_ge0; case: (@mvt x y p)=> //.
move=> c; case/andP=> lxc lcy ->; rewrite mulr_cp0p//.
  by rewrite Pab// (ltr_trans lax)// (ltr_trans lcy).
by rewrite subr_ge0 ltrE.
Qed.

(* Definition signs lp := *)
(*   let fix loop lp n := *)
(*     if n is n.+1 then *)

(*       else *)

End PolyReal.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__8__2.
Require Export lemma__ABCequalsCBA.
Require Export lemma__angleorderrespectscongruence.
Require Export lemma__angleorderrespectscongruence2.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__doublereverse.
Require Export lemma__equalanglessymmetric.
Require Export lemma__inequalitysymmetric.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export lemma__ray4.
Require Export lemma__rightangleNC.
Require Export logic.
Require Export proposition__16.
Require Export proposition__19.
Definition lemma__legsmallerhypotenuse : forall A B C, (euclidean__defs.Per A B C) -> ((euclidean__defs.Lt A B A C) /\ (euclidean__defs.Lt B C A C)).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (* Cut *) (euclidean__defs.Per C B A) as H0.
- apply (@lemma__8__2.lemma__8__2 A B C H).
- assert (exists D, (euclidean__axioms.BetS C B D) /\ ((euclidean__axioms.Cong C B D B) /\ ((euclidean__axioms.Cong C A D A) /\ (euclidean__axioms.neq B A)))) as H1 by exact H0.
destruct H1 as [D H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
assert (* Cut *) (euclidean__axioms.nCol A B C) as H9.
-- apply (@lemma__rightangleNC.lemma__rightangleNC A B C H).
-- assert (euclidean__axioms.Triangle A B C) as H10 by exact H9.
assert (* Cut *) (~(euclidean__axioms.Col A C B)) as H11.
--- intro H11.
assert (* Cut *) (euclidean__axioms.Col A B C) as H12.
---- assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H12.
----- apply (@lemma__collinearorder.lemma__collinearorder A C B H11).
----- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H19.
---- apply (@euclidean__tactics.Col__nCol__False A B C H10 H12).
--- assert (* Cut *) (euclidean__axioms.Triangle A C B) as H12.
---- apply (@euclidean__tactics.nCol__notCol A C B H11).
---- assert (* Cut *) ((euclidean__defs.LtA C A B A B D) /\ (euclidean__defs.LtA B C A A B D)) as H13.
----- apply (@proposition__16.proposition__16 A C B D H12 H3).
----- assert (* Cut *) (A = A) as H14.
------ destruct H13 as [H14 H15].
apply (@logic.eq__refl Point A).
------ assert (* Cut *) (C = C) as H15.
------- destruct H13 as [H15 H16].
apply (@logic.eq__refl Point C).
------- assert (* Cut *) (D = D) as H16.
-------- destruct H13 as [H16 H17].
apply (@logic.eq__refl Point D).
-------- assert (* Cut *) (~(B = C)) as H17.
--------- intro H17.
assert (* Cut *) (euclidean__axioms.Col A B C) as H18.
---------- right.
right.
left.
exact H17.
---------- apply (@H11).
-----------apply (@euclidean__tactics.not__nCol__Col A C B).
------------intro H19.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H18).

--------- assert (* Cut *) (euclidean__axioms.neq B D) as H18.
---------- destruct H13 as [H18 H19].
assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H20.
----------- apply (@lemma__betweennotequal.lemma__betweennotequal C B D H3).
----------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H21.
---------- assert (* Cut *) (euclidean__defs.Out B A A) as H19.
----------- destruct H13 as [H19 H20].
apply (@lemma__ray4.lemma__ray4 B A A).
------------right.
left.
exact H14.

------------ exact H8.
----------- assert (* Cut *) (euclidean__defs.Out B C C) as H20.
------------ destruct H13 as [H20 H21].
apply (@lemma__ray4.lemma__ray4 B C C).
-------------right.
left.
exact H15.

------------- exact H17.
------------ assert (* Cut *) (euclidean__defs.Out B D D) as H21.
------------- destruct H13 as [H21 H22].
apply (@lemma__ray4.lemma__ray4 B D D).
--------------right.
left.
exact H16.

-------------- exact H18.
------------- assert (* Cut *) (euclidean__axioms.Cong B A B A) as H22.
-------------- destruct H13 as [H22 H23].
apply (@euclidean__axioms.cn__congruencereflexive B A).
-------------- assert (* Cut *) (euclidean__axioms.Cong B D B C) as H23.
--------------- destruct H13 as [H23 H24].
assert (* Cut *) ((euclidean__axioms.Cong B D B C) /\ (euclidean__axioms.Cong B C B D)) as H25.
---------------- apply (@lemma__doublereverse.lemma__doublereverse C B D B H5).
---------------- destruct H25 as [H26 H27].
exact H26.
--------------- assert (* Cut *) (euclidean__axioms.Cong A D A C) as H24.
---------------- destruct H13 as [H24 H25].
assert (* Cut *) ((euclidean__axioms.Cong A D A C) /\ (euclidean__axioms.Cong A C A D)) as H26.
----------------- apply (@lemma__doublereverse.lemma__doublereverse C A D A H7).
----------------- destruct H26 as [H27 H28].
exact H27.
---------------- assert (* Cut *) (~(euclidean__axioms.Col A B D)) as H25.
----------------- intro H25.
assert (* Cut *) (euclidean__axioms.Col C B D) as H26.
------------------ right.
right.
right.
right.
left.
exact H3.
------------------ assert (* Cut *) (euclidean__axioms.Col D B C) as H27.
------------------- destruct H13 as [H27 H28].
assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H29.
-------------------- apply (@lemma__collinearorder.lemma__collinearorder C B D H26).
-------------------- destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H37.
------------------- assert (* Cut *) (euclidean__axioms.Col D B A) as H28.
-------------------- destruct H13 as [H28 H29].
assert (* Cut *) ((euclidean__axioms.Col B A D) /\ ((euclidean__axioms.Col B D A) /\ ((euclidean__axioms.Col D A B) /\ ((euclidean__axioms.Col A D B) /\ (euclidean__axioms.Col D B A))))) as H30.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder A B D H25).
--------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H38.
-------------------- assert (* Cut *) (euclidean__axioms.neq B D) as H29.
--------------------- destruct H13 as [H29 H30].
assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H31.
---------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C B D H3).
---------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H18.
--------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H30.
---------------------- destruct H13 as [H30 H31].
apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B D H29).
---------------------- assert (* Cut *) (euclidean__axioms.Col B C A) as H31.
----------------------- destruct H13 as [H31 H32].
apply (@euclidean__tactics.not__nCol__Col B C A).
------------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False B C A H33).
-------------------------apply (@lemma__collinear4.lemma__collinear4 D B C A H27 H28 H30).

----------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H32.
------------------------ destruct H13 as [H32 H33].
assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H34.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C A H31).
------------------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H39.
------------------------ apply (@H11).
-------------------------apply (@euclidean__tactics.not__nCol__Col A C B).
--------------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H32).

----------------- assert (* Cut *) (euclidean__defs.CongA A B D A B C) as H26.
------------------ exists A.
exists D.
exists A.
exists C.
split.
------------------- exact H19.
------------------- split.
-------------------- exact H21.
-------------------- split.
--------------------- exact H19.
--------------------- split.
---------------------- exact H20.
---------------------- split.
----------------------- exact H22.
----------------------- split.
------------------------ exact H23.
------------------------ split.
------------------------- exact H24.
------------------------- apply (@euclidean__tactics.nCol__notCol A B D H25).
------------------ assert (* Cut *) (euclidean__defs.CongA A B C A B D) as H27.
------------------- destruct H13 as [H27 H28].
apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A B D A B C H26).
------------------- assert (* Cut *) (euclidean__defs.LtA B C A A B C) as H28.
-------------------- destruct H13 as [H28 H29].
apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence B C A A B D A B C H29 H27).
-------------------- assert (* Cut *) (euclidean__defs.Lt A B A C) as H29.
--------------------- destruct H13 as [H29 H30].
apply (@proposition__19.proposition__19 A B C H10 H28).
--------------------- assert (* Cut *) (euclidean__defs.LtA C A B A B C) as H30.
---------------------- destruct H13 as [H30 H31].
apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence C A B A B D A B C H30 H27).
---------------------- assert (* Cut *) (~(euclidean__axioms.Col B A C)) as H31.
----------------------- intro H31.
assert (* Cut *) (euclidean__axioms.Col A B C) as H32.
------------------------ destruct H13 as [H32 H33].
assert (* Cut *) ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B C A) /\ (euclidean__axioms.Col C A B))))) as H34.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A C H31).
------------------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H35.
------------------------ apply (@H11).
-------------------------apply (@euclidean__tactics.not__nCol__Col A C B).
--------------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H32).

----------------------- assert (* Cut *) (euclidean__defs.CongA B A C C A B) as H32.
------------------------ destruct H13 as [H32 H33].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B A C).
-------------------------apply (@euclidean__tactics.nCol__notCol B A C H31).

------------------------ assert (* Cut *) (euclidean__defs.LtA B A C A B C) as H33.
------------------------- destruct H13 as [H33 H34].
apply (@lemma__angleorderrespectscongruence2.lemma__angleorderrespectscongruence2 C A B A B C B A C H30 H32).
------------------------- assert (* Cut *) (~(euclidean__axioms.Col C B A)) as H34.
-------------------------- intro H34.
assert (* Cut *) (euclidean__axioms.Col A B C) as H35.
--------------------------- destruct H13 as [H35 H36].
assert (* Cut *) ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C A B) /\ (euclidean__axioms.Col A B C))))) as H37.
---------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B A H34).
---------------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H45.
--------------------------- apply (@H11).
----------------------------apply (@euclidean__tactics.not__nCol__Col A C B).
-----------------------------intro H36.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H35).

-------------------------- assert (* Cut *) (euclidean__axioms.Triangle C B A) as H35.
--------------------------- apply (@euclidean__tactics.nCol__notCol C B A H34).
--------------------------- assert (* Cut *) (euclidean__defs.CongA C B A A B C) as H36.
---------------------------- destruct H13 as [H36 H37].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA C B A H35).
---------------------------- assert (* Cut *) (euclidean__defs.LtA B A C C B A) as H37.
----------------------------- destruct H13 as [H37 H38].
apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence B A C A B C C B A H33 H36).
----------------------------- assert (* Cut *) (euclidean__defs.Lt C B C A) as H38.
------------------------------ destruct H13 as [H38 H39].
apply (@proposition__19.proposition__19 C B A H35 H37).
------------------------------ assert (* Cut *) (euclidean__axioms.Cong C B B C) as H39.
------------------------------- destruct H13 as [H39 H40].
apply (@euclidean__axioms.cn__equalityreverse C B).
------------------------------- assert (* Cut *) (euclidean__defs.Lt B C C A) as H40.
-------------------------------- destruct H13 as [H40 H41].
apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 C B C A B C H38 H39).
-------------------------------- assert (* Cut *) (euclidean__axioms.Cong C A A C) as H41.
--------------------------------- destruct H13 as [H41 H42].
apply (@euclidean__axioms.cn__equalityreverse C A).
--------------------------------- assert (* Cut *) (euclidean__defs.Lt B C A C) as H42.
---------------------------------- destruct H13 as [H42 H43].
apply (@lemma__lessthancongruence.lemma__lessthancongruence B C C A A C H40 H41).
---------------------------------- split.
----------------------------------- exact H29.
----------------------------------- exact H42.
Qed.