Require Import rt.util.all.
Require Import rt.model.jitter.job rt.model.jitter.task rt.model.jitter.task_arrival
               rt.model.jitter.schedule rt.model.jitter.platform rt.model.jitter.interference
               rt.model.jitter.workload rt.model.jitter.schedulability
               rt.model.jitter.priority rt.model.jitter.platform rt.model.jitter.response_time.
Require Import rt.analysis.jitter.workload_bound
               rt.analysis.jitter.interference_bound_edf.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop div path.

Module ResponseTimeAnalysisEDFJitter.

  Export JobWithJitter SporadicTaskset ScheduleOfSporadicTaskWithJitter Workload
         Schedulability ResponseTime Priority SporadicTaskArrival WorkloadBoundJitter
         InterferenceBoundEDFJitter Platform Interference.

  (* In this section, we prove that Bertogna and Cirinei's RTA yields
     safe response-time bounds. *)
  Section ResponseTimeBound.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.
    Variable task_jitter: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.
    Variable job_jitter: Job -> time.

    (* Assume any job arrival sequence... *)
    Context {arr_seq: arrival_sequence Job}.

    (* ... in which jobs arrive sporadically and have valid parameters.
       Note: the jitter of a valid job is bounded by the jitter of its task. *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period arr_seq job_task.
    Hypothesis H_valid_job_parameters:
      forall (j: JobIn arr_seq),
        valid_sporadic_job_with_jitter task_cost task_deadline task_jitter job_cost
                                                 job_deadline job_task job_jitter j.

    (* Consider any schedule such that...*)
    Variable num_cpus: nat.
    Variable sched: schedule num_cpus arr_seq.

    (* ...jobs execute after jitter and no longer than their execution costs. *)
    Hypothesis H_jobs_execute_after_jitter:
      jobs_execute_after_jitter job_jitter sched.
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* Also assume that jobs are sequential and that there exists
       at least one processor. *)
    Hypothesis H_sequential_jobs: sequential_jobs sched.
    Hypothesis H_at_least_one_cpu: num_cpus > 0.

    (* Assume that we have a task set ts, such that all jobs come
       from the task set, and all tasks have valid parameters and
       constrained deadlines. *)
    Variable ts: taskset_of sporadic_task.
    Hypothesis H_all_jobs_from_taskset:
      forall (j: JobIn arr_seq), job_task j \in ts.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.
    Hypothesis H_constrained_deadlines:
      forall tsk, tsk \in ts -> task_deadline tsk <= task_period tsk.

    Let no_deadline_is_missed_by_tsk (tsk: sporadic_task) :=
      task_misses_no_deadline job_cost job_deadline job_task sched tsk.
    Let response_time_bounded_by (tsk: sporadic_task) :=
      is_response_time_bound_of_task job_cost job_task tsk sched.

    (* Assume a known response-time bound R is known...  *)
    Let task_with_response_time := (sporadic_task * time)%type.
    Variable rt_bounds: seq task_with_response_time.

    (* ...for any task in the task set. *)
    Hypothesis H_rt_bounds_contains_all_tasks: unzip1 rt_bounds = ts.

    (* Also, assume that R is a fixed-point of the response-time recurrence, ... *)
    Let I (tsk: sporadic_task) (delta: time) :=
      total_interference_bound_edf task_cost task_period task_deadline task_jitter tsk rt_bounds delta.
    Hypothesis H_response_time_is_fixed_point :
      forall tsk R,
        (tsk, R) \in rt_bounds ->
        R = task_cost tsk + div_floor (I tsk R) num_cpus.

    (* ..., and R is no larger than the deadline. *)
    Hypothesis H_tasks_miss_no_deadlines:
      forall tsk R,
        (tsk, R) \in rt_bounds ->
        task_jitter tsk + R <= task_deadline tsk.

    (* Assume that we have a work-conserving EDF scheduler. *)
    Hypothesis H_work_conserving: work_conserving job_cost job_jitter sched.
    Hypothesis H_edf_policy: enforces_JLDP_policy job_cost job_jitter sched (EDF job_deadline).

    (* Assume that the task set has no duplicates. This is required to
       avoid problems when counting tasks (for example, when stating
       that the number of interfering tasks is at most num_cpus). *)
    Hypothesis H_ts_is_a_set : uniq ts.

    (* In order to prove that R is a response-time bound, we first present some lemmas. *)
    Section Lemmas.

      (* Let (tsk, R) be any task to be analyzed, with its response-time bound R. *)
      Variable tsk: sporadic_task.
      Variable R: time.
      Hypothesis H_tsk_R_in_rt_bounds: (tsk, R) \in rt_bounds.

      (* Consider any job j of tsk. *)
      Variable j: JobIn arr_seq.
      Hypothesis H_job_of_tsk: job_task j = tsk.

      (* Let t1 be the first point in time where j can actually be scheduled. *)
      Let t1 := job_arrival j + job_jitter j.

      (* Assume that job j did not complete on time, ... *)
      Hypothesis H_j_not_completed: ~~ completed job_cost sched j (t1 + R).

      (* and that it is the first job not to satisfy its response-time bound. *)
      Hypothesis H_all_previous_jobs_completed_on_time :
        forall (j_other: JobIn arr_seq) tsk_other R_other,
          job_task j_other = tsk_other ->
          (tsk_other, R_other) \in rt_bounds ->
          job_arrival j_other + task_jitter tsk_other + R_other < job_arrival j + task_jitter tsk + R ->
          completed job_cost sched j_other (job_arrival j_other + task_jitter tsk_other + R_other).

      (* Let's call x the interference incurred by job j due to tsk_other, ...*)
      Let x (tsk_other: sporadic_task) :=
        task_interference job_cost job_task job_jitter sched j tsk_other t1 (t1 + R).

      (* and X the total interference incurred by job j due to any task. *)
      Let X := total_interference job_cost job_jitter sched j t1 (t1 + R).

      (* Recall Bertogna and Cirinei's workload bound ... *)
      Let workload_bound (tsk_other: sporadic_task) (R_other: time) :=
        W_jitter task_cost task_period task_jitter tsk_other R_other R.

      (*... and the EDF-specific bound, ... *)
      Let edf_specific_bound (tsk_other: sporadic_task) (R_other: time) :=
        edf_specific_interference_bound task_cost task_period task_deadline task_jitter tsk tsk_other R_other.

      (* ... which combined form the interference bound. *)
      Let interference_bound (tsk_other: sporadic_task) (R_other: time) :=
        interference_bound_edf task_cost task_period task_deadline task_jitter tsk R (tsk_other, R_other).

      (* Also, let ts_interf be the subset of tasks that interfere with tsk. *)
      Let ts_interf := [seq tsk_other <- ts | jldp_can_interfere_with tsk tsk_other].

      Section LemmasAboutInterferingTasks.

        (* Let (tsk_other, R_other) be any pair of higher-priority task and
           response-time bound computed in previous iterations. *)
        Variable tsk_other: sporadic_task.
        Variable R_other: time.
        Hypothesis H_response_time_of_tsk_other: (tsk_other, R_other) \in rt_bounds.

        (* Note that tsk_other is in task set ts ...*)
        Lemma bertogna_edf_tsk_other_in_ts: tsk_other \in ts.
        Proof.
          by rewrite -H_rt_bounds_contains_all_tasks; apply/mapP; exists (tsk_other, R_other).
        Qed.

        (* Also, R_other is larger than the cost of tsk_other. *)
        Lemma bertogna_edf_R_other_ge_cost :
          R_other >= task_cost tsk_other.
        Proof.
          by rewrite [R_other](H_response_time_is_fixed_point tsk_other);
            first by apply leq_addr.
        Qed.

        (* Since tsk_other cannot interfere more than it executes, we show that
           the interference caused by tsk_other is no larger than workload bound W. *)
        Lemma bertogna_edf_workload_bounds_interference :
          x tsk_other <= workload_bound tsk_other R_other.
        Proof.
          unfold valid_sporadic_job in *.
          rename H_all_previous_jobs_completed_on_time into BEFOREok,
                 H_valid_job_parameters into PARAMS,
                 H_valid_task_parameters into TASK_PARAMS,
                 H_constrained_deadlines into RESTR,
                 H_tasks_miss_no_deadlines into NOMISS.
          unfold x, task_interference, valid_sporadic_job_with_jitter, valid_sporadic_job in *.
          have INts := bertogna_edf_tsk_other_in_ts.
          apply leq_trans with (n := workload job_task sched tsk_other t1 (t1 + R));
            first by apply task_interference_le_workload.
          apply workload_bounded_by_W with (task_deadline0 := task_deadline)
            (job_jitter0 := job_jitter) (job_cost0 := job_cost) (job_deadline0 := job_deadline);
            try (by ins); last 2 first;
            [ by apply NOMISS |
            | by ins; apply TASK_PARAMS
            | by apply RESTR
            | by apply bertogna_edf_R_other_ge_cost].
          {
            intros j0 JOB0 LT0; apply BEFOREok; try (by done).
            unfold t1 in *.
            apply leq_trans with (n := job_arrival j + job_jitter j + R); first by done.
            rewrite leq_add2r leq_add2l.
            specialize (PARAMS j); des.
            rewrite -H_job_of_tsk; apply PARAMS0.
          }
        Qed.

        (* Recall that the edf-specific interference bound also holds. *)
        Lemma bertogna_edf_specific_bound_holds :
          x tsk_other <= edf_specific_bound tsk_other R_other.
        Proof.
          by apply interference_bound_edf_bounds_interference with (job_deadline0 := job_deadline)
                                                                  (ts0 := ts); try (by done);
          [  by apply bertogna_edf_tsk_other_in_ts
          |  by apply H_tasks_miss_no_deadlines
          |  by apply leq_trans with (n := task_jitter tsk + R);
               [apply leq_addl | by apply H_tasks_miss_no_deadlines]
          |  by ins; apply H_all_previous_jobs_completed_on_time with (tsk_other := tsk_other)].
        Qed.

      End LemmasAboutInterferingTasks.

      (* Next we prove some lemmas that help to derive a contradiction.*)
      Section DerivingContradiction.

        (* 0) Since job j did not complete by its response time bound, it follows that
              the total interference X >= R - e_k + 1. *)
        Lemma bertogna_edf_too_much_interference : X >= R - task_cost tsk + 1.
        Proof.
          rename H_completed_jobs_dont_execute into COMP,
                 H_valid_job_parameters into PARAMS, H_response_time_is_fixed_point into REC,
                 H_job_of_tsk into JOBtsk, H_j_not_completed into NOTCOMP.
          unfold completed, valid_sporadic_job_with_jitter, valid_sporadic_job in *.
          unfold X, total_interference; rewrite addn1.
          rewrite -(ltn_add2r (task_cost tsk)).
          rewrite subh1; last by rewrite [R](REC tsk) // leq_addr.
          rewrite -addnBA // subnn addn0.
          move: (NOTCOMP) => /negP NOTCOMP'.
          rewrite neq_ltn in NOTCOMP.
          move: NOTCOMP => /orP [LT | BUG]; last first.
          {
            exfalso; rewrite ltnNge in BUG; move: BUG => /negP BUG; apply BUG.
            by apply cumulative_service_le_job_cost.
          }
          apply leq_ltn_trans with (n := (\sum_(t1 <= t < t1 + R)
                                       backlogged job_cost job_jitter sched j t) +
                                     service sched j (t1 + R)); last first.
          {
            rewrite -addn1 -addnA leq_add2l addn1.
            apply leq_trans with (n := job_cost j); first by done.
            by specialize (PARAMS j); des; rewrite -JOBtsk.
          }
          unfold service.
          rewrite -> big_cat_nat with (n := t1) (m := 0); rewrite ?leq_addr // /=.
          rewrite (cumulative_service_before_jitter_zero job_jitter) // add0n.
          rewrite -big_split /=.
          apply leq_trans with (n := \sum_(t1 <= i < t1 + R) 1);
            first by simpl_sum_const; rewrite addKn.
          apply leq_sum_nat; move => i /andP [GEi LTi] _.
          destruct (backlogged job_cost job_jitter sched j i) eqn:BACK;
            first by rewrite -addn1 addnC; apply leq_add.
          apply negbT in BACK.
          rewrite add0n lt0n -not_scheduled_no_service negbK.
          rewrite /backlogged negb_and negbK in BACK.
          move: BACK => /orP [/negP NOTPENDING | SCHED]; last by done.
          exfalso; apply NOTPENDING; unfold pending; apply/andP; split; first by done.
          apply/negP; red; intro BUG; apply NOTCOMP'.
          by apply completion_monotonic with (t := i); try (by done); apply ltnW.
        Qed.

        Let scheduled_task_other_than_tsk (t: time) (tsk_other: sporadic_task) :=
          task_is_scheduled job_task sched tsk_other t &&
          jldp_can_interfere_with tsk tsk_other.

        (* 1) At all times that j is backlogged, all processors are busy with other tasks. *)
        Lemma bertogna_edf_scheduling_invariant:
          forall t,
            t1 <= t < t1 + R ->
            backlogged job_cost job_jitter sched j t ->
            count (scheduled_task_other_than_tsk t) ts = num_cpus.
        Proof.
          rename H_all_jobs_from_taskset into FROMTS,
                 H_valid_task_parameters into PARAMS,
                 H_valid_job_parameters into JOBPARAMS,
                 H_job_of_tsk into JOBtsk,
                 H_sporadic_tasks into SPO,
                 H_tsk_R_in_rt_bounds into INbounds,
                 H_all_previous_jobs_completed_on_time into BEFOREok,
                 H_tasks_miss_no_deadlines into NOMISS,
                 H_rt_bounds_contains_all_tasks into UNZIP,
                 H_constrained_deadlines into RESTR,
                 H_work_conserving into WORK.
          unfold x, X, total_interference, task_interference,
                 valid_sporadic_job_with_jitter, valid_sporadic_job in *.
          move => t /andP [LEt LTt] BACK.
          unfold scheduled_task_other_than_tsk in *.
          eapply platform_cpus_busy_with_interfering_tasks; try (by done);
            [ by apply WORK | by done | by apply SPO
            | apply PARAMS; rewrite -JOBtsk; apply FROMTS
            | by apply JOBtsk | by apply BACK | ].
          {
            intros j0 tsk0 TSK0 LE.
            cut (tsk0 \in unzip1 rt_bounds = true); last by rewrite UNZIP -TSK0 FROMTS.
            move => /mapP [p IN EQ]; destruct p as [tsk' R0]; simpl in *; subst tsk'.
            apply completion_monotonic with (t0 := job_arrival j0 + task_jitter tsk0 + R0); try (by done).
            {
              rewrite -addnA leq_add2l TSK0.
              apply leq_trans with (n := task_deadline tsk0); first by apply NOMISS.
              by apply RESTR; rewrite -TSK0 FROMTS.
            }
            {
              apply BEFOREok with (tsk_other := tsk0); try (by done).
              apply leq_trans with (n := t1 + R); last first.
              {
                  rewrite leq_add2r leq_add2l -JOBtsk.
                  by specialize (JOBPARAMS j); des.
              }
              apply leq_ltn_trans with (n := t); last by done.
              apply leq_trans with (n := job_arrival j0 + task_period tsk0);
                last by done.
              rewrite -addnA leq_add2l.
              apply leq_trans with (n := task_deadline tsk0); first by apply NOMISS.
              by apply RESTR; rewrite -TSK0; apply FROMTS.
            }
          }
        Qed.

        (* 2) Prove that during the scheduling window of j, any job that is scheduled while j is
           backlogged comes from a different task. *)
        Lemma bertogna_edf_interference_by_different_tasks :
          forall t j_other,
            t1 <= t < t1 + R ->
            backlogged job_cost job_jitter sched j t ->
            scheduled sched j_other t ->
            job_task j_other != tsk.
        Proof.
          rename H_all_jobs_from_taskset into FROMTS,
                 H_valid_task_parameters into PARAMS,
                 H_valid_job_parameters into JOBPARAMS,
                 H_job_of_tsk into JOBtsk, H_sporadic_tasks into SPO,
                 H_work_conserving into WORK,
                 H_tsk_R_in_rt_bounds into INbounds,
                 H_all_previous_jobs_completed_on_time into BEFOREok,
                 H_tasks_miss_no_deadlines into NOMISS,
                 H_constrained_deadlines into CONSTR.
          unfold valid_sporadic_job_with_jitter, valid_sporadic_job in *.
          move => t j_other /andP [LEt GEt] BACK SCHED.
          apply/eqP; red; intro SAMEtsk.
          move: SCHED => /existsP [cpu SCHED].
          assert (SCHED': scheduled sched j_other t).
            by apply/existsP; exists cpu.
          clear SCHED; rename SCHED' into SCHED.
          move: (SCHED) => PENDING.
          apply scheduled_implies_pending with (job_cost0 := job_cost) (job_jitter0 := job_jitter)
            in PENDING; try (by done).
          destruct (ltnP (job_arrival j_other) (job_arrival j)) as [BEFOREother | BEFOREj].
          {
            move: (BEFOREother) => LT; rewrite -(ltn_add2r R) in LT.
            exploit (BEFOREok j_other tsk R SAMEtsk INbounds).
            {
              rewrite -addnA [_ + R]addnC addnA -[(_ + _) + R]addnA [_ tsk + R]addnC addnA.
              by rewrite ltn_add2r.
            }
            intros COMP.
            move: PENDING => /andP [_ /negP NOTCOMP]; apply NOTCOMP.
            apply completion_monotonic with (t0 := job_arrival j_other + task_jitter tsk + R);
              try by done.
            apply leq_trans with (n := job_arrival j);
              last by apply leq_trans with (n := t1); [by apply leq_addr | by done].
            apply leq_trans with (n := job_arrival j_other + task_period tsk).
            {
              rewrite -addnA leq_add2l.
              by apply leq_trans with (n := task_deadline tsk);
                [by apply NOMISS | by apply CONSTR; rewrite -JOBtsk FROMTS].
            }
            rewrite -SAMEtsk; apply SPO; [ | by rewrite JOBtsk | by apply ltnW].
            by red; intro EQ; subst; rewrite ltnn in BEFOREother.
          }
          {
            move: PENDING => /andP [ARRIVED _].
            exploit (SPO j j_other); [ | by rewrite SAMEtsk | by done | ]; last first.
            {
              apply/negP; rewrite -ltnNge JOBtsk.
              apply leq_trans with (n := job_arrival j + task_deadline tsk);
                last by rewrite leq_add2l; apply CONSTR; rewrite -JOBtsk FROMTS.
              apply leq_trans with (n := job_arrival j + task_jitter tsk + R);
                last by rewrite -addnA leq_add2l; apply NOMISS.
              apply leq_trans with (n := t1 + R); last first.
              {
                rewrite leq_add2r leq_add2l -JOBtsk.
                by specialize (JOBPARAMS j); des.
              }
              apply leq_ltn_trans with (n := job_arrival j_other + job_jitter j_other);
                first by apply leq_addr.
              by apply leq_ltn_trans with (n := t).
            }
            by intros EQtsk; subst j_other; rewrite /backlogged SCHED andbF in BACK.
          }
        Qed.

      (* 3) Next, we prove that the sum of the interference of each task is equal
          to the total interference multiplied by the number of processors. This
          holds because interference only occurs when all processors are busy. *)
        Lemma bertogna_edf_all_cpus_busy :
          \sum_(tsk_k <- ts_interf) x tsk_k = X * num_cpus.
        Proof.
          have DIFFTASK := bertogna_edf_interference_by_different_tasks.
          rename H_all_jobs_from_taskset into FROMTS,
                 H_valid_task_parameters into PARAMS,
                 H_job_of_tsk into JOBtsk, H_sporadic_tasks into SPO,
                 H_work_conserving into WORK,
                 H_tsk_R_in_rt_bounds into INbounds,
                 H_all_previous_jobs_completed_on_time into BEFOREok,
                 H_tasks_miss_no_deadlines into NOMISS,
                 H_rt_bounds_contains_all_tasks into UNZIP,
                 H_constrained_deadlines into CONSTR.
          unfold sporadic_task_model in *.
          unfold x, X, total_interference, task_interference.
          rewrite -big_mkcond -exchange_big big_distrl /= mul1n.
          rewrite [\sum_(_ <= _ < _ | backlogged _ _ _ _ _) _]big_mkcond.
          apply eq_big_nat; move => t /andP [GEt LTt].
          destruct (backlogged job_cost job_jitter sched j t) eqn:BACK;
            last by rewrite big1 //; ins; rewrite big1.
          rewrite big_mkcond /=.
          rewrite exchange_big /=.
          apply eq_trans with (y := \sum_(cpu < num_cpus) 1); last by simpl_sum_const.
          apply eq_bigr; intros cpu _.
          move: (WORK j t BACK cpu) => [j_other /eqP SCHED]; unfold scheduled_on in *.
          rewrite (bigD1_seq (job_task j_other)) /=; last by rewrite filter_uniq.
          {
            rewrite (eq_bigr (fun i => 0));
              last by intros i DIFF; rewrite /task_scheduled_on SCHED;apply/eqP;rewrite eqb0 eq_sym.
            simpl_sum_const; apply/eqP; rewrite eqb1.
            by unfold task_scheduled_on; rewrite SCHED.
          }
          rewrite mem_filter; apply/andP; split; last by apply FROMTS.
          unfold jldp_can_interfere_with.
          apply DIFFTASK with (t := t); [by auto | by done |].
          by apply/existsP; exists cpu; apply/eqP.
        Qed.

        (* 4) Show that by the induction hypothesis, all jobs released
           before the end of the interval complete by their periods. *)
        Lemma bertogna_edf_all_previous_jobs_complete_by_their_period:
          forall t (j0: JobIn arr_seq),
            t < t1 + R ->
            job_arrival j0 + task_period (job_task j0) <= t ->
            completed job_cost sched j0
               (job_arrival j0 + task_period (job_task j0)).
        Proof.
          rename H_valid_job_parameters into JOBPARAMS,
                 H_rt_bounds_contains_all_tasks into UNZIP,
                 H_job_of_tsk into JOBtsk,
                 H_constrained_deadlines into CONSTR,
                 H_tasks_miss_no_deadlines into NOMISS,
                 H_all_jobs_from_taskset into FROMTS,
                 H_all_previous_jobs_completed_on_time into BEFOREok.
          unfold valid_sporadic_job_with_jitter, valid_sporadic_job in *.
          intros t j0 LEt LE.
          cut ((job_task j0) \in unzip1 rt_bounds = true); last by rewrite UNZIP FROMTS.
          move => /mapP [p IN EQ]; destruct p as [tsk' R0]; simpl in *; subst tsk'.
          apply completion_monotonic with (t0 := job_arrival j0 +
                                        task_jitter (job_task j0) + R0); first by done.
          {
            rewrite -addnA leq_add2l.
            apply leq_trans with (n := task_deadline (job_task j0));
              [by apply NOMISS | by apply CONSTR; rewrite FROMTS].
          }
          apply BEFOREok with (tsk_other := (job_task j0)); try by done.
          apply leq_ltn_trans with (n := t); last first.
          {
            apply leq_trans with (n := t1 + R); first by done.
            rewrite leq_add2r leq_add2l -JOBtsk.
            by specialize (JOBPARAMS j); des.
          }
          apply leq_trans with (n := job_arrival j0 + task_period (job_task j0)); last by done.
          by rewrite -addnA leq_add2l; apply leq_trans with (n := task_deadline (job_task j0));
            [by apply NOMISS | apply CONSTR; rewrite FROMTS].
        Qed.

        (* Let (cardGE delta) be the number of interfering tasks whose interference
           is larger than delta. *)
        Let cardGE (delta: time) := count (fun i => x i >= delta) ts_interf.

        (* 5) If there is at least one of such tasks (e.g., cardGE > 0), then the
           cumulative interference caused by the complementary set of interfering
           tasks fills at least (num_cpus - cardGE) processors. *)
        Lemma bertogna_edf_helper_lemma :
          forall delta,
            0 < cardGE delta < num_cpus ->
            \sum_(i <- ts_interf | x i < delta) x i >= delta * (num_cpus - cardGE delta).
        Proof.
          have COMP := bertogna_edf_all_previous_jobs_complete_by_their_period.
          have INV := bertogna_edf_scheduling_invariant.
          rename H_all_jobs_from_taskset into FROMTS,
                 H_valid_task_parameters into PARAMS,
                 H_job_of_tsk into JOBtsk, H_sporadic_tasks into SPO,
                 H_tsk_R_in_rt_bounds into INbounds,
                 H_all_previous_jobs_completed_on_time into BEFOREok,
                 H_tasks_miss_no_deadlines into NOMISS,
                 H_constrained_deadlines into CONSTR, H_sequential_jobs into SEQ.
          unfold sporadic_task_model in *.
          move => delta /andP [HAS LT].
          rewrite -has_count in HAS.

          set some_interference_A := fun t =>
            has (fun tsk_k => backlogged job_cost job_jitter sched j t &&
                              (x tsk_k >= delta) &&
                              task_is_scheduled job_task sched tsk_k t) ts_interf.
          set total_interference_B := fun t =>
              backlogged job_cost job_jitter sched j t *
              count (fun tsk_k => (x tsk_k < delta) &&
                    task_is_scheduled job_task sched tsk_k t) ts_interf.

          apply leq_trans with ((\sum_(t1 <= t < t1 + R)
                                some_interference_A t) * (num_cpus - cardGE delta)).
          {
            rewrite leq_mul2r; apply/orP; right.
            move: HAS => /hasP HAS; destruct HAS as [tsk_a INa LEa].
            apply leq_trans with (n := x tsk_a); first by apply LEa.
            unfold x, task_interference, some_interference_A.
            apply leq_sum_nat; move => t /andP [GEt LTt] _.
            destruct (backlogged job_cost job_jitter sched j t) eqn:BACK;
              last by rewrite (eq_bigr (fun x => 0)); [by simpl_sum_const | by ins].
            destruct ([exists cpu, task_scheduled_on job_task sched tsk_a cpu t]) eqn:SCHED;
              last first.
            {
              apply negbT in SCHED; rewrite negb_exists in SCHED; move: SCHED => /forallP ALL.
              rewrite (eq_bigr (fun x => 0)); first by simpl_sum_const.
              by intros cpu _; specialize (ALL cpu); apply negbTE in ALL; rewrite ALL.
            }
            move: SCHED => /existsP [cpu SCHED].
            apply leq_trans with (n := 1); last first.
            {
              rewrite lt0b; apply/hasP; exists tsk_a; first by done.
              by rewrite LEa 2!andTb; apply/existsP; exists cpu.
            }
            rewrite (bigD1 cpu) /= // SCHED.
            rewrite (eq_bigr (fun x => 0)); first by simpl_sum_const; rewrite leq_b1.
            intros cpu' DIFF.
            apply/eqP; rewrite eqb0; apply/negP.
            intros SCHED'.
            move: DIFF => /negP DIFF; apply DIFF; apply/eqP.
            unfold task_scheduled_on in *.
            destruct (sched cpu t) as [j1|] eqn:SCHED1; last by done.
            destruct (sched cpu' t) as [j2|] eqn:SCHED2; last by done.
            move: SCHED SCHED' => /eqP JOB /eqP JOB'.
            subst tsk_a; symmetry in JOB'.
            assert (PENDING1: pending job_cost job_jitter sched j1 t).
            {
              apply scheduled_implies_pending; try by done.
              by apply/existsP; exists cpu; apply/eqP.
            }
            assert (PENDING2: pending job_cost job_jitter sched j2 t).
            {
              apply scheduled_implies_pending; try by done.
              by apply/existsP; exists cpu'; apply/eqP.
            }
            assert (BUG: j1 = j2).
            {
              apply platform_at_most_one_pending_job_of_each_task with (task_cost0 := task_cost)
               (job_jitter0 := job_jitter) (task_period0 := task_period) (job_cost0 := job_cost)
               (task_deadline0 := task_deadline) (tsk0 := tsk) (job_task0 := job_task) (sched0 := sched)
               (j0 := j) (t0 := t);
              rewrite ?JOBtsk ?SAMEtsk //; first by apply PARAMS; rewrite -JOBtsk FROMTS.
              by intros j0 tsk0 TSK0 LE; apply (COMP t); rewrite ?TSK0.
            }
            by subst j2; apply SEQ with (j := j1) (t := t).
          }

          apply leq_trans with (\sum_(t1 <= t < t1 + R) total_interference_B t).
          {
            rewrite big_distrl /=.
            apply leq_sum_nat; move => t LEt _.
            unfold some_interference_A, total_interference_B.
            destruct (backlogged job_cost job_jitter sched j t) eqn:BACK;
              [rewrite mul1n /= | by rewrite has_pred0 //].

            destruct (has (fun tsk_k : sporadic_task => (delta <= x tsk_k) &&
                       task_is_scheduled job_task sched tsk_k t) ts_interf) eqn:HAS';
              last by done.
            rewrite mul1n; move: HAS => /hasP [tsk_k INk LEk].
            unfold cardGE.
            apply leq_trans with (n := num_cpus -
                         count (fun i => (x i >= delta) &&
                            task_is_scheduled job_task sched i t) ts_interf).
            {
              apply leq_sub2l.
              rewrite -2!sum1_count big_mkcond /=.
              rewrite [\sum_(_ <- _ | _ <= _)_]big_mkcond /=.
              apply leq_sum; intros i _.
              by destruct (task_is_scheduled job_task sched i t);
                [by rewrite andbT | by rewrite andbF].
            }
            rewrite -count_filter -[count _ ts_interf]count_filter.
            eapply leq_trans with (n := count (predC (fun tsk => delta <= x tsk)) _);
              last by apply eq_leq, eq_in_count; red; ins; rewrite ltnNge.
            rewrite leq_subLR count_predC size_filter.
            by apply leq_trans with (n := count (scheduled_task_other_than_tsk t) ts);
              [by rewrite INV | by rewrite count_filter].
          }
          {
            unfold x at 2, total_interference_B.
            rewrite exchange_big /=; apply leq_sum; intros t _.
            destruct (backlogged job_cost job_jitter sched j t) eqn:BACK; last by ins.
            rewrite mul1n -sum1_count.
            rewrite big_mkcond [\sum_(i <- ts_interf | _ < _) _]big_mkcond /=.
            apply leq_sum_seq; move => tsk_k IN _.
            destruct (x tsk_k < delta); [rewrite andTb | by rewrite andFb].
            destruct (task_is_scheduled job_task sched tsk_k t) eqn:SCHED; last by done.
            move: SCHED => /existsP [cpu SCHED].
            by rewrite (bigD1 cpu) /= // SCHED.
          }
        Qed.

        (* 6) Next, we prove that, for any interval delta, if the sum of per-task
              interference exceeds delta * num_cpus, the same applies for the
              sum of the minimum between the interference and delta. *)
        Lemma bertogna_edf_minimum_exceeds_interference :
          forall delta,
            \sum_(tsk_k <- ts_interf) x tsk_k >= delta * num_cpus ->
               \sum_(tsk_k <- ts_interf) minn (x tsk_k) delta >=
               delta * num_cpus.
        Proof.
          intros delta SUMLESS.
          set more_interf := fun tsk_k => x tsk_k >= delta.
          rewrite [\sum_(_ <- _) minn _ _](bigID more_interf) /=.
          unfold more_interf, minn.
          rewrite [\sum_(_ <- _ | delta <= _)_](eq_bigr (fun i => delta));
            last by intros i COND; rewrite leqNgt in COND; destruct (delta > x i).
          rewrite [\sum_(_ <- _ | ~~_)_](eq_big (fun i => x i < delta)
                                                (fun i => x i));
            [| by red; ins; rewrite ltnNge
             | by intros i COND; rewrite -ltnNge in COND; rewrite COND].

          (* Case 1: cardGE = 0 *)
          destruct (~~ has (fun i => delta <= x i) ts_interf) eqn:HASa.
          {
            rewrite [\sum_(_ <- _ | _ <= _) _]big_hasC; last by apply HASa.
            rewrite big_seq_cond; move: HASa => /hasPn HASa.
            rewrite add0n (eq_bigl (fun i => (i \in ts_interf) && true));
              last by red; intros tsk_k; destruct (tsk_k \in ts_interf) eqn:INk;
                [by rewrite andTb ltnNge; apply HASa | by rewrite andFb].
            by rewrite -big_seq_cond.
          } apply negbFE in HASa.

          (* Case 2: cardGE >= num_cpus *)
          destruct (cardGE delta >= num_cpus) eqn:CARD.
          {
            apply leq_trans with (delta * cardGE delta);
              first by rewrite leq_mul2l; apply/orP; right.
            unfold cardGE; rewrite -sum1_count big_distrr /=.
            rewrite -[\sum_(_ <- _ | _) _]addn0.
            by apply leq_add; [by apply leq_sum; ins; rewrite muln1|by ins].
          } apply negbT in CARD; rewrite -ltnNge in CARD.

          (* Case 3: cardGE < num_cpus *)
          rewrite big_const_seq iter_addn addn0; fold cardGE.
          apply leq_trans with (n := delta * cardGE delta +
                                     delta * (num_cpus - cardGE delta));
            first by rewrite -mulnDr subnKC //; apply ltnW.
          rewrite leq_add2l; apply bertogna_edf_helper_lemma.
          by apply/andP; split; first by rewrite -has_count.
        Qed.

        (* 7) Now, we prove that the Bertogna's interference bound
              is not enough to cover the sum of the "minimum" term over
              all tasks (artifact of the proof by contradiction). *)
        Lemma bertogna_edf_sum_exceeds_total_interference:
          \sum_((tsk_other, R_other) <- rt_bounds | jldp_can_interfere_with tsk tsk_other)
            minn (x tsk_other) (R - task_cost tsk + 1) > I tsk R.
        Proof.
          have GE_COST := bertogna_edf_R_other_ge_cost.
          have EXCEEDS := bertogna_edf_minimum_exceeds_interference.
          have ALLBUSY := bertogna_edf_all_cpus_busy.
          have TOOMUCH := bertogna_edf_too_much_interference.
          rename H_rt_bounds_contains_all_tasks into UNZIP,
            H_response_time_is_fixed_point into REC.
          apply leq_trans with (n := \sum_(tsk_other <- ts_interf) minn (x tsk_other) (R - task_cost tsk + 1));
            last first.
          {
            rewrite (eq_bigr (fun i => minn (x (fst i)) (R - task_cost tsk + 1)));
              last by ins; destruct i.
            move: UNZIP => UNZIP.
            assert (FILTER: filter (jldp_can_interfere_with tsk) (unzip1 rt_bounds) =
                            filter (jldp_can_interfere_with tsk) ts).
              by f_equal.
            unfold ts_interf; rewrite -FILTER; clear FILTER.
            rewrite -[\sum_(_ <- rt_bounds | _)_]big_filter.
            assert (SUBST: [seq i <- rt_bounds
                   | let '(tsk_other, _) := i in
                          jldp_can_interfere_with tsk tsk_other] = [seq i <- rt_bounds
                             | jldp_can_interfere_with tsk (fst i)]).
            {
              by apply eq_filter; red; intro i; destruct i.
            } rewrite SUBST; clear SUBST.
            have MAP := big_map (fun x => fst x) (fun i => true) (fun i => minn (x i) (R - task_cost tsk + 1)).
            by rewrite -MAP; apply eq_leq; f_equal; rewrite filter_map.
          }

          apply ltn_div_trunc with (d := num_cpus); first by apply H_at_least_one_cpu.
          rewrite -(ltn_add2l (task_cost tsk)) -REC; last by done.
          rewrite -addn1 -leq_subLR.
          rewrite -[R + 1 - _]subh1; last by apply GE_COST.
          rewrite leq_divRL; last by apply H_at_least_one_cpu.
          apply EXCEEDS.
          apply leq_trans with (n := X * num_cpus); last by rewrite ALLBUSY.
          by rewrite leq_mul2r; apply/orP; right; apply TOOMUCH.
        Qed.

        (* 8) After concluding that the sum of the minimum exceeds (R - e_i + 1),
              we prove that there exists a tuple (tsk_k, R_k) such that
              min (x_k, R - e_i + 1) > min (W_k, edf_bound, R - e_i + 1). *)
        Lemma bertogna_edf_exists_task_that_exceeds_bound :
          exists tsk_other R_other,
            (tsk_other, R_other) \in rt_bounds /\
            (minn (x tsk_other) (R - task_cost tsk + 1) > interference_bound tsk_other R_other).
        Proof.
          have SUM := bertogna_edf_sum_exceeds_total_interference.
          have BOUND := bertogna_edf_workload_bounds_interference.
          have EDFBOUND := bertogna_edf_specific_bound_holds.
          rename H_rt_bounds_contains_all_tasks into UNZIP.
          assert (HAS: has (fun tup : task_with_response_time =>
                              let (tsk_other, R_other) := tup in
                              (tsk_other \in ts) && jldp_can_interfere_with tsk tsk_other &&
                                (minn (x tsk_other) (R - task_cost tsk + 1)  >
                                interference_bound tsk_other R_other))
                           rt_bounds).
          {
            apply/negP; unfold not; intro NOTHAS.
            move: NOTHAS => /negP /hasPn ALL.
            rewrite -[_ < _]negbK in SUM.
            move: SUM => /negP SUM; apply SUM; rewrite -leqNgt.
            unfold I, total_interference_bound_edf.
            rewrite big_seq_cond [\sum_(_ <- _ | let _ := _ in _)_]big_seq_cond.
            apply leq_sum; move => tsk_k /andP [INBOUNDSk INTERFk]; destruct tsk_k as [tsk_k R_k].
            specialize (ALL (tsk_k, R_k) INBOUNDSk).
            unfold interference_bound_edf; simpl in *.
            rewrite leq_min; apply/andP; split.
            {
              unfold interference_bound; rewrite leq_min; apply/andP; split;
                last by rewrite geq_minr.
              by apply leq_trans with (n := x tsk_k);
                [by rewrite geq_minl | by apply BOUND].
            }
            {
              apply leq_trans with (n := x tsk_k); first by rewrite geq_minl.
              by apply EDFBOUND.
            }
          }
          move: HAS => /hasP HAS; destruct HAS as [[tsk_k R_k] HPk MIN].
          move: MIN => /andP [/andP [INts INTERFk] MINk].
          by exists tsk_k, R_k; repeat split.
        Qed.

      End DerivingContradiction.

    End Lemmas.

    Section MainProof.

      (* Let (tsk, R) be any task to be analyzed, with its response-time bound R. *)
      Variable tsk: sporadic_task.
      Variable R: time.
      Hypothesis H_tsk_R_in_rt_bounds: (tsk, R) \in rt_bounds.

      (* Using the lemmas above, we prove that R bounds the response time of task tsk. *)
      Theorem bertogna_cirinei_response_time_bound_edf :
        response_time_bounded_by tsk (task_jitter tsk + R).
      Proof.
        have EXISTS := bertogna_edf_exists_task_that_exceeds_bound.
        have BASICBOUND := bertogna_edf_workload_bounds_interference.
        have EDFBOUND := bertogna_edf_specific_bound_holds.
        rename H_valid_job_parameters into JOBPARAMS.
        unfold valid_sporadic_job_with_jitter, valid_sporadic_job in *.
        intros j JOBtsk.

        rewrite addnA.
        (* First, rewrite the claim in terms of the *absolute* response-time bound (arrival + R) *)
        remember (job_arrival j + task_jitter tsk + R) as ctime.

        revert H_tsk_R_in_rt_bounds.
        generalize dependent R; generalize dependent tsk; generalize dependent j.

        (* Now, we apply strong induction on the absolute response-time bound. *)
        induction ctime as [ctime IH] using strong_ind.

        intros j tsk' JOBtsk R' EQc INbounds; subst ctime.

        (* First, let's simplify the induction hypothesis. *)
        assert (BEFOREok: forall (j0: JobIn arr_seq) tsk R0,
                                 job_task j0 = tsk ->
                               (tsk, R0) \in rt_bounds ->
                               job_arrival j0 + task_jitter tsk + R0 < job_arrival j + task_jitter tsk' + R' ->
                               service sched j0 (job_arrival j0 + task_jitter tsk + R0) == job_cost j0).
        {
            by ins; apply IH with (tsk := tsk0) (R := R0).
        }
        clear IH.

        (* The proof follows by contradiction. Assume that job j does not complete by its
           response-time bound. By the induction hypothesis, all jobs with absolute
           response-time bound t < (job_arrival j + R) have correct response-time bounds. *)
        destruct (completed job_cost sched j (job_arrival j + job_jitter j + R')) eqn:NOTCOMP.
        {
          apply completion_monotonic with (t := job_arrival j + job_jitter j + R'); try (by done).
          rewrite leq_add2r leq_add2l.
          specialize (JOBPARAMS j); des.
          by rewrite -JOBtsk; apply JOBPARAMS0.
        }
        apply negbT in NOTCOMP; exfalso.

        (* Next, we derive a contradiction using the previous lemmas. *)
        exploit (EXISTS tsk' R' INbounds j JOBtsk NOTCOMP).
        {
          by ins; apply IH with (tsk := tsk_other) (R := R_other).
        }
        intro EX; destruct EX as [tsk_other [R_other [HP LTmin]]].
        unfold interference_bound_edf, interference_bound_generic in LTmin.
        rewrite minnAC in LTmin; apply min_lt_same in LTmin.
        specialize (BASICBOUND tsk' R' j JOBtsk BEFOREok tsk_other R_other HP).
        specialize (EDFBOUND tsk' R' INbounds j JOBtsk BEFOREok tsk_other R_other HP).
        unfold minn in LTmin; clear -LTmin HP BASICBOUND EDFBOUND tsk; desf.
        {
          by apply (leq_ltn_trans BASICBOUND) in LTmin; rewrite ltnn in LTmin.
        }
        {
          by apply (leq_ltn_trans EDFBOUND) in LTmin; rewrite ltnn in LTmin.
        }
      Qed.

    End MainProof.

  End ResponseTimeBound.

End ResponseTimeAnalysisEDFJitter.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Field.Interface.Representation.
Require Import Crypto.Bedrock.Field.Synthesis.New.ComputedOp.
Require Import Crypto.Bedrock.Field.Synthesis.New.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults32.
Require Import Crypto.Bedrock.Specs.Field.
Import ListNotations.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.Syntax.
Local Open Scope string_scope.
Local Infix "*" := sep : sep_scope.
Delimit Scope sep_scope with sep.
Local Notation function_t := ((String.string * (list String.string * list String.string * Syntax.cmd.cmd))%type).
Local Notation functions_t := (list function_t).
Local Open Scope sep_scope.

(* Parameters for p224 field. *)
Section Field.
  Definition n : nat := 4.
  Definition m : Z := (2^224 - 2^96 + 1)%Z.

  Existing Instances Defaults32.default_parameters
           Defaults32.default_parameters_ok.
  Existing Instances no_select_size split_mul_to split_multiret_to.
  Definition prefix : string := "p224_"%string.

  (* Define p224 field *)
  Instance field_parameters : FieldParameters.
  Proof using Type.
    let M := (eval vm_compute in (Z.to_pos (m))) in
    (* curve 'A' parameter *)
    let a := constr:(F.of_Z M (m - 3)) in
    let prefix := constr:("p224_felem_"%string) in
    eapply
      (field_parameters_prefixed
         M ((a - F.of_Z _ 2) / F.of_Z _ 4)%F prefix).
  Defined.

  Definition to_mont_string := prefix ++ "to_mont".
  Definition from_mont_string := prefix ++ "from_mont".

  (* Call fiat-crypto pipeline on all field operations *)
  Instance p224_ops : @word_by_word_Montgomery_ops from_mont_string to_mont_string _ _ _ _ _ _ _ _ _ _ _ (WordByWordMontgomery.n m machine_wordsize) m.
  Proof using Type. Time constructor; make_computed_op. Defined.

  (**** Translate each field operation into bedrock2 and apply bedrock2 backend
        field pipeline proofs to prove the bedrock2 functions are correct. ****)

        Local Ltac begin_derive_bedrock2_func :=
        lazymatch goal with
        | |- context [spec_of_BinOp bin_mul] => eapply mul_func_correct
        | |- context [spec_of_UnOp un_square] => eapply square_func_correct
        | |- context [spec_of_BinOp bin_add] => eapply add_func_correct
        | |- context [spec_of_BinOp bin_sub] => eapply sub_func_correct
        | |- context [spec_of_UnOp un_opp] => eapply opp_func_correct
        (* | |- context [spec_of_UnOp un_scmula24] => eapply scmula24_func_correct *)
        | |- context [spec_of_from_bytes] => eapply from_bytes_func_correct
        | |- context [spec_of_to_bytes] => eapply to_bytes_func_correct
        end.

      Ltac derive_bedrock2_func op :=
        begin_derive_bedrock2_func;
        (* this goal fills in the evar, so do it first for [abstract] to be happy *)
        try lazymatch goal with
            | |- _ = b2_func _ => vm_compute; reflexivity
            end;
        (* solve all the remaining goals *)
        lazymatch goal with
        | |- _ = @ErrorT.Success ?ErrT unit tt =>
          abstract (vm_cast_no_check (@eq_refl _ (@ErrorT.Success ErrT unit tt)))
        | |- Func.valid_func _ =>
          eapply Func.valid_func_bool_iff;
          abstract vm_cast_no_check (eq_refl true)
        | |- (_ = _)%Z => vm_compute; reflexivity
        end.

  Derive p224_from_bytes
         SuchThat (forall functions,
                      spec_of_from_bytes
                        (field_representation:=field_representation_raw m)
                        (p224_from_bytes :: functions))
         As p224_from_bytes_correct.
  Proof. Time derive_bedrock2_func from_bytes_op. Qed.

  Derive p224_to_bytes
         SuchThat (forall functions,
                      spec_of_to_bytes
                        (field_representation:=field_representation_raw m)
                        (p224_to_bytes :: functions))
         As p224_to_bytes_correct.
  Proof. Time derive_bedrock2_func to_bytes_op. Qed.

  Derive p224_mul
         SuchThat (forall functions,
                      spec_of_BinOp bin_mul
                        (field_representation:=field_representation m)
                        (p224_mul :: functions))
         As p224_mul_correct.
  Proof. Time derive_bedrock2_func mul_op. Qed.

  Derive p224_square
         SuchThat (forall functions,
                      spec_of_UnOp un_square
                        (field_representation:=field_representation m)
                        (p224_square :: functions))
         As p224_square_correct.
  Proof. Time derive_bedrock2_func square_op. Qed.

  Derive p224_add
         SuchThat (forall functions,
                      spec_of_BinOp bin_add
                        (field_representation:=field_representation m)
                        (p224_add :: functions))
         As p224_add_correct.
  Proof. Time derive_bedrock2_func add_op. Qed.

  Derive p224_sub
         SuchThat (forall functions,
                      spec_of_BinOp bin_sub
                        (field_representation:=field_representation m)
                        (p224_sub :: functions))
         As p224_sub_correct.
  Proof. Time derive_bedrock2_func sub_op. Qed.

  (*TODO: adapt derive_bedrock2_func to also derive the remaining functions.*)
  Derive p224_from_mont
         SuchThat (forall functions,
                      spec_of_UnOp un_from_mont
                        (field_representation:=field_representation m)
                        (p224_from_mont :: functions))
         As p224_from_mont_correct.
  Proof.
    eapply (from_mont_func_correct _ _ _ from_mont_string to_mont_string); auto.
        - vm_compute; reflexivity.
        - eapply Func.valid_func_bool_iff. abstract vm_cast_no_check (eq_refl true).
          Unshelve.
            + auto.
            + auto.
  Qed.

  Derive p224_to_mont
         SuchThat (forall functions,
                      spec_of_UnOp un_to_mont
                        (field_representation:=field_representation m)
                        (p224_to_mont :: functions))
         As to_from_mont_correct.
  Proof.
    eapply (to_mont_func_correct _ _ _ from_mont_string to_mont_string); auto.
        - vm_compute; reflexivity.
        - eapply Func.valid_func_bool_iff. abstract vm_cast_no_check (eq_refl true).
          Unshelve. all: auto.
     Qed.

  Derive p224_select_znz
           SuchThat (forall functions,
                      spec_of_selectznz
                        (field_representation:=field_representation m)
                        (p224_select_znz :: functions))
         As select_znz_correct.
  Proof.
    eapply select_znz_func_correct; auto.
        - vm_compute; reflexivity.
        - eapply Func.valid_func_bool_iff. abstract vm_cast_no_check (eq_refl true).
     Qed.
End Field.


Require Import HoTT.Types.Universe.
Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.naturals
  HoTT.Classes.theory.rings
  HoTT.Classes.implementations.peano_naturals.
Require Export
  HoTT.Classes.orders.semirings.

Generalizable Variables N R f.

Section Univ.
Context `{Funext} `{Univalence}.

(*
We axiomatize the order on the naturals and the integers as a non trivial
pseudo semiring order that satisfies the biinduction principle. We prove
some results that hold for the order on the naturals and the integers.
In particular, we show that given another non trivial pseudo semiring order
(that not necessarily has to satisfy the biinduction principle, for example
the rationals or the reals), any morphism to it is an order embedding.
*)
Lemma to_semiring_nonneg `{FullPseudoSemiRingOrder N}
  `{!NaturalsToSemiRing N} `{!Naturals N} `{FullPseudoSemiRingOrder R}
  `{!IsSemiRing R}
  `{!IsSemiRingPreserving (f : N -> R)} n : 0 ≤ f n.
Proof.
revert n. apply naturals.induction.
- rewrite (preserves_0 (f:=f)).
  reflexivity.
- intros n E.
  rewrite (preserves_plus (f:=f)), (preserves_1 (f:=f)).
  apply nonneg_plus_compat.
  + solve_propholds.
  + trivial.
Qed.

Section nat_int_order.
Context `{Naturals N} `{Apart N} `{Le N} `{Lt N} `{!FullPseudoSemiRingOrder le lt}
  `{FullPseudoSemiRingOrder R} `{!IsSemiRing R}
  `{!Biinduction R} `{PropHolds (1 ≶ 0)}.

(* Add Ring R : (stdlib_semiring_theory R). *)

Lemma nat_int_to_semiring : forall x : R, exists z, x = naturals_to_semiring N R z |_|
  (x + naturals_to_semiring N R z)%mc = 0.
Proof.
apply biinduction.
- exists 0.
  left. symmetry. apply preserves_0.
- intros. split;intros E.
  + destruct E as [z [E|E]].
    * exists (1+z).
      left. rewrite E.
      rewrite (preserves_plus (f:=naturals_to_semiring N R)),
      (preserves_1 (f:=naturals_to_semiring N R)). reflexivity.
    * destruct (naturals.case z) as [Ez|[z' Ez]].
      ** rewrite Ez in *.
         rewrite (preserves_0 (A:=N)),plus_0_r in E.
         rewrite E. exists 1. left.
         rewrite (preserves_1 (A:=N)),plus_0_r. reflexivity.
      ** rewrite Ez in *;clear z Ez.
         exists z';right.
         path_via (n + naturals_to_semiring N R (1 + z')).
         clear E. rewrite (preserves_plus (A:=N)),(preserves_1 (A:=N)).
         rewrite plus_assoc,(plus_comm n);reflexivity.
  + destruct E as [z [E|E]].
    * destruct (naturals.case z) as [Ez|[z' Ez]];rewrite Ez in *;clear z Ez.
      ** exists 1;right.
         rewrite (preserves_1 (A:=N)),plus_comm,E.
         apply preserves_0.
      ** exists z';left.
         rewrite (preserves_plus (A:=N)),(preserves_1 (A:=N)) in E.
         apply (left_cancellation plus 1). trivial.
    * exists (1+z).
      right. rewrite (preserves_plus (A:=N)), (preserves_1 (A:=N)),<-E.
      rewrite plus_assoc,(plus_comm n);reflexivity.
Qed.

Lemma nat_int_nonneg_decompose x : 0 ≤ x -> exists z, x = naturals_to_semiring N R z.
Proof.
destruct (nat_int_to_semiring x) as [z [Ez1 | Ez2]].
- exists z. trivial.
- intros E. exists 0. rewrite (preserves_0 (A:=N)).
  apply (antisymmetry (≤)); trivial.
  rewrite <-Ez2. apply nonneg_plus_le_compat_r.
  apply to_semiring_nonneg.
Qed.

Lemma nat_int_le_plus x y : x ≤ y <-> exists z, y = x + naturals_to_semiring N R z.
Proof.
split.
- intros E. destruct (decompose_le E) as [z [Ez1 Ez2]].
  destruct (nat_int_nonneg_decompose _ Ez1) as [u Eu].
  exists u. rewrite <-Eu. trivial.
- intros [z Ez]. rewrite Ez.
  apply nonneg_plus_le_compat_r, to_semiring_nonneg.
Qed.

Lemma nat_int_lt_plus x y : x < y <-> exists z, y = x + 1 + naturals_to_semiring N R z.
Proof.
split.
- intros E.
  destruct ((fst (nat_int_le_plus x y) (lt_le _ _ E))) as [z0 Ez].
  destruct (naturals.case z0) as [E1|[z E1]];rewrite E1 in *;clear z0 E1.
  + rewrite preserves_0, plus_0_r in Ez.
    destruct (lt_ne_flip x y);trivial.
  + exists z.
    rewrite (preserves_plus (A:=N)), preserves_1, plus_assoc in Ez.
    trivial.
- intros [z Ez]. rewrite Ez.
  apply nonneg_plus_lt_compat_r.
  + apply to_semiring_nonneg.
  + apply pos_plus_lt_compat_r; solve_propholds.
Qed.

Lemma lt_iff_plus_1_le x y : x < y <-> x + 1 ≤ y.
Proof.
etransitivity.
- apply nat_int_lt_plus.
- apply symmetry,nat_int_le_plus.
Qed.

Lemma lt_iff_S_le x y : x < y <-> 1 + x ≤ y.
Proof.
rewrite plus_comm. apply lt_iff_plus_1_le.
Qed.

Lemma pos_ge_1 x : 0 < x <-> 1 ≤ x.
Proof.
split; intros E.
- rewrite <-(plus_0_l 1). apply lt_iff_plus_1_le. trivial.
- apply lt_le_trans with 1; [solve_propholds | trivial].
Qed.

Lemma le_iff_lt_plus_1 x y : x ≤ y <-> x < y + 1.
Proof.
split; intros E.
- apply lt_iff_plus_1_le. apply (order_preserving (+1)). trivial.
- apply (order_reflecting (+1)), lt_iff_plus_1_le. trivial.
Qed.

Lemma le_iff_lt_S x y : x ≤ y <-> x < 1 + y.
Proof. rewrite plus_comm. apply le_iff_lt_plus_1. Qed.

Section another_semiring.
  Context `{FullPseudoSemiRingOrder R2} `{!IsSemiRing R2}
    `{PropHolds ((1 : R2) ≶ 0)}
    `{!IsSemiRingPreserving (f : R -> R2)}.

  Instance: OrderPreserving f.
  Proof.
  repeat (split; try apply _).
  intros x y E. apply nat_int_le_plus in E. destruct E as [z E].
  rewrite E, (preserves_plus (f:=f)), (naturals.to_semiring_twice f _ _).
  apply nonneg_plus_le_compat_r. apply to_semiring_nonneg.
  Qed.

  Global Instance: StrictlyOrderPreserving f | 50.
  Proof.
  repeat (split; try apply _).
  intros x y E. apply nat_int_lt_plus in E. destruct E as [z E].
  rewrite E, !(preserves_plus (f:=f)), preserves_1,
  (naturals.to_semiring_twice f _ _).
  apply nonneg_plus_lt_compat_r.
  - apply to_semiring_nonneg.
  - apply pos_plus_lt_compat_r; solve_propholds.
  Qed.

  Global Instance nat_morphism_order_embedding : OrderEmbedding f | 50.
  Proof. split; try apply _. apply full_pseudo_order_reflecting. Qed.
End another_semiring.
End nat_int_order.
End Univ.


Require Import
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.Common.Compose.

Definition composeIf E B
           (monoid : Monoid B)
           (iComp : Comp bool)
           (formatT : E -> Comp (B * E))
           (formatE : E -> Comp (B * E))
           (e : E)
  := b <- iComp;
       If b Then formatT e
          Else formatE e.

Notation "'Either' t 'Or' e " :=
  (composeIf _ _ _ { _ : bool | True} t e) : format_scope.

Lemma composeIf_format_correct
      {A B}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_invT P_invE : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_invT P /\ P_invE P))
      (monoid : Monoid B)
      (predicate : A -> Prop)
      (predicate_rest : A -> B -> Prop)
      (ICompb : B -> bool)
      (formatT : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeT : B -> CacheDecode -> option (A * B * CacheDecode))
      (formatE : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeE : B -> CacheDecode -> option (A * B * CacheDecode))
      (decodeT_pf :
         cache_inv_Property P P_invT
         -> CorrectDecoder
              monoid predicate predicate_rest
              formatT decodeT P)
      (decodeE_pf :
         cache_inv_Property P P_invE
         -> CorrectDecoder
              monoid predicate predicate_rest
              formatE decodeE P)
      (ICompb_OKT : forall data bin env xenv ext,
          predicate data
          -> formatT data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = true)
      (ICompb_OKE : forall data bin env xenv ext,
          predicate data
          -> formatE data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = false)
  : CorrectDecoder
      monoid
      (fun a => predicate a)
      predicate_rest
      (fun (data : A) =>
         composeIf _ _ _ {b : bool | True }
                   (formatT data)
                   (formatE data)
      )%comp
      (fun (b : B) (env : CacheDecode) =>
         If ICompb b Then
            decodeT b env
            Else
            decodeE b env
      ) P.
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm pred_pm_rest com_pf.
    unfold composeIf, Bind2 in com_pf; computes_to_inv; destruct v;
      simpl in com_pf'; computes_to_inv.
    - erewrite ICompb_OKT; eauto.
      simpl; eapply decodeT_pf; intuition eauto.
    - erewrite ICompb_OKE; eauto.
      simpl; eapply decodeE_pf; intuition eauto.
  }
  { intros.
    destruct (ICompb bin) eqn : IComp_v ; simpl in *.
    - eapply decodeT_pf in H1; intuition eauto.
      destruct_ex; intuition; eexists; eexists;
        unfold composeIf; intuition eauto.
      refine pick val true; eauto.
    - eapply decodeE_pf in H1; intuition eauto.
      destruct_ex; intuition; eexists; eexists;
        unfold composeIf; intuition eauto.
      refine pick val false; eauto. }
Qed.

Definition composeIf' E B
           (monoid : Monoid B)
           (format1 : E -> Comp (B * E))
           (format2 : E -> Comp (B * E))
           (iComp : Comp bool)
           (formatT : E -> Comp (B * E))
           (formatE : E -> Comp (B * E))
  :=
    (fun e0 =>
         b <- iComp;
           If b Then
              `(p, e1) <- format1 e0;
            `(q, e2) <- formatT e1;
            ret (mappend p q, e2)
                Else (`(p, e1) <- format2 e0;
                      `(q, e2) <- formatE e1;
                      ret (mappend p q, e2))
    )%comp.

Lemma composeIf'_format_correct
      {A A' B}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_inv1 P_invT P_invE : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_invT P /\ P_invE P))
      (monoid : Monoid B)
      (projectT : A -> A')
      (projectE : A -> A')
      (predicate : A -> Prop)
      (predicate_rest : A' -> B -> Prop)
      (predicate_rest' : A -> B -> Prop)
      (predicate' : A' -> Prop)
      (format1 : A' -> CacheFormat -> Comp (B * CacheFormat))
      (decode1 : B -> CacheDecode -> option (A' * B * CacheDecode))
      (ICompb : A' -> bool)
      (formatT : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeT : A' -> B -> CacheDecode -> option (A * B * CacheDecode))
      (formatE : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeE : A' -> B -> CacheDecode -> option (A * B * CacheDecode))
      (decode1_pf :
         cache_inv_Property P P_inv1
         -> CorrectDecoder
              monoid predicate' predicate_rest
              format1 decode1 P)
      (decodeT_pf : forall proj,
          ICompb proj = true ->
          predicate' proj ->
          cache_inv_Property P P_invT ->
          CorrectDecoder
            monoid
            (fun data => predicate data /\ projectT data = proj)
            predicate_rest'
            formatT
            (decodeT proj) P)
      (decodeE_pf : forall proj,
          ICompb proj = false ->
          predicate' proj ->
          cache_inv_Property P P_invE ->
          CorrectDecoder
            monoid
            (fun data => predicate data /\ projectE data = proj)
            predicate_rest'
            formatE
            (decodeE proj) P)
      (predicate_rest_implT : forall a' b b'',
          (ICompb a' = true /\
           exists a ce ce' ce'' b' b'',
             computes_to (format1 a' ce) (b', ce')
             /\ projectT a = a'
             /\ predicate a
             /\ computes_to (formatT a ce') (b'', ce'')
             /\ predicate_rest' a b)
          -> predicate_rest a' (mappend b'' b))
      (predicate_rest_implE : forall a' b b'',
          (ICompb a' = false /\
           exists a ce ce' ce'' b',
             computes_to (format1 a' ce) (b', ce')
             /\ projectE a = a'
             /\ predicate a
             /\ computes_to (formatE a ce') (b'', ce'')
             /\ predicate_rest' a b)
          -> predicate_rest a' (mappend b'' b))
      (pred_pf : forall data, predicate data -> predicate' (projectT data))
      (pred_pf' : forall data, predicate data -> predicate' (projectE data))
      (ICombT_OK : forall data, ICompb (projectT data) = true)
      (ICombE_OK : forall data, ICompb (projectE data) = false)
  : CorrectDecoder
      monoid
      (fun a => predicate a)
      predicate_rest'
      (fun (data : A) (ctx : CacheFormat) =>
         composeIf' _ _ _ (format1 (projectT data))
                   (format1 (projectE data)) {b : bool | True } (formatT data) (formatE data)  ctx
      )%comp
      (fun (bin : B) (env : CacheDecode) =>
         `(proj, rest, env') <- decode1 bin env;
           If ICompb proj Then
              decodeT proj rest env'
              Else
              decodeE proj rest env'
      ) P.
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm pred_pm_rest com_pf.
    unfold composeIf', Bind2 in com_pf; computes_to_inv; destruct v;
      simpl in com_pf'; computes_to_inv; destruct v; destruct v0;
        simpl in com_pf'', com_pf'''.
    - injections.
      destruct (fun H => proj1 (decode1_pf (proj1 P_inv_pf)) _ _ _ _ _ (mappend b0 ext) env_OK env_pm (pred_pf _ pred_pm) H com_pf'); intuition; simpl in *; injections.
      eapply predicate_rest_implT; repeat eexists; intuition eauto.
      destruct (fun H' => proj1 (decodeT_pf (projectT data) (ICombT_OK data) (pred_pf _ pred_pm)
                                            H)
                                _ _ _ _ _ ext H5 H1 (conj pred_pm (eq_refl _)) H' com_pf'');
        intuition; simpl in *; injections.
      setoid_rewrite <- mappend_assoc; rewrite H2.
      intuition; simpl in *; injections.
      rewrite ICombT_OK, H7; simpl; eauto.
    - injections.
      destruct (fun H' => proj1 (decode1_pf (proj1 P_inv_pf)) _ _ _ _ _ (mappend b0 ext) env_OK env_pm (pred_pf' _ pred_pm) H' com_pf'); intuition; simpl in *; injections.
      eapply predicate_rest_implE; intuition; repeat eexists; intuition eauto.
      destruct (fun H' => proj1 (decodeE_pf (projectE data) (ICombE_OK data) (pred_pf' _ pred_pm)
                                            H4)
                                _ _ _ _ _ ext H5 H1 (conj pred_pm (eq_refl _)) H' com_pf'');
        intuition; simpl in *; injections.
      setoid_rewrite <- mappend_assoc; rewrite H2.
      intuition; simpl in *; injections.
      rewrite ICombE_OK, H7; simpl; eauto.
  }
  { intros.
    destruct (decode1 bin env') as [ [ [? ?] ? ] | ] eqn : ? ;
      simpl in *; try discriminate.
    destruct (ICompb a) eqn: ?; simpl in *.
    - eapply (proj2 (decode1_pf (proj1 P_inv_pf))) in Heqo; eauto;
        destruct Heqo; destruct_ex; intuition;
          eapply (proj2 (decodeT_pf a Heqb0 H7 H3)) in H1; eauto;
            destruct H1; destruct_ex; intuition; subst.
      eexists; eexists; repeat split.
      unfold composeIf'; refine pick val true.
      repeat computes_to_econstructor; eauto.
      eauto.
      simpl; rewrite mappend_assoc; reflexivity.
      eassumption.
      eassumption.
    - eapply (proj2 (decode1_pf (proj1 P_inv_pf))) in Heqo; eauto;
        destruct Heqo; destruct_ex; intuition;
          eapply (proj2 (decodeE_pf a Heqb0 H7 H8)) in H1; eauto;
            destruct H1; destruct_ex; intuition; subst.
      eexists; eexists; repeat split.
      unfold composeIf'; refine pick val false.
      repeat computes_to_econstructor; eauto.
      eauto.
      simpl; repeat computes_to_econstructor; eauto.
      simpl; rewrite mappend_assoc; reflexivity.
      eassumption.
      eassumption.
  }
Qed.


From solutions Require Export sem_type_formers.

(** * The semantic typing judgment *)

(** We define the judgment [Γ ⊨ e : A] for semantic typing of the expression [e]
at semantic type [A], assuming that free variables in [e] belong to the semantic
types described by [Γ]. This notion is defined as follows:

- We define the semantic typing relation [env_sem_typed] for typing contexts:
  An environments (mappings from free variables to values) [vs] is in the
  semantic type for a typing context [Γ], [env_sem_typed Γ vs], if for any free
  variable [x], [vs(x)] is in the semantic type [Γ(x)].
- The semantic typing judgment [Γ ⊨ e : A] holds if for any environment [vs]
  such that [env_sem_typed Γ vs] we have that [subst_map vs e] is an expression
  in the semantics of type [A], i.e., [WP subst_map vs e {{ A }}] holds. *)

(** The semantic type for the typing context (environment). *)
Definition env_sem_typed `{!heapG Σ} (Γ : gmap string (sem_ty Σ))
    (vs : gmap string val) : iProp Σ :=
  ([∗ map] i ↦ A;v ∈ Γ; vs, sem_ty_car A v)%I.
Instance: Params (@env_sem_typed) 2 := {}.

(** The semantics typing judgment. *)
Definition sem_typed `{!heapG Σ}
    (Γ : gmap string (sem_ty Σ)) (e : expr) (A : sem_ty Σ) : iProp Σ :=
  tc_opaque (□ ∀ vs,
    env_sem_typed Γ vs -∗ WP subst_map vs e {{ A }})%I.
Instance: Params (@sem_typed) 2 := {}.
Notation "Γ ⊨ e : A" := (sem_typed Γ e A)
  (at level 74, e, A at next level) : bi_scope.

Definition sem_val_typed `{!heapG Σ} (v : val) (A : sem_ty Σ) : iProp Σ :=
  tc_opaque (A v).
Instance: Params (@sem_val_typed) 3 := {}.
Notation "⊨ᵥ v : A" := (sem_val_typed v A)
  (at level 20, v, A at next level) : bi_scope.
Arguments sem_val_typed : simpl never.

(** A few useful lemmas about the semantic typing judgment. The first
few lemmas involving [Proper]ness are boilerplate required for supporting setoid
rewriting. *)
Section sem_typed.
  Context `{!heapG Σ}.
  Implicit Types A B : sem_ty Σ.
  Implicit Types C : sem_ty Σ → sem_ty Σ.

  Global Instance env_sem_typed_ne n :
    Proper (dist n ==> (=) ==> dist n) (@env_sem_typed Σ _).
  Proof.
    intros Γ1 Γ2 HΓ ρ ? <-.
    apply big_sepM2_ne_2=> // k A1 v1 A2 v2 _ _ HA _ _ /discrete_iff / leibniz_equiv_iff ->.
    by apply HA.
  Qed.
  Global Instance env_sem_typed_proper :
    Proper ((≡) ==> (=) ==> (≡)) (@env_sem_typed Σ _).
  Proof. intros Γ1 Γ2 HΓ ρ ? <-. apply equiv_dist=> n. f_equiv. by rewrite HΓ. Qed.

  Global Instance sem_typed_ne n :
    Proper (dist n ==> (=) ==> dist n ==> dist n) (@sem_typed Σ _).
  Proof. solve_proper. Qed.
  Global Instance sem_typed_proper :
    Proper ((≡) ==> (=) ==> (≡) ==> (≡)) (@sem_typed Σ _).
  Proof. solve_proper. Qed.

  Global Instance sem_typed_persistent Γ e A : Persistent (Γ ⊨ e : A).
  Proof. rewrite /sem_typed /=. apply _. Qed.

  Global Instance sem_val_typed_ne v : NonExpansive (@sem_val_typed Σ _ v).
  Proof. solve_proper. Qed.
  Global Instance sem_val_typed_proper v :
    Proper ((≡) ==> (≡)) (@sem_val_typed Σ _ v).
  Proof. solve_proper. Qed.

  Global Instance sem_val_typed_persistent v A : Persistent (⊨ᵥ v : A).
  Proof. rewrite /sem_val_typed /=. apply _. Qed.

  (* Environments *)
  Lemma env_sem_typed_lookup Γ vs x A :
    Γ !! x = Some A →
    env_sem_typed Γ vs -∗ ∃ v, ⌜ vs !! x = Some v ⌝ ∧ A v.
  Proof.
    iIntros (HΓx) "HΓ". rewrite /env_sem_typed.
    by iApply (big_sepM2_lookup_1 with "HΓ").
  Qed.
  Lemma env_sem_typed_insert Γ vs x A v :
    A v -∗ env_sem_typed Γ vs -∗
    env_sem_typed (binder_insert x A Γ) (binder_insert x v vs).
  Proof.
    destruct x as [|x]=> /=; first by auto. rewrite /env_sem_typed.
    iIntros "#HA #HΓ". by iApply (big_sepM2_insert_2 with "[] HΓ").
  Qed.

  Lemma env_sem_typed_empty : ⊢ env_sem_typed ∅ ∅.
  Proof. iIntros "". by rewrite /env_sem_typed. Qed.
  Lemma env_sem_typed_empty_l_inv vs : env_sem_typed ∅ vs -∗ ⌜vs = ∅⌝.
  Proof. by iIntros "?"; iApply big_sepM2_empty_r. Qed.
End sem_typed.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import ssralg poly polydiv polyorder ssrnum zmodp.
From mathcomp Require Import polyrcf qe_rcf_th complex.
Require Import poly_normal pol.

(*
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)
*)

Set Implicit Arguments.
Unset Strict Implicit.

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

Local Open Scope ring_scope.

Section about_nonneg.

Variable R : rcfType.

Local Notation C := (complex R).

Definition nonneg (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. exact/all_nthP. Qed.

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

Import complex.

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.
by rewrite nmulr_rge0 ?oppr_lt0 ?ltr0n // addr_ge0 // sqr_ge0.
Qed.

Lemma nonneg_mulr (p q : {poly R}) : nonneg p -> nonneg q -> nonneg (p * q).
Proof.
have [->|Hpsize] := eqVneq p 0; first by rewrite mul0r.
have [->|Hqsize Hp Hq] := eqVneq q 0; first by rewrite mulr0.
apply/nonnegP => k lpq.
rewrite coef_mul_poly /= sumr_ge0 // => i _.
apply: mulr_ge0.
  have [Hi2|Hi2] := ltnP i (size p); first exact/nonnegP.
  by rewrite -(coefK p) coef_poly ltnNge Hi2.
have [Hi2|Hi2] := ltnP (k - i) (size q); first exact/nonnegP.
by rewrite -(coefK q) coef_poly ltnNge Hi2.
Qed.

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

Lemma nonneg_root_nonpos (p : {poly R}) : p \is monic ->
   (forall z : C, root (toC p) z -> (Re z <= 0)) -> nonneg p.
Proof.
move=> 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 // lt_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.
have [Himx|Himx] := altP (Im x =P 0).
(* 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%N.
  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).
  + by rewrite Hproots // (eqP Hp) rmorphM rootM Hz.
by rewrite nonneg_poly_deg2 (Hproots _ Hrootx).
Qed.

Lemma nonneg_changes0 (s : seq R) : nonneg s -> changes s = 0%N.
Proof.
elim: s => [ |a ] //.
case=> [_ _ |b l IHbl /andP [] Ha Hblnonneg].
  by rewrite /= mulr0 addn0 ltxx.
have /andP[Hb Hlnonneg] := Hblnonneg.
apply/eqP; rewrite addn_eq0 eqb0 -leNgt 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 ?unitfE//.
by rewrite mulrI_eq0 //; apply/lregX/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.
*)

(* TODO(rei): define as an instance of Mobius in pol.v? *)
Definition Mobius' (R : ringType) (p : {poly R}) (a b : R) : {poly R} :=
(*  Mobius (size p).-1 a b p.? *)
  reciprocal_pol ((p \shift a) \scale (b - a)) \shift 1.

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 Mobius'M (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%N.
  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 pdivmu0_0th_neq0 (p : {poly R}) : p != 0 -> (p %/ 'X^(\mu_0 p))`_0 != 0.
Proof.
move=> 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 Mobius'0 (p : {poly R}) (a b : R) : a != b ->
  (p == 0) = ((Mobius' p a b) == 0).
Proof.
move=> ab; apply/idP/idP => /eqP 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.

From mathcomp Require Import complex.

Section transformations_in_C.
Local Open Scope complex_scope.

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.
- exact: 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 (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=> 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 (R : rcfType) (p : {poly R}) (a : R) :
  a != 0 ->
  polyseq (a *: p) = seqmul (nseq (size p) a) p.
Proof.
move=> 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 -polyCM.
rewrite -!cons_poly_def !polyseq_cons.
case Hp : (nilp p); last first.
  rewrite ifT; last first.
    rewrite nil_poly in Hp.
    by rewrite nil_poly -mul_polyC mulf_neq0 // ?Hp // polyC_eq0.
  by rewrite seqmul_cons IHp.
rewrite ifF; last first.
  rewrite nil_poly in Hp.
  by rewrite nil_poly -mul_polyC mulf_eq0 Hp orbT.
rewrite /= size_polyC.
have [->|Hc] := eqVneq c 0; first by rewrite mulr0 seqmul0 polyseqC eq_refl.
by rewrite !polyseqC mulf_neq0//= Hc seqmul_cons.
Qed.

Lemma changes_mulC  (R : rcfType) (p : {poly R}) (a : R) : a != 0 ->
   changes p = changes (a *: p).
Proof.
move=> Ha.
rewrite mul_polyC_seqmul //=.
case: p.
elim => [Hs//|b/=].
case => [_ _ |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.
by rewrite (@pmulr_rlt0 _ (a ^+2) (b * c)) // exprn_even_gt0.
Qed.

Section thm_3_cercles_partie1.
Local Open Scope complex_scope.

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 HlrC : l%:C != r%:C.
Proof. by rewrite -!complexr0 eq_complex /= negb_and lt_eqF. 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 lt_neqAle addr_ge0 ?sqr_ge0 // andbT eq_sym 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 (z : C) : z + 1 != 0 ->
   (notinC ((r%:C + l%:C * z) / (z + 1))) = (Re z <= 0).
Proof.
move=> 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 (p : {poly R}) :
   (forall (z : C), root (toC p) z -> (notinC z)) ->
   changes (Mobius' p l r) = 0%N.
Proof.
move=> H.
have [/eqP|Hp0] := eqVneq p 0.
  rewrite (@Mobius'0 _ p l r) ?lt_eqF// => /eqP ->.
  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
       -Mobius'0 ?lt_eqF// 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 -Mobius'0 ?lt_eqF// negbT.
by rewrite invr_eq0 lead_coef_eq0 -Mobius'0 ?lt_eqF// 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 (l r : R) (z : C) :
  (inC1 l r z) || (inC2 l r z) = (inC12 l r z).
Proof. by []. Qed.

Definition inB1 (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 lexx/= (expr2 0) !mulr0.
  by rewrite -eq_le oppr_eq0 -sqrf_eq0 eq_le sqr_ge0 andbT.
rewrite -{1}(sqr_sqrtr (a:=3%:R)); last by apply: ler0n.
rewrite -exprMn -(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 lt_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 (@le_trans _ _ `| b |).
  by rewrite -oppr_ge0 Ha2 /= -(normrN (a-1)) (ger0_norm (x:= -(a-1))).
rewrite exprMn mulr_gt0 // lt_def sqr_ge0.
  by rewrite sqrf_eq0 sqrtr_eq0 -ltNge ltr0n.
by rewrite sqrf_eq0 Ha.
Qed.

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

Lemma Im_invc : forall (z : C), Im z^-1 = (- Im z) / ((Re z) ^+ 2 + (Im z) ^+2).
Proof. by case => a b; 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 -ltNge ltr0n.
rewrite /inC1 /= -leNgt add0r oppr0 mul0r !addr0 !mul1r.
rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA
   exprMn -(mulNr b) exprMn 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))) //.
rewrite -[in x in _ = x](mulNr a) -mulrDl.
rewrite -{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 /= -leNgt add0r oppr0 mul0r !addr0 !mul1r.
rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA
   exprMn -(mulNr b) exprMn 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 lt_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 //
     addr_ge0 // sqr_ge0.
by rewrite invr_gt0 lt_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 //
     addr_ge0 // sqr_ge0.
Qed.

Local Open Scope complex_scope.

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 !exprMn !(mulrA (r - l) _ a) !(mulrA (r - l) _ b)
   -expr2 -(mulrN _ a) -mulrA -(mulrN _ (b / Num.sqrt 3%:R))
    -!(mulrDr ((r - l)^+2)) !negb_or -!leNgt.
by rewrite !pmulr_rge0 // lt_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 -!leNgt.
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 (l r : R) (z : C) : l != r -> z + 1 != 0 ->
  inB z = ~~ inC12 l r ((r%:C + l%:C * z) / (z + 1)).
Proof.
move=> 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.
Proof.
elim => [ | c l IHl a Ha] //.
case : l IHl => [IH |b l IHbl ] //.
  by rewrite /= !mulr0 addn0.
have -> : (changes [::c, b & l]) = ((c * b < 0)%R + changes [:: b & l])%N.
  by [].
rewrite -(IHbl a) //.
suff : ((a * c) * (a * b) < 0) = (c * b < 0) by move=> <-.
rewrite (mulrC a b) -mulrA (mulrC a) -!mulrA -expr2 mulrA.
by rewrite pmulr_llt0 // exprn_even_gt0.
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 (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=> Hpnorootr /andP [] Hal Har Hpnoroota H.
have Hlr : l != r by rewrite lt_eqF// (lt_trans Hal).
have Hal2 : l != a by rewrite negbT // lt_eqF.
have [Hp|Hp] := eqVneq p 0.
  have : false => //.
    by rewrite -(andbN (root p a)) Hpnoroota Hp root0.
have Hlc1 : (lead_coef (Mobius' (R:=R) (p * ('X - a%:P)) l r))^-1 != 0.
  rewrite invr_neq0 // Mobius'M lead_coefM mulf_neq0 //;
  rewrite lead_coef_eq0 -Mobius'0 // negbT //.
  exact: polyXsubC_eq0.
have Hl2 : lead_coef (Mobius' p l r) != 0 by rewrite lead_coef_eq0 -Mobius'0.
rewrite -(@changes_nseq _
   (lead_coef (Mobius' (p * ('X - a%:P)) l r)) ^-1) //
    seqn0_nseq // -mul_polyC_seqmul //.
rewrite Mobius'M lead_coefM -mul_polyC invrM ?unitfE; [ | by [] |]; last first.
  by rewrite lead_coef_eq0 -Mobius'0 // negbT // polyXsubC_eq0.
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) -polyCN.
  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.
    exact/lregP/invr_neq0.
  have [/eqP Hz2|Hz2] := eqVneq (z + 1) 0.
    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.
  by rewrite /= eq_complex negb_and/= invr_neq0.
rewrite rootZ.
  rewrite -root_Mobius'_2; last by rewrite add0r oner_neq0.
  by rewrite mulr0 addr0 add0r invr1 mulr1.
exact: invr_neq0.
Qed.

End thm_3_cercles_partie2.


(* Author: Masaki Hara, 2014 *)
(* Linear Logic Toy for Coq *)
Require Import LType.

(*************************************************)
(*                    Examples                   *)
(*************************************************)

Example LTensorPlusDistr{E:LEnv} (A B C:LType) :
  ILL |- A * (B + C) o-o A * B + A * C.
Proof.
  splitll.
  - introsll x.
    destructll x as [x y].
    destructll y as [y | y].
    + leftll.
      splitll carrying x into 1.
      * applyll x.
      * applyll y.
    + rightll.
      splitll carrying y into 2.
      * applyll x.
      * applyll y.
  - introsll x.
    destructll x as [x | x].
    + destructll x as [x y].
      splitll carrying x into 1.
      * applyll x.
      * leftll; applyll y.
    + destructll x as [x y].
      splitll carrying x into 1; [applyll x|].
      rightll; applyll y.
Defined.

Example LOfcExponentialLaw{E:LEnv} (A B:LType) :
  ILL |- !(A && B) o-o !A * !B.
Proof.
  splitll.
  - introsll x.
    clonell x into y.
    splitll carrying x into 1.
    + splitll.
      destructll x as [x].
      destructll x as [x _].
      applyll x.
    + splitll.
      destructll y as [y].
      destructll y as [_ y].
      applyll y.
  - introsll x.
    destructll x as [x y].
    splitll.
    splitll.
    + clearll y.
      destructll x as [x].
      applyll x.
    + clearll x.
      destructll y as [y].
      applyll y.
Defined.