Require Import
  FormTopC.Cont
  FormTopC.FormTop
  FormTopC.FormalSpace
  Algebra.SetsC
  Algebra.OrderC
  Algebra.PreOrder
  FormTopC.Subspace.

Set Universe Polymorphism.
Local Open Scope Subset.
Local Open Scope FT.

Section Patterns.

Context {S T : FormalSpace.t}.

(** Construct a continuous map by pasting together local
    continuous maps in a sheaf-like manner.

    This will be useful, for instance, for definining
    multiplication of real numbers, where I have a family
    of functions which do bounded multiplication which is
    valid only on a subset of the whole space.

    For now, I am assuming that the map is given for every open
    set. That's valid at least for multiplication, and simplifies things. *)
Section SheafMap.

Variable (f : S -> Cont.map S T).

Inductive f_pasted {t : T} {s : S} : Type :=
  Mkf_pasted : forall s', s <= s' -> f s' t s -> f_pasted.

Arguments f_pasted : clear implicits.

Hypothesis f_cont : forall a, Cont.t S T (f a).
(* Not sure if the following is too strong. *)
Hypothesis f_intersect : forall (a : S) (b c : T),
 f_pasted b a -> f_pasted c a ->
  { t : T & (f_pasted t a * (eq b ↓ eq c) t)%type }.

Existing Instances FormalSpace.FT FormalSpace.PreO
  FormalSpace.Cov_Proper FormalSpace.Cov_Proper2
  FormalSpace.Cov_Proper3.

Lemma Cov_intersect : forall a U, a <|[S] U ->
  a <|[S] ⇓ (eq a) ∩ ⇓ U.
Proof.
intros.
apply FormTop.le_right. apply FormTop.refl. reflexivity. assumption.
Qed.

Theorem cont_f_pasted : Cont.t _ _ f_pasted.
Proof.
constructor; intros.
- pose proof (Cont.here (f_cont a)).
  specialize (X a). apply Cov_intersect in X.
  eapply (FormTop.trans X); clear X; intros.
  destruct X. destruct d, d0. unfold In in i. subst.
  destruct i0. destruct i.
  pose proof (Cont.le_left (f_cont a1)).
  eapply FormTop.le_left. Focus 2.
  apply FormTop.refl. econstructor.
  Focus 2.
  econstructor. 2: eapply X. eassumption. eassumption. eassumption.
  constructor. reflexivity.
- induction X0. pose proof (Cont.le_left (f_cont s')).
   apply (X0 _ _ _ X) in f0.
  econstructor. 2: eassumption. etransitivity; eassumption.
- pose proof (f_intersect a b c X X0).
  destruct X1. destruct p.
  apply FormTop.refl. exists x; eassumption.
- destruct X.
  pose proof (Cont.cov (f_cont s') V f0 X0).
  apply Cov_intersect in X.
  eapply (FormTop.trans X); clear X; intros. destruct X.
  destruct d, d0. unfold In in i. subst. destruct i0.
  apply FormTop.refl. exists a. assumption.
  econstructor. 2: eapply (Cont.le_left (f_cont s')).
  transitivity a1; eassumption. 2: eassumption. eassumption.
Qed.

End SheafMap.

Section Pattern.

Variable Ix : Type.
Variable U : Ix -> Open S.
Variable f : forall i : Ix, Cont.map (OpenSub (U i)) T.
Variable f_cont : forall i : Ix, Cont.t _ _ (f i).

Inductive union_f : Cont.map S T :=
  mk_union_f : forall (i : Ix) s t, f i t s -> union_f t s.

Variable covering : forall a : S, a <|[S] union (fun _ => True) union_f.

(* This is all not exactly right. Need to make sure I saturate
  before taking intersections, saturate before taking
  inclusions of open maps... *)
Variable glue_maps : forall i j : Ix,
  Cont.map (OpenSub (U i ∩ U j)) T.

Hypothesis gluing : forall i j : Ix,
  PreO.max (le := RelIncl) (f i) (f j) (glue_maps i j).

End Pattern.

End Patterns.


Require Import LL.SL.FLL.Specifications.Bipoles.

(** ** Syntax *)
Inductive LKCon := TT | FF.
Inductive LKBin := AND | OR | IMP .
Inductive LKQu := EX | ALL .

#[export]Instance LKSyntax : OLSyntax:=
  {|
    OLType := nat;
    ccon := LKCon;
    ucon := Empty_set;
    bcon := LKBin;
    qcon := Empty_set
  |}.

(** ** Inference rules *)

(** *** Constants *)
Definition LKrulesC (c:ccon) :=
  match c return ruleC with
 | TT => {| rc_rgtBody := Top;
                  rc_lftBody  := Zero |}
 | FF => {| rc_rgtBody := Zero;
                  rc_lftBody  := Top |}

  end.

(** *** Unary connectives *)
Definition LKrulesU  (c:ucon) :=
  match c return ruleU with
  end.

(** *** Binary connectives *)
Definition LKrulesB (c :bcon) :=
  match c with
  | AND => {| rb_rgtBody := fun F G => AAnd  (atom (up F)) (atom (up G) );
                 rb_lftBody  := fun F G => AOr (atom (down F) ) (atom (down G)) |}
  | OR => {| rb_rgtBody := fun F G => AOr  (atom (up F)) (atom (up G) );
              rb_lftBody  := fun F G => AAnd  (atom (down F) ) (atom (down G)) |}
  | IMP => {| rb_rgtBody := fun F G => MOr (atom (down F)) (atom (up G) );
                 rb_lftBody  := fun F G =>MAnd (atom (up F) ) (atom (down G)) |}
  end.

(** *** Quantifiers *)
Definition LKrulesQ (c :qcon) :=
  match c return ruleQ with
 (*  | EX => {| rq_rgtBody := fun FX => Some (fun x => atom (up (FX x)));
                 rq_lftBody  := fun FX => All (fun x => atom (down (FX x)))  |}
  | ALL => {| rq_rgtBody := fun FX => Some (fun x => atom (up (FX x))) ;
              rq_lftBody  := fun FX => All (fun x => atom (down (FX x))) |}
  *) end.

#[export] Instance LKRules : OORules :=
  {|
    rulesC := LKrulesC;
    rulesU := LKrulesU ;
    rulesB := LKrulesB;
    rulesQ := LKrulesQ
  |}.


Definition mygoal :=
  forall x1 x2 x3 x4 : Prop,
    x1 \/ x2 \/ ~ x3 ->
    ~ x1 \/ ~ x2 \/ x3 ->
    x2 \/ x3 \/ ~ x4 ->
    ~ x2 \/ ~ x3 \/ x4 ->
    x1 \/ x3 \/ x4 ->
    ~ x1 \/ ~ x3 \/ ~ x4 ->
    ~ x1 \/ x2 \/ x4 ->
    x1 \/ ~ x2 \/ ~ x4 ->
    False.

Goal mygoal.
Proof.
  unfold mygoal.
  intros *. intros H1 H2 H3 H4 H5 H6 H7 H8.
  assert (H9: x1 \/ x2) by (clear -H1 H3 H5; tauto).
  assert (H10: x1) by (clear -H9 H4 H5 H8; tauto).
  assert (H11: x2) by (clear -H9 H3 H6 H7; tauto).
  assert (H12: False) by (clear -H10 H11 H2 H4 H6; tauto).
  exact H12.
Qed.

Require Import Btauto.
Open Scope bool_scope.

Definition mygoal' :=
  forall x1 x2 x3 x4 : bool,
    (x1 || x2 || negb x3) &&
    (negb x1 || negb x2 || x3) &&
    (x2 || x3 || negb x4) &&
    (negb x2 || negb x3 || x4) &&
    (x1 || x3 || x4) &&
    (negb x1 || negb x3 || negb x4) &&
    (negb x1 || x2 || x4) &&
    (x1 || negb x2 || negb x4)
    = false.

Goal mygoal'.
Proof.
  unfold mygoal'.
  intros *.
  Time btauto. (* Finished transaction in 0.012 secs (0.011u,0.s) (successful) *)
Qed.

Goal mygoal.
Proof.
  unfold mygoal.
  intros *. intros H1 H2 H3 H4 H5 H6 H7 H8.
  Time tauto. (* Finished transaction in 40.578 secs (40.323u,0.052s) (successful) *)
Qed.


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

Module ResponseTimeAnalysisFP.

  Export Job SporadicTaskset ScheduleOfSporadicTask Workload Interference
         InterferenceBoundFP Platform Schedulability ResponseTime
         Priority TaskArrival WorkloadBound ConstrainedDeadlines.

  (* In this section, we prove that any fixed point in Bertogna and
     Cirinei's RTA for FP scheduling is a safe response-time bound.
     This analysis can be found in Chapter 18.2 of Baruah et al.'s
     book Multiprocessor Scheduling for Real-time Systems. *)
  Section ResponseTimeBound.

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

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

    (* Assume any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ... in which jobs arrive sporadically and have valid parameters. *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period job_arrival job_task arr_seq.
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Assume that we have a task set where all tasks have valid
       parameters and constrained deadlines, ... *)
    Variable ts: taskset_of sporadic_task.
    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.

    (* ... and that all jobs in the arrival sequence come from the task set. *)
    Hypothesis H_all_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* Next, consider any schedule such that...*)
    Variable num_cpus: nat.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* ...jobs are sequential and do not execute before their
       arrival times nor longer than their execution costs. *)
    Hypothesis H_sequential_jobs: sequential_jobs sched.
    Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute job_arrival sched.
    Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

    (* Assume that there exists at least one processor. *)
    Hypothesis H_at_least_one_cpu: num_cpus > 0.

    (* Consider a given FP policy, ... *)
    Variable higher_eq_priority: FP_policy sporadic_task.

    (* ... and assume that the schedule is a work-conserving
       schedule that respects this policy. *)
    Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
    Hypothesis H_respects_FP_policy:
      respects_FP_policy job_arrival job_cost job_task arr_seq sched higher_eq_priority.

    (* Let's define some local names to avoid passing many parameters. *)
    Let no_deadline_is_missed_by_tsk (tsk: sporadic_task) :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched tsk.
    Let response_time_bounded_by (tsk: sporadic_task) :=
      is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched tsk.

    (* Next, we consider the response-time recurrence.
       Let tsk be a task in ts that is to be analyzed. *)
    Variable tsk: sporadic_task.
    Hypothesis task_in_ts: tsk \in ts.

    (* Let is_hp_task denote whether a task is a higher-priority task
       (with respect to tsk). *)
    Let is_hp_task := higher_priority_task higher_eq_priority tsk.

    (* Assume a response-time bound is known... *)
    Let task_with_response_time := (sporadic_task * time)%type.
    Variable hp_bounds: seq task_with_response_time.
    Hypothesis H_response_time_of_interfering_tasks_is_known:
      forall hp_tsk R,
        (hp_tsk, R) \in hp_bounds ->
        response_time_bounded_by hp_tsk R.

    (* ... for every higher-priority task. *)
    Hypothesis H_hp_bounds_has_interfering_tasks:
      forall hp_tsk,
        hp_tsk \in ts ->
        is_hp_task hp_tsk ->
          exists R, (hp_tsk, R) \in hp_bounds.

    (* Assume that the response-time bounds are larger than task costs. *)
    Hypothesis H_response_time_bounds_ge_cost:
      forall hp_tsk R,
        (hp_tsk, R) \in hp_bounds -> R >= task_cost hp_tsk.

    (* Assume that no deadline is missed by any higher-priority task. *)
    Hypothesis H_interfering_tasks_miss_no_deadlines:
      forall hp_tsk R,
        (hp_tsk, R) \in hp_bounds -> R <= task_deadline hp_tsk.

    (* Let R be the fixed point of Bertogna and Cirinei's recurrence, ...*)
    Variable R: time.
    Hypothesis H_response_time_recurrence_holds :
      R = task_cost tsk +
          div_floor
            (total_interference_bound_fp task_cost task_period tsk hp_bounds R)
            num_cpus.

    (* ... and assume that R is no larger than the deadline of tsk.*)
    Hypothesis H_response_time_no_larger_than_deadline:
      R <= task_deadline tsk.

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

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

      (* Assume that job j is the first job of tsk not to complete by the response time bound. *)
      Hypothesis H_j_not_completed: ~~ completed job_cost sched j (job_arrival j + R).
      Hypothesis H_previous_jobs_of_tsk_completed :
        forall j0,
          arrives_in arr_seq j0 ->
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + R).

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

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

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

      (* Let hp_tasks denote the set of higher-priority tasks. *)
      Let hp_tasks := [seq tsk_other <- ts | is_hp_task tsk_other].

      (* Now we establish results about the higher-priority tasks. *)
      Section LemmasAboutHPTasks.

        (* 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 hp_bounds.

        (* 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_fp_workload_bounds_interference :
          x tsk_other <= workload_bound tsk_other R_other.
        Proof.
          unfold response_time_bounded_by, is_response_time_bound_of_task,
                 completed, completed_jobs_dont_execute, valid_sporadic_job in *.
          rename H_valid_job_parameters into PARAMS,
                 H_all_jobs_from_taskset into FROMTS,
                 H_valid_task_parameters into TASK_PARAMS,
                 H_constrained_deadlines into RESTR,
                 H_response_time_of_interfering_tasks_is_known into RESP,
                 H_interfering_tasks_miss_no_deadlines into NOMISS,
                 H_response_time_bounds_ge_cost into GE_COST.
          unfold x, workload_bound.
          destruct ([exists t: 'I_(job_arrival j + R),
                       task_is_scheduled job_task sched tsk_other t]) eqn: SCHED;
            last first.
          {
            apply negbT in SCHED; rewrite negb_exists in SCHED.
            move: SCHED => /forallP SCHED.
            apply leq_trans with (n := 0); last by done.
            apply leq_trans with (n := \sum_(job_arrival j <= t < job_arrival j + R) 0);
              last by rewrite big1.
            apply leq_sum_nat; move => i /andP [_ LTi] _.
            specialize (SCHED (Ordinal LTi)).
            rewrite negb_exists in SCHED; move: SCHED => /forallP SCHED.
            rewrite big1 //; intros cpu _.
            specialize (SCHED cpu); apply negbTE in SCHED.
            by rewrite SCHED andbF.
          }
          move: SCHED => /existsP [t /existsP [cpu SCHED]].
          unfold task_scheduled_on in SCHED.
          destruct (sched cpu t) as [j0 |] eqn:SCHED'; last by done.
          assert (INts: tsk_other \in ts).
          {
            move: SCHED => /eqP <-. apply FROMTS, (H_jobs_come_from_arrival_sequence j0 t).
            by apply/existsP; exists cpu; apply/eqP.
          }
          apply leq_trans with (n := workload job_task sched tsk_other
                                              (job_arrival j) (job_arrival j + R));
            first by apply task_interference_le_workload.
          by apply workload_bounded_by_W with (task_deadline0 := task_deadline) (arr_seq0 := arr_seq)
             (job_arrival0 := job_arrival) (job_cost0 := job_cost) (job_deadline0 := job_deadline);
            try (by ins); last 2 first;
              [ by ins; apply GE_COST
              | by ins; apply NOMISS
              | by ins; apply TASK_PARAMS
              | by ins; apply RESTR
              | by ins; apply RESP with (hp_tsk := tsk_other)].
        Qed.

      End LemmasAboutHPTasks.

      (* 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_fp_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_recurrence_holds into REC,
                 H_job_of_tsk into JOBtsk, H_j_not_completed into NOTCOMP.
          unfold completed, valid_sporadic_job in *.
          unfold X, total_interference; rewrite addn1.
          rewrite -(ltn_add2r (task_cost tsk)).
          rewrite subh1; last by rewrite [R](REC) // 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_(job_arrival j <= t < job_arrival j + R)
                                       backlogged job_arrival job_cost sched j t) +
                                     service sched j (job_arrival j + R)); last first.
          {
            rewrite -addn1 -addnA leq_add2l addn1.
            apply leq_trans with (n := job_cost j); first by done.
            by specialize (PARAMS j H_j_arrives); des; rewrite -JOBtsk.
          }
          unfold service; rewrite service_before_arrival_eq_service_during //.
          rewrite -big_split /=.
          apply leq_trans with (n := \sum_(job_arrival j <= i < job_arrival j + R) 1);
            first by rewrite big_const_nat iter_addn mul1n addn0 addKn.
          rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
          apply leq_sum; move => i /andP [/andP [GEi LTi] _].
          destruct (backlogged job_arrival job_cost 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.

        (* 1) Next, we prove that during the scheduling window of j, any job that is
              scheduled while j is backlogged comes from a different task.
              This follows from the fact that j is the first job not to complete
              by its response-time bound, so previous jobs of j's task must have
              completed by their periods and cannot be pending. *)
        Lemma bertogna_fp_interference_by_different_tasks :
          forall t j_other,
            job_arrival j <= t < job_arrival j + R ->
            arrives_in arr_seq j_other ->
            backlogged job_arrival job_cost 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_job_of_tsk into JOBtsk, H_sporadic_tasks into SPO,
                 H_work_conserving into WORK,
                 H_constrained_deadlines into CONSTR,
                 H_previous_jobs_of_tsk_completed into PREV,
                 H_response_time_no_larger_than_deadline into NOMISS.
          move => t j_other /andP [LEt GEt] ARRother 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_arrival0 := job_arrival)
                                               (job_cost0 := job_cost) 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.
            specialize (PREV j_other ARRother SAMEtsk BEFOREother).
            move: PENDING => /andP [_ /negP NOTCOMP]; apply NOTCOMP.
            apply completion_monotonic with (t0 := job_arrival j_other + R); try (by done).
            apply leq_trans with (n := job_arrival j); last by done.
            apply leq_trans with (n := job_arrival j_other + task_deadline tsk);
              first by rewrite leq_add2l; apply NOMISS.
            apply leq_trans with (n := job_arrival j_other + task_period tsk);
              first by rewrite leq_add2l; apply CONSTR; rewrite -JOBtsk FROMTS.
            rewrite -SAMEtsk; apply SPO; try (by done); [ | by rewrite JOBtsk | by apply ltnW].
            by intro EQ; subst j_other; rewrite ltnn in BEFOREother.
          }
          {
            move: PENDING => /andP [ARRIVED _].
            exploit (SPO j j_other); try (by done); [ | by rewrite SAMEtsk | ]; last first.
            {
              apply/negP; rewrite -ltnNge.
              apply leq_ltn_trans with (n := t); first by done.
              apply leq_trans with (n := job_arrival j + R); first by done.
              by rewrite leq_add2l; apply leq_trans with (n := task_deadline tsk);
                [by apply NOMISS | by rewrite JOBtsk CONSTR // -JOBtsk FROMTS].
            }
            by red; intros EQtsk; subst j_other; rewrite /backlogged SCHED andbF in BACK.
          }
        Qed.

        (* Let's define a predicate to identify the other tasks that are scheduled. *)
        Let other_scheduled_task (t: time) (tsk_other: sporadic_task) :=
          task_is_scheduled job_task sched tsk_other t &&
          is_hp_task tsk_other.

        (* 2) Now we prove that, at all times that j is backlogged, the number
              of tasks other than tsk that are scheduled is exactly the number
              of processors in the system. This is required to prove lemma (3). *)
        Lemma bertogna_fp_all_cpus_are_busy:
          forall t,
            job_arrival j <= t < job_arrival j + R ->
            backlogged job_arrival job_cost sched j t ->
            count (other_scheduled_task t) ts = num_cpus.
        Proof.
          rename H_valid_task_parameters into PARAMS,
                 H_all_jobs_from_taskset into FROMTS,
                 H_job_of_tsk into JOBtsk,
                 H_sporadic_tasks into SPO,
                 H_valid_job_parameters into JOBPARAMS,
                 H_constrained_deadlines into RESTR,
                 H_hp_bounds_has_interfering_tasks into HAS,
                 H_interfering_tasks_miss_no_deadlines into NOMISS,
                 H_response_time_of_interfering_tasks_is_known into PREV.
          unfold sporadic_task_model, is_response_time_bound_of_task in *.
          move => t /andP [LEt LTt] BACK.
          apply platform_fp_cpus_busy_with_interfering_tasks with (task_cost0 := task_cost)
          (task_period0 := task_period) (task_deadline0 := task_deadline) (job_task0 := job_task)
          (arr_seq0 := arr_seq) (ts0 := ts) (tsk0 := tsk) (higher_eq_priority0 := higher_eq_priority)
            in BACK; try (by done); first by apply PARAMS.
          {
            apply leq_trans with (n := job_arrival j + R); first by done.
            rewrite leq_add2l.
            by apply leq_trans with (n := task_deadline tsk); last by apply RESTR.
          }
          {
            intros j_other tsk_other ARRother JOBother INTERF.
            feed (HAS tsk_other); first by rewrite -JOBother FROMTS.
            move: (HAS INTERF) => [R' IN].
            apply completion_monotonic with (t0 := job_arrival j_other + R'); try (by done);
              last by apply PREV with (hp_tsk := tsk_other).
            {
              rewrite leq_add2l.
              apply leq_trans with (n := task_deadline tsk_other); first by apply NOMISS.
              by apply RESTR; rewrite -JOBother FROMTS.
            }
          }
          {
            ins; apply completion_monotonic with (t0 := job_arrival j0 + R); try (by done);
              last by apply H_previous_jobs_of_tsk_completed.
            rewrite leq_add2l.
            by apply leq_trans with (n := task_deadline tsk); last by apply RESTR.
          }
        Qed.

        (* 3) Now we prove that, at all times that j is backlogged, the number
              of tasks other than tsk that are scheduled is exactly the number
              of processors in the system. This is required to prove lemma (4). *)
        Lemma bertogna_fp_interference_on_all_cpus :
          \sum_(tsk_k <- hp_tasks) x tsk_k = X * num_cpus.
        Proof.
          have DIFFTASK := bertogna_fp_interference_by_different_tasks.
          rename H_work_conserving into WORK, H_respects_FP_policy into FP,
                 H_jobs_come_from_arrival_sequence into SEQ,
                 H_all_jobs_from_taskset into FROMTS, H_job_of_tsk into JOBtsk.
          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_arrival job_cost 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 H_j_arrives BACK cpu) => [j_other /eqP SCHED]; unfold scheduled_on in *.
          rewrite (bigD1_seq (job_task j_other)) /=; last by rewrite filter_uniq; destruct ts.
          {
            rewrite (eq_bigr (fun i => 0));
              last by intros i DIFF; rewrite /task_scheduled_on SCHED;apply/eqP;rewrite eqb0 eq_sym.
            rewrite big_const_seq iter_addn mul0n 2!addn0; apply/eqP; rewrite eqb1.
            by unfold task_scheduled_on; rewrite SCHED.
          }
          have ARRother: arrives_in arr_seq j_other.
            by apply (SEQ j_other t); apply/existsP; exists cpu; apply/eqP.
          rewrite mem_filter; apply/andP; split; last by apply FROMTS.
          apply/andP; split.
          {
            rewrite -JOBtsk; apply FP with (t := t); try by done.
            by apply/existsP; exists cpu; apply/eqP.
          }
          apply DIFFTASK with (t := t); try (by done); first by auto.
          by apply/existsP; exists cpu; apply/eqP.
        Qed.

        (* Before stating the next lemma, let (num_tasks_exceeding delta) be the
           number of interfering tasks whose interference x is larger than delta. *)
        Let num_tasks_exceeding delta := count (fun i => x i >= delta) (hp_tasks).

        (* 4) Now we prove that, for any delta, if (num_task_exceeding delta > 0), then the
              cumulative interference caused by the complementary set of interfering tasks fills
              the remaining, not-completely-full (num_cpus - num_tasks_exceeding delta)
              processors. *)
        Lemma bertogna_fp_interference_in_non_full_processors :
          forall delta,
            0 < num_tasks_exceeding delta < num_cpus ->
            \sum_(i <- hp_tasks | x i < delta) x i >= delta * (num_cpus - num_tasks_exceeding delta).
        Proof.
          have INV := bertogna_fp_all_cpus_are_busy.
          rename H_all_jobs_from_taskset into FROMTS, H_jobs_come_from_arrival_sequence into FROMSEQ,
                 H_valid_task_parameters into PARAMS, H_job_of_tsk into JOBtsk,
                 H_sporadic_tasks into SPO, H_previous_jobs_of_tsk_completed into BEFOREok,
                 H_response_time_no_larger_than_deadline into NOMISS,
                 H_constrained_deadlines into CONSTR, H_sequential_jobs into SEQ,
                 H_respects_FP_policy into FP, H_hp_bounds_has_interfering_tasks into HASHP,
                 H_interfering_tasks_miss_no_deadlines into NOMISSHP.
          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_arrival job_cost sched j t &&
                              (x tsk_k >= delta) &&
                              task_is_scheduled job_task sched tsk_k t) hp_tasks.
          set total_interference_B := fun t =>
              backlogged job_arrival job_cost sched j t *
              count (fun tsk_k => (x tsk_k < delta) &&
                    task_is_scheduled job_task sched tsk_k t) hp_tasks.

          apply leq_trans with ((\sum_(job_arrival j <= t < job_arrival j + R)
                                some_interference_A t) * (num_cpus - num_tasks_exceeding 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_arrival job_cost 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'.
            have ARR1: arrives_in arr_seq j1.
              by apply (FROMSEQ j1 t); apply/existsP; exists cpu; apply/eqP.
            have ARR2: arrives_in arr_seq j2.
              by apply (FROMSEQ j2 t); apply/existsP; exists cpu'; apply/eqP.
            assert (PENDING1: pending job_arrival job_cost sched j1 t).
            {
              apply scheduled_implies_pending; try by done.
              by apply/existsP; exists cpu; apply/eqP.
            }
            assert (PENDING2: pending job_arrival job_cost sched j2 t).
            {
              apply scheduled_implies_pending; try by done.
              by apply/existsP; exists cpu'; apply/eqP.
            }
            assert (BUG: j1 = j2).
            {
              destruct (job_task j1 == tsk) eqn:SAMEtsk.
              {
                move: SAMEtsk => /eqP SAMEtsk.
                move: (PENDING1) => SAMEjob.
                apply platform_fp_no_multiple_jobs_of_tsk with (task_cost0 := task_cost)
                  (arr_seq0 := arr_seq) (task_period0 := task_period) (task_deadline0 := task_deadline)
                  (job_task0 := job_task) (tsk0 := tsk) (j0 := j) in SAMEjob; try (by done);
                  [ | by apply PARAMS | |]; last 2 first.
                  {
                    apply (leq_trans LTt); rewrite leq_add2l.
                    by apply leq_trans with (n := task_deadline tsk); last by apply CONSTR.
                  }
                  {
                    intros j0 ARR0 JOB0 LT0.
                    apply completion_monotonic with (t0 := job_arrival j0 + R); try (by done);
                      last by apply BEFOREok.
                    rewrite leq_add2l.
                    by apply leq_trans with (n := task_deadline tsk); last by apply CONSTR.
                  }
                move: BACK => /andP [_ /negP NOTSCHED]; exfalso; apply NOTSCHED.
                by rewrite -SAMEjob; apply/existsP; exists cpu; apply/eqP.
              }
              {
                assert (INTERF: is_hp_task (job_task j1)).
                {
                  apply/andP; split; last by rewrite SAMEtsk.
                  rewrite -JOBtsk; apply FP with (t := t); try (by done).
                  by apply/existsP; exists cpu; apply/eqP.
                }
                apply platform_fp_no_multiple_jobs_of_interfering_tasks with
                  (job_arrival0 := job_arrival) (arr_seq0 := arr_seq) (task_period0 := task_period)
                  (tsk0 := tsk) (higher_eq_priority0 := higher_eq_priority)
                  (job_cost0 := job_cost) (job_task0 := job_task) (sched0 := sched) (t0 := t);
                  rewrite ?JOBtsk ?SAMEtsk //.
                {
                  intros j0 tsk0 ARR0 JOB0 INTERF0.
                  feed (HASHP tsk0); first by rewrite -JOB0 FROMTS.
                  move: (HASHP INTERF0) => [R0 IN0].
                  apply completion_monotonic with (t0 := job_arrival j0 + R0); try (by done);
                    last by eapply H_response_time_of_interfering_tasks_is_known; first by apply IN0.
                  rewrite leq_add2l.
                  by apply leq_trans with (n := task_deadline tsk0);
                    [by apply NOMISSHP | by apply CONSTR; rewrite -JOB0 FROMTS].
                }
              }
            }
            by subst j2; apply SEQ with (j := j1) (t := t).
          }

          apply leq_trans with (\sum_(job_arrival j <= t < job_arrival j + 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_arrival job_cost 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) hp_tasks) eqn:HAS';
              last by done.
            rewrite mul1n; move: HAS => /hasP [tsk_k INk LEk].
            unfold num_tasks_exceeding.
            apply leq_trans with (n := num_cpus -
                         count (fun i => (x i >= delta) &&
                            task_is_scheduled job_task sched i t) hp_tasks).
            {
              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 _ hp_tasks]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.
            apply leq_trans with (n := count (other_scheduled_task 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_arrival job_cost sched j t) eqn:BACK; last by ins.
            rewrite mul1n -sum1_count.
            rewrite big_mkcond [\sum_(i <- hp_tasks | _ < _) _]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.

        (* 5) Based on lemma (4), 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 of the interference and delta. *)
        Lemma bertogna_fp_minimum_exceeds_interference :
          forall delta,
            \sum_(tsk_k <- hp_tasks) x tsk_k >= delta * num_cpus ->
               \sum_(tsk_k <- hp_tasks) 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: num_tasks_exceeding = 0 *)
          destruct (~~ has (fun i => delta <= x i) hp_tasks) 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 hp_tasks) && true));
              last by red; intros tsk_k; destruct (tsk_k \in hp_tasks) eqn:INk;
                [by rewrite andTb ltnNge; apply HASa | by rewrite andFb].
            by rewrite -big_seq_cond.
          } apply negbFE in HASa.

          (* Case 2: num_tasks_exceeding >= num_cpus *)
          destruct (num_tasks_exceeding delta >= num_cpus) eqn:CARD.
          {
            apply leq_trans with (delta * num_tasks_exceeding delta);
              first by rewrite leq_mul2l; apply/orP; right.
            unfold num_tasks_exceeding; 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: num_tasks_exceeding < num_cpus *)
          rewrite big_const_seq iter_addn addn0; fold num_tasks_exceeding.
          apply leq_trans with (n := delta * num_tasks_exceeding delta +
                                     delta * (num_cpus - num_tasks_exceeding delta));
            first by rewrite -mulnDr subnKC //; apply ltnW.
          rewrite leq_add2l; apply bertogna_fp_interference_in_non_full_processors.
          by apply/andP; split; first by rewrite -has_count.
        Qed.

        (* 6) Next, using lemmas (0), (3) and (5) we prove that the reduction-based
              interference bound is not enough to cover the sum of the minima over all tasks
              (artifact of the proof by contradiction). *)
        Lemma bertogna_fp_sum_exceeds_total_interference:
          \sum_((tsk_k, R_k) <- hp_bounds)
            minn (x tsk_k) (R - task_cost tsk + 1) >
          total_interference_bound_fp task_cost task_period tsk hp_bounds R.
        Proof.
          have EXCEEDS := bertogna_fp_minimum_exceeds_interference.
          have ALLBUSY := bertogna_fp_interference_on_all_cpus.
          have TOOMUCH := bertogna_fp_too_much_interference.
          rename H_hp_bounds_has_interfering_tasks into HAS,
                 H_response_time_recurrence_holds into REC.
          apply leq_trans with (n := \sum_(tsk_k <- hp_tasks) minn (x tsk_k) (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.
            have MAP := @big_map _ 0 addn _ _ (fun x => fst x) hp_bounds (fun x => true) (fun y => minn (x y) (R - task_cost tsk + 1)).
            rewrite -MAP.
            apply leq_sum_sub_uniq; first by apply filter_uniq; destruct ts.
            red; move => tsk0 IN0.
            rewrite mem_filter in IN0; move: IN0 => /andP [INTERF0 IN0].
            apply/mapP.
            feed (HAS tsk0); first by done.
            move: (HAS INTERF0) => [R0 IN].
            by exists (tsk0, R0).
          }
          apply ltn_div_trunc with (d := num_cpus);
            first by apply H_at_least_one_cpu.
          rewrite -(ltn_add2l (task_cost tsk)) -REC.
          rewrite -addn1 -leq_subLR.
          rewrite -[R + 1 - _]subh1; last by rewrite REC; apply leq_addr.
          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.

        (* 7) After concluding that the sum of the minima exceeds (R - e_i + 1),
              we prove that there exists a tuple (tsk_k, R_k) that satisfies
              min (x_k, R - e_i + 1) > min (W_k, R - e_i + 1).
              This implies that x_k > W_k, which is of course a contradiction,
              since W_k is a valid task interference bound. *)
        Lemma bertogna_fp_exists_task_that_exceeds_bound :
          exists tsk_k R_k,
            (tsk_k, R_k) \in hp_bounds /\
            (minn (x tsk_k) (R - task_cost tsk + 1) >
              minn (workload_bound tsk_k R_k) (R - task_cost tsk + 1)).
        Proof.
          have SUM := bertogna_fp_sum_exceeds_total_interference.
          rename H_hp_bounds_has_interfering_tasks into HASHP.
          assert (HAS: has (fun tup : task_with_response_time =>
                            let (tsk_k, R_k) := tup in
                               (minn (x tsk_k) (R - task_cost tsk + 1) >
                                minn (workload_bound tsk_k R_k)(R - task_cost tsk + 1)))
                            hp_bounds).
          {
              apply/negP; unfold not; intro NOTHAS.
              move: NOTHAS => /negP /hasPn ALL.
              rewrite -[_ < _]negbK in SUM.
              move: SUM => /negP SUM; apply SUM; rewrite -leqNgt.
              rewrite (eq_bigr (fun i => minn (x (fst i)) (R - task_cost tsk + 1)));
                last by ins; destruct i.
              unfold total_interference_bound_fp.
              rewrite big_seq_cond.
              rewrite [\sum_(_ <- _ | true)_]big_seq_cond.
              apply leq_sum.
              intros p; rewrite andbT; intros IN.
              by specialize (ALL p IN); destruct p; rewrite leqNgt.
          }
          move: HAS => /hasP HAS; destruct HAS as [[tsk_k R_k] HPk MINk]; exists tsk_k, R_k.
          by repeat split.
        Qed.

      End DerivingContradiction.

    End Lemmas.

    (* Using the lemmas above, we prove that R bounds the response time of task tsk. *)
    Theorem bertogna_cirinei_response_time_bound_fp :
      response_time_bounded_by tsk R.
    Proof.
      have WORKLOAD := bertogna_fp_workload_bounds_interference.
      have EX := bertogna_fp_exists_task_that_exceeds_bound.
      rename H_response_time_bounds_ge_cost into GE_COST,
             H_interfering_tasks_miss_no_deadlines into NOMISS,
             H_response_time_recurrence_holds into REC,
             H_response_time_of_interfering_tasks_is_known into RESP,
             H_hp_bounds_has_interfering_tasks into HAS,
             H_response_time_no_larger_than_deadline into LEdl.
      intros j ARRj JOBtsk.

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

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

      intros j ARRj JOBtsk EQc; subst ctime.

      (* First, let's simplify the induction hypothesis. *)
      assert (BEFOREok: forall j0,
                          arrives_in arr_seq j0 ->
                          job_task j0 = tsk ->
                          job_arrival j0 < job_arrival j ->
                          service sched j0 (job_arrival j0 + R) == job_cost j0).
      {
        by ins; apply IH; try (by done); rewrite ltn_add2r.
      } clear IH.

      unfold response_time_bounded_by, is_response_time_bound_of_task,
             completed, completed_jobs_dont_execute, valid_sporadic_job in *.

      (* Now we start the proof. Assume by contradiction that job j
         is not complete at time (job_arrival j + R). *)
      destruct (completed job_cost sched j (job_arrival j + R)) eqn:NOTCOMP;
        first by done.
      apply negbT in NOTCOMP; exfalso.

      (* We derive a contradiction using the previous lemmas. *)
      specialize (EX j ARRj JOBtsk NOTCOMP BEFOREok).
      destruct EX as [tsk_k [R_k [HPk LTmin]]].
      unfold minn at 1 in LTmin.
      specialize (WORKLOAD j tsk_k R_k HPk).
      destruct (W task_cost task_period tsk_k R_k R < R - task_cost tsk + 1); rewrite leq_min in LTmin;
        last by move: LTmin => /andP [_ BUG]; rewrite ltnn in BUG.
      move: LTmin => /andP [BUG _]; des.
      apply leq_trans with (p := W task_cost task_period tsk_k R_k R) in BUG; last by done.
      by rewrite ltnn in BUG.
    Qed.

  End ResponseTimeBound.

End ResponseTimeAnalysisFP.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(***********************************************************************
      Root.v

      Proof that a polynomial has at most n roots
************************************************************************)
Require Import ZArith.
Require Import List.
Require Import UList.
Require Import Tactic.
Require Import Permutation.

Open Scope Z_scope.

Section Root.

Variable A: Set.
Variable P: A -> Prop.
Variable plus mult: A -> A -> A.
Variable op: A -> A.
Variable zero one: A.

Let pol := list A.

Definition toA z :=
match z with
  Z0  => zero
| Zpos p => iter_pos _ (plus one) zero p
| Zneg p => op (iter_pos _ (plus one) zero p)
end.

Fixpoint eval (p: pol) (x: A) {struct p} : A :=
match p with
  nil => zero
| a::p1 => plus a (mult x (eval p1 x))
end.

Fixpoint div (p: pol) (x: A) {struct p} : pol * A :=
match p with
  nil => (nil, zero)
| a::nil => (nil, a)
| a::p1 =>
                     (snd (div p1 x)::fst (div p1 x),
                     (plus a (mult  x (snd (div p1 x)))))
end.

Hypothesis Pzero: P zero.
Hypothesis Pplus: forall x y, P x -> P y -> P (plus x y).
Hypothesis Pmult: forall x y, P x -> P y -> P (mult x y).
Hypothesis Pop: forall x, P x -> P (op x).
Hypothesis plus_zero: forall a, P a -> plus zero a = a.
Hypothesis plus_comm: forall a b, P a -> P b -> plus a b = plus b a.
Hypothesis plus_assoc: forall a b c, P a -> P b -> P c -> plus a (plus b c) = plus (plus a b) c.
Hypothesis mult_zero: forall a, P a -> mult zero a = zero.
Hypothesis mult_comm: forall a b, P a -> P b -> mult a b = mult b a.
Hypothesis mult_assoc: forall a b c, P a -> P b -> P c -> mult a (mult b c) = mult (mult a b) c.
Hypothesis mult_plus_distr: forall a b c, P a -> P b -> P c -> mult a (plus b c) = plus (mult a b) (mult a c).
Hypothesis plus_op_zero: forall a, P a -> plus a (op a) = zero.
Hypothesis mult_integral: forall a b, P a -> P b -> mult a b = zero -> a = zero \/ b = zero.
(* Not necessary in Set just handy *)
Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}.

Theorem eval_P: forall p a, P a -> (forall i, In i p -> P i) -> P (eval p a).
intros p a Pa; elim p; simpl; auto with datatypes.
intros a1 l1 Rec H; apply Pplus; auto.
Qed.

Hint Resolve eval_P.

Theorem div_P: forall p a, P a -> (forall i, In i p -> P i) -> (forall i, In i (fst (div p a)) -> P i) /\ P (snd (div p a)).
intros p a Pa; elim p; auto with datatypes.
intros a1 l1; case l1.
simpl; intuition.
intros a2 p2 Rec Hi; split.
case Rec; auto with datatypes.
intros H H1 i.
replace (In i (fst (div (a1 :: a2 :: p2) a))) with
 (snd (div (a2::p2) a) = i \/  In i (fst (div (a2::p2) a))); auto.
intros [Hi1 | Hi1]; auto.
rewrite <- Hi1; auto.
change ( P (plus a1 (mult  a (snd (div (a2::p2) a))))); auto with datatypes.
apply Pplus; auto with datatypes.
apply Pmult; auto with datatypes.
case Rec; auto with datatypes.
Qed.

Theorem div_correct:
  forall p x y, P x -> P y -> (forall i, In i p -> P i) -> eval p y = plus (mult (eval (fst (div p x)) y) (plus y (op x))) (snd (div p x)).
intros p x y; elim p; simpl.
intros; rewrite mult_zero; try rewrite plus_zero; auto.
intros a l; case l; simpl; auto.
intros _ px py pa; rewrite (fun x => mult_comm x zero); repeat rewrite mult_zero; try apply plus_comm; auto.
intros a1 l1.
generalize (div_P (a1::l1) x); simpl.
match goal with |-  context[fst ?A]   => case A end; simpl.
intros q r Hd Rec px py pi.
assert (pr: P r).
case Hd; auto.
assert (pa1: P a1).
case Hd; auto.
assert (pey: P (eval q y)).
apply eval_P; auto.
case Hd; auto.
rewrite Rec; auto with datatypes.
rewrite (fun x y => plus_comm x (plus a y)); try rewrite <- plus_assoc; auto.
apply f_equal2 with (f := plus); auto.
repeat rewrite mult_plus_distr; auto.
repeat (rewrite (fun x y => (mult_comm (plus x y))) || rewrite mult_plus_distr); auto.
rewrite (fun x => (plus_comm  x (mult y r))); auto.
repeat rewrite  plus_assoc; try apply f_equal2 with (f := plus); auto.
2: repeat rewrite mult_assoc; try rewrite (fun y => mult_comm y (op x));
    repeat rewrite mult_assoc; auto.
rewrite (fun z => (plus_comm  z (mult (op x) r))); auto.
repeat rewrite  plus_assoc; try apply f_equal2 with (f := plus); auto.
2: apply f_equal2 with (f := mult); auto.
repeat rewrite (fun x => mult_comm x r); try rewrite <- mult_plus_distr; auto.
rewrite (plus_comm (op x)); try rewrite plus_op_zero; auto.
rewrite (fun x => mult_comm x zero); try rewrite mult_zero; try rewrite plus_zero; auto.
Qed.

Theorem div_correct_factor:
  forall p a, (forall i, In i p -> P i) -> P a ->
       eval p a = zero -> forall x,  P x -> eval p x =  (mult (eval (fst (div p a)) x) (plus x (op a))).
intros p a Hp Ha H x px.
case (div_P p a); auto; intros Hd1 Hd2.
rewrite (div_correct p a x); auto.
generalize (div_correct p a a).
rewrite plus_op_zero; try rewrite (fun x => mult_comm x zero); try rewrite mult_zero; try rewrite plus_zero; try rewrite H; auto.
intros H1; rewrite <- H1; auto.
rewrite (fun x => plus_comm x zero); auto.
Qed.

Theorem length_decrease: forall p x, p <> nil -> (length (fst (div p x)) < length p)%nat.
intros p x; elim p; simpl; auto.
intros H1; case H1; auto.
intros a l; case l; simpl; auto.
intros a1 l1.
match goal with |-  context[fst ?A]   => case A end; simpl; auto with zarith.
intros p1 _ H H1.
apply lt_n_S; apply H; intros; discriminate.
Qed.

Theorem root_max:
forall p l, ulist l -> (forall i, In i p -> P i) -> (forall i, In i l -> P i) ->
  (forall x, In x l -> eval p x = zero) -> (length p <= length l)%nat -> forall x, P x -> eval p x = zero.
intros p l; generalize p; elim l; clear l p; simpl; auto.
intros p; case p; simpl; auto.
intros a p1 _ _ _ _ H; contradict H; auto with arith.
intros a p1 Rec p; case p.
simpl; auto.
intros a1 p2 H H1 H2 H3 H4 x px.
assert (Hu: eval (a1 :: p2) a = zero); auto with datatypes.
rewrite (div_correct_factor (a1 :: p2) a); auto with datatypes.
match goal with |- mult ?X _ = _ => replace X with zero end; try apply mult_zero; auto.
apply sym_equal; apply Rec; auto with datatypes.
apply ulist_inv with (1 := H).
intros i Hi; case (div_P (a1 :: p2) a); auto.
intros x1 H5; case (mult_integral (eval (fst (div (a1 :: p2) a)) x1) (plus x1 (op a))); auto.
apply eval_P; auto.
intros i Hi; case (div_P (a1 :: p2) a); auto.
rewrite <- div_correct_factor; auto.
intros H6; case (ulist_app_inv _ (a::nil) p1 x1); simpl; auto.
left.
apply trans_equal with (plus zero x1); auto.
rewrite <- (plus_op_zero a); try rewrite <- plus_assoc; auto.
rewrite (fun x => plus_comm (op x)); try rewrite H6; try rewrite plus_comm; auto.
apply sym_equal; apply plus_zero; auto.
apply lt_n_Sm_le;apply lt_le_trans with (length (a1 :: p2)); auto with zarith.
apply length_decrease; auto with datatypes.
Qed.

Theorem root_max_is_zero:
forall p l, ulist l -> (forall i, In i p -> P i) -> (forall i, In i l -> P i) ->
  (forall x, In x l -> eval p x = zero) -> (length p <= length l)%nat -> forall x, (In x p) -> x = zero.
intros p l; generalize p; elim l; clear l p; simpl; auto.
intros p; case p; simpl; auto.
intros _ _ _  _ _ x H; case H.
intros a p1 _ _ _ _ H; contradict H; auto with arith.
intros a p1 Rec p; case p.
simpl; auto.
intros _ _ _ _ _ x H; case H.
simpl; intros a1 p2 H H1 H2 H3 H4 x H5.
assert (Ha1: a1 = zero).
assert (Hu: (eval (a1::p2) zero = zero)).
apply root_max with (l := a :: p1); auto.
rewrite <- Hu; simpl; rewrite mult_zero; try rewrite plus_comm; sauto.
case H5; clear H5; intros H5; subst; auto.
apply Rec with p2; auto with arith.
apply ulist_inv with (1 := H).
intros x1 Hx1.
case (In_dec A_dec zero p1); intros Hz.
case (in_permutation_ex _ zero p1); auto; intros p3 Hp3.
apply root_max with (l := a::p3); auto.
apply ulist_inv with zero.
apply ulist_perm with (a::p1); auto.
apply permutation_trans with (a:: (zero:: p3)); auto.
apply permutation_skip; auto.
apply permutation_sym; auto.
simpl; intros x2 [Hx2 | Hx2]; subst; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
simpl; intros x2 [Hx2 | Hx2]; subst.
case (mult_integral x2 (eval p2 x2)); auto.
rewrite <- H3 with x2; sauto.
rewrite plus_zero; auto.
intros H6; case (ulist_app_inv _ (x2::nil) p1 x2) ; auto with datatypes.
rewrite H6; apply permutation_in with (1 := Hp3); auto with datatypes.
case (mult_integral x2 (eval p2 x2)); auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
apply eval_P; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
rewrite <- H3 with x2; sauto; try right.
apply sym_equal; apply plus_zero; auto.
apply Pmult; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
apply eval_P; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
apply permutation_in with (1 := Hp3); auto with datatypes.
intros H6; case (ulist_app_inv _ (zero::nil) p3 x2) ; auto with datatypes.
simpl; apply ulist_perm with (1:= (permutation_sym _ _ _ Hp3)).
apply ulist_inv with (1 := H).
rewrite H6; auto with datatypes.
replace (length (a :: p3))  with (length (zero::p3)); auto.
rewrite permutation_length with (1 := Hp3); auto with arith.
case (mult_integral x1 (eval p2 x1)); auto.
rewrite <- H3 with x1; sauto; try right.
apply sym_equal; apply plus_zero; auto.
intros HH; case Hz; rewrite <- HH; auto.
Qed.

End Root.


(******************************************************************************)
(* A bit library for Coq: extensional theory of words.                        *)
(******************************************************************************)
(*                                                                            *)
(* (c) 2016, MINES ParisTech                                                  *)
(*                                                                            *)
(* Written by Pierre-Evariste Dagand                                          *)
(*            Emilio J. Gallego Arias                                         *)
(*                                                                            *)
(* LICENSE: CECILL-B                                                          *)
(*                                                                            *)
(******************************************************************************)

From mathcomp
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div.
From mathcomp
Require Import choice fintype finset tuple finfun.
From mathcomp
Require Import bigop ssralg ssrnum fingroup perm finalg zmodp ssrint.

Require Import bitseq.

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

(******************************************************************************)
(*                                                                            *)
(* We develop the theory of bit sequences or words. This file provides a high *)
(* level, non-computable extensional specification of the theory.             *)
(*                                                                            *)
(*      word = {ffun 'I_n -> bool}                                            *)
(*                                                                            *)
(* The main operations are:                                                   *)
(*                                                                            *)
(*    seqw w  == returns the underlying sequence.                             *)
(*    wrds bs == builds a word from a bitseq                                  *)
(*                                                                            *)
(* and their stronger counterparts:                                           *)
(*                                                                            *)
(*    bitw w == returns the underlying tuple.                                 *)
(*    wrdB t == builds a word from t : 'B_n                                   *)
(*                                                                            *)
(* We define all bit operations over this representation, and provide a       *)
(* bijection with the compuational representation.                            *)
(*                                                                            *)
(******************************************************************************)

(* Aux lemmas *)
Lemma val_tcast T n m (t : n.-tuple T) (eq_nm : n = m) :
  val (tcast eq_nm t) = val t.
Proof. by move: (eq_nm); rewrite /tcast -eq_nm => eq_nn; rewrite eq_axiomK. Qed.

(* XXX: Move. Note this is "list order" *)
(* Lemma nth_rot T x0 n i (s : seq T) (i_lt_s : i < size s) (n_lt_s : n <= size s) : *)
(*   nth x0 (rot n s) i = nth x0 s ((n + i) %% size s). *)
(* Proof. *)
(* rewrite nth_cat nth_drop; case: ltnP; rewrite size_drop ?ltn_subRL => hs. *)
(*   by rewrite modn_small. *)
(* (* Second case, we are taking after the drop *) *)
(* rewrite nth_take. *)
(* Admitted. *)

(* Lemma nth_rotr T x0 n i (s : seq T) (i_lt_s : i < size s) (n_lt_s : n <= size s) : *)
(*   nth x0 (rotr n s) i = nth x0 s ((size s - n + i) %% size s). *)
(* Proof. by rewrite /rot nth_rot // leq_subr. Qed. *)

(* Lemma tnth_rot T k n (n_lt_s : n <= k.+1) (t : k.+1.-tuple T) (i : 'I_k.+1): *)
(*   tnth [tuple of rot n t] i = tnth t (inZp n + i)%R. *)
(* Proof. *)
(* set x0 := tnth t ord0. *)
(* by rewrite !(tnth_nth x0) nth_rot ?size_tuple // /inZp /= modnDml. *)
(* Qed. *)

Definition word n := {ffun 'I_n -> bool}.

Notation "''W_' n" := (word n)
  (at level 8, n at level 2, format "''W_' n").

(* We thank Cyril Cohen for the suggestion *)
Section BitWord.

Local Open Scope bits_scope.

Variable n : nat.
Notation word := (word n).

Implicit Type (s : bitseq) (b : 'B_n) (w : word).

Definition seqw w        := val (fgraph w).
Definition wrds s : word := [ffun i => nth false s (val i)].

Lemma size_seqw w : size (seqw w) = n.
Proof. by rewrite size_tuple card_ord. Qed.

Lemma seqwK : cancel seqw wrds.
Proof. by move=> w; apply/ffunP=> i; rewrite /= !ffunE nth_fgraph_ord. Qed.

Lemma wrdbK : {in [pred x | size x == n], cancel wrds seqw}.
Proof.
move=> b /eqP hsz; apply: (@eq_from_nth _ false); first by rewrite size_seqw.
move=> i; rewrite size_seqw => hlt.
by rewrite (_ : i = (Ordinal hlt)) // nth_fgraph_ord ffunE.
Qed.

Definition bitw w        := tcast (@card_ord n) (fgraph w).
Definition wrdB t : word := [ffun i => tnth t i].

Lemma bitwE w : bitw w = seqw w :> bitseq.
Proof. by rewrite val_tcast. Qed.

(* The rest should follow from the cancellation lemmas *)
Lemma wrdBK : cancel wrdB bitw.
Proof.
move=> t; apply: eq_from_tnth => i.
by rewrite tcastE tnth_fgraph ffunE enum_val_ord cast_ordKV.
Qed.

Lemma wordP w : tnth (bitw w) =1 w.
Proof.
by move=> i; rewrite /bitw tcastE tnth_fgraph enum_val_ord cast_ordKV.
Qed.

End BitWord.

(* Properties for lifted operators: *)
Section WordLifted.

Variable k : nat.
Notation word := (word k).
Implicit Type (s : bitseq) (b : 'B_k) (w : word).

Definition orw  w1 w2 := [ffun i => w1 i || w2 i].
Definition andw w1 w2 := [ffun i => w1 i && w2 i].
Definition negw w     := [ffun i => ~~ w i].

End WordLifted.

Section WordIdx.

Variable k : nat.
Notation word := (word k.+1).

Local Open Scope ring_scope.

Implicit Type (s : bitseq) (b : 'B_k.+1) (w : word).

(******************************************************************************)
(* Rotation                                                                   *)
(******************************************************************************)
Definition rolw k w : word := [ffun i => w (i+k)].
Definition rorw k w : word := [ffun i => w (i-k)].

(* Lemma rolwP n w : bitw (rolw n w) = rolB n (bitw w). *)
(* Proof. *)
(* apply/eq_from_tnth=> i. *)
(* rewrite tcastE tnth_fgraph ffunE enum_val_ord !cast_ordKV. *)
(* rewrite /rolB (tnth_nth false) nth_rotr ?size_tuple //. *)
(*   rewrite val_tcast (_ : (_ %% _) = (i+n)) ?nth_fgraph_ord //. *)
(*   admit. *)
(* by rewrite ltnW. *)
(* Admitted. *)

(******************************************************************************)
(* Word Shift                                                                 *)
(******************************************************************************)

Definition shlw (n : 'I_k.+1) w : word :=
  [ffun i : 'I_k.+1 => (n <= i)%N && w (i-n) ].

Definition shrw (n : 'I_k.+1) w : word :=
  [ffun i : 'I_k.+1 => (i < k.+1 - n)%N && w (i+n) ].

Lemma shlwP n w : bitw (shlw n w) = shlB (bitw w) n.
Proof.
apply/eq_from_tnth=> i.
by rewrite tcastE tnth_fgraph ffunE enum_val_ord cast_ordKV tnth_shlB wordP.
Qed.

(* Boring arithmetic, we may streamline this *)
(* suff -> : insubd i (i - n)%N = i - n by []. *)
(* apply/val_inj; rewrite val_insubd /=; set u := k.+1. *)
(* have in_ltn_u : (i - n < u)%N. *)
(*   by rewrite (leq_ltn_trans (leq_subr _ _)). *)
(* rewrite in_ltn_u !modnDmr addnBA 1?ltnW //. *)
(* by rewrite  addnC -addnBA // modnDl modn_small. *)
(* Qed. *)

Lemma shrwP n w : bitw (shrw n w) = shrB (bitw w) n.
Proof.
apply/eq_from_tnth=> i.
by rewrite tcastE tnth_fgraph ffunE enum_val_ord cast_ordKV tnth_shrB wordP.
Qed.

(* Boring arithmetic, we may streamline this *)
(* suff -> : insubd i (i + n)%N = i + n by []. *)
(* apply/val_inj; rewrite val_insubd /=; set u := k.+1 in h_leq *. *)
(* by rewrite ltn_subRL addnC in h_leq; rewrite h_leq modn_small. *)

End WordIdx.

(* Arithmetic *)

Section WordRing.

End WordRing.


From Coq Require Import ZArith Psatz Bool String List Wellfounded Program.Equality.
From Coq Require Import FunctionalExtensionality.
From CDF Require Import IMP Sequences.

Local Open Scope string_scope.
Local Open Scope Z_scope.

(** * 4.  Logiques de programmes: logique de Hoare *)

(** ** 4.1.  Prologue: vérifier directement un programme  *)

(** On peut vérifier la correction d'un programme en utilisant uniquement la
    sémantique opérationnelle du langage dans lequel il est écrit.  Par exemple,
    voici un programme IMP qui échange les valeurs de deux variables. *)

Definition swap_xy :=
  ASSIGN "t" (VAR "x");; ASSIGN "x" (VAR "y");; ASSIGN "y" (VAR "t").

(** On peut caractériser le comportement attendu du programme comme suit:
    démarré dans un état mémoire [s], il termine toujours et dans un état
    mémoire [s'] où ["x"] vaut [s "y"] et ["y"] vaut [s "x"]. *)

Lemma swap_xy_correct:
  forall s, exists s',
  star red (swap_xy, s) (SKIP, s') /\ s' "x" = s "y" /\ s' "y" = s "x".
Proof.
  intros. econstructor; split.
- eapply star_step. apply red_seq_step. apply red_assign.
  eapply star_step. apply red_seq_done.
  eapply star_step. apply red_seq_step. apply red_assign.
  eapply star_step. apply red_seq_done.
  eapply star_step. apply red_assign.
  apply star_refl.
- unfold update; cbn. auto.
Qed.

(** La démonstration est longue mais pas très difficile.  Dans un premier temps
    on fait l'exécution "symbolique" du programme en enchaînant les étapes
    de réduction.  Cela détermine l'état final [s'], qui vérifie facilement
    la propriété attendue. *)

(** Voici un exemple plus compliqué car il fait appel à une boucle.
    Le programme ajoute ["x"] à ["y"] en incrémentant ["y"] et
    décrémentant ["x"] jusqu'à ce que ["x"] tombe à zéro. *)

Definition slow_add :=
  WHILE (LESSEQUAL (CONST 1) (VAR "x"))
        (ASSIGN "x" (MINUS (VAR "x") (CONST 1)) ;;
         ASSIGN "y" (PLUS  (VAR "y") (CONST 1))).

(** L'énoncé de correction du programme reste simple. *)

Lemma slow_add_correct:
  forall s,
  s "x" >= 0 ->
  exists s', star red (slow_add, s) (SKIP, s') /\ s' "y" = s "y" + s "x".
Proof.
  assert (REC: forall v, 0 <= v ->
               forall s, s "x" = v ->
               exists s', star red (slow_add, s) (SKIP, s') /\ s' "y" = s "y" + s "x").
  { intros v0 v0POS. pattern v0. apply natlike_ind; auto.
  - intros. exists s; split.
    + apply star_one. apply red_while_done. cbn. rewrite H. apply Z.leb_nle. lia.
    + lia.
  - intros v VPOS REC s EQ.
    set (s1 := update "x" v s).
    set (s2 := update "y" (s "y" + 1) s1).
    destruct (REC s2) as (s' & REDS & EQ'). auto.
    exists s'; split.
    + eapply star_step. apply red_while_loop. cbn. rewrite EQ. apply Z.leb_le. lia.
      eapply star_step. apply red_seq_step. apply red_seq_step. apply red_assign.
      eapply star_step. apply red_seq_step. apply red_seq_done.
      eapply star_step. apply red_seq_step. apply red_assign.
      eapply star_step. apply red_seq_done.
      cbn. replace (s "x" - 1) with v by lia. apply REDS.
    + rewrite EQ'. cbn. lia.
  }
  intros. eapply REC; eauto. lia.
Qed.

(** En revanche, la démonstration devient difficile.  Il faut faire
    une récurrence explicite sur la valeur [v] de la variable ["x"].
    Pour exploiter l'hypothèse de récurrence, il faut déterminer
    manuellement certains états mémoire intermédiaires: l'exécution
    purement symbolique ne suffit plus.  On ne se voit pas vérifier
    des programmes beaucoup plus complexes avec ces techniques. *)

(** Les logiques de programmes fournissent des principes de plus haut
    niveau pour vérifier formellement des programmes.  En particulier,
    on peut raisonner sur les boucles sans faire de récurrence
    explicite.  *)

(** La logique de programmes la plus connue est la logique de Hoare.
    Dans ce fichier, nous construisons une logique de Hoare pour
    raisonner sur les programmes écrits en langage IMP. *)

(** ** 4.2.  Assertions sur l'état mémoire *)

(** La logique de Hoare manipule des formules / des énoncés / des assertions
    qui "parlent" des valeurs des variables du programme.  Une assertion typique
    est [0 <= x /\ x <= y], signifiant "à ce point du programme, la valeur de
    la variable [x] est positive et inférieure ou égale à la valeur de [y]". *)

(** Dans notre développement Coq, nous représentons les assertions par
    des formules logique de Coq (type [Prop]) paramétrées par un état mémoire
    (type [store]) qui donne des valeurs aux variables.

    Par exemple, l'assertion [0 <= x /\ x <= y] ci-dessus est représentée par
    [fun s => 0 <= s "x" /\ s "x" <= s "y"]. *)

Definition assertion : Type := store -> Prop.

(** Voici quelques assertions utiles.
    La conjonction et la  disjonction de deux assertions. *)

Definition aand (P Q: assertion) : assertion :=
  fun s => P s /\ Q s.

Definition aor (P Q: assertion) : assertion :=
  fun s => P s \/ Q s.

(** L'assertion "l'expression arithmétique [a] s'évalue en la valeur [v]". *)

Definition aequal (a: aexp) (v: Z) : assertion :=
  fun s => aeval a s = v.

(** Les assertions "l'expression booléenne [b] s'évalue à vrai / à faux". *)

Definition atrue (b: bexp) : assertion :=
  fun s => beval b s = true.

Definition afalse (b: bexp) : assertion :=
  fun s => beval b s = false.

(** L'assertion notée "[ P[x <- a] ]" dans les articles.
    Substituer [x] par [a] dans [P], cela revient à évaluer [P] dans
    des états mémoire où la variable [x] est égale à la valeur de
    l'expression [a]. *)

Definition aupdate (x: ident) (a: aexp) (P: assertion) : assertion :=
  fun s => P (update x (aeval a s) s).

(** L'implication point-à-point.  Contrairement à la conjonction et la
    disjonction, ce n'est pas une assertion sur l'état mémoire, juste
    une proposition Coq. *)

Definition aimp (P Q: assertion) : Prop :=
  forall s, P s -> Q s.

(** Quelques notations pour faciliter la lecture. *)

Notation "P -->> Q" := (aimp P Q) (at level 95, no associativity).
Notation "P //\\ Q" := (aand P Q) (at level 80, right associativity).
Notation "P \\// Q" := (aor P Q) (at level 75, right associativity).

(** ** 4.3.  Règles de la logique de Hoare faible *)

(** Voici les règles de base de la logique de Hoare.
    Elles définissent une relation [Hoare P c Q], avec
-   [P] la précondition, que l'on suppose vraie "avant" l'exécution de [c];
-   [c] le programme ou le fragment de programme sur lequel on raisonne;
-   [Q] la postcondition, que l'on garantit vraie "après" l'exécution de [c].

  Il s'agit d'une logique "faible" au sens où elle ne garantit pas la
  terminaison de [c].  La seule garantie est que si [c] termine, alors
  l'état final satisfait la postcondition [Q]. *)

Inductive Hoare: assertion -> com -> assertion -> Prop :=
  | Hoare_skip: forall P,
      Hoare P SKIP P
  | Hoare_assign: forall P x a,
      Hoare (aupdate x a P) (ASSIGN x a) P
  | Hoare_seq: forall P Q R c1 c2,
      Hoare P c1 Q ->
      Hoare Q c2 R ->
      Hoare P (c1;;c2) R
  | Hoare_ifthenelse: forall P Q b c1 c2,
      Hoare (atrue b //\\ P) c1 Q ->
      Hoare (afalse b //\\ P) c2 Q ->
      Hoare P (IFTHENELSE b c1 c2) Q
  | Hoare_while: forall P b c,
      Hoare (atrue b //\\ P) c P ->
      Hoare P (WHILE b c) (afalse b //\\ P)
  | Hoare_consequence: forall P Q P' Q' c,
      Hoare P c Q ->
      P' -->> P ->
      Q -->> Q' ->
      Hoare P' c Q'.

(** Quelques règles dérivées. *)

Lemma Hoare_consequence_pre: forall P P' Q c,
      Hoare P c Q ->
      P' -->> P ->
      Hoare P' c Q.
Proof.
  intros. apply Hoare_consequence with (P := P) (Q := Q); unfold aimp; auto.
Qed.

Lemma Hoare_consequence_post: forall P Q Q' c,
      Hoare P c Q ->
      Q -->> Q' ->
      Hoare P c Q'.
Proof.
  intros. apply Hoare_consequence with (P := P) (Q := Q); unfold aimp; auto.
Qed.

Lemma Hoare_ifthen: forall b c P Q,
    Hoare (atrue b //\\ P) c Q ->
    afalse b //\\ P -->> Q ->
    Hoare P (IFTHENELSE b c SKIP) Q.
Proof.
  intros. apply Hoare_ifthenelse; auto.
  apply Hoare_consequence_pre with Q; auto using Hoare_skip.
Qed.

(** Un exemple de dérivation. *)

Example Hoare_swap_xy: forall m n,
  Hoare (aequal (VAR "x") m //\\ aequal (VAR "y") n)
        swap_xy
        (aequal (VAR "x") n //\\ aequal (VAR "y") m).
Proof.
  intros.
  eapply Hoare_consequence_pre.
- unfold swap_xy. eapply Hoare_seq. apply Hoare_assign.
  eapply Hoare_seq. apply Hoare_assign. apply Hoare_assign.
- unfold aequal, aupdate, aand, aimp; cbn. tauto.
Qed.

(** *** Exercice (2 étoiles) *)
(** Voici une autre manière d'échanger les valeurs de deux variables entières,
    sans utiliser de variable temporaire. *)

Definition swap_xy_2 :=
  ASSIGN "x" (PLUS (VAR "x") (VAR "y")) ;;
  ASSIGN "y" (MINUS (VAR "x") (VAR "y")) ;;
  ASSIGN "x" (MINUS (VAR "x") (VAR "y")).

(** Montrer que ce programme satisfait la même propriété que [swap_xy].
    Indication: reprendre le script de preuve de [Hoare_swap_xy],
    l'adaptation à effectuer est minimale. *)

Example Hoare_swap_xy_2: forall m n,
  Hoare (aequal (VAR "x") m //\\ aequal (VAR "y") n)
        swap_xy_2
        (aequal (VAR "x") n //\\ aequal (VAR "y") m).
Proof.
  (* A COMPLÉTER *)
Admitted.

(** ** 4.4.  Sûreté de la logique de Hoare *)

(** On va interpréter sémantiquement les énoncés [Hoare P c Q] de la
    logique de Hoare par la relation [triple P c Q] ci-dessous,
    définie en termes de la sémantique naturelle d'IMP
    (la relation [cexec s c s']). *)

Definition triple (P: assertion) (c: com) (Q: assertion) : Prop :=
  forall s s', cexec s c s' -> P s -> Q s'.

Notation "{{ P }} c {{ Q }}" := (triple P c Q) (at level 90, c at next level).

(** L'interprétation sémantique valide chacune des règles de la
    logique de Hoare. *)

Lemma triple_skip: forall P,
     {{P}} SKIP {{P}}.
Proof.
  unfold triple; intros. inversion H; subst. auto.
Qed.

Lemma triple_assign: forall P x a,
      {{aupdate x a P}} ASSIGN x a {{P}}.
Proof.
  unfold triple, aupdate; intros. inversion H; subst. auto.
Qed.

Lemma triple_seq: forall P Q R c1 c2,
      {{P}} c1 {{Q}} ->
      {{Q}} c2 {{R}} ->
      {{P}} c1;;c2 {{R}}.
Proof.
  unfold triple; intros. inversion H1; subst. eauto.
Qed.

Lemma triple_ifthenelse: forall P Q b c1 c2,
      {{atrue b //\\ P}} c1 {{Q}} ->
      {{afalse b //\\ P}} c2 {{Q}} ->
      {{P}} IFTHENELSE b c1 c2 {{Q}}.
Proof.
  unfold triple, aand, atrue, afalse; intros. inversion H1; subst.
  destruct (beval b s) eqn:B; eauto.
Qed.

Lemma triple_while: forall P b c,
      {{atrue b //\\ P}} c {{P}} ->
      {{P}} WHILE b c {{afalse b //\\ P}}.
Proof.
  unfold triple; intros P b c T s s' E. dependent induction E; intros.
- split; auto.
- eapply IHE2; eauto. apply T with s; auto. split; auto.
Qed.

Lemma triple_consequence: forall P Q P' Q' c,
      {{P}} c {{Q}} ->
      P' -->> P ->
      Q -->> Q' ->
      {{P'}} c {{Q'}}.
Proof.
  unfold triple, aimp; intros. eauto.
Qed.

(** Il s'ensuit que la logique de Hoare est sûre: tout triplet déductible par
    les règles de la logique est sémantiquement valide. *)

Theorem Hoare_sound:
  forall P c Q, Hoare P c Q -> {{P}} c {{Q}}.
Proof.
  induction 1; eauto using triple_skip, triple_assign, triple_seq,
  triple_ifthenelse, triple_while, triple_consequence.
Qed.

(** ** 4.5.  Complétude de la logique de Hoare *)

(** La réciproque du théorème [Hoare_sound] est vraie: un "triplet de Hoare"
    qui est vrai sémantiquement ([{{P}} c {{Q}}]) peut toujours être dérivé
    par les règles de Hoare ([Hoare P c Q]).  La démonstration utilise la
    notion de "plus faible précondition" ("weakest precondition", WP). *)

(** La plus faible précondition pour une commande [c] avec postcondition [Q]. *)

Definition wp (c: com) (Q: assertion) : assertion :=
  fun s => forall s', cexec s c s' -> Q s'.

(** C'est une précondition. *)

Lemma wp_precondition: forall c Q, {{wp c Q}} c {{Q}}.
Proof.
  unfold triple, wp; intros. auto.
Qed.

(** C'est la plus faible des préconditions:
    toute autre précondition l'implique. *)

Lemma wp_weakest: forall P c Q, {{P}} c {{Q}} -> P -->> wp c Q.
Proof.
  unfold triple, wp, aimp; intros. eauto.
Qed.

(** Les règles de la logique de Hoare sont suffisamment puissantes pour dériver
    le fait que [wp c Q] est une précondition valide pour [c] et [Q]. *)

Lemma Hoare_wp: forall c Q, Hoare (wp c Q) c Q.
Proof.
  induction c; intros Q.
- (* SKIP *)
  eapply Hoare_consequence_pre. apply Hoare_skip.
  unfold aimp, wp; intros. apply H. apply cexec_skip.
- (* ASSIGN *)
  eapply Hoare_consequence_pre. apply Hoare_assign.
  unfold aimp, aupdate, wp; intros. apply H. apply cexec_assign.
- (* SEQ *)
  eapply Hoare_consequence_pre.
  eapply Hoare_seq with (wp c2 Q); eauto.
  unfold aimp, wp; intros. apply H. apply cexec_seq with s'; auto.
- (* IFTHENELSE *)
  apply Hoare_ifthenelse.
  + eapply Hoare_consequence_pre. apply IHc1.
    unfold atrue, aand, aimp, wp; intros. destruct H.
    apply H1. apply cexec_ifthenelse. rewrite H; auto.
  + eapply Hoare_consequence_pre. apply IHc2.
    unfold afalse, aand, aimp, wp; intros. destruct H.
    apply H1. apply cexec_ifthenelse. rewrite H; auto.
- (* WHILE *)
  eapply Hoare_consequence_post.
  + apply Hoare_while.
    eapply Hoare_consequence_pre. apply IHc.
    unfold atrue, aand, aimp, wp; intros. destruct H.
    apply H2. apply cexec_while_loop with s'; auto.
  + unfold afalse, aand, aimp, wp; intros. destruct H.
    apply H0. apply cexec_while_done; auto.
Qed.

(** Il s'ensuit que tout triplet [{{P}} c {{Q}}] sémantiquement valide
    est dérivable par les règles de Hoare. *)

Theorem Hoare_complete: forall P c Q, {{P}} c {{Q}} -> Hoare P c Q.
Proof.
  intros. apply Hoare_consequence_pre with (wp c Q).
- apply Hoare_wp.
- apply wp_weakest; auto.
Qed.

(** ** 4.6.  Autres règles utiles *)

(** Avec la définition sémantique des triplets de Hoare, il est très facile
    d'ajouter des règles de raisonnement supplémentaires.  Ce sont juste
    des lemmes que l'on démontre une fois pour toute.  Par exemple: *)

Lemma triple_conj:
  forall c P1 Q1 P2 Q2,
  {{P1}} c {{Q1}} -> {{P2}} c {{Q2}} -> {{P1 //\\ P2}} c {{Q1 //\\ Q2}}.
Proof.
  intros; red; intros. destruct H2 as [PRE1 PRE2]. split; eauto.
Qed.

Lemma triple_disj:
  forall c P1 Q1 P2 Q2,
  {{P1}} c {{Q1}} -> {{P2}} c {{Q2}} -> {{P1 \\// P2}} c {{Q1 \\// Q2}}.
Proof.
  intros; red; intros. destruct H2 as [PRE1|PRE2]; [left|right]; eauto.
Qed.

(** Nous pouvons aussi donner une règle de raisonnement sur l'affectation
    qui fonctionne "en avant" (la postcondition est déterminée à partir
    de la précondition) au lieu de "en arrière" comme la règle de Hoare. *)

Definition aexists {A: Type} (P: A -> assertion) : assertion :=
  fun (s: store) => exists (a: A), P a s.

Lemma triple_assign_fwd: forall x a P,
  {{ P }}
  ASSIGN x a
  {{ aexists (fun m => aexists (fun n =>
     aequal (VAR x) n //\\ aupdate x (CONST m) (P //\\ aequal a n))) }}.
Proof.
  intros. unfold triple, aequal, aupdate; intros.
  inversion H; subst.
  exists (s x); exists (aeval a s); cbn.
  split. apply update_same.
  replace (update x (s x) (update x (aeval a s) s)) with s.
  split; auto.
  apply functional_extensionality; intros y.
  unfold update. destruct (string_dec x y); congruence.
Qed.

(** Pour finir, nous allons construire une règle d'encadrement
    ("frame rule" en anglais) qui permet de réutiliser une vérification
    déjà effectuée de [{{P} c {{Q}}]
    pour ajouter des faits supplémentaires [R]
    à la précondition et à la postcondition,
    obtenant une vérification de [{{P //\\ R}} c {{Q //\\ R}}]. *)

(** Par exemple: si on a montré la correction de [swap_xy] comme suit
<<
    {{ aequal (VAR "x") m //\\ aequal (VAR "y") n }}
    swap_xy
    {{ aequal (VAR "x") n //\\ aequal (VAR "y") m }}
>>
    on devrait pouvoir, sans refaire la vérification de [swap_xy],
    montrer un triplet plus informatif, comme par exemple
<<
    {{ aequal (VAR "x") m //\\ aequal (VAR "y") n //\\ aequal (VAR "z") p }}
    swap_xy
    {{ aequal (VAR "x") n //\\ aequal (VAR "y") m //\\ aequal (VAR "z") p }}
>>
    c'est à dire: "et en plus la valeur de la variable [z] est préservée". *)

(** Ce raisonnement est valide à condition que les faits supplémentaires [R]
    portent uniquement sur des variables qui sont pas modifiées
    pendant l'exécution de la commande [c], c'est-à-dire, en première
    approximation, des variables qui n'apparaissent pas dans une
    construction [ASSIGN] de [c]. *)

Fixpoint modified_by (c: com) (x: ident) : Prop :=
  match c with
  | SKIP => False
  | ASSIGN y a => x = y
  | SEQ c1 c2 => modified_by c1 x \/ modified_by c2 x
  | IFTHENELSE b c1 c2 => modified_by c1 x \/ modified_by c2 x
  | WHILE b c1 => modified_by c1 x
  end.

Lemma cexec_modified:
  forall x s1 c s2,
  cexec s1 c s2 -> ~modified_by c x -> s2 x = s1 x.
Proof.
  induction 1; cbn; intros MB.
- auto.
- unfold update. destruct (string_dec x0 x); congruence.
- rewrite IHcexec2, IHcexec1 by tauto. auto.
- apply IHcexec. destruct (beval b s); tauto.
- auto.
- rewrite IHcexec2, IHcexec1 by tauto. auto.
Qed.

(** Syntaxiquement, une assertion [P] est indépendante d'un ensemble [vars]
    de variables si aucune de ces variables n'apparaît dans [P].
    Avec notre codage des assertions comme fonctions [store -> Prop],
    on ne peut pas exprimer cette condition de cette manière.
    Mais on peut dire que l'assertion prend la même valeur de vérité
    dans deux états [s1] et [s2] qui ne diffèrent que par les valeurs
    des variables dans [vars]. *)

Definition independent_of (P: assertion) (vars: ident -> Prop) : Prop :=
  forall s1 s2,
  (forall x, ~ vars x -> s1 x = s2 x) ->
  (P s1 <-> P s2).

(** Finalement, on obtient la règle d'encadrement suivante. *)

Lemma triple_frame:
  forall c P Q R,
  {{P}} c {{Q}} ->
  independent_of R (modified_by c) ->
  {{P //\\ R}} c {{Q //\\ R}}.
Proof.
  intros; red; intros. destruct H2 as [PRE1 PRE2]. split.
- eapply H; eauto.
- apply (H0 s' s).
  + intros. apply cexec_modified with c; auto.
  + auto.
Qed.

(** ** 4.7.  Triplets de Hoare forts *)

(** La logique de Hoare que nous avons vue jusqu'ici est dite "faible"
    car elle ne garantit pas la terminaison des programmes, et ne peut
    donc montrer que des résultats de correction partielle. *)

(** En suivant les mêmes approches, nous allons maintenant construire
    une logique de Hoare "forte", qui garantit la terminaison
    et montre donc des résultats de correction totale. *)

(** Comme nous avons fait pour la logique "faible", nous pourrions
    donner les règles de la logique "forte" sous forme de prédicat
    inductif, puis les interpréter sémantiquement.  Pour simplifier,
    nous omettons le prédicat inductif et définissons la logique "forte"
    directement à partir de la sémantique opérationnelle, via la relation
    [ [[P]] c [[Q]] ] ci-dessous: *)

Definition Triple (P: assertion) (c: com) (Q: assertion) :=
  forall s, P s -> exists s', cexec s c s' /\ Q s'.

Notation "[[ P ]] c [[ Q ]]" := (Triple P c Q) (at level 90, c at next level).

(** Notons la différence avec la logique faible:
-   Pour la logique faible [ {{P}} c {{Q}} ], on conclut
    "si [c] termine alors l'état final [s'] satisfait [Q]".
-   Pour la logique forte [ [[P]] c [[Q]] ], on conclut
    "[c] termine et l'état final [s'] satisfait [Q]".
*)

(** Les règles de base de la logique forte sont les mêmes que celles de la
    logique faible, sauf pour les boucles. *)

Lemma Triple_skip: forall P,
      [[P]] SKIP [[P]].
Proof.
  intros P s PRE. exists s; split; auto. apply cexec_skip.
Qed.

Lemma Triple_assign: forall P x a,
      [[aupdate x a P]] ASSIGN x a [[P]].
Proof.
  intros P x a s PRE. exists (update x (aeval a s) s); split.
- apply cexec_assign.
- exact PRE.
Qed.

Lemma Triple_seq: forall P Q R c1 c2,
      [[P]] c1 [[Q]] -> [[Q]] c2 [[R]] ->
      [[P]] c1;;c2 [[R]].
Proof.
  intros; intros s PRE.
  destruct (H s PRE) as (s1 & EXEC1 & MID).
  destruct (H0 s1 MID) as (s2 & EXEC2 & POST).
  exists s2; split.
- apply cexec_seq with s1; auto.
- exact POST.
Qed.

Lemma Triple_ifthenelse: forall P Q b c1 c2,
      [[atrue b //\\ P]] c1 [[Q]] ->
      [[afalse b //\\ P]] c2 [[Q]] ->
      [[P]] IFTHENELSE b c1 c2 [[Q]].
Proof.
  intros; intros s PRE. destruct (beval b s) eqn:B.
- destruct (H s) as (s' & EXEC & POST). split; auto.
  exists s'; split; auto. constructor; rewrite B; auto.
- destruct (H0 s) as (s' & EXEC & POST). split; auto.
  exists s'; split; auto. constructor; rewrite B; auto.
Qed.

Lemma Triple_consequence: forall P Q P' Q' c,
      [[P]] c [[Q]] -> P' -->> P -> Q -->> Q' ->
      [[P']] c [[Q']].
Proof.
  intros; intros s PRE.
  destruct (H s) as (s' & EXEC & POST). apply H0; auto.
  exists s'; auto.
Qed.

(** Pour les boucles [WHILE b c], le triplet fort doit garantir la terminaison
    de la boucle pour tous les états initiaux satisfaisant la précondition.
    Une manière simple de garantir la terminaison est d'exhiber une "variante":
    une expression à valeurs entières qui décroît strictement à chaque
    tour de boucle tout en restant positive. *)

Definition alessthan (a: aexp) (v: Z) : assertion :=
  fun (s: store) => 0 <= aeval a s < v.

Lemma Triple_while: forall P variant b c,
  (forall v,
     [[ P //\\ atrue b //\\ aequal variant v ]]
     c
     [[ P //\\ alessthan variant v ]])
  ->
     [[P]] WHILE b c [[P //\\ afalse b]].
Proof.
  intros P variant b c T.
  assert (REC: forall v s, P s -> aeval variant s = v ->
               exists s', cexec s (WHILE b c) s' /\ (P s' /\ beval b s' = false)).
  { induction v using (well_founded_induction (Z.lt_wf 0)).
    intros. destruct (beval b s) eqn:B.
  - destruct (T v s) as (s1 & EXEC1 & (PS1 & LT1)). unfold aand, aequal, atrue; auto.
    destruct (H _ LT1 s1 PS1) as (s2 & EXEC2 & PS2). auto.
    exists s2; split; auto. apply cexec_while_loop with s1; auto.
  - exists s; split; auto. apply cexec_while_done; auto.
  }
  intros s PRE. apply REC with (v := aeval variant s); auto.
Qed.

(** *** Exercice (3 étoiles) *)

(** La technique de la "variante" et l'ordre sur les entiers positifs
    ne suffisent pas toujours à montrer la terminaison d'une boucle
    [WHILE].  Voici une règle qui utilise deux variantes et l'ordre
    lexicographique entre paires d'entiers positifs.  Montrer que
    cette règle est valide. *)

Lemma Triple_while_lexico: forall P variant1 variant2 b c,
  (forall v1 v2,
    [[ P //\\ atrue b //\\ aequal variant1 v1 //\\ aequal variant2 v2 ]]
    c
    [[ P //\\ (alessthan variant1 v1 \\// aequal variant1 v1 //\\ alessthan variant2 v2) ]])
  ->
    [[P]] WHILE b c [[P //\\ afalse b]].
Proof.
  intros P variant1 variant2 b c T.
  assert (REC: forall v1 v2 s, P s -> aeval variant1 s = v1 -> aeval variant2 s = v2 ->
               exists s', cexec s (WHILE b c) s' /\ (P s' /\ beval b s' = false)).
  (* A COMPLÉTER *)
Admitted.

(** ** 4.8.  Génération des conditions de vérification *)

(** Exceptée la règle pour les boucles [WHILE], les règles de la
    logique de Hoare peuvent se lire comme un algorithme qui, étant
    données une commande [c] et une postcondition [Q], calcule une
    plus faible précondition [P].  Par exemple, si [c] se compose de
    deux affectations en séquence
<<
    c = ASSIGN x1 a1 ;; ASSIGN x2 a2
>>
    la précondition [P] est déterminée comme
<<
    P = aupdate x1 a1 (aupdate x2 a2 Q)
>>
    Un tel calcul est beaucoup plus simple qu'une recherche de preuve
    générale, cette dernière pouvant faire intervenir la règle
    d'affaiblissement [triple_consequence] à tout moment. *)

(** Le problème est bien entendu les boucles [WHILE].  L'invariant de
    la boucle ne peut pas être déterminé automatiquement par calcul. *)

(** Dans ce qui suit, nous développons une approche hybride où les boucles
    sont annotées manuellement par leurs invariants de boucle, mais où toutes
    les autres préconditions sont calculées automatiquement à partir des
    postconditions. *)

Module VCGEN.

(** Voici le langage des commandes avec les boucles [WHILE] annotées par
    un invariant [Inv]. *)

Inductive com: Type :=
  | SKIP
  | ASSIGN (x: ident) (a: aexp)
  | SEQ (c1: com) (c2: com)
  | IFTHENELSE (b: bexp) (c1: com) (c2: com)
  | WHILE (Inv: assertion) (b: bexp) (c1: com).  (**r nouveau! *)

(** La fonction [pre c Q] calcule une précondition pour la commande [c]
    et la postcondition [Q], par "exécution en arrière" de la commande [c] et
    application des règles de la logique de Hoare.  Seule exception: pour
    les boucles [WHILE], on prend l'invariant déclaré pour la boucle comme
    précondition. *)

Fixpoint pre (c: com) (Q: assertion) : assertion :=
  match c with
  | SKIP => Q
  | ASSIGN x a => aupdate x a Q
  | SEQ c1 c2 => pre c1 (pre c2 Q)
  | IFTHENELSE b c1 c2 => atrue b //\\ pre c1 Q \\// afalse b //\\ pre c2 Q
  | WHILE Inv b c => Inv
  end.

(** Le triplet de Hoare [ {{ pre c Q }} c {{ Q }} ] n'est pas toujours vrai:
    il faut aussi s'assurer que les invariants déclarés pour les boucles sont
    bien des invariants.  Pour une boucle [WHILE Inv b c] de postcondition [Q],
    il faut que
-   [afalse b //\\ Inv -->> Q] :
    quand on sort de la boucle, l'invariant implique la postcondition.
-   [atrue b //\\ Inv -->> pre c Inv] :
    quand on itère la boucle, l'invariant implique la précondition du corps
    de la boucle.

    La fonction [vcg] (Verification Condition Generator) ci-dessous collecte
    ces "conditions de vérification" pour toutes les boucles [WHILE]
    apparaissant dans la commande [c]. *)

Fixpoint vcg (c: com) (Q: assertion) : Prop :=
  match c with
  | SKIP => True
  | ASSIGN x a => True
  | SEQ c1 c2 => vcg c1 (pre c2 Q) /\ vcg c2 Q
  | IFTHENELSE b c1 c2 => vcg c1 Q /\ vcg c2 Q
  | WHILE Inv b c =>
       vcg c Inv
    /\ (afalse b //\\ Inv -->> Q)
    /\ (atrue b //\\ Inv -->> pre c Inv)
  end.

(** Le triplet [ {{P}} c {{Q}} ] est valide dès lors que
-   [P] implique la précondition [pre c Q]
-   les conditions [vcg c Q] sont toutes vraies.
*)

Definition vcgen (P: assertion) (c: com) (Q: assertion) : Prop :=
  (P -->> pre c Q) /\ vcg c Q.

(** Pour montrer la correction de cet algorithme de vérification,
    nous définissons l'effacement [erase c] d'une commande annotée
    en commande IMP standard.  Il s'agit juste d'oublier les invariants
    de boucles qui annotent les noeuds [WHILE]. *)

Fixpoint erase (c: com) : IMP.com :=
  match c with
  | SKIP => IMP.SKIP
  | ASSIGN x a => IMP.ASSIGN x a
  | SEQ c1 c2 => IMP.SEQ (erase c1) (erase c2)
  | IFTHENELSE b c1 c2 => IMP.IFTHENELSE b (erase c1) (erase c2)
  | WHILE Inv b c => IMP.WHILE b (erase c)
  end.

(** Nous pouvons alors montrer que [pre c Q] est une précondition valide
    de [c] et de [Q], pourvu que les conditions [vcg c Q] soient vraies. *)

Lemma vcg_sound:
  forall c Q, vcg c Q -> {{pre c Q}} erase c {{Q}}.
Proof.
  induction c; cbn; intros.
- apply triple_skip.
- apply triple_assign.
- destruct H as (V1 & V2).
  apply triple_seq with (pre c2 Q); auto.
- destruct H as (V1 & V2).
  apply triple_ifthenelse.
  + eapply triple_consequence. eapply IHc1; eauto.
    unfold aimp, aand, aor, atrue, afalse. intuition congruence.
    unfold aimp; auto.
  + eapply triple_consequence. eapply IHc2; eauto.
    unfold aimp, aand, aor, atrue, afalse. intuition congruence.
    unfold aimp; auto.
- destruct H as (V1 & V2 & V3).
  eapply triple_consequence.
  + apply triple_while. eapply triple_consequence. apply IHc; eauto.
    eauto. red; auto.
  + red; auto.
  + auto.
Qed.

(** On en déduit la correction de l'algorithme [vcgen]. *)

Theorem vcgen_correct:
  forall P c Q, vcgen P c Q -> {{P}} erase c {{Q}}.
Proof.
  unfold vcgen; intros. destruct H as (V1 & V2).
  eapply triple_consequence. eapply vcg_sound; eauto. auto. red; auto.
Qed.

(** *** Application: la division Euclidienne *)

Infix ";;" := SEQ (at level 80, right associativity).

(** Voici la précondition, l'invariant de boucle, et la postcondition pour
    le programme de division euclidienne par soustraction itérée. *)

Definition Pre (s: store) :=
  s "a" >= 0 /\ s "b" > 0.

Definition Inv (s: store) :=
  s "r" >= 0 /\ s "b" > 0 /\ s "a" = s "b" * s "q" + s "r".

Definition Post (s: store) :=
  s "q" = s "a" / s "b" /\ s "r" = s "a" mod s "b".

(** Voici le programme IMP avec la boucle annotée par [Inv]. *)

Definition Euclidean_division :=
  ASSIGN "r" (VAR "a") ;;
  ASSIGN "q" (CONST 0) ;;
  WHILE Inv (LESSEQUAL (VAR "b") (VAR "r"))
    (ASSIGN "r" (MINUS (VAR "r") (VAR "b")) ;;
     ASSIGN "q" (PLUS (VAR "q") (CONST 1))).

(** Et voici la preuve de sa correction.  Elle n'applique explicitement aucune
    des règles de la logique de Hoare.  À la place, on applique le théorème
    [vcgen_correct], puis on fait calculer par Coq les conditions de
    vérification.  Il reste une formule de logique usuelle à démontrer,
    en utilisant les tactiques Coq standard. *)

Theorem Euclidean_division_correct:
  {{Pre}} erase Euclidean_division {{Post}}.
Proof.
  apply vcgen_correct. red; cbn.
  unfold aimp, aupdate, aand, afalse, atrue, Pre, Post, Inv; cbn.
  intuition auto.
  (* La précondition implique l'invariant de boucle. *)
  - lia.
  (* L'invariant et la sortie de boucle impliquent la postcondition. *)
  - apply Z.leb_gt in H0. apply Zdiv_unique with (s "r"). lia. auto.
  - apply Z.leb_gt in H0. apply Zmod_unique with (s "q"). lia. auto.
  (* L'invariant de boucle est préservé *)
  - apply Z.leb_le in H0. lia.
  - lia.
Qed.

(** *** Exercice (1 étoile) *)
(** Refaire la vérification en supprimant l'hypothèse [s "b" > 0] de
    la précondition et de l'invariant.  Comment est-il possible que
    la vérification "passe" même quand le diviseur [b] est nul? *)

(** *** Exercice (3 étoiles) *)
(** Spécifier et vérifier le programme suivant.  Il met dans [r]
    la racine carrée entière de [a].
<<
    r := 0; s := 1;
    while s <= a do (r := r + 1; s := s + r + r + 1)
>>
*)

End VCGEN.