(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq.
From mathcomp
Require Import bigop ssralg poly polydiv.

(******************************************************************************)
(*   A proof that algebraically closed field enjoy quantifier elimination,    *)
(*   as described in                                                          *)
(*   ``A formal quantifier elimination for algebraically closed fields'',     *)
(*    proceedings of Calculemus 2010, by Cyril Cohen and Assia Mahboubi       *)
(*                                                                            *)
(* This file constructs an instance of quantifier elimination mixin,          *)
(* (see the ssralg library) from the theory of polynomials with coefficients  *)
(* is an algebraically closed field (see the polydiv library).                *)
(*                                                                            *)
(* This file hence deals with the transformation of formulae part, which we   *)
(* address by implementing one CPS style formula transformer per effective    *)
(* operation involved in the proof of quantifier elimination. See the paper   *)
(* for more details.                                                          *)
(******************************************************************************)

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

Import GRing.
Local Open Scope ring_scope.

Import Pdiv.Ring.
Import PreClosedField.

Section ClosedFieldQE.

Variable F : Field.type.

Variable axiom : ClosedField.axiom F.

Notation fF := (formula F).
Notation qf f := (qf_form f && rformula f).

Definition polyF := seq (term F).

Fixpoint eval_poly (e : seq F) pf :=
  if pf is c::q then (eval_poly e q)*'X + (eval e c)%:P else 0.

Definition rpoly (p : polyF) := all (@rterm F) p.

Fixpoint sizeT (k : nat -> fF) (p : polyF) :=
  if p is c::q then
    sizeT (fun n =>
      if n is m.+1 then k m.+2 else
        GRing.If (c == 0) (k 0%N) (k 1%N)) q
   else k O%N.

Lemma sizeTP (k : nat -> formula F) (pf : polyF) (e : seq F) :
  qf_eval e (sizeT k pf) = qf_eval e (k (size (eval_poly e pf))).
Proof.
elim: pf e k; first by move=> *; rewrite size_poly0.
move=> c qf Pqf e k; rewrite Pqf.
rewrite size_MXaddC -(size_poly_eq0 (eval_poly _ _)).
by case: (size (eval_poly e qf))=> //=; case: eqP; rewrite // orbF.
Qed.

Lemma sizeT_qf (k : nat -> formula F) (p : polyF) :
  (forall n, qf (k n)) -> rpoly p -> qf (sizeT k p).
Proof.
elim: p k => /= [|c q ihp] k kP rp; first exact: kP.
case/andP: rp=> rc rq.
apply: ihp; rewrite ?rq //; case=> [|n]; last exact: kP.
have [/andP[qf0 rf0] /andP[qf1 rf1]] := (kP 0, kP 1)%N.
by rewrite If_form_qf ?If_form_rf //= andbT.
Qed.

Definition isnull (k : bool -> fF) (p : polyF) :=
  sizeT (fun n => k (n == 0%N)) p.

Lemma isnullP (k : bool -> formula F) (p : polyF) (e : seq F) :
  qf_eval e (isnull k p) = qf_eval e (k (eval_poly e p == 0)).
Proof. by rewrite sizeTP size_poly_eq0. Qed.

Lemma isnull_qf (k : bool -> formula F) (p : polyF) :
  (forall b, qf (k b)) -> rpoly p -> qf (isnull k p).
Proof. by move=> *; apply: sizeT_qf. Qed.

Definition lt_sizeT (k : bool -> fF) (p q : polyF) : fF :=
  sizeT (fun n => sizeT (fun m => k (n<m)) q) p.

Definition lift (p : {poly F}) := let: q := p in map Const q.

Lemma eval_lift (e : seq F) (p : {poly F}) : eval_poly e (lift p) = p.
Proof.
elim/poly_ind: p => [|p c]; first by rewrite /lift polyseq0.
rewrite -cons_poly_def /lift polyseq_cons /nilp.
case pn0: (_ == _) => /=; last by move->; rewrite -cons_poly_def.
move=> _; rewrite polyseqC.
case c0: (_==_)=> /=.
  move: pn0; rewrite (eqP c0) size_poly_eq0; move/eqP->.
  by apply: val_inj=> /=; rewrite polyseq_cons // polyseq0.
by rewrite mul0r add0r; apply: val_inj=> /=; rewrite polyseq_cons // /nilp pn0.
Qed.

Fixpoint lead_coefT (k : term F -> fF) p :=
  if p is c::q then
    lead_coefT (fun l => GRing.If (l == 0) (k c) (k l)) q
  else k (Const 0).

Lemma lead_coefTP (k : term F -> formula F) :
 (forall x e, qf_eval e (k x) = qf_eval e (k (Const (eval e x)))) ->
  forall (p : polyF) (e : seq F),
  qf_eval e (lead_coefT k p) = qf_eval e (k (Const (lead_coef (eval_poly e p)))).
Proof.
move=> Pk p e; elim: p k Pk => /= [*|a p' Pp' k Pk]; first by rewrite lead_coef0.
rewrite Pp'; last by move=> *; rewrite //= -Pk.
rewrite GRing.eval_If /= lead_coef_eq0.
case p'0: (_ == _); first by rewrite (eqP p'0) mul0r add0r lead_coefC -Pk.
rewrite lead_coefDl ?lead_coefMX // polyseqC size_mul ?p'0 //; last first.
  by rewrite -size_poly_eq0 size_polyX.
rewrite size_polyX addnC /=; case: (_ == _)=> //=.
by rewrite ltnS lt0n size_poly_eq0 p'0.
Qed.

Lemma lead_coefT_qf (k : term F -> formula F) (p : polyF) :
 (forall c, rterm c -> qf (k c)) -> rpoly p -> qf (lead_coefT k p).
Proof.
elim: p k => /= [|c q ihp] k kP rp; first exact: kP.
move: rp; case/andP=> rc rq; apply: ihp; rewrite ?rq // => l rl.
have [/andP[qfc rfc] /andP[qfl rfl]] := (kP c rc, kP l rl).
by rewrite If_form_qf ?If_form_rf //= andbT.
Qed.

Fixpoint amulXnT (a : term F) (n : nat) : polyF :=
  if n is n'.+1 then (Const 0) :: (amulXnT a n') else [::a].

Lemma eval_amulXnT  (a : term F) (n : nat) (e : seq F) :
  eval_poly e (amulXnT a n) = (eval e a)%:P * 'X^n.
Proof.
elim: n=> [|n] /=; first by rewrite expr0 mulr1 mul0r add0r.
by move->; rewrite addr0 -mulrA -exprSr.
Qed.

Lemma ramulXnT: forall a n, rterm a -> rpoly (amulXnT a n).
Proof. by move=> a n; elim: n a=> [a /= -> //|n ihn a ra]; apply: ihn. Qed.

Fixpoint sumpT (p q : polyF) :=
  if p is a::p' then
    if q is b::q' then (Add a b)::(sumpT p' q')
      else p
    else q.

Lemma eval_sumpT (p q : polyF) (e : seq F) :
  eval_poly e (sumpT p q) = (eval_poly e p) + (eval_poly e q).
Proof.
elim: p q => [|a p Hp] q /=; first by rewrite add0r.
case: q => [|b q] /=; first by rewrite addr0.
rewrite Hp mulrDl -!addrA; congr (_ + _); rewrite polyC_add addrC -addrA.
by congr (_ + _); rewrite addrC.
Qed.

Lemma rsumpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (sumpT p q).
Proof.
elim: p q=> [|a p ihp] q rp rq //; move: rp; case/andP=> ra rp.
case: q rq => [|b q]; rewrite /= ?ra ?rp //=.
by case/andP=> -> rq //=; apply: ihp.
Qed.

Fixpoint mulpT (p q : polyF) :=
  if p is a :: p' then sumpT (map (Mul a) q) (Const 0::(mulpT p' q)) else [::].

Lemma eval_mulpT (p q : polyF) (e : seq F) :
  eval_poly e (mulpT p q) = (eval_poly e p) * (eval_poly e q).
Proof.
elim: p q=> [|a p Hp] q /=; first by rewrite mul0r.
rewrite eval_sumpT /= Hp addr0 mulrDl addrC mulrAC; congr (_ + _).
elim: q=> [|b q Hq] /=; first by rewrite mulr0.
by rewrite Hq polyC_mul mulrDr mulrA.
Qed.

Lemma rpoly_map_mul (t : term F) (p : polyF) (rt : rterm t) :
  rpoly (map (Mul t) p) = rpoly p.
Proof.
by rewrite /rpoly all_map /= (@eq_all _ _ (@rterm _)) // => x; rewrite /= rt.
Qed.

Lemma rmulpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (mulpT p q).
Proof.
elim: p q=> [|a p ihp] q rp rq //=; move: rp; case/andP=> ra rp /=.
apply: rsumpT; last exact: ihp.
by rewrite rpoly_map_mul.
Qed.

Definition opppT := map (Mul (@Const F (-1))).

Lemma eval_opppT (p : polyF) (e : seq F) :
 eval_poly e (opppT p) = - eval_poly e p.
Proof.
by elim: p; rewrite /= ?oppr0 // => ? ? ->; rewrite !mulNr opprD polyC_opp mul1r.
Qed.

Definition natmulpT n := map (Mul (@NatConst F n)).

Lemma eval_natmulpT  (p : polyF) (n : nat) (e : seq F) :
  eval_poly e (natmulpT n p) = (eval_poly e p) *+ n.
Proof.
elim: p; rewrite //= ?mul0rn // => c p ->.
rewrite mulrnDl mulr_natl polyC_muln; congr (_ + _).
by rewrite -mulr_natl mulrAC -mulrA mulr_natl mulrC.
Qed.

Fixpoint redivp_rec_loopT (q : polyF) sq cq (k : nat * polyF * polyF -> fF)
  (c : nat) (qq r : polyF) (n : nat) {struct n}:=
  sizeT (fun sr =>
    if sr < sq then k (c, qq, r) else
      lead_coefT (fun lr =>
        let m := amulXnT lr (sr - sq) in
        let qq1 := sumpT (mulpT qq [::cq]) m in
        let r1 := sumpT (mulpT r ([::cq])) (opppT (mulpT m q)) in
        if n is n1.+1 then redivp_rec_loopT q sq cq k c.+1 qq1 r1 n1
        else k (c.+1, qq1, r1)
      ) r
  ) r.

Fixpoint redivp_rec_loop (q : {poly F}) sq cq
   (k : nat) (qq r : {poly F})(n : nat) {struct n} :=
    if size r < sq then (k, qq, r) else
      let m := (lead_coef r) *: 'X^(size r - sq) in
      let qq1 := qq * cq%:P + m in
      let r1 := r * cq%:P - m * q in
      if n is n1.+1 then redivp_rec_loop q sq cq k.+1 qq1 r1 n1 else
        (k.+1, qq1, r1).

Lemma redivp_rec_loopTP (k : nat * polyF * polyF -> formula F) :
  (forall c qq r e,  qf_eval e (k (c,qq,r))
    = qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r))))
  -> forall q sq cq c qq r n e
    (d := redivp_rec_loop (eval_poly e q) sq (eval e cq)
      c (eval_poly e qq) (eval_poly e r) n),
    qf_eval e (redivp_rec_loopT q sq cq k c qq r n)
    = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)).
Proof.
move=> Pk q sq cq c qq r n e /=.
elim: n c qq r k Pk e => [|n Pn] c qq r k Pk e; rewrite sizeTP.
  case ltrq : (_ < _); first by rewrite /= ltrq /= -Pk.
  rewrite lead_coefTP => [|a p]; rewrite Pk.
    rewrite ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=.
    by rewrite ltrq //= mul_polyC ?(mul0r,add0r).
  by symmetry; rewrite Pk ?(eval_mulpT,eval_amulXnT,eval_sumpT, eval_opppT).
case ltrq : (_<_); first by rewrite /= ltrq Pk.
rewrite lead_coefTP.
  rewrite Pn ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=.
  by rewrite ltrq //= mul_polyC ?(mul0r,add0r).
rewrite -/redivp_rec_loopT => x e'.
rewrite Pn; last by move=> *; rewrite Pk.
symmetry; rewrite Pn; last by move=> *; rewrite Pk.
rewrite Pk ?(eval_lift,eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT).
by rewrite mul_polyC ?(mul0r,add0r).
Qed.

Lemma redivp_rec_loopT_qf (q : polyF) (sq : nat) (cq : term F)
 (k : nat * polyF * polyF -> formula F) (c : nat) (qq r : polyF) (n : nat) :
  (forall r, [&& rpoly r.1.2 & rpoly r.2] -> qf (k r)) ->
  rpoly q -> rterm cq -> rpoly qq -> rpoly r ->
    qf (redivp_rec_loopT q sq cq k c qq r n).
Proof.
elim: n q sq cq k c qq r => [|n ihn] q sq cq k c qq r kP rq rcq rqq rr.
  apply: sizeT_qf=> // n; case: (_ < _); first by apply: kP; rewrite // rqq rr.
  apply: lead_coefT_qf=> // l rl; apply: kP.
  by rewrite /= ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq.
apply: sizeT_qf=> // m; case: (_ < _); first by apply: kP => //=; rewrite rqq rr.
apply: lead_coefT_qf=> // l rl; apply: ihn; rewrite //= ?rcq //.
  by rewrite ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq.
by rewrite ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq.
Qed.

Definition redivpT (p : polyF) (k : nat * polyF * polyF -> fF)
                   (q : polyF) : fF :=
  isnull (fun b =>
    if b then k (0%N, [::Const 0], p) else
      sizeT (fun sq =>
        sizeT (fun sp =>
          lead_coefT (fun lq =>
            redivp_rec_loopT q sq lq k 0 [::Const 0] p sp
          ) q
        ) p
      ) q
  ) q.

Lemma redivp_rec_loopP  (q : {poly F}) (c : nat) (qq r : {poly F}) (n : nat) :
  redivp_rec q c qq r n = redivp_rec_loop q (size q) (lead_coef q) c qq r n.
Proof. by elim: n c qq r => [| n Pn] c qq r //=; rewrite Pn. Qed.

Lemma redivpTP (k : nat * polyF * polyF -> formula F) :
  (forall c qq r e,
     qf_eval e (k (c,qq,r)) =
     qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r)))) ->
  forall p q e (d := redivp (eval_poly e p) (eval_poly e q)),
    qf_eval e (redivpT p k q) = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)).
Proof.
move=> Pk p q e /=; rewrite isnullP unlock.
case q0 : (_ == _); first by rewrite Pk /= mul0r add0r polyC0.
rewrite !sizeTP lead_coefTP /=; last by move=> *; rewrite !redivp_rec_loopTP.
rewrite redivp_rec_loopTP /=; last by move=> *; rewrite Pk.
by rewrite mul0r add0r polyC0 redivp_rec_loopP.
Qed.

Lemma redivpT_qf (p : polyF) (k : nat * polyF * polyF -> formula F) (q : polyF) :
  (forall r, [&& rpoly r.1.2 & rpoly r.2] -> qf (k r)) ->
   rpoly p -> rpoly q -> qf (redivpT p k q).
Proof.
move=> kP rp rq; rewrite /redivpT; apply: isnull_qf=> // [[]]; first exact: kP.
apply: sizeT_qf => // sq; apply: sizeT_qf=> // sp.
by apply: lead_coefT_qf=> // lq rlq; apply: redivp_rec_loopT_qf.
Qed.

Definition rmodpT (p : polyF) (k : polyF -> fF) (q : polyF) : fF :=
  redivpT p (fun d => k d.2) q.
Definition rdivpT (p : polyF) (k:polyF -> fF) (q : polyF) : fF :=
  redivpT p (fun d => k d.1.2) q.
Definition rscalpT (p : polyF) (k: nat -> fF) (q : polyF) : fF :=
  redivpT p (fun d => k d.1.1) q.
Definition rdvdpT (p : polyF) (k:bool -> fF) (q : polyF) : fF :=
  rmodpT p (isnull k) q.

Fixpoint rgcdp_loop n (pp qq : {poly F}) {struct n} :=
  if rmodp pp qq == 0 then qq
    else if n is n1.+1 then rgcdp_loop n1 qq (rmodp pp qq)
         else rmodp pp qq.

Fixpoint rgcdp_loopT (pp : polyF) (k : polyF -> formula F) n (qq : polyF) :=
  rmodpT pp (isnull
    (fun b => if b then (k qq)
              else (if n is n1.+1
                    then rmodpT pp (rgcdp_loopT qq k n1) qq
                    else rmodpT pp k qq)
    )
            ) qq.

Lemma rgcdp_loopP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall n p q e,
    qf_eval e (rgcdp_loopT p k n q) =
    qf_eval e (k (lift (rgcdp_loop n (eval_poly e p) (eval_poly e q)))).
Proof.
move=> Pk n p q e.
elim: n p q e => /= [| m Pm] p q e.
  rewrite redivpTP; last by move=> *; rewrite !isnullP eval_lift.
  rewrite isnullP eval_lift; case: (_ == 0); first by rewrite Pk.
  by rewrite redivpTP; last by move=> *; rewrite Pk.
rewrite redivpTP; last by move=> *; rewrite !isnullP eval_lift.
rewrite isnullP eval_lift; case: (_ == 0); first by rewrite Pk.
by rewrite redivpTP => *; rewrite ?Pm !eval_lift.
Qed.

Lemma rgcdp_loopT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) (n : nat) :
  (forall r, rpoly r -> qf (k r)) ->
  rpoly p -> rpoly q -> qf (rgcdp_loopT p k n q).
elim: n p k q => [|n ihn] p k q kP rp rq.
  apply: redivpT_qf=> // r; case/andP=> _ rr.
  apply: isnull_qf=> // [[]]; first exact: kP.
  by apply: redivpT_qf=> // r'; case/andP=> _ rr'; apply: kP.
apply: redivpT_qf=> // r; case/andP=> _ rr.
apply: isnull_qf=> // [[]]; first exact: kP.
by apply: redivpT_qf=> // r'; case/andP=> _ rr'; apply: ihn.
Qed.

Definition rgcdpT (p : polyF) k (q : polyF) : fF :=
  let aux p1 k q1 := isnull
    (fun b => if b
      then (k q1)
      else (sizeT (fun n => (rgcdp_loopT p1 k n q1)) p1)) p1
    in (lt_sizeT (fun b => if b then (aux q k p) else (aux p k q)) p q).

Lemma rgcdpTP (k : seq (term F) -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
   forall p q e, qf_eval e (rgcdpT p k q) =
                 qf_eval e (k (lift (rgcdp (eval_poly e p) (eval_poly e q)))).
Proof.
move=> Pk p q e; rewrite /rgcdpT !sizeTP; case lqp: (_ < _).
  rewrite isnullP; case q0: (_ == _); first by rewrite Pk (eqP q0) rgcdp0.
  rewrite sizeTP rgcdp_loopP => [|e' p']; last by rewrite Pk.
  by rewrite /rgcdp lqp q0.
rewrite isnullP; case p0: (_ == _); first by rewrite Pk (eqP p0) rgcd0p.
rewrite sizeTP rgcdp_loopP => [|e' p']; last by rewrite Pk.
by rewrite /rgcdp lqp p0.
Qed.

Lemma rgcdpT_qf  (p : polyF) (k : polyF -> formula F) (q : polyF) :
  (forall r, rpoly r -> qf (k r)) -> rpoly p -> rpoly q -> qf (rgcdpT p k q).
Proof.
move=> kP rp rq; apply: sizeT_qf=> // n; apply: sizeT_qf=> // m.
by case: (_ < _);
   apply: isnull_qf=> //; case; do ?apply: kP=> //;
   apply: sizeT_qf=> // n'; apply: rgcdp_loopT_qf.
Qed.

Fixpoint rgcdpTs k (ps : seq polyF) : fF :=
  if ps is p::pr then rgcdpTs (rgcdpT p k) pr else k [::Const 0].

Lemma rgcdpTsP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall ps e,
    qf_eval e (rgcdpTs k ps) =
    qf_eval e (k (lift (\big[@rgcdp _/0%:P]_(i <- ps)(eval_poly e i)))).
Proof.
move=> Pk ps e.
elim: ps k Pk; first by move=> p Pk; rewrite /= big_nil Pk /= mul0r add0r.
move=> p ps Pps /= k Pk /=; rewrite big_cons Pps => [|p' e'].
  by rewrite rgcdpTP // eval_lift.
by rewrite !rgcdpTP // Pk !eval_lift .
Qed.

Definition rseq_poly ps := all rpoly ps.

Lemma rgcdpTs_qf (k : polyF -> formula F) (ps : seq polyF) :
  (forall r, rpoly r -> qf (k r)) -> rseq_poly ps -> qf (rgcdpTs k ps).
Proof.
elim: ps k=> [|c p ihp] k kP rps=> /=; first exact: kP.
by move: rps; case/andP=> rc rp; apply: ihp=> // r rr; apply: rgcdpT_qf.
Qed.

Fixpoint rgdcop_recT (q : polyF) k  (p : polyF) n :=
  if n is m.+1 then
    rgcdpT p (sizeT (fun sd =>
      if sd == 1%N then k p
      else rgcdpT p (rdivpT p (fun r => rgdcop_recT q k r m)) q
    )) q
  else isnull (fun b => k [::Const b%:R]) q.

Lemma rgdcop_recTP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p))))
  -> forall p q n e, qf_eval e (rgdcop_recT p k q n)
    = qf_eval e (k (lift (rgdcop_rec (eval_poly e p) (eval_poly e q) n))).
Proof.
move=> Pk p q n e.
elim: n k Pk p q e => [|n Pn] k Pk p q e /=.
  rewrite isnullP /=.
  by case: (_ == _); rewrite Pk /= mul0r add0r ?(polyC0, polyC1).
rewrite rgcdpTP ?sizeTP ?eval_lift //.
  rewrite /rcoprimep; case se : (_==_); rewrite Pk //.
  do ?[rewrite (rgcdpTP,Pn,eval_lift,redivpTP) | move=> * //=].
by do ?[rewrite (sizeTP,eval_lift) | move=> * //=].
Qed.

Lemma rgdcop_recT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) (n : nat) :
 (forall r, rpoly r -> qf (k r)) ->
 rpoly p -> rpoly q -> qf (rgdcop_recT p k q n).
Proof.
elim: n p k q => [|n ihn] p k q kP rp rq /=.
apply: isnull_qf=> //; first by case; rewrite kP.
apply: rgcdpT_qf=> // g rg; apply: sizeT_qf=> // n'.
case: (_ == _); first exact: kP.
apply: rgcdpT_qf=> // g' rg'; apply: redivpT_qf=> // r; case/andP=> rr _.
exact: ihn.
Qed.

Definition rgdcopT q k p := sizeT (rgdcop_recT q k p) p.

Lemma rgdcopTP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall p q e, qf_eval e (rgdcopT p k q) =
                qf_eval e (k (lift (rgdcop (eval_poly e p) (eval_poly e q)))).
Proof. by move=> *; rewrite sizeTP rgdcop_recTP 1?Pk. Qed.

Lemma rgdcopT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) :
  (forall r, rpoly r -> qf (k r)) -> rpoly p -> rpoly q -> qf (rgdcopT p k q).
Proof.
by move=> kP rp rq; apply: sizeT_qf => // n; apply: rgdcop_recT_qf.
Qed.

Definition ex_elim_seq (ps : seq polyF) (q : polyF) :=
  (rgcdpTs (rgdcopT q (sizeT (fun n => Bool (n != 1%N)))) ps).

Lemma ex_elim_seqP (ps : seq polyF) (q : polyF) (e : seq F) :
  let gp := (\big[@rgcdp _/0%:P]_(p <- ps)(eval_poly e p)) in
  qf_eval e (ex_elim_seq ps q) = (size (rgdcop (eval_poly e q) gp) != 1%N).
Proof.
by do ![rewrite (rgcdpTsP,rgdcopTP,sizeTP,eval_lift) //= | move=> * //=].
Qed.

Lemma ex_elim_seq_qf  (ps : seq polyF) (q : polyF) :
  rseq_poly ps -> rpoly q -> qf (ex_elim_seq ps q).
Proof.
move=> rps rq; apply: rgcdpTs_qf=> // g rg; apply: rgdcopT_qf=> // d rd.
exact : sizeT_qf.
Qed.

Fixpoint abstrX (i : nat) (t : term F) :=
  match t with
    | (Var n) => if n == i then [::Const 0; Const 1] else [::t]
    | (Opp x) => opppT (abstrX i x)
    | (Add x y) => sumpT (abstrX i x) (abstrX i y)
    | (Mul x y) => mulpT (abstrX i x) (abstrX i y)
    | (NatMul x n) => natmulpT n (abstrX i x)
    | (Exp x n) => let ax := (abstrX i x) in
      iter n (mulpT ax) [::Const 1]
    | _ => [::t]
  end.

Lemma abstrXP  (i : nat) (t : term F) (e : seq F) (x : F) :
  rterm t -> (eval_poly e (abstrX i t)).[x] = eval (set_nth 0 e i x) t.
Proof.
elim: t => [n | r | n | t tP s sP | t tP | t tP n | t tP s sP | t tP | t tP n] h.
- move=> /=; case ni: (_ == _);
    rewrite //= ?(mul0r,add0r,addr0,polyC1,mul1r,hornerX,hornerC);
    by rewrite // nth_set_nth /= ni.
- by rewrite /= mul0r add0r hornerC.
- by rewrite /= mul0r add0r hornerC.
- by case/andP: h => *; rewrite /= eval_sumpT hornerD tP ?sP.
- by rewrite /= eval_opppT hornerN tP.
- by rewrite /= eval_natmulpT hornerMn tP.
- by case/andP: h => *; rewrite /= eval_mulpT hornerM tP ?sP.
- by [].
- elim: n h => [|n ihn] rt; first by rewrite /= expr0 mul0r add0r hornerC.
  by rewrite /= eval_mulpT exprSr hornerM ihn // mulrC tP.
Qed.

Lemma rabstrX (i : nat) (t : term F) : rterm t -> rpoly (abstrX i t).
Proof.
elim: t; do ?[ by move=> * //=; do ?case: (_ == _)].
- move=> t irt s irs /=; case/andP=> rt rs.
  by apply: rsumpT; rewrite ?irt ?irs //.
- by move=> t irt /= rt; rewrite rpoly_map_mul ?irt //.
- by move=> t irt /= n rt; rewrite rpoly_map_mul ?irt //.
- move=> t irt s irs /=; case/andP=> rt rs.
  by apply: rmulpT; rewrite ?irt ?irs //.
- move=> t irt /= n rt; move: (irt rt)=> {rt} rt; elim: n => [|n ihn] //=.
  exact: rmulpT.
Qed.

Implicit Types tx ty : term F.

Lemma abstrX_mulM (i : nat) : {morph abstrX i : x y / Mul x y >-> mulpT x y}.
Proof. done. Qed.

Lemma abstrX1 (i : nat) : abstrX i (Const 1) = [::Const 1].
Proof. done. Qed.

Lemma eval_poly_mulM e : {morph eval_poly e : x y / mulpT x y >-> mul x y}.
Proof. by move=> x y; rewrite eval_mulpT. Qed.

Lemma eval_poly1 e : eval_poly e [::Const 1] = 1.
Proof. by rewrite /= mul0r add0r. Qed.

Notation abstrX_bigmul := (big_morph _ (abstrX_mulM _) (abstrX1 _)).
Notation eval_bigmul := (big_morph _ (eval_poly_mulM _) (eval_poly1 _)).
Notation bigmap_id := (big_map _ (fun _ => true) id).

Lemma rseq_poly_map (x : nat) (ts : seq (term F)) :
  all (@rterm _) ts ->  rseq_poly (map (abstrX x) ts).
Proof.
by elim: ts => //= t ts iht; case/andP=> rt rts; rewrite rabstrX // iht.
Qed.

Definition ex_elim (x : nat) (pqs : seq (term F) * seq (term F)) :=
  ex_elim_seq (map (abstrX x) pqs.1)
  (abstrX x (\big[Mul/Const 1]_(q <- pqs.2) q)).

Lemma ex_elim_qf (x : nat) (pqs : seq (term F) * seq (term F)) :
  dnf_rterm pqs -> qf (ex_elim x pqs).
case: pqs => ps qs; case/andP=> /= rps rqs.
apply: ex_elim_seq_qf; first exact: rseq_poly_map.
apply: rabstrX=> /=.
elim: qs rqs=> [|t ts iht] //=; first by rewrite big_nil.
by case/andP=> rt rts; rewrite big_cons /= rt /= iht.
Qed.

Lemma holds_conj : forall e i x ps, all (@rterm _) ps ->
  (holds (set_nth 0 e i x) (foldr (fun t : term F => And (t == 0)) True ps)
  <-> all ((@root _)^~ x) (map (eval_poly e \o abstrX i) ps)).
Proof.
move=> e i x; elim=> [|p ps ihps] //=.
case/andP=> rp rps; rewrite rootE abstrXP //.
constructor; first by case=> -> hps; rewrite eqxx /=; apply/ihps.
by case/andP; move/eqP=> -> psr; split=> //; apply/ihps.
Qed.

Lemma holds_conjn (e : seq F) (i : nat) (x : F) (ps : seq (term F)) :
  all (@rterm _) ps ->
  (holds (set_nth 0 e i x) (foldr (fun t : term F => And (t != 0)) True ps) <->
  all (fun p => ~~root p x) (map (eval_poly e \o abstrX i) ps)).
Proof.
elim: ps => [|p ps ihps] //=.
case/andP=> rp rps; rewrite rootE abstrXP //.
constructor; first by case=> /eqP-> hps /=; apply/ihps.
by case/andP=> pr psr; split; first apply/eqP=> //; apply/ihps.
Qed.

Lemma holds_ex_elim: GRing.valid_QE_proj ex_elim.
Proof.
move=> i [ps qs] /= e; case/andP=> /= rps rqs.
rewrite ex_elim_seqP big_map.
have -> : \big[@rgcdp _/0%:P]_(j <- ps) eval_poly e (abstrX i j) =
          \big[@rgcdp _/0%:P]_(j <- (map (eval_poly e) (map (abstrX i) (ps)))) j.
  by rewrite !big_map.
rewrite -!map_comp.
  have aux I (l : seq I) (P : I -> {poly F}) :
    \big[(@gcdp F)/0]_(j <- l) P j %= \big[(@rgcdp F)/0]_(j <- l) P j.
    elim: l => [| u l ihl] /=; first by rewrite !big_nil eqpxx.
    rewrite !big_cons; move: ihl; move/(eqp_gcdr (P u)) => h.
    by apply: eqp_trans h _; rewrite eqp_sym; apply: eqp_rgcd_gcd.
case g0: (\big[(@rgcdp F)/0%:P]_(j <- map (eval_poly e \o abstrX i) ps) j == 0).
  rewrite (eqP g0) rgdcop0.
  case m0 : (_ == 0)=> //=; rewrite ?(size_poly1,size_poly0) //=.
    rewrite abstrX_bigmul eval_bigmul -bigmap_id in m0.
    constructor=> [[x] // []] //.
    case=> _; move/holds_conjn=> hc; move/hc:rqs.
    by rewrite -root_bigmul //= (eqP m0) root0.
  constructor; move/negP:m0; move/negP=>m0.
  case: (closed_nonrootP axiom _ m0) => x {m0}.
  rewrite abstrX_bigmul eval_bigmul -bigmap_id root_bigmul=> m0.
  exists x; do 2?constructor=> //; last by apply/holds_conjn.
  apply/holds_conj; rewrite //= -root_biggcd.
  by rewrite (eqp_root (aux _ _ _ )) (eqP g0) root0.
apply: (iffP (closed_rootP axiom _)); case=> x Px; exists x; move: Px => //=.
  rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 //.
  rewrite -(eqp_root (aux _ _ _ )) root_biggcd  abstrX_bigmul eval_bigmul.
  rewrite -bigmap_id root_bigmul; case/andP=> psr qsr.
  do 2?constructor; first by apply/holds_conj.
  by apply/holds_conjn.
rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 // -(eqp_root (aux _ _ _)).
rewrite root_biggcd abstrX_bigmul eval_bigmul -bigmap_id.
rewrite root_bigmul=> [[] // [hps hqs]]; apply/andP.
constructor; first by apply/holds_conj.
by apply/holds_conjn.
Qed.

Lemma wf_ex_elim : GRing.wf_QE_proj ex_elim.
Proof. by move=> i bc /= rbc; apply: ex_elim_qf. Qed.

Definition closed_fields_QEMixin :=
  QEdecFieldMixin wf_ex_elim holds_ex_elim.

End ClosedFieldQE.


Require Export List.
Require Export Util.

Module Type RED_LANG.

  (** The languages of terms, values, redex, and context, the empty context is also needed. *)
  Parameters term value redex elem_context : Set.
  Definition context := list elem_context.
  Definition empty : context := nil.

  (** The values and redexes are sublanguages of terms *)
  Parameter value_to_term : value -> term.
  Parameter redex_to_term : redex -> term.
  Axiom value_to_term_injective : forall v v' : value,
    value_to_term v = value_to_term v' -> v = v'.
  Axiom redex_to_term_injective : forall r r' : redex,
    redex_to_term r = redex_to_term r' -> r = r'.

  (** The main functions of reduction semantics, defining plugging terms into contexts and
      composing contexts, effectively defining reduction semantics, and some properties. *)
  Definition compose (c0 c1 : context) : context := app c0 c1.
  Parameter atom_plug : term -> elem_context -> term.
  Definition plug (t : term) (c : context) : term := fold_left atom_plug c t.

  (** The other main function of reduction semantics -- contraction of a redex into a term *)
  Parameter contract : redex -> option term.

  Definition only_empty (t : term) : Prop := forall t' c, plug t' c = t -> c = empty.
  Definition only_trivial (t : term) : Prop := forall t' c, plug t' c = t ->
    c = empty \/ exists v, t' = value_to_term v.

  Axiom value_trivial : forall v : value, only_trivial (value_to_term v).
  Axiom redex_trivial : forall r : redex, only_trivial (redex_to_term r).
  Axiom value_redex : forall (v : value) (r : redex), value_to_term v <> redex_to_term r.
  Axiom trivial_val_red : forall t : term, only_trivial t ->
    (exists v : value, t = value_to_term v) \/ (exists r : redex, t = redex_to_term r).

  (** Datatype of decompositions -- either a value or a redex in a context (analogous to the decompose lemma) *)
  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_term: term -> elem_context -> interm_dec.

  Definition decomp_to_term (d : decomp) : term :=
  match d with
    | d_val v => value_to_term v
    | d_red r c0 => plug (redex_to_term r) c0
  end.

End RED_LANG.

Module Type LANG_PROP (R : RED_LANG).

  Axiom plug_empty : forall t, R.plug t R.empty = t.
  Axiom compose_empty : forall c : R.context, c = R.compose c R.empty.
  Axiom plug_compose : forall (c c' : R.context) (t : R.term), R.plug t (R.compose c c') = R.plug (R.plug t c) c'.

End LANG_PROP.

Module Type RED_REF_LANG.

  Declare Module R : RED_LANG.

  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Inductive subterm_one_step : R.term -> R.term -> Prop :=
  | st_1 : forall t t0 ec (DECT : t = R.atom_plug t0 ec), subterm_one_step t0 t.
  Axiom wf_st1 : well_founded subterm_one_step.

  Definition subterm_order := clos_trans_n1 R.term subterm_one_step.
  Notation " a <| b " := (subterm_order a b) (at level 40).
  Definition wf_sto : well_founded subterm_order := wf_clos_trans_r _ _ wf_st1.

  Parameter ec_order : R.elem_context -> R.elem_context -> Prop.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Axiom wf_eco : well_founded ec_order.

  Axiom dec_term_red_empty  : forall t r, dec_term t = R.in_red r -> R.only_empty t.
  Axiom dec_term_val_empty  : forall t v, dec_term t = R.in_val v -> R.only_empty t.
  Axiom dec_term_term_top   : forall t t' ec, dec_term t = R.in_term t' ec ->
    forall ec', ~ec <: ec'.
  Axiom dec_context_red_bot : forall ec v r, dec_context ec v = R.in_red r ->
    forall ec', ~ ec' <: ec.
  Axiom dec_context_val_bot : forall ec v v', dec_context ec v = R.in_val v' ->
    forall ec', ~ ec' <: ec.
  Axiom dec_context_term_next : forall ec v t ec', dec_context ec v = R.in_term t ec' ->
    ec' <: ec /\ forall ec'', ec'' <: ec -> ~ ec' <: ec''.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t' ec => R.atom_plug t' ec = t
    end.
  Axiom dec_context_correct : forall ec v, match dec_context ec v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) ec
    | R.in_val v' => R.value_to_term v' = R.atom_plug (R.value_to_term v) ec
    | R.in_term t ec' => R.atom_plug t ec' = R.atom_plug (R.value_to_term v) ec
    end.

  Axiom ec_order_antisym : forall ec ec0, ec <: ec0 -> ~ ec0 <: ec.
  Axiom dec_ec_ord : forall t0 t1 ec0 ec1, R.atom_plug t0 ec0 = R.atom_plug t1 ec1 -> ec0 <: ec1 \/ ec1 <: ec0 \/ (t0 = t1 /\ ec0 = ec1).
  Axiom elem_context_det : forall t0 t1 ec0 ec1, ec0 <: ec1 -> R.atom_plug t0 ec0 = R.atom_plug t1 ec1 ->
    exists v, t1 = R.value_to_term v.

End RED_REF_LANG.

  Ltac prove_st_wf := intro a; constructor; induction a; (intros y H;
    inversion H as [t t0 ec DECT]; subst; destruct ec; inversion DECT; subst; constructor; auto).
  Ltac prove_ec_wf := intro a; destruct a; repeat (constructor; intros ec T; destruct ec; inversion T; subst; clear T).

Module Type ABSTRACT_MACHINE.

  Parameters term value configuration : Set.
  Parameter c_init : term -> configuration.
  Parameter c_final : value -> configuration.
  Parameter transition : configuration -> configuration -> Prop.

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
  | multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

End ABSTRACT_MACHINE.

Module Type SOS_SEM.

  Parameters term value : Set.
  Parameter step : term -> term -> Prop.
  Parameter value_to_term : value -> term.

  Inductive step_close : term -> value -> Prop :=
  | s_val  : forall v, step_close (value_to_term v) v
  | s_step : forall t t0 v, step t t0 -> step_close t0 v -> step_close t v.

End SOS_SEM.


Require Export p_is_pos p_is_neg is_pos_neg_lemmas.
Require Import Lia.

(* p_is_pos lemmas *)

Lemma p_is_pos_notin : forall (phi : Modal) (p : propvar),
  p_is_pos phi p -> pv_in_modal phi p.
Proof.
  intros phi p H_pos.  inversion H_pos as [Hpv Hpos].
  destruct (pv_in_modal_dec phi p) as [Hdec | Hdec].
  assumption. contradiction.
Qed.

Lemma p_is_pos_atom : forall (p q : propvar),
  p_is_pos (atom q) p -> p = q.
Proof.
  intros p q [Hpv Hpos].
  apply pv_in_modal_atom. assumption.
Qed.

Lemma p_is_pos_mneg : forall (phi : Modal) (p : propvar),
    p_is_pos (mneg phi) p -> ~ p_is_pos phi p .
Proof.
  intros phi q [Hpv Hpos] [Hpv2 Hpos2].
  (* Left it here *)
  simpl in *. apply  pv_in_modal_occ_in_modal in Hpv2.
  destruct Hpv2 as [i [H1 H2]].
  pose proof (Hpos2 i H1 H2).
  apply occ_in_modal_mneg in H1.
  pose proof (Hpos i H1 H2) as H0.
  apply is_pos_mneg in H0. auto.
Qed.

Lemma p_is_pos_mconj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mconj phi1 phi2) p ->
    pv_in_modal phi1 p ->
      p_is_pos phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  constructor. auto.
  inversion Hpos as [H1 H2].
  intros i Hocc2 Hat.
  pose proof (occ_in_modal_mconj_l phi1 phi2 i Hocc2) as Hocc3.
  apply H2 in Hocc3. apply is_pos_mconj_l in Hocc3; auto.
  simpl. rewrite at_pv_app_l. auto.
  apply occ_in_modal_le. auto.
Qed.

Lemma p_is_pos_mconj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mconj phi1 phi2) p ->
    pv_in_modal phi2 p ->
      p_is_pos phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  destruct Hpos as [Hpocct Hpoccf].
  constructor. assumption.
  intros i Hocc Hat.
  assert (i = (i + (length (pv_in phi1)) - (length (pv_in phi1)))) as Heq.
    firstorder.
  rewrite Heq in *.
  apply is_pos_mconj_r. apply Hpoccf.
  apply occ_in_modal_mconj_r2.
  auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pv_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
  lia.
Qed.

Lemma p_is_pos_mdisj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mdisj phi1 phi2) p ->
    pv_in_modal phi1 p ->
    p_is_pos phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  constructor. auto.
  inversion Hpos as [H1 H2].
  intros i Hocc2 Hat.
  pose proof (occ_in_modal_mdisj_l phi1 phi2 i Hocc2) as Hocc3.
  apply H2 in Hocc3. apply is_pos_mdisj_l in Hocc3; auto.
  simpl. rewrite at_pv_app_l. auto.
  apply occ_in_modal_le. auto.
Qed.

Lemma p_is_pos_mdisj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mdisj phi1 phi2) p ->
    pv_in_modal phi2 p ->
    p_is_pos phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  destruct Hpos as [Hpocct Hpoccf].
  constructor. assumption.
  intros i Hocc Hat.
  assert (i = (i + (length (pv_in phi1)) - (length (pv_in phi1)))) as Heq.
    firstorder.
  rewrite Heq in *.
  apply is_pos_mdisj_r. apply Hpoccf.
  apply occ_in_modal_mdisj_r2.
  auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pv_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all : auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
  lia.
Qed.

Lemma p_is_pos_mimpl2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mimpl phi1 phi2) p ->
    pv_in_modal phi1 p ->
    p_is_neg phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  constructor. auto.
  inversion Hpos as [H1 H2].
  intros i Hocc2 Hat.
  pose proof (occ_in_modal_mimpl_l phi1 phi2 i Hocc2) as Hocc3.
  apply H2 in Hocc3. apply is_pos_neg_mimpl_l in Hocc3; auto.
  simpl. rewrite at_pv_app_l. auto.
  apply occ_in_modal_le. all : auto.
Qed.

Lemma p_is_pos_mimpl2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mimpl phi1 phi2) p ->
    pv_in_modal phi2 p ->
    p_is_pos phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  destruct Hpos as [Hpocct Hpoccf].
  constructor. assumption.
  intros i Hocc Hat.
  assert (i = (i + (length (pv_in phi1)) - (length (pv_in phi1)))) as Heq.
    firstorder.
  rewrite Heq in *.
  apply is_pos_mimpl_r2. apply Hpoccf.
  apply occ_in_modal_mimpl_r2.
  auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pv_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
Qed.

Lemma p_is_pos_box : forall (phi : Modal) (p : propvar),
  p_is_pos (box phi) p -> p_is_pos phi p.
Proof.
  intros phi p H.
  destruct H as [H1 H2].
  constructor. rewrite (pv_in_modal_box phi) in H1. auto.
  intros i Hocc Hat.
  apply is_pos_box. apply H2. apply (occ_in_modal_box phi). all : auto.
Qed.

Lemma p_is_pos_dia : forall (phi : Modal) (p : propvar),
    p_is_pos (dia phi) p -> p_is_pos phi p.
Proof.
  intros phi p H.
  destruct H as [H1 H2].
  constructor. rewrite (pv_in_modal_dia phi) in H1. auto.
  intros i Hocc Hat.
  apply is_pos_dia. apply H2. apply (occ_in_modal_dia phi). all : auto.
Qed.

(* ---------------------------------------------------------------------------- *)
(* p_is_neg lemmas *)

Lemma p_is_neg_notin : forall (phi : Modal) (p : propvar),
  p_is_neg phi p -> pv_in_modal phi p.
Proof. intros. firstorder. Qed.

Lemma p_is_neg_atom : forall (p q : propvar),
  p_is_neg (atom q) p -> p = q.
Proof.
  intros p q H. destruct H as [H1 H2].
  apply pv_in_modal_atom. auto.
Qed.

Lemma p_is_neg_mconj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mconj phi1 phi2) p ->
    pv_in_modal phi1 p ->
      p_is_neg phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  constructor. auto.
  inversion Hpos as [H1 H2].
  intros i Hocc2 Hat.
  pose proof (occ_in_modal_mconj_l phi1 phi2 i Hocc2) as Hocc3.
  apply H2 in Hocc3. apply is_neg_mconj_l in Hocc3; auto.
  simpl. rewrite at_pv_app_l. auto.
  apply occ_in_modal_le. auto.
Qed.

Lemma p_is_neg_mconj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mconj phi1 phi2) p ->
    pv_in_modal phi2 p ->
      p_is_neg phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  destruct Hpos as [Hpocct Hpoccf].
  constructor. assumption.
  intros i Hocc Hat.
  assert (i = (i + (length (pv_in phi1)) - (length (pv_in phi1)))) as Heq.
    firstorder.
  rewrite Heq in *.
  apply is_neg_mconj_r. apply Hpoccf.
  apply occ_in_modal_mconj_r2.
  auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pv_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
  lia.
Qed.

Lemma p_is_neg_mdisj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mdisj phi1 phi2) p ->
    pv_in_modal phi1 p ->
    p_is_neg phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  constructor. auto.
  inversion Hpos as [H1 H2].
  intros i Hocc2 Hat.
  pose proof (occ_in_modal_mdisj_l phi1 phi2 i Hocc2) as Hocc3.
  apply H2 in Hocc3. apply is_neg_mdisj_l in Hocc3; auto.
  simpl. rewrite at_pv_app_l. auto.
  apply occ_in_modal_le. auto.
Qed.

Lemma p_is_neg_mdisj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mdisj phi1 phi2) p ->
    pv_in_modal phi2 p ->
    p_is_neg phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  destruct Hpos as [Hpocct Hpoccf].
  constructor. assumption.
  intros i Hocc Hat.
  assert (i = (i + (length (pv_in phi1)) - (length (pv_in phi1)))) as Heq.
    firstorder.
  rewrite Heq in *.
  apply is_neg_mdisj_r. apply Hpoccf.
  apply occ_in_modal_mdisj_r2.
  auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pv_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: lia.
Qed.

Lemma p_is_neg_mimpl2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mimpl phi1 phi2) p ->
    pv_in_modal phi1 p ->
    p_is_pos phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  constructor. auto.
  inversion Hpos as [H1 H2].
  intros i Hocc2 Hat.
  pose proof (occ_in_modal_mimpl_l phi1 phi2 i Hocc2) as Hocc3.
  apply H2 in Hocc3. apply is_neg_pos_mimpl_l in Hocc3; auto.
  simpl. rewrite at_pv_app_l. auto.
  apply occ_in_modal_le. all : auto.
Qed.

Lemma p_is_neg_mimpl2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mimpl phi1 phi2) p ->
    pv_in_modal phi2 p ->
    p_is_neg phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  destruct Hpos as [Hpocct Hpoccf].
  constructor. assumption.
  intros i Hocc Hat.
  assert (i = (i + (length (pv_in phi1)) - (length (pv_in phi1)))) as Heq.
    firstorder.
  rewrite Heq in *.
  apply is_neg_mimpl_r2. apply Hpoccf.
  apply occ_in_modal_mimpl_r2.
  auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pv_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. rewrite PeanoNat.Nat.add_sub in Hocc.
  contradiction (occ_in_modal_0 _ _ Hocc). all: try auto.
Qed.

Lemma p_is_neg_box : forall (phi : Modal) (p : propvar),
  p_is_neg (box phi) p -> p_is_neg phi p.
Proof.
  intros phi p H.
  destruct H as [H1 H2].
  constructor. rewrite (pv_in_modal_box phi) in H1. auto.
  intros i Hocc Hat.
  apply is_neg_box. apply H2. apply (occ_in_modal_box phi). all : auto.
Qed.

Lemma p_is_neg_dia : forall (phi : Modal) (p : propvar),
  p_is_neg (dia phi) p -> p_is_neg phi p.
Proof.
  intros phi p H.
  destruct H as [H1 H2].
  constructor. rewrite (pv_in_modal_dia phi) in H1. auto.
  intros i Hocc Hat.
  apply is_neg_dia. apply H2. apply (occ_in_modal_dia phi). all : auto.
Qed.

(* ---------------------------------------------------------------------------- *)
(* p_is_pos and p_is_neg relationship *)

Lemma p_is_pos_neg : forall (phi : Modal) (p : propvar),
  p_is_pos (mneg phi) p -> p_is_neg phi p.
Proof.
  intros phi p Hpos.
  destruct Hpos as [H1 H2].
  constructor. apply (pv_in_modal_mneg phi) in H1. auto.
  intros i Hocc Hat. apply is_pos_neg_f. auto.
  apply is_pos_mneg. apply H2. apply (occ_in_modal_mneg phi).
  all : auto.
Qed.

Lemma p_is_neg_pos : forall (phi : Modal) (p : propvar),
  p_is_neg (mneg phi) p -> p_is_pos phi p.
Proof.
  intros phi p Hpos.
  destruct Hpos as [H1 H2].
  constructor. apply (pv_in_modal_mneg phi) in H1. auto.
  intros i Hocc Hat. apply is_neg_pos_f. auto.
  apply is_neg_mneg. apply H2. apply (occ_in_modal_mneg phi).
  all : auto.
Qed.


(** Calculation for the lambda calculus + arithmetic using a call
    stack for saving registers before a call. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.
Require Import Coq.Program.Equality.
Module Lambda (Import mem : Memory).

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr.

(** * Semantics *)

(** The evaluator for this language is given as follows (as in the
paper):
<<
type Env = [Value]
data Value =  Num Int | Fun (Value -> Value)

eval ::  Expr -> Env -> Value
eval (Val n) e   = Num n
eval (Add x y) e = case eval x e of
                     Num n -> case eval y e of
                                Num m -> Num (n+m)
eval (Var i) e   = e !! i
eval (Abs x) e   = Fun (\v -> eval x (v:e))
eval (App x y) e = case eval x e of
                     Fun f -> f (eval y e)
>>
After defunctionalisation and translation into relational form we
obtain the semantics below. *)

Inductive Value : Set :=
| Num : nat -> Value
| Clo : Expr -> list Value -> Value.

Definition Env := list Value.

Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> Value -> Prop :=
| eval_val e n : Val n ⇓[e] Num n
| eval_add e x y n n' : x ⇓[e] Num n -> y ⇓[e] Num n' -> Add x y ⇓[e] Num (n + n')
| eval_var e i v : nth e i = Some v -> Var i ⇓[e] v
| eval_abs e x : Abs x ⇓[e] Clo x e
| eval_app e e' x x' x'' y y' : x ⇓[e] Clo x' e' -> y ⇓[e] y' -> x' ⇓[y' :: e'] x'' -> App x y ⇓[e] x''
where "x ⇓[ e ] y" := (eval x e y).

(** * Compiler *)

Inductive Code : Set :=
| HALT : Code
| LOAD : nat -> Code -> Code
| LOOKUP : nat -> Code -> Code
| STORE : Reg -> Code -> Code
| ADD : Reg -> Code -> Code
| STC : Reg -> Code -> Code
| APP : Reg -> Code -> Code
| ABS : Code -> Code -> Code
| RET : Code.

Fixpoint comp (e : Expr) (r : Reg) (c : Code) : Code :=
  match e with
    | Val n   => LOAD n c
    | Var i   => LOOKUP i c
    | Add x y => comp x r (STORE r (comp y (next r) (ADD r c)))
    | App x y => comp x r (STC r (comp y (next r) (APP r c)))
    | Abs x   => ABS (comp x (next first) RET) c
  end.

Definition compile (e : Expr) : Code := comp e first HALT.

(** * Virtual Machine *)

Inductive Value' : Set :=
| Num' : nat -> Value'
| Clo' : Code -> list Value' -> Value'.

Definition Env' := list Value'.

Inductive val : Set :=
| NUM : nat -> val
| CLO : Code -> Env' -> val.

Definition empty := (@empty val).

Definition Lam : Type := list (Mem val).

Inductive Conf : Type :=
| conf : Code -> Value' -> Env' -> Lam -> Mem val -> Conf.

Notation "⟨ c , a , e , s , m ⟩" := (conf c a e s m).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
| vm_load n c m a e s :
    ⟨LOAD n c, a, e, s, m⟩         ==> ⟨c, Num' n, e, s, m⟩
| vm_add c a n r m e s : m[r] = NUM n ->
    ⟨ADD r c, Num' a, e, s, m⟩     ==> ⟨c, Num'(n + a), e, s, m⟩
| vm_store c n r m e s :
    ⟨STORE r c, Num' n, e, s, m⟩   ==> ⟨c, Num' n, e, s, m[r:=NUM n]⟩
| vm_stc c c' e' r m e s :
    ⟨STC r c, Clo' c' e', e, s, m⟩ ==> ⟨c, Clo' c' e', e, s, m[r:=CLO c' e']⟩
| vm_lookup e i c v a m s : nth e i = Some v ->
    ⟨LOOKUP i c, a, e, s, m⟩       ==> ⟨c, v, e, s, m⟩
| vm_ret a c e e' m m' s : m[first] = CLO c e ->
    ⟨RET, a, e', m' :: s, m⟩       ==> ⟨c, a, e, s, m'⟩
| vm_call c c' e e' v r m s : m[r]=CLO c' e' ->
    ⟨APP r c, v, e, s, m⟩          ==> ⟨c', v, v :: e', m :: s, empty[first:=CLO c e]⟩
| vm_fun a c c' m e s :
    ⟨ABS c' c, a, e, s, m⟩         ==> ⟨c, Clo' c' e, e, s, m⟩
where "x ==> y" := (VM x y).

(** Conversion functions from semantics to VM *)

Fixpoint conv (v : Value) : Value' :=
  match v with
    | Num n   => Num' n
    | Clo x e => Clo' (comp x (next first) RET) (map conv e)
  end.

Definition convE : Env -> Env' := map conv.

Inductive stackle : Lam -> Lam -> Prop :=
| stackle_empty : stackle nil nil
| stackle_cons m m' s s' : m ⊑ m' -> stackle s s' -> stackle (m :: s) (m' :: s').

Hint Constructors stackle : memory.

Lemma stackle_refl s : stackle s s.
Proof.
  induction s; constructor; auto with memory.
Qed.

Lemma stackle_trans s1 s2 s3 : stackle s1 s2 -> stackle s2 s3 -> stackle s1 s3.
Proof.
  intros L1. generalize s3. induction L1; intros s3' L2. assumption. inversion L2. subst. constructor;
  eauto with memory.
Qed.

Hint Resolve stackle_refl stackle_trans : core.

Inductive cle : Conf -> Conf -> Prop :=
 | cle_mem  c a e s s' m m' : stackle s s' -> m ⊑ m' -> cle ⟨ c , a , e , s, m ⟩ ⟨ c , a , e , s', m' ⟩.

Hint Constructors cle : core.

Lemma rel_eq {T} {R : T -> T -> Prop} x y y' : R x y' -> y = y' -> R x y.
Proof. intros. subst. auto.
Qed .
Lemma rel_eq' {T} {R : T -> T -> Prop} x x' y : R x' y -> x = x' -> R x y.
Proof. intros. subst. auto.
Qed .

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Machine.
Definition Conf := Conf.
Definition Pre := cle.
Definition Rel := VM.
Lemma monotone : monotonicity cle VM.
  prove_monotonicity1;
    try (match goal with [H : stackle (_ :: _) _ |- _] => inversion H end)
    ; prove_monotonicity2.
Qed.
Lemma preorder : is_preorder cle.
prove_preorder. Qed.
End VM.

Module VMCalc := Calculation mem VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec p v e r c a m s :
  freeFrom r m ->  p ⇓[e] v ->
  ⟨comp p r c, a, convE e, s, m⟩ =|> ⟨c , conv v, convE e, s, m⟩.

(** Setup the induction proof *)

Proof.
  intros F E.
  generalize dependent c.
  generalize dependent a.
  generalize dependent m.
  generalize dependent r.
  generalize dependent s.
  induction E;intros.

(** Calculation of the compiler *)

(** - [Val n ⇓[e] Num n]: *)

  begin
  ⟨c, Num' n , convE e, s, m⟩.
  <== { apply vm_load }
  ⟨LOAD n c, a, convE e, s, m⟩.
  [].

(** - [Add x y ⇓[e] Num (n + n')]: *)

  begin
    ⟨c, Num' (n + n'), convE e, s, m⟩.
  ⊑ {auto}
    ⟨c, Num' (n + n'), convE e, s, m[r:=NUM n]⟩ .
  <== { apply vm_add }
    ⟨ADD r c, Num' n', convE e, s, m[r:=NUM n]⟩ .
  <|= { apply IHE2 }
      ⟨comp y (next r) (ADD r c), Num' n, convE e, s, m[r:=NUM n]⟩ .
  <== { apply vm_store }
      ⟨STORE r (comp y (next r) (ADD r c)), Num' n, convE e, s, m⟩.
  <|= { apply IHE1 }
      ⟨comp x r (STORE r (comp y (next r) (ADD r c))), a, convE e, s, m⟩.
  [].

(** - [Var i ⇓[e] v] *)

  begin
    ⟨c, conv v, convE e , s, m⟩.
  <== {apply vm_lookup; unfold convE; rewrite nth_map; rewr_assumption}
      ⟨LOOKUP i c, a , convE e, s, m ⟩.
   [].

(** - [Abs x ⇓[e] Clo x e] *)

  begin
    ⟨c, Clo' (comp x (next first) RET) (convE e), convE e, s, m ⟩.
  <== { apply vm_fun }
    ⟨ABS (comp x (next first) RET) c, a, convE e, s, m ⟩.
  [].

(** - [App x y ⇓[e] x''] *)

  begin
    ⟨c, conv x'', convE e, s, m ⟩.
  <== { apply vm_ret }
      ⟨RET, conv x'', convE (y' :: e'), m :: s, empty[first:=CLO c (convE e)]⟩.
  <|= {apply  IHE3}
      ⟨comp x' (next first) RET, conv y', convE (y' :: e'), m :: s, empty[first:=CLO c (convE e)]⟩.
  = {auto}
      ⟨comp x' (next first) RET, conv y', conv y' :: convE e', m::s, empty[first:=CLO c (convE e)]⟩.
  ⊑ {auto with memory}
      ⟨comp x' (next first) RET, conv y', conv y' :: convE e', m[r:=CLO (comp x' (next first) RET) (convE e')]::s, empty[first:=CLO c (convE e)]⟩.
  <== {apply vm_call}
      ⟨APP r c, conv y', convE e, s, m[r:=CLO (comp x' (next first) RET) (convE e')]⟩.
  <|= {apply IHE2}
      ⟨comp y (next r) (APP r c), (Clo' (comp x' (next first) RET) (convE e')), convE e, s, m[r:=CLO (comp x' (next first) RET) (convE e')]⟩.
  <== { apply vm_stc }
    ⟨STC r (comp y (next r) (APP r c)), (Clo' (comp x' (next first) RET) (convE e')), convE e, s, m⟩.
  = {auto}
    ⟨STC r (comp y (next r) (APP r c)), conv (Clo x' e'), convE e, s, m ⟩.
  <|= { apply IHE1 }
    ⟨comp x r (STC r (comp y (next r) (APP r c))), a, convE e, s, m ⟩.
  [].
Qed.

(** Specification of the whole compiler *)

Theorem spec' x a (e : Env) s v : x ⇓[e] v ->
                                ⟨compile x, a, convE e, s, empty⟩  =|> ⟨HALT , conv v , convE e, s, empty⟩.
Proof.
  intros E.
  begin
    ⟨HALT , conv v , convE e, s, empty⟩.
  <|= {apply spec; auto using empty_mem_free}
      ⟨comp x first HALT, a, convE e, s, empty⟩.
  [].
Qed.

(** * Soundness *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; congruence.
Qed.

Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r.

Theorem sound p a C : terminates p -> ⟨compile p, a, nil, nil, empty⟩ =>>! C ->
                          exists v m, C = ⟨HALT , conv v, nil, nil, m⟩ /\ p ⇓[nil] v.
Proof.
  unfold terminates. intros T M. destruct T as [v T].
  pose (spec' p a nil nil v T) as H'.
  unfold Reach in *. repeat autodestruct.
  pose (determ_trc determ_vm) as D.
  unfold determ in D. inversion H0.  inversion H7.  subst. exists v. eexists. split. eapply D. apply M. split.
  unfold comp.
  simpl in *. apply H. intro Contra. destruct Contra.
  inversion H1. assumption.
Qed.

End Lambda.


Require Import rt.util.all.
Require Import rt.analysis.parallel.bertogna_edf_theory.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop div path.

Module ResponseTimeIterationEDF.

  Import ResponseTimeAnalysisEDF.

  (* In this section, we define the algorithm for Bertogna and Cirinei's
     response-time analysis for EDF scheduling. *)
  Section Analysis.

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

    (* As input for each iteration of the algorithm, we consider pairs
       of tasks and computed response-time bounds. *)
    Let task_with_response_time := (sporadic_task * time)%type.

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

    (* Consider a platform with num_cpus processors. *)
    Variable num_cpus: nat.

    (* First, recall the interference bound under EDF, ... *)
    Let I (rt_bounds: seq task_with_response_time)
          (tsk: sporadic_task) (delta: time) :=
      total_interference_bound_edf task_cost task_period task_deadline tsk rt_bounds delta.

    (* ..., which yields the following response-time bound. *)
    Definition edf_response_time_bound (rt_bounds: seq task_with_response_time)
                                           (tsk: sporadic_task) (delta: time) :=
      task_cost tsk + div_floor (I rt_bounds tsk delta) num_cpus.

    (* Also note that a response-time is only valid if it is no larger
       than the deadline. *)
    Definition R_le_deadline (pair: task_with_response_time) :=
      let (tsk, R) := pair in
        R <= task_deadline tsk.

    (* Next we define the fixed-point iteration for computing
       Bertogna's response-time bound of a task set. *)

    (* Given a sequence 'rt_bounds' of task and response-time bounds
       from the previous iteration, we compute the response-time
       bound of a single task using the RTA for EDF. *)
    Definition update_bound (rt_bounds: seq task_with_response_time)
                        (pair : task_with_response_time) :=
      let (tsk, R) := pair in
        (tsk, edf_response_time_bound rt_bounds tsk R).

    (* To compute the response-time bounds of the entire task set,
       We start the iteration with a sequence of tasks and costs:
       <(task1, cost1), (task2, cost2), ...>. *)
    Let initial_state (ts: taskset_of sporadic_task) :=
      map (fun t => (t, task_cost t)) ts.

    (* Then, we successively update the the response-time bounds based
       on the slack computed in the previous iteration. *)
    Definition edf_rta_iteration (rt_bounds: seq task_with_response_time) :=
      map (update_bound rt_bounds) rt_bounds.

    (* To ensure that the procedure converges, we run the iteration a
       "sufficient" number of times: task_deadline tsk - task_cost tsk + 1.
       This corresponds to the time complexity of the procedure. *)
    Let max_steps (ts: taskset_of sporadic_task) :=
      \sum_(tsk <- ts) (task_deadline tsk - task_cost tsk) + 1.

    (* This yields the following definition for the RTA. At the end of
       the iteration, we check if all computed response-time bounds
       are less than or equal to the deadline, in which case they are
       valid. *)
    Definition edf_claimed_bounds (ts: taskset_of sporadic_task) :=
      let R_values := iter (max_steps ts) edf_rta_iteration (initial_state ts) in
        if (all R_le_deadline R_values) then
          Some R_values
        else None.

    (* The schedulability test simply checks if we got a list of
       response-time bounds (i.e., if the computation did not fail). *)
    Definition edf_schedulable (ts: taskset_of sporadic_task) :=
      edf_claimed_bounds ts != None.

    (* In the following section, we prove several helper lemmas about the
       list of tasks/response-time bounds. *)
    Section SimpleLemmas.

      (* Updating a single response-time bound does not modify the task. *)
      Lemma edf_claimed_bounds_unzip1_update_bound :
        forall l rt_bounds,
          unzip1 (map (update_bound rt_bounds) l) = unzip1 l.
      Proof.
        induction l; first by done.
        intros rt_bounds.
        simpl; f_equal; last by done.
        by unfold update_bound; desf.
      Qed.

      (* At any point of the iteration, the tasks are the same. *)
      Lemma edf_claimed_bounds_unzip1_iteration :
        forall l k,
          unzip1 (iter k edf_rta_iteration (initial_state l)) = l.
      Proof.
        intros l k; clear -k.
        induction k; simpl.
        {
          unfold initial_state.
          induction l; first by done.
          by simpl; rewrite IHl.
        }
        {
          unfold edf_rta_iteration.
          by rewrite edf_claimed_bounds_unzip1_update_bound.
        }
      Qed.

      (* The iteration preserves the size of the list. *)
      Lemma edf_claimed_bounds_size :
        forall l k,
          size (iter k edf_rta_iteration (initial_state l)) = size l.
      Proof.
        intros l k; clear -k.
        induction k; simpl; first by rewrite size_map.
        by rewrite size_map.
      Qed.

      (* If the analysis succeeds, the computed response-time bounds are no smaller
         than the task cost. *)
      Lemma edf_claimed_bounds_ge_cost :
        forall l k tsk R,
          (tsk, R) \in (iter k edf_rta_iteration (initial_state l)) ->
          R >= task_cost tsk.
      Proof.
        intros l k tsk R IN.
        destruct k.
        {
          move: IN => /mapP IN; destruct IN as [x IN EQ]; inversion EQ.
          by apply leqnn.
        }
        {
          rewrite iterS in IN.
          move: IN => /mapP IN; destruct IN as [x IN EQ].
          unfold update_bound in EQ; destruct x; inversion EQ.
          by unfold edf_response_time_bound; apply leq_addr.
        }
      Qed.

      (* If the analysis suceeds, the computed response-time bounds are no larger
         than the deadline. *)
      Lemma edf_claimed_bounds_le_deadline :
        forall ts rt_bounds tsk R,
          edf_claimed_bounds ts = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          R <= task_deadline tsk.
      Proof.
        intros ts rt_bounds tsk R SOME PAIR; unfold edf_claimed_bounds in SOME.
        destruct (all R_le_deadline (iter (max_steps ts)
                                          edf_rta_iteration (initial_state ts))) eqn:DEADLINE;
          last by done.
        move: DEADLINE => /allP DEADLINE.
        inversion SOME as [EQ]; rewrite -EQ in PAIR.
        by specialize (DEADLINE (tsk, R) PAIR).
      Qed.

      (* The list contains a response-time bound for every task in the task set. *)
      Lemma edf_claimed_bounds_has_R_for_every_task :
        forall ts rt_bounds tsk,
          edf_claimed_bounds ts = Some rt_bounds ->
          tsk \in ts ->
          exists R,
            (tsk, R) \in rt_bounds.
      Proof.
        intros ts rt_bounds tsk SOME IN.
        unfold edf_claimed_bounds in SOME.
        destruct (all R_le_deadline (iter (max_steps ts) edf_rta_iteration (initial_state ts)));
          last by done.
        inversion SOME as [EQ]; clear SOME EQ.
        generalize dependent tsk.
        induction (max_steps ts) as [| step]; simpl in *.
        {
          intros tsk IN; unfold initial_state.
          exists (task_cost tsk).
          by apply/mapP; exists tsk.
        }
        {
          intros tsk IN.
          set prev_state := iter step edf_rta_iteration (initial_state ts).
          fold prev_state in IN, IHstep.
          specialize (IHstep tsk IN); des.
          exists (edf_response_time_bound prev_state tsk R).
          by apply/mapP; exists (tsk, R); [by done | by f_equal].
        }
      Qed.

    End SimpleLemmas.

    (* In this section, we prove the convergence of the RTA procedure.
       Since we define the RTA procedure as the application of a function
       a fixed number of times, this translates into proving that the value
       of the iteration at (max_steps ts) is equal to the value at (max_steps ts) + 1. *)
    Section Convergence.

      (* Consider any valid task set. *)
      Variable ts: taskset_of sporadic_task.
      Hypothesis H_valid_task_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.

      (* To simplify, let f denote the RTA procedure. *)
      Let f (k: nat) := iter k edf_rta_iteration (initial_state ts).

      (* Since the iteration is applied directly to a list of tasks and response-times,
         we define a corresponding relation "<=" over those lists. *)

      (* Let 'all_le' be a binary relation over lists of tasks/response-time bounds.
         It states that every element of list l1 has a response-time bound R that is less
         than or equal to the corresponding response-time bound R' in list l2 (point-wise).
         In addition, the relation states that the tasks of both lists are unchanged. *)
      Let all_le := fun (l1 l2: list task_with_response_time) =>
        (unzip1 l1 == unzip1 l2) &&
        all (fun p => (snd (fst p)) <= (snd (snd p))) (zip l1 l2).

      (* Similarly, we define a strict version of 'all_le' called 'one_lt', which states that
         there exists at least one element whose response-time bound increases. *)
      Let one_lt := fun (l1 l2: list task_with_response_time) =>
        (unzip1 l1 == unzip1 l2) &&
        has (fun p => (snd (fst p)) < (snd (snd p))) (zip l1 l2).

      (* Next, we prove some basic properties about the relation all_le. *)
      Section RelationProperties.

        (* The relation is reflexive, ... *)
        Lemma all_le_reflexive : reflexive all_le.
        Proof.
          intros l; unfold all_le; rewrite eq_refl andTb.
          destruct l; first by done.
          by apply/(zipP t (fun x y => snd x <= snd y)).
        Qed.

        (* ... and transitive. *)
        Lemma all_le_transitive: transitive all_le.
        Proof.
          unfold transitive, all_le.
          move => y x z /andP [/eqP ZIPxy LExy] /andP [/eqP ZIPyz LEyz].
          apply/andP; split; first by rewrite ZIPxy -ZIPyz.
          move: LExy => /(zipP _ (fun x y => snd x <= snd y)) LExy.
          move: LEyz => /(zipP _ (fun x y => snd x <= snd y)) LEyz.
          assert (SIZExy: size (unzip1 x) = size (unzip1 y)).
            by rewrite ZIPxy.
          assert (SIZEyz: size (unzip1 y) = size (unzip1 z)).
            by rewrite ZIPyz.
          rewrite 2!size_map in SIZExy; rewrite 2!size_map in SIZEyz.
          destruct y.
          {
            apply size0nil in SIZExy; symmetry in SIZEyz.
            by apply size0nil in SIZEyz; subst.
          }
          apply/(zipP t (fun x y => snd x <= snd y));
            first by rewrite SIZExy -SIZEyz.
          intros i LTi.
          exploit LExy; first by rewrite SIZExy.
          {
            rewrite size_zip -SIZEyz -SIZExy minnn in LTi.
            by rewrite size_zip -SIZExy minnn; apply LTi.
          }
          instantiate (1 := t); intro LE.
          exploit LEyz; first by apply SIZEyz.
          {
            rewrite size_zip SIZExy SIZEyz minnn in LTi.
            by rewrite size_zip SIZEyz minnn; apply LTi.
          }
          by instantiate (1 := t); intro LE'; apply (leq_trans LE).
        Qed.

        (* At any step of the iteration, the corresponding list
           is larger than or equal to the initial state. *)
        Lemma bertogna_edf_comp_iteration_preserves_minimum :
          forall step, all_le (initial_state ts) (f step).
        Proof.
          unfold f.
          intros step; destruct step; first by apply all_le_reflexive.
          apply/andP; split.
          {
            assert (UNZIP0 := edf_claimed_bounds_unzip1_iteration ts 0).
            by simpl in UNZIP0; rewrite UNZIP0 edf_claimed_bounds_unzip1_iteration.
          }
          destruct ts as [| tsk0 ts'].
          {
            clear -step; induction step; first by done.
            by rewrite iterSr IHstep.
          }

          apply/(zipP (tsk0,0) (fun x y => snd x <= snd y));
            first by rewrite edf_claimed_bounds_size size_map.

          intros i LTi; rewrite iterS; unfold edf_rta_iteration at 1.
          have MAP := @nth_map _ (tsk0,0) _ (tsk0,0).
          rewrite size_zip edf_claimed_bounds_size size_map minnn in LTi.
          rewrite MAP; clear MAP; last by rewrite edf_claimed_bounds_size.
          destruct (nth (tsk0, 0) (initial_state (tsk0 :: ts')) i) as [tsk_i R_i] eqn:SUBST.
          rewrite SUBST; unfold update_bound.
          unfold initial_state in SUBST.
          have MAP := @nth_map _ tsk0 _ (tsk0, 0).
          rewrite ?MAP // in SUBST; inversion SUBST; clear MAP.
          assert (EQtsk: tsk_i = fst (nth (tsk0, 0) (iter step edf_rta_iteration
                                                         (initial_state (tsk0 :: ts'))) i)).
          {
            have MAP := @nth_map _ (tsk0,0) _ tsk0 (fun x => fst x).
            rewrite -MAP; clear MAP; last by rewrite edf_claimed_bounds_size.
            have UNZIP := edf_claimed_bounds_unzip1_iteration; unfold unzip1 in UNZIP.
            by rewrite UNZIP; symmetry.
          }
          destruct (nth (tsk0, 0) (iter step edf_rta_iteration (initial_state (tsk0 :: ts')))) as [tsk_i' R_i'].
          by simpl in EQtsk; rewrite -EQtsk; subst; apply leq_addr.
        Qed.

        (* The application of the function is inductive. *)
        Lemma bertogna_edf_comp_iteration_inductive (P : seq task_with_response_time -> Type) :
          P (initial_state ts) ->
          (forall k, P (f k) -> P (f (k.+1))) ->
          P (f (max_steps ts)).
        Proof.
          by intros P0 Pn; induction (max_steps ts); last by apply Pn.
        Qed.

        (* As a last step, we show that edf_rta_iteration preserves order, i.e., for any
           list l1 no smaller than the initial state, and list l2 such that
           l1 <= l2, we have (edf_rta_iteration l1) <= (edf_rta_iteration l2). *)
        Lemma bertogna_edf_comp_iteration_preserves_order :
          forall l1 l2,
            all_le (initial_state ts) l1 ->
            all_le l1 l2 ->
            all_le (edf_rta_iteration l1) (edf_rta_iteration l2).
        Proof.
          rename H_valid_task_parameters into VALID.
          intros x1 x2 LEinit LE.
          move: LE => /andP [/eqP ZIP LE]; unfold all_le.

          assert (UNZIP': unzip1 (edf_rta_iteration x1) = unzip1 (edf_rta_iteration x2)).
          {
            by rewrite 2!edf_claimed_bounds_unzip1_update_bound.
          }

          apply/andP; split; first by rewrite UNZIP'.
          apply f_equal with (B := nat) (f := fun x => size x) in UNZIP'.
          rename UNZIP' into SIZE.
          rewrite size_map [size (unzip1 _)]size_map in SIZE.
          move: LE => /(zipP _ (fun x y => snd x <= snd y)) LE.
          destruct x1 as [| p0 x1'], x2 as [| p0' x2']; try (by ins).
          apply/(zipP p0 (fun x y => snd x <= snd y)); first by done.

          intros i LTi.
          exploit LE; first by rewrite 2!size_map in SIZE.
          {
            by rewrite size_zip 2!size_map -size_zip in LTi; apply LTi.
          }
          rewrite 2!size_map in SIZE.
          instantiate (1 := p0); intro LEi.
          rewrite (nth_map p0);
            last by rewrite size_zip 2!size_map -SIZE minnn in LTi.
          rewrite (nth_map p0);
            last by rewrite size_zip 2!size_map SIZE minnn in LTi.
          unfold update_bound, edf_response_time_bound; desf; simpl.
          rename s into tsk_i, s0 into tsk_i', t into R_i, t0 into R_i', Heq into EQ, Heq0 into EQ'.
          assert (EQtsk: tsk_i = tsk_i').
          {
            destruct p0 as [tsk0 R0], p0' as [tsk0' R0']; simpl in H2; subst.
            have MAP := @nth_map _ (tsk0',R0) _ tsk0' (fun x => fst x) i ((tsk0', R0) :: x1').
            have MAP' := @nth_map _ (tsk0',R0) _ tsk0' (fun x => fst x) i ((tsk0', R0') :: x2').
            assert (FSTeq: fst (nth (tsk0', R0)((tsk0', R0) :: x1') i) =
                           fst (nth (tsk0',R0) ((tsk0', R0') :: x2') i)).
            {
              rewrite -MAP;
                last by simpl; rewrite size_zip 2!size_map /= -H0 minnn in LTi.
              rewrite -MAP';
                last by simpl; rewrite size_zip 2!size_map /= H0 minnn in LTi.
              by f_equal; simpl; f_equal.
            }
            apply f_equal with (B := sporadic_task) (f := fun x => fst x) in EQ.
            apply f_equal with (B := sporadic_task) (f := fun x => fst x) in EQ'.
            by rewrite FSTeq EQ' /= in EQ; rewrite EQ.
          }
          subst tsk_i'; rewrite leq_add2l.
          unfold I, total_interference_bound_edf; apply leq_div2r.
          rewrite 2!big_cons.
          destruct p0 as [tsk0 R0], p0' as [tsk0' R0'].
          simpl in H2; subst tsk0'.
          rename R_i into delta, R_i' into delta'.
          rewrite EQ EQ' in LEi; simpl in LEi.
          rename H0 into SIZE, H1 into UNZIP; clear EQ EQ'.

          assert (SUBST: forall l delta,
                    \sum_(j <- l | let '(tsk_other, _) := j in
                      jldp_can_interfere_with tsk_i tsk_other)
                        (let '(tsk_other, R_other) := j in
                          interference_bound_edf task_cost task_period task_deadline tsk_i delta
                            (tsk_other, R_other)) =
                    \sum_(j <- l | jldp_can_interfere_with tsk_i (fst j))
                      interference_bound_edf task_cost task_period task_deadline tsk_i delta j).
          {
            intros l x; clear -l.
            induction l; first by rewrite 2!big_nil.
            by rewrite 2!big_cons; rewrite IHl; desf; rewrite /= Heq in Heq0.
          } rewrite 2!SUBST; clear SUBST.

          assert (VALID': valid_sporadic_taskset task_cost task_period task_deadline
                                                       (unzip1 ((tsk0, R0) :: x1'))).
          {
            move: LEinit => /andP [/eqP EQinit _].
            rewrite -EQinit; unfold valid_sporadic_taskset.
            move => tsk /mapP IN. destruct IN as [p INinit EQ]; subst.
            by move: INinit => /mapP INinit; destruct INinit as [tsk INtsk]; subst; apply VALID.
          }

          assert (GE_COST: all (fun p => task_cost (fst p) <= snd p) ((tsk0, R0) :: x1')).
          {
            clear LE; move: LEinit => /andP [/eqP UNZIP' LE].
            move: LE => /(zipP _ (fun x y => snd x <= snd y)) LE.
            specialize (LE (tsk0, R0)).
            apply/(all_nthP (tsk0,R0)).
            intros j LTj; generalize UNZIP'; simpl; intro SIZE'.
            have F := @f_equal _ _ size (unzip1 (initial_state ts)).
            apply F in SIZE'; clear F; rewrite /= 3!size_map in SIZE'.
            exploit LE; [by rewrite size_map /= | |].
            {
              rewrite size_zip size_map /= SIZE' minnn.
              by simpl in LTj; apply LTj.
            }
            clear LE; intro LE.
            unfold initial_state in LE.
            have MAP := @nth_map _ tsk0 _ (tsk0,R0).
            rewrite MAP /= in LE;
              [clear MAP | by rewrite SIZE'; simpl in LTj].
            apply leq_trans with (n := task_cost (nth tsk0 ts j));
              [apply eq_leq; f_equal | by done].
            have MAP := @nth_map _ (tsk0, R0) _ tsk0 (fun x => fst x).
            rewrite -MAP; [clear MAP | by done].
            unfold unzip1 in UNZIP'; rewrite -UNZIP'; f_equal.
            clear -ts; induction ts; [by done | by simpl; f_equal].
          }
          move: GE_COST => /allP GE_COST.

          assert (LESUM: \sum_(j <- x1' | jldp_can_interfere_with tsk_i (fst j))
                        interference_bound_edf task_cost task_period task_deadline tsk_i delta j <=                                  \sum_(j <- x2' | jldp_can_interfere_with tsk_i (fst j))
                        interference_bound_edf task_cost task_period task_deadline tsk_i delta' j).
          {
            set elem := (tsk0, R0); rewrite 2!(big_nth elem).
            rewrite -SIZE.
            rewrite big_mkcond [\sum_(_ <- _ | jldp_can_interfere_with _ _)_]big_mkcond.
            rewrite big_seq_cond [\sum_(_ <- _ | true) _]big_seq_cond.
            apply leq_sum; intros j; rewrite andbT; intros INj.
            rewrite mem_iota add0n subn0 in INj; move: INj => /andP [_ INj].
            assert (FSTeq: fst (nth elem x1' j) = fst (nth elem x2' j)).
            {
              have MAP := @nth_map _ elem _ tsk0 (fun x => fst x).
              by rewrite -2?MAP -?SIZE //; f_equal.
            } rewrite -FSTeq.
            destruct (jldp_can_interfere_with tsk_i (fst (nth elem x1' j))) eqn:INTERF;
              last by done.
            {
              exploit (LE elem); [by rewrite /= SIZE | | intro LEj].
              {
                rewrite size_zip 2!size_map /= -SIZE minnn in LTi.
                by rewrite size_zip /= -SIZE minnn; apply (leq_ltn_trans INj).
              }
              simpl in LEj.
              exploit (VALID' (fst (nth elem x1' j))); last intro VALIDj.
              {
                apply/mapP; exists (nth elem x1' j); last by done.
                by rewrite in_cons; apply/orP; right; rewrite mem_nth.
              }
              exploit (GE_COST (nth elem x1' j)); last intro GE_COSTj.
              {
                by rewrite in_cons; apply/orP; right; rewrite mem_nth.
              }
              unfold is_valid_sporadic_task in *.
              destruct (nth elem x1' j) as [tsk_j R_j] eqn:SUBST1,
                       (nth elem x2' j) as [tsk_j' R_j'] eqn:SUBST2.
              rewrite SUBST1 SUBST2 in LEj.
              simpl in FSTeq; rewrite -FSTeq; simpl in LEj; simpl in VALIDj; des.
              by apply interference_bound_edf_monotonic.
            }
          }
          destruct (jldp_can_interfere_with tsk_i tsk0) eqn:INTERFtsk0; last by done.
          apply leq_add; last by done.
          {
            exploit (LE (tsk0, R0)); [by rewrite /= SIZE | | intro LEj];
              first by instantiate (1 := 0); rewrite size_zip /= -SIZE minnn.
            exploit (VALID' tsk0); first by rewrite in_cons; apply/orP; left.
            exploit (GE_COST (tsk0, R0)); first by rewrite in_cons eq_refl orTb.
            unfold is_valid_sporadic_task; intros GE_COST0 VALID0; des; simpl in LEj.
            by apply interference_bound_edf_monotonic.
          }
        Qed.

        (* It follows from the properties above that the iteration is monotonically increasing. *)
        Lemma bertogna_edf_comp_iteration_monotonic: forall k, all_le (f k) (f k.+1).
        Proof.
          unfold f; intros k.
          apply fun_mon_iter_mon_generic with (x1 := k) (x2 := k.+1);
            try (by done);
            [ by apply all_le_reflexive
            | by apply all_le_transitive
            | by apply bertogna_edf_comp_iteration_preserves_order
            | by apply bertogna_edf_comp_iteration_preserves_minimum].
        Qed.

      End RelationProperties.

      (* Knowing that the iteration is monotonically increasing (with respect to all_le),
         we show that the RTA procedure converges to a fixed point. *)

      (* First, note that when there are no tasks, the iteration trivially converges. *)
      Lemma bertogna_edf_comp_f_converges_with_no_tasks :
        size ts = 0 ->
        f (max_steps ts) = f (max_steps ts).+1.
      Proof.
        intro SIZE; destruct ts; last by inversion SIZE.
        unfold max_steps; rewrite big_nil /=.
        by unfold edf_rta_iteration.
      Qed.

      (* Otherwise, if the iteration reached a fixed point before (max_steps ts), then
         the value at (max_steps ts) is still at a fixed point. *)
      Lemma bertogna_edf_comp_f_converges_early :
        (exists k, k <= max_steps ts /\ f k = f k.+1) ->
        f (max_steps ts) = f (max_steps ts).+1.
      Proof.
        by intros EX; des; apply iter_fix with (k := k).
      Qed.

      (* Else, we derive a contradiction. *)
      Section DerivingContradiction.

        (* Assume that there are tasks. *)
        Hypothesis H_at_least_one_task: size ts > 0.

        (* Assume that the iteration continued to diverge. *)
        Hypothesis H_keeps_diverging:
          forall k,
            k <= max_steps ts -> f k != f k.+1.

        (* Since the iteration is monotonically increasing, it must be
           strictly increasing. *)
        Lemma bertogna_edf_comp_f_increases :
          forall k,
            k <= max_steps ts -> one_lt (f k) (f k.+1).
        Proof.
          rename H_at_least_one_task into NONEMPTY.
          intros step LEstep; unfold one_lt; apply/andP; split;
            first by rewrite 2!edf_claimed_bounds_unzip1_iteration.
          rewrite -[has _ _]negbK; apply/negP; unfold not; intro ALL.
          rewrite -all_predC in ALL.
          move: ALL => /allP ALL.
          exploit (H_keeps_diverging step); [by done | intro DIFF].
          assert (DUMMY: exists tsk: sporadic_task, True).
          {
            destruct ts as [|tsk0]; first by rewrite ltnn in NONEMPTY.
            by exists tsk0.
          }
          des; clear DUMMY.
          move: DIFF => /eqP DIFF; apply DIFF.
          apply eq_from_nth with (x0 := (tsk, 0));
            first by simpl; rewrite size_map.
          {
            intros i LTi.
            remember (nth (tsk, 0)(f step) i) as p_i;rewrite -Heqp_i.
            remember (nth (tsk, 0)(f step.+1) i) as p_i';rewrite -Heqp_i'.
            rename Heqp_i into EQ, Heqp_i' into EQ'.
            exploit (ALL (p_i, p_i')).
            {
              rewrite EQ EQ'.
              rewrite -nth_zip; last by unfold f; rewrite iterS size_map.
              apply mem_nth; rewrite size_zip.
              unfold f; rewrite iterS size_map.
              by rewrite minnn.
            }
            unfold predC; simpl; rewrite -ltnNge; intro LTp.

            have GROWS := bertogna_edf_comp_iteration_monotonic step.
            move: GROWS => /andP [_ /allP GROWS].
            exploit (GROWS (p_i, p_i')).
            {
              rewrite EQ EQ'.
              rewrite -nth_zip; last by unfold f; rewrite iterS size_map.
              apply mem_nth; rewrite size_zip.
              unfold f; rewrite iterS size_map.
              by rewrite minnn.
            }
            simpl; intros LE.
            destruct p_i as [tsk_i R_i], p_i' as [tsk_i' R_i'].
            simpl in *.
            assert (EQtsk: tsk_i = tsk_i').
            {
              unfold edf_rta_iteration in EQ'.
              rewrite (nth_map (tsk, 0)) in EQ'; last by done.
              by unfold update_bound in EQ'; desf.
            }
            rewrite EQtsk; f_equal.
            by apply/eqP; rewrite eqn_leq; apply/andP; split.
          }
        Qed.

        (* In the end, each response-time bound is so high that the sum
           of all response-time bounds exceeds the sum of all deadlines.
           Contradiction! *)
        Lemma bertogna_edf_comp_rt_grows_too_much :
          forall k,
            k <= max_steps ts ->
            \sum_((tsk, R) <- f k) (R - task_cost tsk) + 1 > k.
        Proof.
          have LT := bertogna_edf_comp_f_increases.
          have MONO := bertogna_edf_comp_iteration_monotonic.
          rename H_at_least_one_task into NONEMPTY.
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
          rename H_valid_task_parameters into VALID.
          intros step LE.
          assert (DUMMY: exists tsk: sporadic_task, True).
          {
            destruct ts as [|tsk0]; first by rewrite ltnn in NONEMPTY.
            by exists tsk0.
          } destruct DUMMY as [elem _].

          induction step; first by rewrite addn1.
          {
            rewrite -addn1 ltn_add2r.
            apply leq_ltn_trans with (n := \sum_(i <- f step) (let '(tsk, R) := i in R - task_cost tsk)).
            {
              rewrite -ltnS; rewrite addn1 in IHstep.
              by apply IHstep, ltnW.
            }
            rewrite (eq_bigr (fun x => snd x - task_cost (fst x)));
              last by ins; destruct i.
            rewrite [\sum_(_ <- f step.+1)_](eq_bigr (fun x => snd x - task_cost (fst x)));
              last by ins; destruct i.
            unfold f at 2; rewrite iterS.
            rewrite big_map; fold (f step).
            rewrite -(ltn_add2r (\sum_(i <- f step) task_cost (fst i))).
            rewrite -2!big_split /=.
            rewrite big_seq_cond [\sum_(_ <- _ | true)_]big_seq_cond.
            rewrite (eq_bigr (fun i => snd i)); last first.
            {
              intro i; rewrite andbT; intro IN;
              rewrite subh1; first by rewrite -addnBA // subnn addn0.
              have GE_COST := edf_claimed_bounds_ge_cost ts step.
              by destruct i; apply GE_COST.
            }
            rewrite [\sum_(_ <- _ | _)(_ - _ + _)](eq_bigr (fun i => snd (update_bound (f step) i))); last first.
            {
              intro i; rewrite andbT; intro IN.
              unfold update_bound; destruct i; simpl.
              rewrite subh1; first by rewrite -addnBA // subnn addn0.
              apply (edf_claimed_bounds_ge_cost ts step.+1).
              by rewrite iterS; apply/mapP; exists (s, t).
            }
            rewrite -2!big_seq_cond.

            specialize (LT step (ltnW LE)).
            specialize (MONO step).
            move: LT => /andP [_ LT]; move: LT => /hasP LT.
            destruct LT as [[x1 x2] INzip LT]; simpl in *.
            move: MONO => /andP [_ /(zipP _ (fun x y => snd x <= snd y)) MONO].
            rewrite 2!(big_nth (elem, 0)).
            apply mem_zip_exists with (elem := (elem, 0)) (elem' := (elem, 0)) in INzip; des;
              last by rewrite size_map.
            rewrite -> big_cat_nat with (m := 0) (n := idx) (p := size (f step));
              [simpl | by done | by apply ltnW].
            rewrite -> big_cat_nat with (m := idx) (n := idx.+1) (p := size (f step));
              [simpl | by done | by done].
            rewrite big_nat_recr /=; last by done.
            rewrite -> big_cat_nat with (m := 0) (n := idx) (p := size (f step));
              [simpl | by done | by apply ltnW].
            rewrite -> big_cat_nat with (m := idx) (n := idx.+1) (p := size (f step));
              [simpl | by done | by done].
            rewrite big_nat_recr /=; last by done.
            rewrite [\sum_(idx <= i < idx) _]big_geq // add0n.
            rewrite [\sum_(idx <= i < idx) _]big_geq // add0n.
            rewrite -addn1 -addnA; apply leq_add.
            {
              rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
              apply leq_sum; move => i /andP [/andP [LT1 LT2] _].
              exploit (MONO (elem,0)); [by rewrite size_map | | intro LEi].
              {
                rewrite size_zip; apply (ltn_trans LT2).
                by apply leq_trans with (n := size (f step));
                  [by done | by rewrite size_map minnn].
              }
              unfold edf_rta_iteration in LEi.
              by rewrite -> nth_map with (x1 := (elem, 0)) in LEi;
                last by apply (ltn_trans LT2).
            }
            rewrite -addnA [_ + 1]addnC addnA; apply leq_add.
            {
              unfold edf_rta_iteration in INzip2; rewrite addn1.
              rewrite -> nth_map with (x1 := (elem, 0)) in INzip2; last by done.
              by rewrite -INzip2 -INzip1.
            }
            {
              rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
              apply leq_sum; move => i /andP [/andP [LT1 LT2] _].
              exploit (MONO (elem,0));
                [ by rewrite size_map
                | by rewrite size_zip; apply (leq_trans LT2); rewrite size_map minnn | intro LEi ].
              unfold edf_rta_iteration in LEi.
              by rewrite -> nth_map with (x1 := (elem, 0)) in LEi; last by done.
            }
          }
        Qed.

      End DerivingContradiction.

      (* Using the lemmas above, we prove that edf_rta_iteration reaches
         a fixed point after (max_steps ts) step, ... *)
      Lemma edf_claimed_bounds_finds_fixed_point_of_list :
        forall rt_bounds,
          edf_claimed_bounds ts = Some rt_bounds ->
          valid_sporadic_taskset task_cost task_period task_deadline ts ->
          f (max_steps ts) = edf_rta_iteration (f (max_steps ts)).
      Proof.
        intros rt_bounds SOME VALID.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
        unfold edf_claimed_bounds in SOME; desf.
        rename Heq into LE.
        fold (f (max_steps ts)) in *; fold (f (max_steps ts).+1).

        (* Either the task set is empty or not. *)
        destruct (size ts == 0) eqn:EMPTY;
          first by apply bertogna_edf_comp_f_converges_with_no_tasks; apply/eqP.
        apply negbT in EMPTY; rewrite -lt0n in EMPTY.

        (* Either f converges by the deadline or not. *)
        destruct ([exists k in 'I_((max_steps ts).+1), f k == f k.+1]) eqn:EX.
        {
          move: EX => /exists_inP EX; destruct EX as [k _ ITERk].
          destruct k as [k LTk]; simpl in ITERk.
          apply bertogna_edf_comp_f_converges_early.
          exists k; split; [by apply LTk | by apply/eqP].
        }

        (* If not, then we reach a contradiction *)
        apply negbT in EX; rewrite negb_exists_in in EX.
        move: EX => /forall_inP EX.

        assert (SAMESUM: \sum_(tsk <- ts) task_cost tsk = \sum_(p <- f (max_steps ts)) task_cost (fst p)).
        {
          have MAP := @big_map _ 0 addn _ _ (fun x => fst x) (f (max_steps ts))
                               (fun x => true) (fun x => task_cost x).
          have UNZIP := edf_claimed_bounds_unzip1_iteration ts (max_steps ts).
          fold (f (max_steps ts)) in UNZIP; unfold unzip1 in UNZIP.
          by rewrite UNZIP in MAP; rewrite MAP.
        }

        (* Show that the sum is less than the sum of all deadlines. *)
        assert (SUM: \sum_(p <- f (max_steps ts)) (snd p - task_cost (fst p)) + 1 <= max_steps ts).
        {
          unfold max_steps at 2; rewrite leq_add2r.
          rewrite -(leq_add2r (\sum_(tsk <- ts) task_cost tsk)).
          rewrite {1}SAMESUM -2!big_split /=.
          rewrite big_seq_cond [\sum_(_ <- _ | true)_]big_seq_cond.
          rewrite (eq_bigr (fun x => snd x)); last first.
          {
            intro i; rewrite andbT; intro IN.
            rewrite subh1; first by rewrite -addnBA // subnn addn0.
            have GE_COST := edf_claimed_bounds_ge_cost ts (max_steps ts).
            fold (f (max_steps ts)) in GE_COST.
            by destruct i; apply GE_COST.
          }
          rewrite (eq_bigr (fun x => task_deadline x)); last first.
          {
            intro i; rewrite andbT; intro IN.
            rewrite subh1; first by rewrite -addnBA // subnn addn0.
            by specialize (VALID i IN); des.
          }
          rewrite -2!big_seq_cond.
          have MAP := @big_map _ 0 addn _ _ (fun x => fst x) (f (max_steps ts))
                               (fun x => true) (fun x => task_deadline x).
          have UNZIP := edf_claimed_bounds_unzip1_iteration ts (max_steps ts).
          fold (f (max_steps ts)) in UNZIP; unfold unzip1 in UNZIP.
          rewrite UNZIP in MAP; rewrite MAP.
          rewrite big_seq_cond [\sum_(_ <- _|true)_]big_seq_cond.
          apply leq_sum; intro i; rewrite andbT; intro IN.
          move: LE => /allP LE; unfold R_le_deadline in LE.
          by specialize (LE i IN); destruct i.
        }

        have TOOMUCH :=
          bertogna_edf_comp_rt_grows_too_much EMPTY _ (max_steps ts) (leqnn (max_steps ts)).
        exploit TOOMUCH; [| intro BUG].
        {
          intros k LEk; rewrite -ltnS in LEk.
          by exploit (EX (Ordinal LEk)); [by done | by ins].
        }
        rewrite (eq_bigr (fun i => snd i - task_cost (fst i))) in BUG;
          last by ins; destruct i.
        by apply (leq_ltn_trans SUM) in BUG; rewrite ltnn in BUG.
      Qed.

      (* ...and since there cannot be a vector of response-time bounds with values less than
         the task costs, this solution is also the least fixed point. *)
      Lemma edf_claimed_bounds_finds_least_fixed_point :
        forall v,
          all_le (initial_state ts) v ->
          v = edf_rta_iteration v ->
          all_le (f (max_steps ts)) v.
      Proof.
        intros v GE0 EQ.
        apply bertogna_edf_comp_iteration_inductive; first by done.
        intros k GEk.
        rewrite EQ.
        apply bertogna_edf_comp_iteration_preserves_order; last by done.
        by apply bertogna_edf_comp_iteration_preserves_minimum.
      Qed.

      (* Therefore, with regard to the response-time bound recurrence, ...*)
      Let rt_recurrence (tsk: sporadic_task) (rt_bounds: seq task_with_response_time) (R: time) :=
        task_cost tsk + div_floor (I rt_bounds tsk R) num_cpus.

      (* ..., the individual response-time bounds (elements of the list) are also fixed points. *)
      Theorem edf_claimed_bounds_finds_fixed_point_for_each_bound :
        forall tsk R rt_bounds,
          edf_claimed_bounds ts = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          R = rt_recurrence tsk rt_bounds R.
      Proof.
        intros tsk R rt_bounds SOME IN.
        have CONV := edf_claimed_bounds_finds_fixed_point_of_list rt_bounds.
        rewrite -iterS in CONV; fold (f (max_steps ts).+1) in CONV.
        unfold edf_claimed_bounds in *; desf.
        exploit (CONV); [by done | by done | intro ITER; clear CONV].
        unfold f in ITER.

        cut (update_bound (iter (max_steps ts)
               edf_rta_iteration (initial_state ts)) (tsk,R) = (tsk, R)).
        {
          intros EQ.
          have F := @f_equal _ _ (fun x => snd x) _ (tsk, R).
          by apply F in EQ; simpl in EQ.
        }
        set s := iter (max_steps ts) edf_rta_iteration (initial_state ts).
        fold s in ITER, IN.
        move: IN => /(nthP (tsk,0)) IN; destruct IN as [i LT EQ].
        generalize EQ; rewrite ITER iterS in EQ; intro EQ'.
        fold s in EQ.
        unfold edf_rta_iteration in EQ.
        have MAP := @nth_map _ (tsk,0) _ _ (update_bound s).
        by rewrite MAP // EQ' in EQ; rewrite EQ.
      Qed.

    End Convergence.

    Section MainProof.

      (* Consider a task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume the task set has no duplicates, ... *)
      Hypothesis H_ts_is_a_set: uniq ts.

      (* ...all tasks have valid parameters, ... *)
      Hypothesis H_valid_task_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.

      (* ...constrained deadlines, ...*)
      Hypothesis H_constrained_deadlines:
        forall tsk, tsk \in ts -> task_deadline tsk <= task_period tsk.

      (* Next, consider any arrival sequence such that...*)
      Context {arr_seq: arrival_sequence Job}.

     (* ...all jobs come from task set ts, ...*)
      Hypothesis H_all_jobs_from_taskset:
        forall (j: JobIn arr_seq), job_task j \in ts.

      (* ...they have valid parameters,...*)
      Hypothesis H_valid_job_parameters:
        forall (j: JobIn arr_seq),
          valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

      (* ... and satisfy the sporadic task model.*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period arr_seq job_task.

      (* Then, consider any platform with at least one CPU such that...*)
      Variable sched: schedule num_cpus arr_seq.
      Hypothesis H_at_least_one_cpu :
        num_cpus > 0.

      (* ...jobs only execute after they arrived and no longer
         than their execution costs,... *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute sched.
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Assume a work-conserving scheduler with EDF policy. *)
      Hypothesis H_work_conserving: work_conserving job_cost sched.
      Hypothesis H_edf_policy: enforces_JLDP_policy job_cost sched (EDF job_deadline).

      Definition no_deadline_missed_by_task (tsk: sporadic_task) :=
        task_misses_no_deadline job_cost job_deadline job_task sched tsk.
      Definition no_deadline_missed_by_job :=
        job_misses_no_deadline job_cost job_deadline sched.
      Let response_time_bounded_by (tsk: sporadic_task) :=
        is_response_time_bound_of_task job_cost job_task tsk sched.

      (* In the following theorem, we prove that any response-time bound contained
         in edf_claimed_bounds is safe. The proof follows by direct application of
         the main Theorem from bertogna_edf_theory.v. *)
      Theorem edf_analysis_yields_response_time_bounds :
        forall tsk R,
          (tsk, R) \In edf_claimed_bounds ts ->
          response_time_bounded_by tsk R.
      Proof.
        intros tsk R IN j JOBj.
        destruct (edf_claimed_bounds ts) as [rt_bounds |] eqn:SOME; last by done.
        unfold edf_rta_iteration in *.
        have BOUND := bertogna_cirinei_response_time_bound_edf.
        unfold is_response_time_bound_of_task in *.
        apply BOUND with (task_cost := task_cost) (task_period := task_period)
           (task_deadline := task_deadline) (job_deadline := job_deadline)
           (job_task := job_task) (ts := ts) (tsk := tsk) (rt_bounds := rt_bounds); try (by ins).
          by unfold edf_claimed_bounds in SOME; desf; rewrite edf_claimed_bounds_unzip1_iteration.
          by ins; apply edf_claimed_bounds_finds_fixed_point_for_each_bound with (ts := ts).
          by ins; rewrite (edf_claimed_bounds_le_deadline ts rt_bounds).
      Qed.

      (* Therefore, if the schedulability test suceeds, ...*)
      Hypothesis H_test_succeeds: edf_schedulable ts.

      (*... no task misses its deadline. *)
      Theorem taskset_schedulable_by_edf_rta :
        forall tsk, tsk \in ts -> no_deadline_missed_by_task tsk.
      Proof.
        have RLIST := (edf_analysis_yields_response_time_bounds).
        have DL := (edf_claimed_bounds_le_deadline ts).
        have HAS := (edf_claimed_bounds_has_R_for_every_task ts).
        unfold no_deadline_missed_by_task, task_misses_no_deadline,
               job_misses_no_deadline, completed,
               edf_schedulable,
               valid_sporadic_job in *.
        rename H_valid_job_parameters into JOBPARAMS,
               H_valid_task_parameters into TASKPARAMS,
               H_constrained_deadlines into RESTR,
               H_completed_jobs_dont_execute into COMP,
               H_jobs_must_arrive_to_execute into MUSTARRIVE,
               H_all_jobs_from_taskset into ALLJOBS,
               H_test_succeeds into TEST.

        move => tsk INtsk j JOBtsk.
        destruct (edf_claimed_bounds ts) as [rt_bounds |] eqn:SOME; last by ins.
        exploit (HAS rt_bounds tsk); [by ins | by ins | clear HAS; intro HAS; des].
        have COMPLETED := RLIST tsk R HAS j JOBtsk.
        exploit (DL rt_bounds tsk R);
          [by ins | by ins | clear DL; intro DL].

        rewrite eqn_leq; apply/andP; split; first by apply cumulative_service_le_job_cost.
        apply leq_trans with (n := service sched j (job_arrival j + R)); last first.
        {
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
          apply extend_sum; rewrite // leq_add2l.
          specialize (JOBPARAMS j); des; rewrite JOBPARAMS1.
          by rewrite JOBtsk.
        }
        rewrite leq_eqVlt; apply/orP; left; rewrite eq_sym.
        by apply COMPLETED.
      Qed.

      (* For completeness, since all jobs of the arrival sequence
         are spawned by the task set, we conclude that no job misses
         its deadline. *)
      Theorem jobs_schedulable_by_edf_rta :
        forall (j: JobIn arr_seq), no_deadline_missed_by_job j.
      Proof.
        intros j.
        have SCHED := taskset_schedulable_by_edf_rta.
        unfold no_deadline_missed_by_task, task_misses_no_deadline in *.
        apply SCHED with (tsk := job_task j); last by done.
        by apply H_all_jobs_from_taskset.
      Qed.

    End MainProof.

  End Analysis.

End ResponseTimeIterationEDF.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Equivalences *)

Require Import Overture PathGroupoids.
Local Open Scope path_scope.

Generalizable Variables A B C f g h.

Definition moveR_equiv_pM `{Funext} `{IsEquiv A B g} `(f:B -> C) `(h:A -> C)
  : f o g = h -> f = h o g^-1
  := fun p => (path_forall _ _ (fun x => ap f (eisretr g x)))^
              @ (ap (fun u => u o g^-1) p).

Definition moveR_equiv_pV `{Funext} `{IsEquiv B A g} `(f:B -> C) `(h:A -> C)
  : f o g^-1 = h -> f = h o g
  := fun p => (path_forall _ _ (fun x => ap f (eissect g x)))^
              @ (ap (fun u => u o g) p).

Definition moveR_equiv_Mp `{Funext} `{IsEquiv B C f} `(g:A -> B) `(h:A -> C)
  : f o g = h -> g = f^-1 o h
  := fun p => (path_forall _ _ (fun x => eissect f (g x)))^
              @ (ap (fun u => f^-1 o u) p).

Definition moveR_equiv_Vp `{Funext} `{IsEquiv C B f} `(g:A -> B) `(h:A -> C)
  : f^-1 o g = h -> g = f o h
  := fun p => (path_forall _ _ (fun x => eisretr f (g x)))^
              @ (ap (fun u => f o u) p).

Definition moveL_equiv_pM `{Funext} `{IsEquiv B A g} `(f:B -> C) `(h:A -> C)
  : f = h o g -> f o g^-1 = h
  := fun p => (ap (fun u => u o g^-1) p)
                @ (path_forall _ _ (fun x => ap h (eisretr g x))).

Definition moveL_equiv_pV `{Funext} `{IsEquiv A B g} `(f:B -> C) `(h:A -> C)
  : f = h o g^-1 -> f o g = h
  := fun p => (ap (fun u => u o g) p)
                @ (path_forall _ _ (fun x => ap h (eissect g x))).

Definition moveL_equiv_Mp `{Funext} `{IsEquiv A C h} `(g:B -> A) `(f:B -> C)
  : f = h o g -> h^-1 o f = g
  := fun p => (ap (fun u => h^-1 o u) p)
                @ (path_forall _ _ (fun x => (eissect h (g x)))).

Definition moveL_equiv_Vp `{Funext} `{IsEquiv C A h} `(g:B -> A) `(f:B -> C)
  : f = h^-1 o g -> h o f = g
  := fun p => (ap (fun u => h o u) p)
                @ (path_forall _ _ (fun x => (eisretr h (g x)))).


Require Import XR_Rle_dec.
Require Import XR_Rmin.

Local Open Scope R_scope.

Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y.
Proof.
  intros x y z.
  intros hx hy.
  unfold Rmin.
  destruct (Rle_dec x y) as [ hminl | hminr ].
  { exact hx. }
  { exact hy. }
Qed.