Require Import Coq.Program.Equality. (* for dependent induction *)

Require Export CatSem.CAT.cat_INDEXED_TYPE.
Require Export CatSem.CAT.initial_terminal.
Require Export CatSem.CAT.orders.
Require Export CatSem.CAT.monad_haskell.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(**
    i tried to make the following in a modular way, which means

    [ T -> PO_obj ]
    [ fun A B => fun t => PO_mor (A t) (B t) ]

    like, to be easily generalizable to [T -> C] for any cat C

    and so on. consequence: no coercions as we'd like them

   modular programming rules, but not in coq

*)

Section ind_po_cat.

Variable T: Type.

(** Category of a family of preorders indexed by T *)

Class ipo_obj_struct (A : T -> Type) := {
  IRel : forall t, relation (A t);
  IPOprf :> forall t, PreOrder (@IRel t)
}.

Notation "y <<< z" := (IRel y z) (at level 60).

Record ipo_obj := {
  ipo_obj_carrier :> T -> Type ;
  ipo_obj_s :> ipo_obj_struct ipo_obj_carrier
}.

Existing Instance ipo_obj_s.

Instance IRel_Trans (A : ipo_obj) t : Transitive (IRel (A:=A) (t:=t)).
Proof.
  intros;
  apply IPOprf.
Qed.

Lemma IRel_refl (V : ipo_obj) t (x : V t) : x <<< x.
Proof.
  reflexivity.
Qed.

Lemma IRel_eq (V : ipo_obj) t (x y : V t) : x = y -> x <<< y.
Proof.
  intros;
  subst;
  apply IRel_refl.
Qed.

Lemma IRel_eq_r (V : ipo_obj) t (x y z : V t) :
    x <<< y -> y = z -> x <<< z.
Proof.
  intros;
  subst;
  auto.
Qed.

Lemma IRel_eq_l (V : ipo_obj) t (x y z : V t) :
    x <<< z -> x = y -> y <<< z.
Proof.
  intros; subst; auto.
Qed.

Lemma IRel_trans (V : ipo_obj) t (x y z : V t) :
       x <<< y -> y <<< z -> x <<< z.
Proof.
  intros;
  etransitivity;
  eauto.
Qed.

Lemma IRel_trans_2 (V : ipo_obj) t (x y z : V t) :
       x <<< z -> y <<< x -> y <<< z.
Proof.
  intros;
  etransitivity;
  eauto.
Qed.

Program Instance ipo_proj_struct (A:ipo_obj) (t:T) :
    PO_obj_struct (A t) := {
  Rel := IRel (t:=t)
}.

Definition ipo_proj A t := Build_PO_obj (ipo_proj_struct A t).

Lemma proj_rel (A : ipo_obj) (t : T) (x y : A t) :
        x <<< y -> x << y.
Proof.
  auto.
Qed.

Lemma rel_proj (A : ipo_obj) (t : T) (x y : A t) :
       x << y -> x <<< y.
Proof.
  auto.
Qed.

Notation "'OB'" := ipo_obj (at level 70).

(*Definition ind_po_obj_car (X:OB) (t:T) := POCarrier (X t).

Coercion ind_po_obj_car : ind_po_obj >-> Funclass.
*)

Existing Instance ipo_obj_s.

Class ipo_mor_struct (a b: OB) (f: forall t, a t -> b t) := {
  ind_po_struct :> forall t, Proper (IRel (t:=t) ==> IRel (t:=t)) (f t)
}.

Record ipo_mor (a b: OB) := {
  ipo_mor_carrier :> forall t, a t -> b t;
  ipo_mor_s :> ipo_mor_struct ipo_mor_carrier
}.

Notation "'MOR'" := ipo_mor (at level 70).

Lemma IPO_mor_monotone (a b : ipo_obj)(f : ipo_mor a b):
   forall t x y, x <<< y -> f t x <<< f t y.
Proof.
  intros a b f t x y;
  apply f.
Qed.

Hint Resolve IPO_mor_monotone.

Program Instance ipo_comp_s (a b c: OB) (f: MOR a b)
         (g: MOR b c) : ipo_mor_struct (fun t z => g t (f t z)).
Next Obligation.
Proof.
  unfold Proper; red;
  intros; auto.
Qed.

Definition ipo_comp a b c f g := Build_ipo_mor (ipo_comp_s a b c f g).

Program Definition ind_po_id (a : OB) : MOR a a :=
        Build_ipo_mor (ipo_mor_carrier :=
                             fun t z => z) _ .
Next Obligation.
Proof.
  constructor; intros;
  unfold Proper; red;
  auto.
Qed.

Lemma eq_ind_setoid (a b: OB) :
   Equivalence (fun f g: MOR a b => forall t z, f t z = g t z).
Proof.
  intros; constructor;
  unfold Reflexive,
     Symmetric,
     Transitive;
  intros;
  try etransitivity; auto.
Qed.

Definition ind_po_oid (a b: OB) :=
            Build_Setoid (eq_ind_setoid a b).

Obligation Tactic := cat;
   try (match goal with | [ |- Proper _ _ ] =>
             unfold Proper; do 2 red end) ;
   cat; repeat rew_hyp_2; cat.

Program Instance IPO_struct : Cat_struct ipo_mor := {
  mor_oid := ind_po_oid;
  comp := ipo_comp;
  id := ind_po_id
}.

Canonical Structure IPO := Build_Cat IPO_struct.

Inductive smallest_irel (V : ITYPE T) : forall t, relation (V t) :=
  | t_eq : forall t (x : V t), smallest_irel x x.

Program Instance sm_ipo_struct (V : ITYPE T) : ipo_obj_struct V := {
  IRel := smallest_irel (V:=V)
}.
Next Obligation.
Proof.
  constructor;
  intros; simpl;
  unfold Transitive;
  intros;
  try (match goal with [ H : smallest_irel _ _ |- _ ] =>
       destruct H end);
  try constructor;
  auto.
Qed.

Canonical Structure sm_ipo (V : ITYPE T) : IPO :=
      Build_ipo_obj (sm_ipo_struct V).

Ltac elim_sm := match goal with
   | [ H : @IRel (ipo_obj_carrier (sm_ipo _))
            (ipo_obj_s (sm_ipo _)) _ _ _  |- _ ] => destruct H end.

Lemma sm_irel_eq (V : ITYPE T) t (x y : sm_ipo V t) :
     x <<< y -> x = y.
Proof.
  intros;
  elim_sm;
  auto.
Qed.

Section sm_ipo_mor.

Variables V W : ITYPE T.
Variable f : V ---> W.

Obligation Tactic := intros;
  unfold Proper; red; intros; elim_sm; constructor.

Program Instance sm_ipo_mor_s :
  ipo_mor_struct (a:=sm_ipo V) (b:=sm_ipo W) f.

Canonical Structure sm_ipo_mor : sm_ipo V ---> sm_ipo W :=
        Build_ipo_mor sm_ipo_mor_s.

End sm_ipo_mor.

Obligation Tactic := cat;
   try (match goal with | [ |- Proper _ _ ] =>
             unfold Proper; red end) ;
   cat; repeat rew_hyp_2; cat.

Program Instance SM_ipo_s : Functor_struct sm_ipo_mor.

Definition IDelta := Build_Functor SM_ipo_s.
(*Definition SM_ipo := Build_Functor SM_ipo_s.*)
(*Definition IDelta := SM_ipo.*)

Section SM_ind.

Variable V : ITYPE T.
Variable W : IPO.

Variable f : forall t, V t -> W t.

Obligation Tactic := idtac.

Program Instance SM_ind_s : ipo_mor_struct
  (a:=IDelta V) (b:=W) f.
Next Obligation.
Proof.
  intros;
  try (match goal with | [ |- Proper _ _ ] =>
             unfold Proper; red end);
  intros;
  match goal with [H : IRel _  _|- _ ] => destruct H end;
  reflexivity.
Qed.

Canonical Structure SM_ind := Build_ipo_mor SM_ind_s.

End SM_ind.

Notation "'IP'":= IPO.

Section proj.

Section hom.

Variable t: T.
Variables a b : OB.
Variable f : MOR a b.
(*
Definition ipo_proj_mor_car: ipo_proj a t -> ipo_proj b t :=
             f t .
*)
Program Definition ipo_mor_proj :=
    Build_PO_mor (a:=ipo_proj a t) (b:=ipo_proj b t)
        (PO_fun := f t) _ .
Next Obligation.
Proof.
  constructor.
  unfold Proper; red.
  simpl.
  intros; apply f.
  auto.
Qed.

End hom.

Program Instance IP_proj_Func (t:T) :
     Functor_struct (C:=IP) (D:=Ord)(*Fobj:= fun a => ipo_proj a t*)
                        (ipo_mor_proj t).

Canonical Structure IP_proj t := Build_Functor (IP_proj_Func t).
End proj.

(** Forgetful functor [(T -> PO) -> (T -> Set)] *)
Section forget.

(** if i give Fobj as implicit argument, i will have a BAD
   eta expansion which breaks the NT in po_monads *)

Program Instance OIP_struct : Functor_struct (C:=IPO) (D:= ITYPE T)
  (*Fobj := fun V => fun t => V t*)
  (fun V W => fun f => f).

Definition OIP := Build_Functor OIP_struct.

End forget.

(** Category IP has initial and terminal object *)

Section IND_PO_init_term.

Program Instance IP_term_struct : ipo_obj_struct (fun t => unit) := {
  IRel t := fun _ _ => True
}.
Next Obligation.
Proof.
  constructor;
  auto.
Qed.

Definition IP_term := Build_ipo_obj IP_term_struct.

Program Instance IP_term_mor_struct (a: OB) :
     ipo_mor_struct (a:=a)(b:=IP_term)(fun _ _ => tt).

Definition IP_term_mor (a:OB) := Build_ipo_mor (IP_term_mor_struct a).

Hint Extern 3 (?a = ?b) => try destruct a.

Program Instance IP_Terminal : Terminal IP := {
  Term :=  IP_term;
  TermMor := IP_term_mor
}.

Program Instance IP_init_struct : ipo_obj_struct (fun t => TEMPTY) := {
  IRel t := fun _ _ => True
}.
Next Obligation.
Proof.
  constructor;
  auto.
Qed.

Definition IP_init := Build_ipo_obj IP_init_struct.

Obligation Tactic := intros;
  unfold Proper; red; cat;
  repeat (match goal with
  [ H : TEMPTY |- _ ] => elim H end); cat.

Program Instance IP_init_mor_struct (a : OB) :
   ipo_mor_struct
     (a:=IP_init)
     (b:=a)
     (fun t => InitMor (C:=TYPE) (a t)).

Definition IP_init_mor (a:OB) := Build_ipo_mor (IP_init_mor_struct a).

Program Instance IP_Initial : Initial IP := {
  Init := IP_init;
  InitMor := IP_init_mor
}.

End IND_PO_init_term.

(** Adding a distinct element of type (T u)
      to a family of preorders A *)

Inductive optrelT (u:T) (V: IP) :
  forall t,relation (opt u V t):=
  | optrelTP_none :  optrelT (none u V) (none u V)
  | optrelTP_some : forall t (y z:V t), y <<< z ->
          optrelT (some u y) (some u z).

Program Instance opt_TP_preorder (u:T)(A:IP):
     ipo_obj_struct (opt u A) := {
 IRel := @optrelT u A
}.
Next Obligation.
Proof.
  intros;
  constructor;
  unfold Reflexive, Transitive.
  intro z; induction z;
  constructor. apply IPOprf.

  intros r y z H. generalize dependent z.
  elim H.
  intros z Hz.
  dependent induction Hz.
  constructor.

  intros t0 x0 y0 H0 z H1.
  generalize dependent x0.
  dependent destruction H1. (* worked with dependent induction in 8.3rc1 *)
  intros.
  constructor.
  transitivity y0; auto.
Qed.

Canonical Structure opt_TP u A := Build_ipo_obj (opt_TP_preorder u A).

Notation "V *" := (opt_TP _ V) (at level 5).

(** injection Some_TP is a morphism of preorders *)
Obligation Tactic := unfold Proper; red;
                  constructor; auto.

Program Instance Some_TP_POs (u:T) (A:IP) :
  ipo_mor_struct (a:=A)(b:=A*)
  (@some _ u _ ).

Canonical Structure Some_TP_PO (u:T) (A:IP): A ---> A* :=
  Build_ipo_mor (Some_TP_POs u A).

(** opt_TP is a monad
     - return := Some_TP
     - bind f := default f None_TP
   this would give us a functor again *)

Program Definition opt_TP_weta (u:T)(V:IP) : V ---> V* :=
   Build_ipo_mor (ipo_mor_carrier := @some _ u V) _.

Obligation Tactic := idtac.

Program Definition opt_TP_kl (u:T) (V W : OB)
              (f: V ---> W*) : V* ---> W* :=
   Build_ipo_mor (ipo_mor_carrier := @opt_kl _ u V W f) _.
Next Obligation.
Proof.
  constructor.
  unfold Proper;
  repeat red; intros.
  induction H; simpl.
  constructor.
  apply f; auto.
Qed.

Canonical Structure opt_TP_kl.

Obligation Tactic := repeat red; cat; elim_opt.

Program Instance opt_TP_monad_struct (u:T) :
   Monad_struct (fun V => opt_TP u V) := {
  weta V := opt_TP_weta u V;
  kleisli V W f := opt_TP_kl (u:=u)  f
}.

Canonical Structure opt_TP_monad (u:T):=
     Build_Monad (opt_TP_monad_struct u).

Section opt_TP_opt_T.

Lemma TP_T_kl: forall u (V W:IP) (f:V ---> W*) (t:T) z,
   kleisli (Monad_struct:= (opt_TP_monad u)) f z =
         kleisli (Monad_struct:= (opt_monad u)) f z.
Proof.
  intros; simpl; auto.
Qed.

Lemma TP_T_weta: forall u (V:IP) (t:T) (z:V t),
   weta (Monad_struct:= (opt_TP_monad u)) V t z =
   (weta (Monad_struct:= (opt_monad u))) V t z.
Proof.
  intros; simpl; auto.
Qed.

End opt_TP_opt_T.

(** Derived Module *)

Section PostComp_w_Monad.

(** default *)

Program Definition opt_TP_default (u:T) (V W : IP)
      (f: V ---> W) (w:W u): V* ---> W :=
  Build_ipo_mor (ipo_mor_carrier := @opt_default _ u V W f w) _ .
Next Obligation.
Proof.
  constructor.
  unfold Proper;  red.
  intros t q y H;
  induction H; simpl.
  apply IPOprf.
  apply f.
  auto.
Qed.

Canonical Structure opt_TP_default.
(** Monad P, we define
     - var_inj V : V ---> P V*
     - def_var_inj (f: V ---> P W) -> V* ---> P W*
*)

Variable P : Monad IPO.

Existing Instance IPO_struct.

Definition opt_TP_def_varinj (u:T) (V W: IP) (f:V ---> P W) :
          opt_TP u V ---> P (opt_TP u W):=
 (opt_TP_default (u:=u) (V:=V) (W:=P (opt_TP u W))
 (f ;; lift (weta (Monad_struct := (opt_TP_monad u)) W))
 (weta (Monad_struct := P) (opt_TP u W) u (none u W))).

(** needed for module property of the derivative *)

Ltac t := simpl; intros; elim_opt; rew (lift_weta P).

Lemma opt_TP_def_varinj_weta (u:T)(V:IP) :
      opt_TP_def_varinj u (weta V) == weta _.
Proof. t.
Qed.

Lemma opt_TP_def_varinj_weta_f (u:T) (V V':IP) (f: V' ---> V) :
     opt_TP_def_varinj u (f ;; weta V) ==
         lift (M :=opt_TP_monad u) f ;; weta _ .
Proof. t.
Qed.

End PostComp_w_Monad.

Section substitution.

Variable R: Monad IP.

Section subst_kleisli_arg.

Variable V: IP.
Variable r: T.
Variable W : R V r.

Definition IPsubst_map := opt_TP_default (weta (Monad_struct:=R) _ ) W.

End subst_kleisli_arg.

Definition IPsubstar (r:T) (V:IP) (W:R V r) := kleisli (IPsubst_map W).

End substitution.

End ind_po_cat.

Notation "x <<< y" := (IRel x y) (at level 60).

Existing Instance IP_Initial.
Existing Instance IP_Terminal.
Existing Instance IPO_struct.
Existing Instance ipo_obj_s.
Existing Instance ipo_mor_s.
Existing Instance IPOprf.


Require Export prosa.model.task.preemption.parameters.
Require Export prosa.model.schedule.priority_driven.
Require Export prosa.model.schedule.work_conserving.
Require Export prosa.analysis.definitions.job_properties.
Require Export prosa.analysis.definitions.busy_interval.
Require Export prosa.analysis.facts.model.ideal_schedule.
Require Export prosa.analysis.facts.busy_interval.busy_interval.

(** Throughout this file, we assume ideal uni-processor schedules. *)
Require Import prosa.model.processor.ideal.

(** Throughout the file we assume for the classic Liu & Layland model
    of readiness without jitter and no self-suspensions, where
    pending jobs are always ready. *)
Require Import prosa.model.readiness.basic.

(** In preparation of the derivation of the priority inversion bound, we
    establish two basic facts on preemption times. *)
Section PreemptionTimes.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.
  Context `{TaskMaxNonpreemptiveSegment Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** In addition, we assume the existence of a function mapping a
      task to its maximal non-preemptive segment ... *)
  Context `{TaskMaxNonpreemptiveSegment Task}.

  (** ... and the existence of a function mapping a job and
      its progress to a boolean value saying whether this job is
      preemptable at its current point of execution. *)
  Context `{JobPreemptable Job}.

  (** Consider any arrival sequence with consistent arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.

  (** Next, consider any ideal uniprocessor schedule of this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_jobs_come_from_arrival_sequence:
    jobs_come_from_arrival_sequence sched arr_seq.

  (** Consider a valid model with bounded nonpreemptive segments. *)
  Hypothesis H_model_with_bounded_nonpreemptive_segments:
    valid_model_with_bounded_nonpreemptive_segments arr_seq sched.

  (** Then, we show that time 0 is a preemption time. *)
  Lemma zero_is_pt: preemption_time sched 0.
  Proof.
    unfold preemption_time.
    case SCHED: (sched 0) => [j | ]; last by done.
    move: (SCHED) => /eqP; rewrite -scheduled_at_def; move => ARR.
    apply H_jobs_come_from_arrival_sequence in ARR.
    rewrite /service /service_during big_geq; last by done.
    destruct H_model_with_bounded_nonpreemptive_segments as [T1 T2].
    by move: (T1 j ARR) => [PP _].
  Qed.

  (** Also, we show that the first instant of execution is a preemption time. *)
  Lemma first_moment_is_pt:
    forall j prt,
      arrives_in arr_seq j ->
      ~~ scheduled_at sched j prt ->
      scheduled_at sched j prt.+1 ->
      preemption_time sched prt.+1.
  Proof.
    intros s pt ARR NSCHED SCHED.
    unfold preemption_time.
    move: (SCHED); rewrite scheduled_at_def; move => /eqP SCHED2; rewrite SCHED2; clear SCHED2.
    destruct H_model_with_bounded_nonpreemptive_segments as [T1 T2].
    by move: (T1 s ARR) => [_ [_ [_ P]]]; apply P.
  Qed.

End PreemptionTimes.

(** * Priority inversion is bounded *)
(** In this module we prove that any priority inversion that occurs in the model with bounded
    nonpreemptive segments defined in module prosa.model.schedule.uni.limited.platform.definitions
    is bounded. *)
Section PriorityInversionIsBounded.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent arrivals ... *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.

  (** ... and any ideal uniprocessor schedule of this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_jobs_come_from_arrival_sequence:
    jobs_come_from_arrival_sequence sched arr_seq.

  (** ... where jobs do not execute before their arrival or after completion. *)
  Hypothesis H_jobs_must_arrive_to_execute : jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute : completed_jobs_dont_execute sched.

  (** Consider a JLFP policy that indicates a higher-or-equal priority relation,
      and assume that the relation is reflexive and transitive. *)
  Context `{JLFP_policy Job}.
  Hypothesis H_priority_is_reflexive: reflexive_priorities.
  Hypothesis H_priority_is_transitive: transitive_priorities.

  (** In addition, we assume the existence of a function mapping a
      task to its maximal non-preemptive segment ... *)
  Context `{TaskMaxNonpreemptiveSegment Task}.

  (** ... and the existence of a function mapping a job and its
      progress to a boolean value saying whether this job is
      preemptable at its current point of execution. *)
  Context `{JobPreemptable Job}.

  (** And assume that they define a valid preemption model with
     bounded nonpreemptive segments. *)
  Hypothesis H_valid_model_with_bounded_nonpreemptive_segments:
    valid_model_with_bounded_nonpreemptive_segments arr_seq sched.

  (** Next, we assume that the schedule is a work-conserving schedule... *)
  Hypothesis H_work_conserving : work_conserving arr_seq sched.

  (** ... and the schedule respects the policy defined by the
       predicate [job_preemptable] (i.e., bounded nonpreemptive
       segments). *)
  Hypothesis H_respects_policy:
    respects_policy_at_preemption_point arr_seq sched.

  (** Let's define some local names for clarity. *)
  Let job_scheduled_at := scheduled_at sched.
  Let job_completed_by := completed_by sched.

  (** Finally, we introduce the notion of the maximal length of
       (potential) priority inversion at a time instant [t], which is
       defined as the maximum length of nonpreemptive segments among
       all jobs that arrived so far. Note that the value
       [job_max_nonpreemptive_segment j_lp] is at least [ε] for any job
       [j_lp], so the maximal length of priority inversion cannot be
       negative. *)
  Definition max_length_of_priority_inversion (j : Job) (t : instant) :=
    \max_(j_lp <- arrivals_before arr_seq t | ~~ hep_job j_lp j)
     (job_max_nonpreemptive_segment j_lp - ε).

  (** Next we prove that a priority inversion of a job is bounded by
      function [max_length_of_priority_inversion]. *)

  (** Note that any bound on function
      [max_length_of_priority_inversion] will also be a bound on the
      maximal priority inversion. This bound may be different for
      different scheduler and/or task models. Thus, we don't define
      such a bound in this module. *)

  (** Consider any job [j] of [tsk] with positive job cost. *)
  Variable j : Job.
  Hypothesis H_j_arrives : arrives_in arr_seq j.
  Hypothesis H_job_cost_positive : job_cost_positive j.

  (** Consider any busy interval prefix <<[t1, t2)>> of job j. *)
  Variable t1 t2 : instant.
  Hypothesis H_busy_interval_prefix:
    busy_interval_prefix arr_seq sched j t1 t2.

  (** * Processor Executes HEP jobs after Preemption Point *)
  (** In this section, we prove that at any time instant after any preemption point
     (inside the busy interval), the processor is always busy scheduling a
     job with higher or equal priority. *)
  Section PreemptionTimeAndPriorityInversion.

    (** First, we show that the processor at any preemptive point is always
        busy scheduling a job with higher or equal priority. *)
    Section ProcessorBusyWithHEPJobAtPreemptionPoints.

      (** Consider an arbitrary preemption time t ∈ <<[t1,t2)>>. *)
      Variable t : instant.
      Hypothesis H_t_in_busy_interval : t1 <= t < t2.
      Hypothesis H_t_preemption_time : preemption_time sched t.

      (** First note since [t] lies inside the busy interval,
          the processor cannot be idle at time [t]. *)
      Lemma instant_t_is_not_idle:
        ~ is_idle sched t.
      Proof.
        intros Idle.
          by exfalso; eapply not_quiet_implies_not_idle with (t0 := t); eauto 2.
      Qed.

      (** Next we consider two cases: (1) when [t] is less than [t2 - 1] and (2) [t] is equal to [t2 - 1]. *)
      Lemma t_lt_t2_or_t_eq_t2:
        t < t2.-1 \/ t = t2.-1.
      Proof.
        have TEMP: t <= t2.-1.
        { move: (H_t_in_busy_interval) => /andP [GEt LEt].
            by rewrite -subn1 subh3 // addn1.
        }
        rewrite leq_eqVlt in TEMP; move: TEMP => /orP [/eqP EQUALt2m1 | LTt2m1].
        - right; auto.
        - left; auto.
      Qed.

      (** In case when [t < t2 - 1], we use the fact that time instant
          [t+1] is not a quiet time. The later implies that there is a
          pending higher-or-equal priority job at time [t]. Thus, the
          assumption that the schedule respects priority policy at
          preemption points implies that the scheduled job must have a
          higher-or-equal priority. *)
      Lemma scheduled_at_preemption_time_implies_higher_or_equal_priority_lt:
        t < t2.-1 ->
        forall jhp,
          scheduled_at sched jhp t ->
          hep_job jhp j.
      Proof.
        intros LTt2m1 jhp Sched_jhp.
        move: (H_t_in_busy_interval) (H_busy_interval_prefix) => /andP [GEt LEt] [SL [QUIET [NOTQUIET INBI]]].
        apply contraT; move => /negP NOTHP; exfalso.
        apply NOTQUIET with (t := t.+1).
        { apply/andP; split.
          - by apply leq_ltn_trans with t1.
          - rewrite -subn1 ltn_subRL addnC in LTt2m1.
              by rewrite -[t.+1]addn1.
        }
        intros j_hp' IN HP ARR.
        apply contraT; move => /negP NOTCOMP'; exfalso.
        have BACK: backlogged sched j_hp' t.
        { apply/andP; split; last first.
          { apply/negP; intro SCHED'.
            move: (ideal_proc_model_is_a_uniprocessor_model jhp j_hp' sched t Sched_jhp SCHED') => EQ; subst.
              by apply: NOTHP.
          }
          apply/andP; split. unfold arrived_before, has_arrived in *. by done.
          apply/negP; intro COMP; apply NOTCOMP'.
            by apply completion_monotonic with (t0 := t).
        }
        apply NOTHP, (H_priority_is_transitive t j_hp'); eauto 2.
      Qed.

      (** In case when [t = t2 - 1], we cannot use the same proof
          since [t+1 = t2], but [t2] is a quiet time. So we do a
          similar case analysis on the fact that [t1 = t ∨ t1 < t]. *)
      Lemma scheduled_at_preemption_time_implies_higher_or_equal_priority_eq:
        t = t2.-1 ->
        forall jhp,
          scheduled_at sched jhp t ->
          hep_job jhp j.
      Proof.
        intros EQUALt2m1 jhp Sched_jhp.
        move: (H_t_in_busy_interval) (H_busy_interval_prefix) => /andP [GEt LEt] [SL [QUIET [NOTQUIET INBI]]].
        apply contraT; move => /negP NOTHP; exfalso.
        rewrite leq_eqVlt in GEt; first move: GEt => /orP [/eqP EQUALt1 | LARGERt1].
        - subst t; clear LEt.
          rewrite -EQUALt1 in Sched_jhp; move: EQUALt1 => /eqP EQUALt1.
          destruct (job_scheduled_at j t1) eqn:SCHEDj.
          + apply NOTHP; erewrite (ideal_proc_model_is_a_uniprocessor_model j jhp); eauto.
              by apply (H_priority_is_reflexive 0).
          + eapply NOTHP, (H_respects_policy _ _ t2.-1); auto;
              last by rewrite -(eqbool_to_eqprop EQUALt1).
            apply/andP; split; last first.
            * by rewrite -(eqbool_to_eqprop EQUALt1); unfold job_scheduled_at in *; rewrite SCHEDj.
            * have EQ: t1 = job_arrival j.
              { rewrite -eqSS in EQUALt1.
                have EQ: t2 = t1.+1.
                { rewrite prednK in EQUALt1; first by apply/eqP; rewrite eq_sym.
                  apply negbNE; rewrite -eqn0Ngt; apply/neqP; intros EQ0.
                  move: INBI; rewrite EQ0; move => /andP [_ CONTR].
                    by rewrite ltn0 in CONTR.
                } clear EQUALt1.
                  by move: INBI; rewrite EQ ltnS -eqn_leq; move => /eqP INBI.
              }
                by rewrite -(eqbool_to_eqprop EQUALt1) EQ; eapply job_pending_at_arrival; eauto 2.
        - feed (NOTQUIET t); first by apply/andP; split.
          apply NOTQUIET; intros j_hp' IN HP ARR.
          apply contraT; move => /negP NOTCOMP'; exfalso.
          have BACK: backlogged sched j_hp' t.
          { apply/andP; split.
            - apply/andP; split. unfold arrived_before, has_arrived in *. by rewrite ltnW.
              apply/negP; intro COMP; apply NOTCOMP'.
                by apply completion_monotonic with (t0 := t).
            - apply/negP; intro SCHED'.
              move: (ideal_proc_model_is_a_uniprocessor_model jhp j_hp' sched t Sched_jhp SCHED') => EQ; subst.
                by apply: NOTHP.
          }
          apply NOTHP, (H_priority_is_transitive t j_hp'); eauto 2.
      Qed.

      (** By combining the above facts we conclude that a job that is
          scheduled at time [t] has higher-or-equal priority. *)
      Corollary scheduled_at_preemption_time_implies_higher_or_equal_priority:
        forall jhp,
          scheduled_at sched jhp t ->
          hep_job jhp j.
      Proof.
        move: (H_t_in_busy_interval) (H_busy_interval_prefix) => /andP [GEt LEt] [SL [QUIET [NOTQUIET INBI]]].
        destruct t_lt_t2_or_t_eq_t2.
        - by apply scheduled_at_preemption_time_implies_higher_or_equal_priority_lt.
        - by apply scheduled_at_preemption_time_implies_higher_or_equal_priority_eq.
      Qed.

      (** Since a job that is scheduled at time [t] has higher-or-equal priority,
          by properties of a busy interval it cannot arrive before time instant [t1]. *)
      Lemma scheduled_at_preemption_time_implies_arrived_between_within_busy_interval:
        forall jhp,
          scheduled_at sched jhp t ->
          arrived_between jhp t1 t2.
      Proof.
        intros jhp Sched_jhp.
        rename H_work_conserving into WORK, H_jobs_come_from_arrival_sequence into CONS.
        move: (H_busy_interval_prefix) => [SL [QUIET [NOTQUIET INBI]]].
        move: (H_t_in_busy_interval) => /andP [GEt LEt].
        have HP := scheduled_at_preemption_time_implies_higher_or_equal_priority _ Sched_jhp.
        move: (Sched_jhp) => PENDING.
        eapply scheduled_implies_pending in PENDING; eauto 2 with basic_facts.
        apply/andP; split; last by apply leq_ltn_trans with (n := t); first by move: PENDING => /andP [ARR _].
        apply contraT; rewrite -ltnNge; intro LT; exfalso.
        feed (QUIET jhp); first by eapply CONS, Sched_jhp.
        specialize (QUIET HP LT).
        have COMP: job_completed_by jhp t by apply completion_monotonic with (t0 := t1).
        apply completed_implies_not_scheduled in COMP; last by done.
          by move: COMP => /negP COMP; apply COMP.
      Qed.

      (** From the above lemmas we prove that there is a job [jhp] that is (1) scheduled at time [t],
          (2) has higher-or-equal priority, and (3) arrived between [t1] and [t2].   *)
      Corollary not_quiet_implies_exists_scheduled_hp_job_at_preemption_point:
        exists j_hp,
          arrived_between j_hp t1 t2 /\
          hep_job j_hp j /\
          job_scheduled_at j_hp t.
      Proof.
        move: (H_busy_interval_prefix) => [SL [QUIET [NOTQUIET INBI]]].
        move: (H_t_in_busy_interval) => /andP [GEt LEt].
        ideal_proc_model_sched_case_analysis sched t jhp.
        { by exfalso; apply instant_t_is_not_idle. }
        exists jhp.
        repeat split.
        - by apply scheduled_at_preemption_time_implies_arrived_between_within_busy_interval.
        - by apply scheduled_at_preemption_time_implies_higher_or_equal_priority.
        - by done.
      Qed.

    End ProcessorBusyWithHEPJobAtPreemptionPoints.

    (** Next we prove that every nonpreemptive segment
        always begins with a preemption time ... *)
    Lemma scheduling_of_any_segment_starts_with_preemption_time:
      forall j t,
        job_scheduled_at j t ->
        exists pt,
          job_arrival j <= pt <= t /\
          preemption_time sched pt /\
          (forall t', pt <= t' <= t -> job_scheduled_at j t').
    Proof.
      intros s t SCHEDst.
      have EX: exists t', (t' <= t) && (job_scheduled_at s t')
                              && (all (fun t'' => job_scheduled_at s t'') (index_iota t' t.+1 )).
      { exists t. apply/andP; split; [ by apply/andP; split | ].
        apply/allP; intros t'.
          by rewrite mem_index_iota ltnS -eqn_leq; move => /eqP <-.
      }
      have MIN := ex_minnP EX.
      move: MIN => [mpt /andP [/andP [LT1 SCHEDsmpt] /allP ALL] MIN]; clear EX.
      destruct mpt.
      - exists 0; repeat split.
        + by apply/andP; split; first apply H_jobs_must_arrive_to_execute in SCHEDsmpt.
        + by eapply zero_is_pt; eauto 2.
        + by intros; apply ALL; rewrite mem_iota subn0 add0n ltnS.
      - have NSCHED: ~~ job_scheduled_at s mpt.
        { apply/negP; intros SCHED.
          enough (F : mpt < mpt); first by rewrite ltnn in F.
          apply MIN.
          apply/andP; split; [by apply/andP; split; [ apply ltnW | ] | ].
          apply/allP; intros t'.
          rewrite mem_index_iota; move => /andP [GE LE].
          move: GE; rewrite leq_eqVlt; move => /orP [/eqP EQ| LT].
          - by subst t'.
          - by apply ALL; rewrite mem_index_iota; apply/andP; split.
        }
        have PP: preemption_time sched mpt.+1.
        { by eapply first_moment_is_pt with (j0 := s); eauto 2. }
        exists mpt.+1; repeat split; try done.
        + apply/andP; split; last by done.
            by apply H_jobs_must_arrive_to_execute in SCHEDsmpt.
        + move => t' /andP [GE LE].
            by apply ALL; rewrite mem_index_iota; apply/andP; split.
    Qed.

    (** ... and the fact that at any time instant after a preemption point the
       processor is always busy with a job with higher or equal priority. *)
    Lemma not_quiet_implies_exists_scheduled_hp_job_after_preemption_point:
      forall tp t,
        preemption_time sched tp ->
        t1 <= tp < t2 ->
        tp <= t < t2 ->
        exists j_hp,
          arrived_between j_hp t1 t.+1 /\
          hep_job j_hp j /\
          job_scheduled_at j_hp t.
    Proof.
      move: (H_jobs_come_from_arrival_sequence) (H_work_conserving) => CONS WORK.
      move: (H_respects_policy) => PRIO.
      move => tp t PRPOINT /andP [GEtp LTtp] /andP [LEtp LTt].
      ideal_proc_model_sched_case_analysis_eq sched t jhp.
      { exfalso; eapply not_quiet_implies_not_idle with (t0 := t); eauto 2.
          by apply/andP; split; first apply leq_trans with tp. }
      exists jhp.
      have HP: hep_job jhp j.
      { intros.
        have SOAS := scheduling_of_any_segment_starts_with_preemption_time _ _ Sched_jhp.
        move: SOAS => [prt [/andP [_ LE] [PR SCH]]].
        case E:(t1 <= prt).
        - move: E => /eqP /eqP E; rewrite subn_eq0 in E.
          edestruct not_quiet_implies_exists_scheduled_hp_job_at_preemption_point as [jlp [_ [HEP SCHEDjhp]]]; eauto 2.
          { by apply /andP; split; last by apply leq_ltn_trans with t. }
          enough (EQ : jhp = jlp); first by subst.
          eapply ideal_proc_model_is_a_uniprocessor_model with (t0 := prt); eauto;
            by apply SCH; apply/andP; split.
        - move: E => /eqP /neqP E; rewrite -lt0n subn_gt0 in E.
          apply negbNE; apply/negP; intros LP; rename jhp into jlp.
          edestruct not_quiet_implies_exists_scheduled_hp_job_at_preemption_point
            as [jhp [_ [HEP SCHEDjhp]]]; [ | apply PRPOINT| ]; first by apply/andP; split.
          move: LP => /negP LP; apply: LP.
          enough (EQ : jhp = jlp); first by subst.
          eapply ideal_proc_model_is_a_uniprocessor_model with (j1 := jhp) (t0 := tp); eauto.
            by apply SCH; apply/andP; split; first apply leq_trans with t1; auto.
      }
      repeat split; try done.
      move: (H_busy_interval_prefix) => [SL [QUIET [NOTQUIET EXj]]]; move: (Sched_jhp) => PENDING.
      eapply scheduled_implies_pending in PENDING; eauto with basic_facts.
      apply/andP; split; last by apply leq_ltn_trans with (n := t); first by move: PENDING => /andP [ARR _].
      apply contraT; rewrite -ltnNge; intro LT; exfalso.
      feed (QUIET jhp); first by eapply CONS, Sched_jhp.
      specialize (QUIET HP LT).
      have COMP: job_completed_by jhp t.
      { by apply completion_monotonic with (t0 := t1); [ apply leq_trans with tp | ]. }
      apply completed_implies_not_scheduled in COMP; last by done.
        by move: COMP => /negP COMP; apply COMP.
    Qed.

    (** Now, suppose there exists some constant K that bounds the distance to
       a preemption time from the beginning of the busy interval. *)
    Variable K : duration.
    Hypothesis H_preemption_time_exists:
      exists pr_t, preemption_time sched pr_t /\ t1 <= pr_t <= t1 + K.

    (** Then we prove that the processor is always busy with a job with
       higher-or-equal priority after time instant [t1 + K]. *)
    Lemma not_quiet_implies_exists_scheduled_hp_job:
      forall t,
        t1 + K <= t < t2 ->
        exists j_hp,
          arrived_between j_hp t1 t.+1 /\
          hep_job j_hp j /\
          job_scheduled_at j_hp t.
    Proof.
      move => t /andP [GE LT].
      move: H_preemption_time_exists => [prt [PR /andP [GEprt LEprt]]].
      apply not_quiet_implies_exists_scheduled_hp_job_after_preemption_point with (tp := prt); eauto 2.
      -  apply/andP; split; first by done.
         apply leq_ltn_trans with (t1 + K); first by done.
           by apply leq_ltn_trans with t.
      - apply/andP; split; last by done.
          by apply leq_trans with (t1 + K).
    Qed.

  End PreemptionTimeAndPriorityInversion.

  (** * Preemption Time Exists *)
  (** In this section we prove that the function [max_length_of_priority_inversion]
     indeed upper bounds the priority inversion length. *)
  Section PreemptionTimeExists.

    (** First we prove that if a job with higher-or-equal priority is scheduled at
       a quiet time [t+1] then this is the first time when this job is scheduled. *)
    Lemma hp_job_not_scheduled_before_quiet_time:
      forall jhp t,
        quiet_time arr_seq sched j t.+1 ->
        job_scheduled_at jhp t.+1 ->
        hep_job jhp j ->
        ~~ job_scheduled_at jhp t.
    Proof.
      intros jhp t QT SCHED1 HP.
      apply/negP; intros SCHED2.
      specialize (QT jhp).
      feed_n 3 QT; eauto.
      apply completed_implies_not_scheduled in QT; last by done.
        by move: QT => /negP NSCHED; apply: NSCHED.
    Qed.

    (** Also, we show that lower-priority jobs that are scheduled inside the
       busy-interval prefix <<[t1,t2)>> must arrive before that interval. *)
    Lemma low_priority_job_arrives_before_busy_interval_prefix:
      forall jlp t,
        t1 <= t < t2 ->
        job_scheduled_at jlp t ->
        ~~ hep_job jlp j ->
        job_arrival jlp < t1.
    Proof.
      move => jlp t /andP [GE LT] SCHED LP.
      move: (H_busy_interval_prefix) => [NEM [QT [NQT HPJ]]].
      apply negbNE; apply/negP; intros ARR; rewrite -leqNgt in ARR.
      have SCH:= scheduling_of_any_segment_starts_with_preemption_time _ _ SCHED.
      move: SCH => [pt [/andP [NEQ1 NEQ2] [PT FA]]].
      have NEQ: t1 <= pt < t2.
      { apply/andP; split.
        apply leq_trans with (job_arrival jlp); by done.
        apply leq_ltn_trans with t; by done. }
      have LL:= not_quiet_implies_exists_scheduled_hp_job_at_preemption_point pt.
      feed_n 2 LL; try done.
      move: LL => [jhp [ARRjhp [HP SCHEDhp]]].
      feed (FA pt); first (by apply/andP; split).
      move: LP => /negP LP; apply: LP.
        by have ->: jlp = jhp by eapply ideal_proc_model_is_a_uniprocessor_model; eauto.
    Qed.

    (** Moreover, we show that lower-priority jobs that are scheduled
        inside the busy-interval prefix <<[t1,t2)>> must be scheduled
        before that interval. *)
    Lemma low_priority_job_scheduled_before_busy_interval_prefix:
      forall jlp t,
        t1 <= t < t2 ->
        job_scheduled_at jlp t ->
        ~~ hep_job jlp j ->
        exists t', t' < t1 /\ job_scheduled_at jlp t'.
    Proof.
      move => jlp t NEQ SCHED LP; move: (NEQ) => /andP [GE LT].
      have ARR := low_priority_job_arrives_before_busy_interval_prefix _ _ NEQ SCHED LP.
      exists t1.-1; split.
      { by rewrite prednK; last apply leq_ltn_trans with (job_arrival jlp). }
      move: (H_busy_interval_prefix) => [NEM [QT [NQT HPJ]]].
      have SCHEDST := scheduling_of_any_segment_starts_with_preemption_time _ _ SCHED.
      move: SCHEDST => [pt [NEQpt [PT SCHEDc]]].
      have LT2: pt < t1.
      { rewrite ltnNge; apply/negP; intros CONTR.
        have NQSCHED := not_quiet_implies_exists_scheduled_hp_job_at_preemption_point pt.
        feed_n 2 NQSCHED; try done.
        { apply/andP; split; first by done.
            by apply leq_ltn_trans with t; move: NEQpt => /andP [_ T].
        } move: NQSCHED => [jhp [ARRhp [HPhp SCHEDhp]]].
        specialize (SCHEDc pt).
        feed SCHEDc; first by apply/andP; split; last move: NEQpt => /andP [_ T].
        move: LP => /negP LP; apply: LP.
          by have ->: jlp = jhp by eapply ideal_proc_model_is_a_uniprocessor_model; eauto.
      }
      apply SCHEDc; apply/andP; split.
      - by rewrite -addn1 in LT2; apply subh3 in LT2; rewrite subn1 in LT2.
      - by apply leq_trans with t1; first apply leq_pred.
    Qed.

    (** Thus, there must be a preemption time in the interval [t1, t1
        + max_priority_inversion t1]. That is, if a job with
        higher-or-equal priority is scheduled at time instant t1, then
        t1 is a preemption time. Otherwise, if a job with lower
        priority is scheduled at time t1, then this jobs also should
        be scheduled before the beginning of the busy interval. So,
        the next preemption time will be no more than
        [max_priority_inversion t1] time units later. *)

    (** We proceed by doing a case analysis. *)
    Section CaseAnalysis.

      (** (1) Case when the schedule is idle at time [t1]. *)
      Section Case1.

        (** Assume that the schedule is idle at time [t1]. *)
        Hypothesis H_is_idle : is_idle sched t1.

        (** Then time instant [t1] is a preemption time. *)
        Lemma preemption_time_exists_case1:
          exists pr_t,
            preemption_time sched pr_t /\
            t1 <= pr_t <= t1 + max_length_of_priority_inversion j t1.
        Proof.
          set (service := service sched).
          move: (H_valid_model_with_bounded_nonpreemptive_segments) => CORR.
          move: (H_busy_interval_prefix) => [NEM [QT1 [NQT HPJ]]].
          exists t1; split.
          - by rewrite /preemption_time (eqbool_to_eqprop H_is_idle).
          - by apply/andP; split; last rewrite leq_addr.
        Qed.

      End Case1.

      (** (2) Case when a job with higher-or-equal priority is scheduled at time [t1]. *)
      Section Case2.

        (** Assume that a job [jhp] with higher-or-equal priority is scheduled at time [t1]. *)
        Variable jhp : Job.
        Hypothesis H_jhp_is_scheduled : scheduled_at sched jhp t1.
        Hypothesis H_jhp_hep_priority : hep_job jhp j.

        (** Then time instant [t1] is a preemption time. *)
        Lemma preemption_time_exists_case2:
          exists pr_t,
            preemption_time sched pr_t /\
            t1 <= pr_t <= t1 + max_length_of_priority_inversion j t1.
        Proof.
          set (service := service sched).
          move: (H_valid_model_with_bounded_nonpreemptive_segments) => CORR.
          move: (H_busy_interval_prefix) => [NEM [QT1 [NQT HPJ]]].
          exists t1; split; last first.
          apply/andP; split; [by done | by rewrite leq_addr].
          destruct t1.
          - eapply zero_is_pt; eauto 2.
          - eapply hp_job_not_scheduled_before_quiet_time in QT1; eauto 2.
              by eapply first_moment_is_pt with (j0 := jhp); eauto 2.
        Qed.

      End Case2.

      (** (3) Case when a job with lower priority is scheduled at time [t1]. *)
      Section Case3.

        (** Assume that a job [jhp] with lower priority is scheduled at time [t1]. *)
        Variable jlp : Job.
        Hypothesis H_jlp_is_scheduled : scheduled_at sched jlp t1.
        Hypothesis H_jlp_low_priority : ~~ hep_job jlp j.

        (** To prove the lemma in this case we need a few auxiliary
            facts about the first preemption point of job [jlp]. *)
        Section FirstPreemptionPointOfjlp.

          (** Let's denote the progress of job [jlp] at time [t1] as [progr_t1]. *)
          Let progr_t1 := service sched jlp t1.

          (** Consider the first preemption point of job [jlp] after [progr_t1]. *)
          Variable fpt : instant.
          Hypothesis H_fpt_is_preemptio_point : job_preemptable jlp (progr_t1 + fpt).
          Hypothesis H_fpt_is_first_preemption_point:
            forall ρ,
              progr_t1 <= ρ <= progr_t1 + (job_max_nonpreemptive_segment jlp - ε) ->
              job_preemptable jlp ρ ->
              service sched jlp t1 + fpt <= ρ.

          (** For convenience we also assume the following inequality holds. *)
          Hypothesis H_progr_le_max_nonp_segment:
            progr_t1 <= progr_t1 + fpt <= progr_t1 + (job_max_nonpreemptive_segment jlp - ε).

          (** First we show that [fpt] is indeed the first preemption point after [progr_t1]. *)
          Lemma no_intermediate_preemption_point:
            forall ρ,
              progr_t1 <= ρ < progr_t1 + fpt ->
              ~~ job_preemptable jlp ρ.
          Proof.
            move => prog /andP [GE LT].
            apply/negP; intros PPJ.
            move: H_fpt_is_first_preemption_point => K; specialize (K prog).
            feed_n 2 K; first (apply/andP; split); try done.
            apply leq_trans with (service sched jlp t1 + fpt).
            + by apply ltnW.
            + by move: H_progr_le_max_nonp_segment => /andP [_ LL].
                by move: K; rewrite leqNgt; move => /negP NLT; apply: NLT.
          Qed.

          (** Thanks to the fact that the scheduler respects the notion of preemption points
              we show that [jlp] is continuously scheduled in time interval <<[t1, t1 + fpt)>>. *)
          Lemma continuously_scheduled_between_preemption_points:
            forall t',
              t1 <= t' < t1 + fpt ->
              job_scheduled_at jlp t'.
          Proof.
             move: (H_valid_model_with_bounded_nonpreemptive_segments) => CORR.
             move: (H_jlp_is_scheduled) => ARRs; apply H_jobs_come_from_arrival_sequence in ARRs.
            move => t' /andP [GE LT].
              have Fact: exists Δ, t' = t1 + Δ.
              { by exists (t' - t1); apply/eqP; rewrite eq_sym; apply/eqP; rewrite subnKC. }
              move: Fact => [Δ EQ]; subst t'.
              have NPPJ := @no_intermediate_preemption_point (@service _ _ _ sched jlp (t1 + Δ)).
              apply proj1 in CORR; specialize (CORR jlp ARRs).
              move: CORR => [_ [_ [T _] ]].
              apply T; apply: NPPJ; apply/andP; split.
              { by apply service_monotonic; rewrite leq_addr. }
              rewrite /service  -(service_during_cat _ _ _ t1).
              { rewrite ltn_add2l; rewrite ltn_add2l in LT.
                apply leq_ltn_trans with Δ; last by done.
                rewrite -{2}(sum_of_ones t1 Δ).
                rewrite leq_sum //; intros t _.
                apply service_at_most_one.
                  by apply ideal_proc_model_provides_unit_service.
              }
              { by apply/andP; split; [done | rewrite leq_addr]. }
          Qed.

          (** Thus, job [jlp] reaches its preemption point at time instant [t1 + fpt],
              which implies that time instant [t1 + fpt] is a preemption time. *)
          Lemma first_preemption_time:
            preemption_time sched (t1 + fpt).
          Proof.
            rewrite /preemption_time.
            move: (H_valid_model_with_bounded_nonpreemptive_segments) => CORR.
            ideal_proc_model_sched_case_analysis_eq sched (t1 + fpt) s'; try done.
            clear EqSched_s'; move: (Sched_s'); rewrite scheduled_at_def;
              move => /eqP EqSched_s'; rewrite EqSched_s'.
            destruct (jlp == s') eqn: EQ.
            - move: EQ => /eqP EQ; subst s'.
              rewrite /service -(service_during_cat _ _ _ t1); last first.
              { by apply/andP; split; last rewrite leq_addr. }
              have ->: service_during sched jlp t1 (t1 + fpt) = fpt.
              { rewrite -{2}(sum_of_ones t1 fpt) /service_during.
                apply/eqP; rewrite eqn_leq //; apply/andP; split.
                + rewrite leq_sum //; intros t _.
                  apply service_at_most_one.
                    by apply ideal_proc_model_provides_unit_service.
                + rewrite big_nat_cond [in X in _ <= X]big_nat_cond.
                  rewrite leq_sum //.
                  move => x /andP [HYP _].
                    by rewrite lt0b -scheduled_at_def; apply continuously_scheduled_between_preemption_points.
              } by done.
            - case: (posnP fpt) => [ZERO|POS].
              { subst fpt.
                exfalso; move: EQ => /negP EQ; apply: EQ.
                move: H_jlp_is_scheduled; rewrite scheduled_at_def; move => /eqP SCHED2.
                rewrite addn0 in EqSched_s'; rewrite EqSched_s' in SCHED2.
                  by inversion SCHED2.
              }
              { have EX: exists sm, sm.+1 = fpt.
                { exists fpt.-1. ssromega. }
                destruct EX as [sm EQ2]. rewrite -EQ2.
                rewrite addnS.
                move: ((proj1 CORR) s' (H_jobs_come_from_arrival_sequence _ _ Sched_s')) => T.
                apply T; clear T. apply /negP; intros CONTR.
                move: EQ => /negP EQ; apply: EQ.
                move: (continuously_scheduled_between_preemption_points (t1 + sm)) => SCHEDs0.
                feed SCHEDs0; first by apply/andP; split; [rewrite leq_addr | rewrite -EQ2 addnS].
                apply/eqP; eapply ideal_proc_model_is_a_uniprocessor_model; eauto 2.
                  by rewrite -addnS EQ2.
              }
          Qed.

          (** And since [fpt <= max_length_of_priority_inversion j t1],
              [t1 <= t1 + fpt <= t1 + max_length_of_priority_inversion j t1]. *)
          Lemma preemption_time_le_max_len_of_priority_inversion:
            t1 <= t1 + fpt <= t1 + max_length_of_priority_inversion j t1.
          Proof.
            move: (H_jlp_is_scheduled) => ARRs; apply H_jobs_come_from_arrival_sequence in ARRs.
            move: H_progr_le_max_nonp_segment => /andP [GE LE].
            apply/andP; split; first by rewrite leq_addr.
            rewrite leq_add2l.
            unfold max_length_of_priority_inversion.
            rewrite (big_rem jlp) //=.
            { rewrite H_jlp_low_priority; simpl.
              apply leq_trans with (job_max_nonpreemptive_segment jlp - ε); last by rewrite leq_maxl.
                by rewrite leq_add2l in LE. }
            eapply arrived_between_implies_in_arrivals; eauto 2.
            apply/andP; split; first by done.
            eapply low_priority_job_arrives_before_busy_interval_prefix with t1; eauto 2.
              by move: (H_busy_interval_prefix) => [NEM [QT1 [NQT HPJ]]]; apply/andP; split.
          Qed.

        End FirstPreemptionPointOfjlp.

        (** Next we combine the facts above to conclude the lemma. *)
        Lemma preemption_time_exists_case3:
          exists pr_t,
            preemption_time sched pr_t /\
            t1 <= pr_t <= t1 + max_length_of_priority_inversion j t1.
        Proof.
          set (service := service sched).
          have EX: exists pt,
              ((service jlp t1) <= pt <= (service jlp t1) + (job_max_nonpreemptive_segment jlp - 1)) && job_preemptable jlp pt.
          { move: (H_jlp_is_scheduled) => ARRs; apply H_jobs_come_from_arrival_sequence in ARRs.
            move: (proj2 (H_valid_model_with_bounded_nonpreemptive_segments) jlp ARRs) =>[_ EXPP].
            specialize (EXPP (service jlp t1)).
            feed EXPP.
            { apply/andP; split; first by done.
              apply service_at_most_cost; first by done.
                by apply ideal_proc_model_provides_unit_service.
            }
            move: EXPP => [pt [NEQ PP]].
            exists pt; apply/andP; split; by done.
          }
          move: (ex_minnP EX) => [sm_pt /andP [NEQ PP] MIN]; clear EX.
          have Fact: exists Δ, sm_pt = service jlp t1 + Δ.
          { exists (sm_pt - service jlp t1).
            apply/eqP; rewrite eq_sym; apply/eqP; rewrite subnKC //.
              by move: NEQ => /andP [T _]. }
          move: Fact => [Δ EQ]; subst sm_pt; rename Δ into sm_pt.
          exists (t1 + sm_pt); split.
          - apply first_preemption_time.
            all: unfold service.service; try done.
            intros; apply MIN; apply/andP; split; by done.
          - apply preemption_time_le_max_len_of_priority_inversion.
            unfold service.service; try done.
        Qed.

      End Case3.

    End CaseAnalysis.

    (** By doing the case analysis, we show that indeed there is a
        preemption time in time interval [[t1, t1 +
        max_length_of_priority_inversion j t1]. *)
    Lemma preemption_time_exists:
      exists pr_t,
        preemption_time sched pr_t /\
        t1 <= pr_t <= t1 + max_length_of_priority_inversion j t1.
    Proof.
      set (service := service sched).
      move: (H_valid_model_with_bounded_nonpreemptive_segments) => CORR.
      move: (H_busy_interval_prefix) => [NEM [QT1 [NQT HPJ]]].
      ideal_proc_model_sched_case_analysis sched t1 s.
      - by apply preemption_time_exists_case1.
      - destruct (hep_job s j) eqn:PRIO.
        + by eapply preemption_time_exists_case2; eauto.
        + eapply preemption_time_exists_case3 with s; eauto.
            by rewrite -eqbF_neg; apply /eqP.
    Qed.

  End PreemptionTimeExists.

End PriorityInversionIsBounded.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rle.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rlt_eq_compat : forall r1 r2 r3 r4,
  r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3.
Proof.
  intros u v w x.
  intros huv hvx hxw.
  subst v.
  subst w.
  exact hvx.
Qed.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(* Make [omega] work for [N] *)

Require Import Coq.Arith.Arith Coq.ZArith.ZArith Coq.NArith.NArith.

Local Open Scope N_scope.

Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat
  nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
  congruence.
Qed.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
  intuition.
Qed.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nomega :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega).


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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

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

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

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

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

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. lfind. Admitted.


Require Import List.
Import ListNotations.
Require Import String.
Require Import Flocq.Appli.Fappli_IEEE_bits.
Require Import Flocq.Appli.Fappli_IEEE.
Require Import ZArith.

Require Import v1.EpicsTypes.
Require Import v1.Multi.
Require Import v1.NeutronTactics.
Require Import v1.FloatAux.
Require Import v1.Util.

Require Import v1.Expr.

Definition b64_eq (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Eq => one
    | _ => zero
    end.

Definition b64_ne (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt | Some Datatypes.Gt => one
    | _ => zero
    end.

Definition b64_lt (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt => one
    | _ => zero
    end.

Definition b64_le (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt | Some Datatypes.Eq => one
    | _ => zero
    end.

Definition b64_gt (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Gt => one
    | _ => zero
    end.

Definition b64_ge (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Gt | Some Datatypes.Eq => one
    | _ => zero
    end.

Definition b64_and (x y : e_double) :=
    if is_zero x then zero else (if is_zero y then zero else one).

Definition b64_or (x y : e_double) :=
    if is_zero x then (if is_zero y then zero else one) else one.

Definition b64_min (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt => x
    | _ => y
    end.

Definition b64_max (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt => y
    | _ => x
    end.

Fixpoint b64_minimum (xs : list e_double) :=
    match xs with
    | [] => zero
    | x :: xs => b64_min x (b64_minimum xs)
    end.

Fixpoint b64_maximum (xs : list e_double) :=
    match xs with
    | [] => zero
    | [x] => x
    | x :: xs => b64_max x (b64_maximum xs)
    end.

Inductive dbl_tydesc := Nil | Dbl.
Scheme Equality for dbl_tydesc.

Definition dbl_ty_denote ty :=
    match ty with
    | Nil => unit
    | Dbl => e_double
    end.

Definition dbl_eval_bits : eval_bits e_double :=
    {| tydesc := dbl_tydesc
    ; tydesc_eq_dec := dbl_tydesc_eq_dec
    ; ty_denote := dbl_ty_denote

    ; var_ty := Dbl
    ; xvar_ty := Nil
    ; convert_lit := fun d => existT dbl_ty_denote Dbl d

    ; nil_ty := Nil
    ; nil_value := tt

    ; unop_denote := fun op ty1 =>
        match ty1 with
        | Dbl =>
                let mk f := Some (existT (unop_impl _ Dbl) Dbl f) in
                match op with
                | NotAlg => mk (fun x => b64_opp x)
                | NotLog => mk (fun x => if is_zero x then one else zero)
                end
        | Nil => None
        end

    ; binop_denote := fun op ty1 ty2 =>
        match ty1, ty2 with
        | Dbl, Dbl =>
                let mk f := Some (existT (binop_impl _ Dbl Dbl) Dbl f) in
                match op with
                | Add => mk (b64_plus mode_NE)
                | Sub => mk (b64_minus mode_NE)
                | Mul => mk (b64_mult mode_NE)
                | Div => mk (b64_div mode_NE)
                | Ge => mk b64_ge
                | Gt => mk b64_gt
                | Le => mk b64_le
                | Lt => mk b64_lt
                | Ne => mk b64_ne
                | Eq => mk b64_eq
                | AndLog => mk b64_and
                | OrLog => mk b64_or
                end
        | _, _ => None
        end

    ; ternop_denote := fun op ty1 ty2 ty3 =>
        match ty1, ty2, ty3 with
        | Dbl, Dbl, Dbl =>
                let mk f := Some (existT (ternop_impl _ Dbl Dbl Dbl) Dbl f) in
                match op with
                | Cond => mk (fun c x y => if negb (is_zero c) then x else y)
                end
        | _, _, _ => None
        end

    ; varop_denote := fun op ty1 =>
        match ty1 with
        | Dbl =>
                let mk f := Some (existT (varop_impl _ Dbl) Dbl f) in
                match op with
                | Min => mk (fun xs => b64_minimum xs)
                | Max => mk (fun xs => b64_maximum xs)
                end
        | _ => None
        end
    |}.

Definition denote {n} (e : expr e_double n) :
        option (multi n e_double -> multi n e_double * e_double) :=
    unpack_ty dbl_eval_bits Dbl (denote' dbl_eval_bits e)
        (fun f =>
            let f' sv :=
                let '(sv, sx, r) := f sv (multi_rep n tt) in
                (sv, r) in
            Some f').


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Cprime : Universe, ((wd_ O A /\ (wd_ O B /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ O C /\ (col_ O A B /\ (col_ A B C /\ col_ A B Cprime))))))) -> col_ O C Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep Platform.Wrap Platform.StringOps Platform.XmlLex Platform.SinglyLinkedList Platform.Malloc.

Set Implicit Arguments.

(** * Definition of XML search language *)

Inductive pat :=

(* Match CDATA constant. *)
| Cdata (const : string)

(* Record CDATA at this position via two variables. *)
| Var (start len : string)

| TreeVar (start len : string)
(* Like [Var], but grabs a whole XML tree *)

(* Match a specific tag at this level in the XML tree, then continue into its children. *)
| Tag (tag : string) (inner : pat)

(* Match two different patterns at this level of the tree. *)
| Both (p1 p2 : pat)

(* Match one pattern and then another in the part of the XML tree right after the match of the first. *)
| Ordered (p1 p2 : pat).

(** Which program variables appear free in a pattern? *)
Fixpoint freeVar (p : pat) (x : string) : Prop :=
  match p with
    | Cdata _ => False
    | Var start len => x = start \/ x = len
    | TreeVar start len => x = start \/ x = len
    | Tag _ inner => freeVar inner x
    | Both p1 p2 => freeVar p1 x \/ freeVar p2 x
    | Ordered p1 p2 => freeVar p1 x \/ freeVar p2 x
  end.

(** Does the pattern avoid:
  * - double-binding a program variable?
  * - mentioning a huge string constant as a tag name? *)
Fixpoint wf (p : pat) : Prop :=
  match p with
    | Cdata const => goodSize (String.length const)
    | Var start len => start <> len
    | TreeVar start len => start <> len
    | Tag tag inner => goodSize (String.length tag) /\ wf inner
    | Both p1 p2 => wf p1 /\ wf p2 /\ (forall x, freeVar p1 x -> ~freeVar p2 x)
    | Ordered p1 p2 => wf p1 /\ wf p2 /\ (forall x, freeVar p1 x -> ~freeVar p2 x)
  end%type.

(** All pairs of start-length variables in a pattern *)
Fixpoint allCdatas (p : pat) : list (string * string) :=
  match p with
    | Cdata _ => nil
    | Var start len => (start, len) :: nil
    | TreeVar start len => (start, len) :: nil
    | Tag _ inner => allCdatas inner
    | Both p1 p2 => allCdatas p2 ++ allCdatas p1
    | Ordered p1 p2 => allCdatas p2 ++ allCdatas p1
  end.

(** * Compiling patterns into Bedrock chunks *)

Section Pat.
  Variable A : Type.
  Variables invPre : A -> vals -> HProp.
  Variables invPost : A -> vals -> W -> HProp.

  (* Do all start-length pairs in a list denote valid spans in a string of length "len"? *)
  Definition inBounds (cdatas : list (string * string)) (V : vals) :=
    List.Forall (fun p => wordToNat (V (fst p)) + wordToNat (V (snd p)) <= wordToNat (V "len"))%nat
    cdatas.

  (* Are all saved positions in a list valid pointers within a string of a given length? *)
  Definition stackOk (ls : list W) (len : W) :=
    List.Forall (fun x => x <= len) ls.

  (* Precondition and postcondition of search *)
  Definition invar :=
    Al a : A, Al bs, Al ls,
    PRE[V] array8 bs (V "buf") * xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| stackOk ls (V "len") |] * invPre a V
    POST[R] array8 bs (V "buf") * mallocHeap 0 * invPost a V R.

  (* Primary invariant, recording that a set of CDATA positions is in bounds. *)
  Definition inv cdatas :=
    Al a : A, Al bs, Al ls,
    PRE[V] array8 bs (V "buf") * xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
      * [| stackOk ls (V "len") |] * invPre a V
    POST[R] array8 bs (V "buf") * mallocHeap 0 * invPost a V R.

  (* Intermediate invariant, to use right after reading token position from the lexer. *)
  Definition invP cdatas :=
    Al a : A, Al bs, Al ls,
    PRE[V, R] array8 bs (V "buf") * xmlp' (V "len") R (V "lex") * mallocHeap 0
      * sll ls (V "stack")
      * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
      * [| stackOk ls (V "len") |] * invPre a V
    POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'.

  (* Intermediater invariant, to use right after reading token length from the lexer. *)
  Definition invL cdatas start :=
    Al a : A, Al bs, Al ls,
    PRE[V, R] array8 bs (V "buf") * xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
      * [| stackOk ls (V "len") |]
      * [| wordToNat (V start) + wordToNat R <= wordToNat (V "len") |]%nat * invPre a V
    POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'.

  (* Alternate sequencing operator, which generates twistier code but simpler postconditions and VCs *)
  Definition SimpleSeq (ch1 ch2 : chunk) : chunk := fun ns res =>
    Structured nil (fun im mn H => Seq_ H (toCmd ch1 mn H ns res) (toCmd ch2 mn H ns res)).

  Infix ";;" := SimpleSeq : SP_scope.

  (* Workhorse pattern compilation function, taking as input:
   * p: an XML pattern to compile
   * level: tree depth at which this pattern is applied (starts at 1 for top-level pattern)
   * cdatas: list of start-length pairs denoting spans within the string we match against,
   *         set by earlier successfull matches of subpatterns
   * onSuccess: continuation code to run when the pattern matches fully
   *)
  Fixpoint Pat' (p : pat) (level : nat) (cdatas : list (string * string))
    (onSuccess : chunk) : chunk :=
    match p with
      | Cdata const =>
        (* Read next token. *)
        "res" <-- Call "xml_lex"!"next"("buf", "lex")
        [inv cdatas];;

        (* Now here's a gross hack to support XML-RPC, which has some positions where
         * "blah" and "<string>blah</string>" are equivalent. *)
        If ("res" = 1) {
          "level" <- (level + 1)%nat;;
          "res" <-- Call "xml_lex"!"next"("buf", "lex")
          [inv cdatas]
        } else {
          "level" <- level
        };;

        (* What type of token is it? *)
        If ("res" = 2) {
          (* We may have a match!  First, grab the boundaries of the matching string. *)
          "tagStart" <-- Call "xml_lex"!"tokenStart"("lex")
          [invP cdatas];;

          "tagLen" <-- Call "xml_lex"!"tokenLength"("lex")
          [invL cdatas "tagStart"];;

          If ("tagLen" = String.length const) {
            (* Now check if the CDATA content here matches the constant from the pattern. *)
            StringEq "buf" "len" "tagStart" "matched" const
            (fun a V => Ex ls, xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
              * [| inBounds cdatas V |] * [| stackOk ls (V "len") |] * invPre a V)%Sep
            (fun bs a V R => array8 bs (V "buf") * mallocHeap 0 * invPost a V R)%Sep;;

            If ("matched" = 0) {
              (* Nope, not equal. *)
              Skip
            } else {
              (* Equal! *)
              If ("level" = level) {
                Skip
              } else {
                "level" <- level;;
                "res" <-- Call "xml_lex"!"next"("buf", "lex")
                [inv cdatas]
              };;
              onSuccess
            }
          } else {
            (* Tag is wrong length to match. *)
            Skip
          }
        } else {
          (* It's not CDATA.  Pattern doesn't match. *)
          Skip
        }

      | Var start len =>
        (* Read next token. *)
        "res" <-- Call "xml_lex"!"next"("buf", "lex")
        [inv cdatas];;

        (* Now here's a gross hack to support XML-RPC, which has some positions where
         * "blah" and "<string>blah</string>" are equivalent. *)
        If ("res" = 1) {
          "level" <- (level + 1)%nat;;
          "res" <-- Call "xml_lex"!"next"("buf", "lex")
          [inv cdatas]
        } else {
          "level" <- level
        };;

        (* What type of token is it? *)
        If ("res" = 2) {
          (* This is indeed CDATA!  Save the position and signal success. *)
          start <-- Call "xml_lex"!"tokenStart"("lex")
          [invP cdatas];;

          len <-- Call "xml_lex"!"tokenLength"("lex")
          [invL cdatas start];;

          If ("level" = level) {
            Skip
          } else {
            "level" <- level;;
            "res" <-- Call "xml_lex"!"next"("buf", "lex")
            [inv ((start, len) :: cdatas)]
          };;

          onSuccess
        } else {
          (* It's not CDATA.  Pattern doesn't match. *)
          Skip
        }

      | TreeVar start len =>
        start <-- Call "xml_lex"!"position"("lex")
        [inv cdatas];;

        (* Read next token. *)
        "res" <-- Call "xml_lex"!"next"("buf", "lex")
        [inv cdatas];;

        (* What type of token is it? *)
        If ("res" = 2) {
          (* This is the easy case: just CDATA.  Do like for [Var]. *)
          start <-- Call "xml_lex"!"tokenStart"("lex")
          [invP cdatas];;

          len <-- Call "xml_lex"!"tokenLength"("lex")
          [invL cdatas start];;

          onSuccess
        } else {
          If ("res" = 1) {
            (* It's an open tag, so we should keep lexing until encountering the matching closer. *)

            "level" <- level;;

            [inv cdatas]
            While ("level" >= level) {
              "res" <-- Call "xml_lex"!"next"("buf", "lex")
              [inv cdatas];;

              If ("res" = 1) {
                (* Open tag *)
                "level" <- "level" + 1
              } else {
                If ("res" = 3) {
                  (* Close tag *)
                  "level" <- "level" - 1
                } else {
                  Skip
                }
              }
            };;

            "level" <- level;;

            "res" <-- Call "xml_lex"!"position"("lex")
            [inv cdatas];;

            If (start > "res") {
              (* Shouldn't be possible, but we can't prove it ATM. *)
              Skip
            } else {
              len <- "res" - start;;

              If ("res" > "len") {
                (* Again, shouldn't be possible. *)
                Skip
              } else {
                onSuccess
              }
            }
          } else {
            (* This is not going to be a valid tree. *)
            Skip
          }
        }

      | Tag tag inner =>
        (* Initialize a variable storing the tree depth of our current position.
         * We'll consult this variable to see when we're at the proper depth for matching
         * the current pattern. *)
        "level" <- level;;

        (* Loop until level drops below the starting level (after which the pattern never applies again). *)
        [inv cdatas]
        While ("level" >= level) {
          (* Lex next token. *)
          "res" <-- Call "xml_lex"!"next"("buf", "lex")
          [inv cdatas];;

          (* What type of token is it? *)
          If ("res" = 1) {
            (* Open tag -- does it match? *)

            If ("level" > level) {
              (* We've descended too deep, so this position doesn't qualify. *)
              "level" <- "level" + 1;;
              Skip
            } else {
              "level" <- "level" + 1;;

              (* We may have a match!  First, grab the boundaries of the matching string. *)
              "tagStart" <-- Call "xml_lex"!"tokenStart"("lex")
              [invP cdatas];;

              "tagLen" <-- Call "xml_lex"!"tokenLength"("lex")
              [invL cdatas "tagStart"];;

              If ("tagLen" = String.length tag) {
                (* Now check if the tag name here matches the name from the pattern. *)
                StringEq "buf" "len" "tagStart" "matched" tag
                (fun a V => Ex ls, xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
                  * [| inBounds cdatas V |] * [| stackOk ls (V "len") |] * invPre a V)%Sep
                (fun bs a V R => array8 bs (V "buf") * mallocHeap 0 * invPost a V R)%Sep;;

                If ("matched" = 0) {
                  (* Nope, not equal. *)
                  Skip
                } else {
                  (* Equal!  Continue with the nested pattern. *)
                  Pat' inner (S level) cdatas onSuccess
                }
              } else {
                (* Tag is wrong length to match. *)
                Skip
              }
            }
          } else {
            If ("res" = 3) {
              (* Close tag *)
              "level" <- "level" - 1
            } else {
              If ("res" = 0) {
                (* Done parsing.  Force exit from the loop. *)
                "level" <- 0
              } else {
                (* Ignore any other kind of token. *)
                Skip
              }
            }
          }
        }

      | Both p1 p2 =>
        (* Warning: shameless reuse here of variables for new purposes *)

        (* Get the current position, which we will save to return to later. *)
        "tagLen" <-- Call "xml_lex"!"position"("lex")
        [Al a : A, Al bs, Al ls,
          PRE[V, R] array8 bs (V "buf") * xmlp (V "len") (V "lex")
            * sll ls (V "stack") * mallocHeap 0 * [| R <= V "len" |]%word
            * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
            * [| stackOk ls (V "len") |] * invPre a V
          POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'];;

        (* Allocate a new entry for the position stack. *)
        "tagStart" <-- Call "malloc"!"malloc"(0, 2)
        [Al a : A, Al bs, Al ls,
          PRE[V, R] array8 bs (V "buf") * xmlp (V "len") (V "lex")
            * sll ls (V "stack") * mallocHeap 0 * [| V "tagLen" <= V "len" |]%word
            * R =?> 2 * [| R <> 0 |] * [| freeable R 2 |]
            * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
            * [| stackOk ls (V "len") |] * invPre a V
          POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'];;

        (* Save the current position in this entry, then push it onto the stack. *)
        "tagStart" *<- "tagLen";;
        "tagStart"+4 *<- "stack";;
        "stack" <- "tagStart";;

        (* Try matching the first pattern. *)
        Pat' p1 level cdatas
        ((* Make sure the stack is nonempty afterward.
          * Only buggy code here could lead to that outcome, but we aren't verifying at that level
          * of detail yet, so we use a run-time check. *)
        If ("stack" = 0) {
          (* We hope this case is impossible. *)
          Call "sys"!"abort"()
          [PREonly[_] [| False |]]
        } else {
          (* Stack nonempty!  Pop position off of stack (into "tagLen"). *)
          "tagLen" <-* "stack";;
          "tagStart" <- "stack";;
          "stack" <-* "stack"+4;;

          (* Free the popped stack entry. *)
          Call "malloc"!"free"(0, "tagStart", 2)
          [Al a : A, Al bs, Al ls,
            PRE[V] array8 bs (V "buf") * xmlp (V "len") (V "lex")
              * sll ls (V "stack") * mallocHeap 0 * [| V "tagLen" <= V "len" |]%word
              * [| length bs = wordToNat (V "len") |] * [| inBounds (allCdatas p1 ++ cdatas) V |]
              * [| stackOk ls (V "len") |] * invPre a V
          POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'];;

          (* Restore the position we popped. *)
          Call "xml_lex"!"setPosition"("lex", "tagLen")
          [inv (allCdatas p1 ++ cdatas)];;

          (* Now try matching the second pattern from the same initial position. *)
          Pat' p2 level (allCdatas p1 ++ cdatas)
          onSuccess
        })

      | Ordered p1 p2 =>
        (* Try matching the first pattern. *)
        Pat' p1 level cdatas (
          (* Loop lexing tokens until we return to the appropriate tree level. *)
          [inv (allCdatas p1 ++ cdatas)]
          While ("level" > level) {
            "res" <-- Call "xml_lex"!"next"("buf", "lex")
            [inv (allCdatas p1 ++ cdatas)];;

            If ("res" = 1) {
              (* Open tag *)
              "level" <- "level" + 1
            } else {
              If ("res" = 3) {
                (* Close tag *)
                "level" <- "level" - 1
              } else {
                Skip
              }
            }
          };;

          (* Now try matching the second pattern from the same initial position. *)
          Pat' p2 level (allCdatas p1 ++ cdatas)
          onSuccess
        )
    end%SP.

  Notation baseVars := ("buf" :: "len" :: "lex" :: "res"
    :: "tagStart" :: "tagLen" :: "matched" :: "stack" :: "level" :: nil).

  Definition noConflict pt := List.Forall (fun p => ~In (fst p) baseVars /\ ~In (snd p) baseVars
    /\ ~freeVar pt (fst p) /\ ~freeVar pt (snd p)).

  Notation "l ~~ im ~~> s" := (LabelMap.find l%SP im = Some (Precondition s None)) (at level 0).

  Lemma inBounds_sel : forall cdatas V, inBounds cdatas (sel V) = inBounds cdatas V.
    auto.
  Qed.

  Lemma Forall_impl2 : forall A (P Q R : A -> Prop) ls,
    List.Forall P ls
    -> List.Forall Q ls
    -> (forall x, P x -> Q x -> R x)
    -> List.Forall R ls.
    induction 1; inversion 1; eauto.
  Qed.

  Lemma incl_peel : forall A (x : A) ls ls',
    incl (x :: ls) ls'
    -> In x ls' /\ incl ls ls'.
    unfold incl; intuition.
  Qed.

  Ltac deDouble := simpl in *;
    repeat match goal with
             | [ H : incl nil _ |- _ ] => clear H
             | [ H : incl _ _ |- _ ] => apply incl_peel in H; destruct H
             | [ H : forall x, x = _ \/ x = _ -> _ |- _ ] =>
               generalize (H _ (or_introl _ eq_refl)); intro;
                 specialize (H _ (or_intror _ eq_refl))
             | [ H : forall x, freeVar _ _ \/ freeVar _ _ -> _ |- _ ] =>
               generalize (fun x H0 => H x (or_introl _ H0)); intro;
                 specialize (fun x H0 => H x (or_intror _ H0))
           end;
    intuition idtac; repeat match goal with
                              | [ H : False -> False |- _ ] => clear H
                            end.

  Lemma mult4_S : forall n,
    4 * S n = S (S (S (S (4 * n)))).
    simpl; intros; omega.
  Qed.

  Lemma invPre_sel : forall a V, invPre a (sel V) = invPre a V.
    auto.
  Qed.

  Lemma invPost_sel : forall a V R, invPost a (sel V) R = invPost a V R.
    auto.
  Qed.

  Ltac evalu :=
    match goal with
      | [ ns : list string |- _ ] =>
        repeat match goal with
                 | [ H : In _ ns |- _ ] => clear H
               end
    end; try rewrite mult4_S in *; repeat rewrite inBounds_sel in *;
    repeat rewrite invPre_sel in *; repeat rewrite invPost_sel in *;
    match goal with
      | [ _ : evalInstrs _ _ _ = _ |- _ ] => evaluate SinglyLinkedList.hints
      | [ _ : evalCond _ _ _ _ _ = _ |- _ ] => evaluate SinglyLinkedList.hints
      | _ => idtac
    end;
    repeat match goal with
             | [ H : In _ _ |- _ ] => clear H
             | [ H : evalInstrs _ _ _ = _ |- _ ] => clear H
           end;
    try match goal with
          | [ st : (settings * state)%type |- _ ] => destruct st; simpl in *
        end.

  Ltac finish := descend; repeat (step SinglyLinkedList.hints; descend); auto.

  Hint Extern 1 (@eq W _ _) => unfold natToW in *; words.

  Opaque mult.

  Lemma stackOk_cons : forall w len ws,
    w <= len
    -> stackOk ws len
    -> stackOk (w :: ws) len.
    constructor; auto.
  Qed.

  Hint Immediate stackOk_cons.

  Ltac noConflict := unfold noConflict; intros; eapply Forall_impl; [ | eauto ]; (cbv beta; simpl; tauto).

  Lemma noConflict_Both1 : forall p1 p2 cdatas,
    noConflict (Both p1 p2) cdatas
    -> noConflict p1 cdatas.
    noConflict.
  Qed.

  Lemma noConflict_Both2' : forall p1 p2 cdatas,
    noConflict (Both p1 p2) cdatas
    -> noConflict p2 cdatas.
    noConflict.
  Qed.

  Ltac allCdatas_freeVar := intros ? p;
    induction p; simpl; intuition; subst; auto;
      match goal with
        | [ H : _ |- _ ] => apply in_app_or in H; tauto
      end.

  Lemma allCdatas_freeVar1 : forall xy p,
    In xy (allCdatas p) -> freeVar p (fst xy).
    allCdatas_freeVar.
  Qed.

  Lemma allCdatas_freeVar2 : forall xy p,
    In xy (allCdatas p) -> freeVar p (snd xy).
    allCdatas_freeVar.
  Qed.

  Lemma noConflict_Both2 : forall p1 p2 cdatas,
    noConflict (Both p1 p2) cdatas
    -> (forall x, freeVar p1 x -> freeVar p2 x -> False)
    -> (forall x, freeVar p1 x -> ~In x baseVars)
    -> noConflict p2 (allCdatas p1 ++ cdatas).
    intros; apply Forall_app.
    2: eapply noConflict_Both2'; eauto.
    apply Forall_forall; intros.
    generalize (allCdatas_freeVar1 _ _ H2); intro.
    apply allCdatas_freeVar2 in H2.
    intuition eauto.
  Qed.

  Hint Immediate noConflict_Both1.
  Hint Extern 1 (noConflict _ (_ ++ _)) => eapply noConflict_Both2; [ eassumption | eassumption |
    simpl; intros; match goal with
                     | [ H : _, H' : freeVar _ _ |- _ ] => apply H in H'; tauto
                   end ].

  Hint Extern 1 (incl _ _) => hnf; simpl; intuition congruence.

  Lemma Forall_app1 : forall A P (ls1 ls2 : list A),
    List.Forall P (ls1 ++ ls2)
    -> List.Forall P ls1.
    induction ls1; inversion 1; eauto.
  Qed.

  Lemma Forall_app2 : forall A P (ls1 ls2 : list A),
    List.Forall P (ls1 ++ ls2)
    -> List.Forall P ls2.
    induction ls1; inversion 1; eauto.
  Qed.

  Lemma inBounds_app1 : forall ls1 ls2 x,
    inBounds (ls1 ++ ls2) x
    -> inBounds ls1 x.
    intros; eapply Forall_app1; eauto.
  Qed.

  Lemma inBounds_app2 : forall ls1 ls2 x,
    inBounds (ls1 ++ ls2) x
    -> inBounds ls2 x.
    intros; eapply Forall_app2; eauto.
  Qed.

  Hint Immediate inBounds_app1 inBounds_app2.

  Lemma inBounds_decons : forall x cdatas y,
    inBounds (x :: cdatas) y
    -> inBounds cdatas y.
    inversion 1; auto.
  Qed.

  Hint Immediate inBounds_decons.

  Lemma inBounds_assoc : forall ls1 ls2 ls3 x,
    inBounds ((ls1 ++ ls2) ++ ls3) x
    -> inBounds (ls1 ++ ls2 ++ ls3) x.
    intros; rewrite app_assoc; assumption.
  Qed.

  Lemma inBounds_assoc' : forall ls1 ls2 ls3 x,
    inBounds (ls1 ++ ls2 ++ ls3) x
    -> inBounds ((ls1 ++ ls2) ++ ls3) x.
    intros; rewrite <- app_assoc; assumption.
  Qed.

  Hint Immediate inBounds_assoc inBounds_assoc'.

  Lemma wplus_wminus : forall u v : W,
    u ^+ v ^- v = u.
    intros; words.
  Qed.

  Hint Rewrite wplus_wminus mult4_S : sepFormula.

  Ltac inBounds :=
    rewrite <- inBounds_sel;
      repeat match goal with
               | [ H : inBounds _ ?X |- _ ] =>
                 match X with
                   | sel _ => fail 1
                   | _ => rewrite <- inBounds_sel in H
                 end
             end;
      try (constructor; [ descend | ]);
        match goal with
          | [ H : inBounds _ _, H' : noConflict _ _ |- _ ] =>
            eapply Forall_impl2; [ apply H
              | (eapply noConflict_Both2; [ eassumption | eassumption |
                simpl; intros; match goal with
                                 | [ H : _, H' : freeVar _ _ |- _ ] => apply H in H'; tauto
                               end ]) || apply H'
              | cbv beta; simpl; intuition descend;
                repeat match goal with
                         | [ H : forall x, _ |- _ ] => rewrite <- H by congruence
                       end; assumption ]
        end.

  Ltac reger := repeat match goal with
                         | [ H : Regs _ _ = _ |- _ ] => rewrite H
                       end.

  Ltac inver :=
    match goal with
      | [ H : forall a : A, _ |- himp _ ?P ?Q ] =>
        match P with
          | context[invPre _ ?vs] =>
            match Q with
              | context[invPre _ ?vs'] =>
                match vs' with
                  | vs => fail 1
                  | _ => rewrite (H _ vs vs') by intuition descend
                end
            end
          | context[invPost _ ?vs _] =>
            match Q with
              | context[invPost _ ?vs' _] =>
                match vs' with
                  | vs => fail 1
                  | _ => rewrite (H _ vs vs') by intuition descend
                end
            end
        end
    end.

  Ltac bash :=
    unfold inv, invP, invL, localsInvariant; try rewrite mult4_S in *; reger; try inver; descend;
      try rewrite inBounds_sel; try rewrite invPre_sel in *; try rewrite invPost_sel in *;
        try match goal with
              | [ _ : inBounds ?cdatas _ |- interp _ (![?pre] _ ---> ![?post] _)%PropX ] =>
                match post with
                  | context[locals ?ns _ _ _] =>
                    match pre with
                      | context[locals ns ?vs _ _] =>
                        assert (inBounds cdatas vs) by inBounds
                    end
                end
              | [ H : context[invPost] |- ?P = ?Q ] =>
                match P with
                  | context[invPost ?a ?V _] =>
                    match Q with
                      | context[invPost a ?V' _] =>
                        rewrite (H a V V') by intuition
                    end
                end;
                match goal with
                  | [ H : forall x : string, _ -> sel ?V _ = sel ?V' _ |- _ ] =>
                    repeat match goal with
                             | [ |- context[V ?x] ] => change (V x) with (sel V x)
                             | [ |- context[V' ?x] ] => change (V' x) with (sel V' x)
                           end;
                    repeat rewrite H by intuition congruence
                end; reflexivity
            end;
        try match goal with
              | [ |- interp _ (![?pre] _ ---> ![?post] _)%PropX ] =>
                match post with
                  | context[locals ?ns _ _ _] =>
                    match pre with
                      | context[locals ns ?vs _ _] =>
                        match pre with
                          | context[invPre ?a ?vs'] =>
                            assert (unit -> invPre a vs' = invPre a vs) by
                              match goal with
                                | [ H : _ |- _ ] => intro; apply H; intuition descend
                              end
                          | context[invPost ?a ?vs' ?r] =>
                            assert (unit -> invPost a vs' r = invPost a vs r) by
                              match goal with
                                | [ H : _ |- _ ] => intro; apply H; intuition descend
                              end
                        end
                    end
                end;
                try match goal with
                      | [ _ : context[Var ?start ?len] |- _ ] =>
                        match post with
                          | context[locals ?ns _ _ _] =>
                            match pre with
                              | context[locals ns ?vs _ _] =>
                                assert (wordToNat (sel vs start) + wordToNat (sel vs len)
                                  <= wordToNat (sel vs "len"))%nat by descend
                            end
                        end
                    end
            end;
        step SinglyLinkedList.hints;
        try match goal with
              | [ H : unit -> invPre _ _ = invPre _ _ |- _ ] => rewrite (H tt)
              | [ H : unit -> invPost _ _ _ = invPost _ _ _ |- _ ] => rewrite (H tt)
            end.

  Ltac clear_fancier := match goal with
                          | [ H : importsGlobal _ |- _ ] =>
                            repeat match goal with
                                     | [ H' : context[H] |- _ ] => clear H'
                                   end; clear H
                        end.

  Ltac deSpec := simpl in *;
    repeat match goal with
             | [ H : LabelMap.find _ _ = _ |- _ ] => try rewrite H; clear H
           end; clear_fancier;
    try match goal with
          | [ st : (settings * state)%type |- _ ] => destruct st; simpl in *
        end.

  Ltac prove_Himp :=
    deSpec; apply Himp_ex; intro;
      repeat match goal with
               | [ V : vals |- _ ] =>
                 match goal with
                   | [ |- context[V ?x] ] => change (V x) with (sel V x)
                 end
             end;
      match goal with
        | [ H : context[invPre] |- ?P ===> ?Q ] =>
          match P with
            | context[invPre ?a ?V] =>
              match Q with
                | context[invPre a ?V'] =>
                  rewrite (H a V V') by intuition
              end
          end
      end;
      match goal with
        | [ H : forall x : string, _ |- _ ] =>
          repeat rewrite H by congruence; cancel auto_ext; inBounds
      end.

  Ltac invoke1 :=
    match goal with
      | [ |- _ ===> _ ] => prove_Himp
      | [ H : _ |- vcs _ ] => apply H; clear H
      | [ H : forall x, _, H' : interp _ _ |- _ ] => apply H in H'; clear H
      | [ |- vcs _ ] => wrap0
    end; try eassumption; try (rewrite app_assoc; eassumption); eauto; propxFo;
    try match goal with
          | [ st : (settings * state)%type |- _ ] => destruct st; simpl in *
        end.

  Ltac set_env :=
    match goal with
      | [ _ : context[locals ?ns ?vs ?res ?sp] |- context[locals ?ns ?vs' ?res ?sp'] ] =>
        match sp with
          | sp' => idtac
          | _ => let H := fresh in assert (H : sp = sp') by words; clear H
        end; equate vs' vs; descend
    end.

  Ltac prep_call :=
    match goal with
      | [ H : context[locals ?ns ?vs ?avail ?p]
        |- context[locals ?ns' _ ?avail' _] ] =>
      match avail' with
        | avail => fail 1
        | _ =>
          let offset := eval simpl in (4 * List.length ns) in
            change (locals ns vs avail p) with (locals_call ns vs avail p ns' avail' offset) in H;
              assert (ok_call ns ns' avail avail' offset)%nat
                by (split; [ simpl; omega
                  | split; [ simpl; omega
                    | split; [ NoDup
                      | reflexivity ] ] ])
      end;
      match goal with
        | [ H : interp _ _ |- _ ] => autorewrite with sepFormula in H; simpl in H
      end
    end.

  Ltac split_IH := match goal with
                     | [ IH : forall level : nat, _ |- _ ] =>
                       generalize (fun a b c d e f g h i j => proj1 (IH a b c d e f g h i j));
                         generalize (fun a b c d e f g h i j => proj2 (IH a b c d e f g h i j));
                           clear IH; intros
                   end.

  Ltac PatR := repeat split_IH; wrap0; deDouble; propxFo; repeat invoke1;
    deSpec; simp; repeat invoke1; try prep_call;
      evalu; try tauto; descend; try set_env; repeat bash; inBounds || eauto.

  Hint Constructors unit.

  Lemma StringMatch_ok : forall (x : W) n y,
    (wordToNat x + n <= wordToNat y)%nat
    -> x <= y.
    intros; nomega.
  Qed.

  Hint Immediate StringMatch_ok.

  Lemma stackOk_hd : forall w ws len,
    stackOk (w :: ws) len
    -> w <= len.
    inversion 1; auto.
  Qed.

  Lemma stackOk_tl : forall w ws len,
    stackOk (w :: ws) len
    -> stackOk ws len.
    inversion 1; auto.
  Qed.

  Hint Immediate stackOk_hd stackOk_tl.

  Lemma inBounds_easy : forall start len cdatas V k,
    inBounds ((start, len) :: cdatas) V
    -> noConflict (Var start len) cdatas
    -> "res" <> start
    -> "res" <> len
    -> inBounds ((start, len) :: cdatas) (upd V "res" k).
    intros.
    rewrite <- inBounds_sel in *.
    inversion_clear H.
    constructor.
    descend; assumption.
    eapply Forall_impl2.
    apply H4.
    apply H0.
    simpl; intuition idtac.
    descend.
  Qed.

  Hint Immediate inBounds_easy.

  Lemma inBounds_easyTree : forall start len cdatas V k w q,
    inBounds cdatas V
    -> noConflict (TreeVar start len) cdatas
    -> "res" <> start
    -> "res" <> len
    -> "len" <> len
    -> start <> len
    -> sel (upd (upd V "res" w) len q) "res" <= sel (upd (upd V "res" w) len q) "len"
    -> sel (upd V "res" w) start <= w
    -> inBounds ((start, len) :: cdatas) (upd (upd V "res" k) len (w ^- sel V start)).
    intros.
    autorewrite with sepFormula in *.
    rewrite <- inBounds_sel in *.
    constructor.
    descend.
    simpl in *.
    nomega.
    eapply Forall_impl2.
    apply H.
    apply H0.
    simpl; intuition idtac.
    descend.
  Qed.

  Hint Immediate inBounds_easyTree.

  Theorem PatR_correct : forall im mn H ns res,
    ~In "rp" ns
    -> incl baseVars ns
    -> (res >= 11)%nat
    -> "xml_lex"!"next" ~~ im ~~> nextS
    -> "xml_lex"!"position" ~~ im ~~> positionS
    -> "xml_lex"!"setPosition" ~~ im ~~> setPositionS
    -> "xml_lex"!"tokenStart" ~~ im ~~> tokenStartS
    -> "xml_lex"!"tokenLength" ~~ im ~~> tokenLengthS
    -> "malloc"!"malloc" ~~ im ~~> mallocS
    -> "malloc"!"free" ~~ im ~~> freeS
    -> "sys"!"abort" ~~ im ~~> abortS
    -> forall p level cdatas onSuccess,
      (forall x, freeVar p x -> In x ns /\ ~In x baseVars /\ x <> "rp")
      -> wf p
      -> noConflict p cdatas
      -> (forall a V V', (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
        -> invPre a V = invPre a V')
      -> (forall a V V' R, (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
        -> invPost a V R = invPost a V' R)
      -> (forall specs pre st,
        interp specs (Postcondition (toCmd onSuccess (im := im) mn H ns res pre) st)
        -> interp specs (inv (allCdatas p ++ cdatas) true (fun w => w) ns res st))
      -> (forall pre,
        (forall specs st, interp specs (pre st)
          -> interp specs (inv (allCdatas p ++ cdatas) true (fun w => w) ns res st))
        -> vcs (VerifCond (toCmd onSuccess (im := im) mn H ns res pre)))
      -> forall pre,
        (forall specs st, interp specs (pre st) -> interp specs (inv cdatas true (fun x => x) ns res st))
        -> (forall specs st, interp specs ((toCmd (Pat' p level cdatas onSuccess)
          (im := im) mn H ns res pre).(Postcondition) st)
          -> interp specs (inv cdatas true (fun x => x) ns res st))
        /\ vcs ((toCmd (Pat' p level cdatas onSuccess) (im := im) mn H ns res pre).(VerifCond)).
    induction p; abstract PatR.
  Qed.

  Notation PatVcs p onSuccess := (fun im ns res =>
    (~In "rp" ns) :: incl baseVars ns
    :: (forall x, freeVar p x -> In x ns /\ ~In x baseVars)
    :: wf p
    :: (forall specs mn H pre st,
      interp specs (Postcondition (toCmd onSuccess (im := im) mn H ns res pre) st)
      -> interp specs (inv (allCdatas p) true (fun w => w) ns res st))
    :: (res >= 11)%nat
    :: "xml_lex"!"next" ~~ im ~~> nextS
    :: "xml_lex"!"position" ~~ im ~~> positionS
    :: "xml_lex"!"setPosition" ~~ im ~~> setPositionS
    :: "xml_lex"!"tokenStart" ~~ im ~~> tokenStartS
    :: "xml_lex"!"tokenLength" ~~ im ~~> tokenLengthS
    :: "malloc"!"malloc" ~~ im ~~> mallocS
    :: "malloc"!"free" ~~ im ~~> freeS
    :: "sys"!"abort" ~~ im ~~> abortS
    :: (forall mn H pre,
      (forall specs st, interp specs (pre st)
        -> interp specs (inv (allCdatas p) true (fun w => w) ns res st))
      -> vcs (VerifCond (toCmd onSuccess (im := im) mn H ns res pre)))
    :: (forall a V V', (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
      -> invPre a V = invPre a V')
    ::  (forall a V V' R, (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
      -> invPost a V R = invPost a V' R)
    :: nil).

  Hint Extern 1 (noConflict _ nil) => constructor.
  Hint Extern 1 (inBounds nil _) => constructor.

  Definition Pat (p : pat) (onSuccess : chunk) : chunk.
    refine (WrapC (Pat' p 1 nil onSuccess)
      invar
      invar
      (PatVcs p onSuccess)
      _ _); abstract (wrap0;
        match goal with
          | [ H : wf _ |- _ ] => eapply PatR_correct in H;
            match goal with
              | [ |- Logic.ex _ ] => destruct H; PatR
              | [ |- vcs _ ] => destruct H; PatR
              | _ => try rewrite app_nil_r; eauto
            end; (intros; app; simpl; intuition congruence) || PatR
        end).
  Defined.

End Pat.