Require Export GeoCoq.Elements.OriginalProofs.lemma_notperp.
Require Export GeoCoq.Elements.OriginalProofs.lemma_pointreflectionisometry.
Require Export GeoCoq.Elements.OriginalProofs.lemma_planeseparation.
Require Export GeoCoq.Elements.OriginalProofs.lemma_oppositesidesymmetric.

Section Euclid.
Context `{Ax:euclidean_neutral_ruler_compass}.
Lemma proposition_11B :
   forall A B C P,
   BetS A C B -> nCol A B P ->
   exists X, Per A C X /\ TS X A B P.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists M, (nCol A B M /\ OS M P A B /\ ~ Per A C M)) by (conclude lemma_notperp);destruct Tf as [M];spliter.
assert (neq A B) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists Q, Perp_at M Q A B Q) by (conclude proposition_12);destruct Tf as [Q];spliter.
let Tf:=fresh in
assert (Tf:exists E, (Col M Q Q /\ Col A B Q /\ Col A B E /\ Per E Q M)) by (conclude_def Perp_at );destruct Tf as [E];spliter.
assert (~ eq M Q).
 {
 intro.
 assert (Col A B M) by (conclude cn_equalitysub).
 contradict.
 }
assert (neq Q M) by (conclude lemma_inequalitysymmetric).
assert (Col A B C) by (conclude_def Col ).
assert (Col B A E) by (forward_using lemma_collinearorder).
assert (Col B A C) by (forward_using lemma_collinearorder).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (~ eq C Q).
 {
 intro.
 assert (Per E C M) by (conclude cn_equalitysub).
 assert (Col A E C) by (conclude lemma_collinear4).
 assert (Col E C A) by (forward_using lemma_collinearorder).
 assert (neq A C) by (forward_using lemma_betweennotequal).
 assert (Per A C M) by (conclude lemma_collinearright).
 contradict.
 }
assert (Col C Q E) by (conclude lemma_collinear5).
assert (Col E Q C) by (forward_using lemma_collinearorder).
assert (Per C Q M) by (conclude lemma_collinearright).
assert (neq Q C) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists G, (BetS Q G C /\ Cong G Q G C)) by (conclude proposition_10);destruct Tf as [G];spliter.
assert (~ eq M G).
 {
 intro.
 assert (BetS Q M C) by (conclude cn_equalitysub).
 assert (Col Q M C) by (conclude_def Col ).
 assert (Col B Q C) by (conclude lemma_collinear4).
 assert (Col Q C M) by (forward_using lemma_collinearorder).
 assert (Col Q C B) by (forward_using lemma_collinearorder).
 assert (neq Q C) by (forward_using lemma_betweennotequal).
 assert (Col C M B) by (conclude lemma_collinear4).
 assert (Col C B M) by (forward_using lemma_collinearorder).
 assert (Col C B A) by (forward_using lemma_collinearorder).
 assert (neq C B) by (forward_using lemma_betweennotequal).
 assert (Col B M A) by (conclude lemma_collinear4).
 assert (Col A B M) by (forward_using lemma_collinearorder).
 contradict.
 }
rename_H H;let Tf:=fresh in
assert (Tf:exists H, (BetS M G H /\ Cong G H M G)) by (conclude lemma_extension);destruct Tf as [H];spliter.
assert (Cong M G G H) by (conclude lemma_congruencesymmetric).
assert (Midpoint M G H) by (conclude_def Midpoint ).
assert (Cong Q G G C) by (forward_using lemma_congruenceflip).
assert (Midpoint Q G C) by (conclude_def Midpoint ).
assert (Col Q G C) by (conclude_def Col ).
assert (Col C Q G) by (forward_using lemma_collinearorder).
assert (neq Q G) by (forward_using lemma_betweennotequal).
assert (neq G Q) by (conclude lemma_inequalitysymmetric).
assert (Per G Q M) by (conclude lemma_collinearright).
let Tf:=fresh in
assert (Tf:exists J, (BetS M Q J /\ Cong Q J M Q)) by (conclude lemma_extension);destruct Tf as [J];spliter.
assert (Cong M Q Q J) by (conclude lemma_congruencesymmetric).
assert (Per M Q G) by (conclude lemma_8_2).
assert (Cong M G J G) by (conclude lemma_rightreverse).
assert (BetS J Q M) by (conclude axiom_betweennesssymmetry).
assert (Cong J Q M Q) by (forward_using lemma_congruenceflip).
assert (Cong J G M G) by (conclude lemma_congruencesymmetric).
assert (Per J Q G) by (conclude_def Per ).
assert (~ eq J G).
 {
 intro.
 assert (Col J Q G) by (conclude_def Col ).
 assert (nCol J Q G) by (conclude lemma_rightangleNC).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists K, (BetS J G K /\ Cong G K J G)) by (conclude lemma_extension);destruct Tf as [K];spliter.
assert (Cong J G G K) by (conclude lemma_congruencesymmetric).
assert (Midpoint J G K) by (conclude_def Midpoint ).
assert (Cong M Q H C) by (conclude lemma_pointreflectionisometry).
assert (neq J Q) by (forward_using lemma_betweennotequal).
assert (neq Q J) by (conclude lemma_inequalitysymmetric).
assert (neq M J) by (forward_using lemma_betweennotequal).
assert (Cong Q J C K) by (conclude lemma_pointreflectionisometry).
assert (Cong M J H K) by (conclude lemma_pointreflectionisometry).
assert (BetS H C K) by (conclude lemma_betweennesspreserved).
assert (Cong H G G M) by (forward_using lemma_congruenceflip).
assert (Cong G M J G) by (forward_using lemma_congruenceflip).
assert (Cong H G J G) by (conclude lemma_congruencetransitive).
assert (Cong J G G K) by (conclude lemma_congruencesymmetric).
assert (Cong H G G K) by (conclude lemma_congruencetransitive).
assert (Cong H G K G) by (forward_using lemma_congruenceflip).
assert (neq G C) by (forward_using lemma_betweennotequal).
assert (Cong H C M Q) by (conclude lemma_congruencesymmetric).
assert (Cong M Q Q J) by (conclude lemma_congruencesymmetric).
assert (Cong H C Q J) by (conclude lemma_congruencetransitive).
assert (Cong H C C K) by (conclude lemma_congruencetransitive).
assert (Cong H C K C) by (forward_using lemma_congruenceflip).
assert (neq G C) by (forward_using lemma_betweennotequal).
assert (neq C G) by (conclude lemma_inequalitysymmetric).
assert (Per H C G) by (conclude_def Per ).
assert (Per G C H) by (conclude lemma_8_2).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col A B A) by (conclude_def Col ).
assert (Col Q C A) by (conclude lemma_collinear5).
assert (Col Q C G) by (forward_using lemma_collinearorder).
assert (Col C A G) by (conclude lemma_collinear4).
assert (Col G C A) by (forward_using lemma_collinearorder).
assert (neq A C) by (forward_using lemma_betweennotequal).
assert (Per A C H) by (conclude lemma_collinearright).
assert (Col C A B) by (forward_using lemma_collinearorder).
assert (neq C A) by (conclude lemma_inequalitysymmetric).
assert (Col A G B) by (conclude lemma_collinear4).
assert (Col A B G) by (forward_using lemma_collinearorder).
assert (OS P M A B) by (forward_using lemma_samesidesymmetric).
assert (TS M A B H) by (conclude_def TS ).
assert (TS P A B H) by (conclude lemma_planeseparation).
assert (TS H A B P) by (conclude lemma_oppositesidesymmetric).
close.
Qed.

End Euclid.


(** * Permutations
Some additional results about permutations. Most of the proofs in this
script where taken from #
https://github.com/PrincetonUniversity/certicoq/blob/master/libraries/MyPermutations.v#
 *)

Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.

Lemma eq_then_Permutation: forall{A:Type} (l1 l2:list A),
    l1 = l2 -> Permutation l1 l2.
Proof.
  intros A l1 l2 H.
  rewrite H; reflexivity.
Qed.

Lemma app_compat_perm_latter(A:Type) : forall l a1 a2:list A,
    Permutation a1 a2 -> Permutation (l++a1) (l++a2).
Proof.
  intros l a1 a2 Ha.
  induction l.
  - exact Ha.
  - apply perm_skip,IHl.
Qed.

Instance app_compat_perm(A:Type) :
  Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A).
Proof.
  unfold Proper,respectful.
  intros a1 a2 Ha b1 b2 Hb.
  induction Ha.
  - exact Hb.
  - apply perm_skip.
    exact IHHa.
  - apply perm_trans with ((x::y::l)++b1).
    + apply perm_swap.
    + apply perm_skip,perm_skip,app_compat_perm_latter,Hb.
  - apply perm_trans with (l'++b2); [exact IHHa1|].
    apply perm_trans with (l'++b1); [|exact IHHa2].
    apply app_compat_perm_latter,Permutation_sym,Hb.
Qed.

Lemma Permutation_In_In: forall{A:Type} (x:A) (l1 l2:list A),
    Permutation l1 l2 -> In x l1 -> In x l2.
Proof.
  intros A x l1 l2 HP H.
  induction HP.
  - exact H.
  - destruct H as [H|H].
    + left.
      exact H.
    + right.
      apply IHHP,H.
  - destruct H as [H|[H|H]].
    + right.
      left.
      exact H.
    + left.
      exact H.
    + right.
      right.
      exact H.
  - apply IHHP2,IHHP1,H.
Qed.

Instance In_compat_perm(A:Type):
  Proper (eq ==> @Permutation A ==> iff) (@In A).
Proof.
  unfold Proper,respectful.
  intros x1 x2 Hx l1 l2 Hl.
  rewrite Hx; clear x1 Hx.
  split.
  - apply Permutation_In_In,Hl.
  - apply Permutation_In_In.
    symmetry.
    exact Hl.
Qed.

Instance length_compat_perm(A:Type):
  Proper (@Permutation A ==> eq) (@length A).
Proof.
  unfold Proper, respectful.
  intros LA LB HL.
  apply Permutation_length,HL.
Qed.

Lemma app_normalize_1:
  forall(A:Type) (l1 l2 l3:list A),
    (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros A l1 l2 l3.
  rewrite app_assoc.
  reflexivity.
Qed.

Lemma app_normalize_2:
  forall(A:Type) (a1:A) (l2 l3:list A),
    (a1 :: l2) ++ l3 = a1 :: (l2 ++ l3).
Proof.
  intros; reflexivity.
Qed.

Lemma app_normalize_3:
  forall(A:Type) (l1:list A), (nil++l1) = l1.
Proof.
  intros; reflexivity.
Qed.

Ltac app_normalize := repeat (
                          rewrite app_normalize_1 ||
                          rewrite app_normalize_2 ||
                          rewrite app_normalize_3).

Lemma perm_takeit_1:
  forall(A:Type) (target:list A) (l1 l2:list A),
    Permutation (l1 ++ (target ++ l2)) (target ++ (l1 ++ l2)).
Proof.
  intros A target l1 l2.
  rewrite (app_assoc l1 target l2),
  (Permutation_app_comm l1 target),
  <-(app_assoc target l1 l2).
  reflexivity.
Qed.

Lemma perm_takeit_2:
  forall(A:Type) (target:list A) (a1:A) (l2:list A),
    Permutation (a1 :: (target ++ l2)) (target ++ (a1 :: l2)).
Proof.
  intros A target a1 l2.
  apply (perm_takeit_1 _ _ (a1::nil)).
Qed.

Lemma perm_takeit_3:
  forall(A:Type) (target:list A) (l1:list A),
    Permutation (l1 ++ target) (target ++ l1).
Proof.
  intros A target l1.
  apply Permutation_app_comm.
Qed.

Lemma perm_takeit_4:
  forall(A:Type) (target:list A) (a1:A),
    Permutation (a1 :: target) (target ++ (a1::nil)).
Proof.
  intros A target a1.
  apply (perm_takeit_3 _ _ (a1::nil)).
Qed.

Lemma perm_takeit_5:
  forall(A:Type) (target:A) (l1 l2:list A),
    Permutation (l1 ++ (target :: l2)) (target :: (l1 ++ l2)).
Proof.
  intros A target l1 l2.
  apply (perm_takeit_1 _ (target::nil)).
Qed.

Lemma perm_takeit_6:
  forall(A:Type) (target:A) (a1:A) (l2:list A),
    Permutation (a1 :: (target :: l2)) (target :: (a1 :: l2)).
Proof.
  intros A target a1 l2.
  apply (perm_takeit_2 _ (target::nil)).
Qed.

Lemma perm_takeit_7:
  forall(A:Type) (target:A) (l1:list A),
    Permutation (l1 ++ (target::nil)) (target :: l1).
Proof.
  intros A target l1.
  apply (perm_takeit_3 _ (target::nil)).
Qed.

Lemma perm_takeit_8:
  forall(A:Type) (target:A) (a1:A),
    Permutation (a1 :: (target::nil)) (target :: (a1::nil)).
Proof.
  intros A target a1.
  apply (perm_takeit_4 _ (target::nil)).
Qed.

Ltac perm_simplify := app_normalize; repeat (
                                         rewrite app_nil_r ||
                                         match goal with
                                         | [ |- Permutation ?L1 ?L1 ] => reflexivity
                                         | [ |- Permutation (?A1++_) (?A1++_) ] => apply Permutation_app_head
                                         | [ |- Permutation (?A1::_) (?A1::_) ] => apply perm_skip
                                         | [ |- Permutation _ (?L1++_) ] => (
                                             rewrite (perm_takeit_1 _ L1) at 1 ||
                                             rewrite (perm_takeit_2 _ L1) at 1 ||
                                             rewrite (perm_takeit_3 _ L1) at 1 ||
                                             rewrite (perm_takeit_4 _ L1) at 1 )
                                         | [ |- Permutation _ (?A1::_) ] => (
                                             rewrite (perm_takeit_5 _ A1) at 1 ||
                                             rewrite (perm_takeit_6 _ A1) at 1 ||
                                             rewrite (perm_takeit_7 _ A1) at 1 ||
                                             rewrite (perm_takeit_8 _ A1) at 1 )
                                         | [ |- Permutation _ _ ] => fail
                                         end).

Ltac perm :=
  match goal with
  | [ |- Permutation _ _ ] => perm_simplify; fail "perm failed"
  | [ |- _ ] => fail "perm can't solve this system."
  end.

Lemma PProp_perm_select:
  forall(A:Type) (P1 P2:A) (L1 L2:list A),
    Permutation (P1::L1) (P2::L2) ->
    (
      P1 = P2 /\ Permutation L1 L2
    ) \/ (
      exists L2',
        Permutation L2 (P1::L2') /\
        Permutation L1 (P2::L2')
    ).
Proof.
  intros A P1 P2 L1 L2 HP.
  assert (HI:=in_eq P1 L1).
  rewrite HP in HI.
  destruct HI as [HI|HI].
  - left.
    split.
    + symmetry.
      exact HI.
    + rewrite HI in HP.
      apply Permutation_cons_inv in HP.
      exact HP.
  - right.
    destruct (in_split _ _ HI) as (L2A,(L2B,HL2)).
    exists (L2A++L2B).
    split.
    + rewrite HL2.
      perm.
    + apply Permutation_cons_inv with (a:=P1).
      rewrite HP.
      rewrite HL2.
      perm.
Qed.

Lemma PProp_perm_select':
  forall(A:Type) (P:A) (L1 L2 L3:list A),
    Permutation (L1++L2) (P::L3) ->
    (exists L1', Permutation L1 (P :: L1') /\
                 Permutation (L1'++L2) L3)
    \/
    exists L2', Permutation L2 (P :: L2') /\
                Permutation (L1++L2') L3 .
Proof.
  induction L1.
  - intros; right.
    exists L3. auto.
  - intros.
    rewrite app_normalize_2 in H.
    apply PProp_perm_select in H.
    destruct H.
    +
      destruct H;subst;left.
      exists L1. auto.
    +
      do 2 destruct H.
      apply IHL1 in H0.
      destruct H0.
      *
        do 2 destruct H0.
        left.
        exists (a::x0).
        split.
        rewrite H0.
        perm.
        rewrite H.
        rewrite <- H1.
        perm.
      *
        do 2 destruct H0.
        right.
        exists (x0).
        split.
        rewrite H0.
        perm.
        rewrite H.
        rewrite <- H1.
        perm.
Qed.

Lemma PProp_perm_sel:
  forall(A:Type) (P:A) (L1 L2 L3:list A),
    Permutation (L3++P::nil) (L1++L2)  ->
    (exists L1', Permutation L1 (L1'++P::nil) /\
                 Permutation (L1'++L2) L3)
    \/
    exists L2', Permutation L2 (L2'++P::nil) /\
                Permutation (L1++L2') L3 .
Proof.
  intros.
  rewrite perm_takeit_7 in H.
  symmetry in H.
  apply PProp_perm_select' in H.
  destruct H;[left;destruct H|right;destruct H].
  * exists x.
    destruct H;split;auto.
    rewrite perm_takeit_7;auto.
  * exists x.
    destruct H;split;auto.
    rewrite perm_takeit_7;auto.
Qed.

Lemma Permutation_assoc_comm: forall (T:Type) (X Y Z : list T), Permutation  ((X ++ Y) ++ Z) ((X ++ Z) ++ Y).
  intros.
  perm.
Qed.


Require Export prosa.util.div_mod.

Require Import Arith Omega Nat.
Require Import prosa.classic.util.tactics prosa.util.ssromega prosa.classic.util.nat.

From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop div.

  Definition div_floor (x y: nat) : nat := x %/ y.
  Definition div_ceil (x y: nat) := if y %| x then x %/ y else (x %/ y).+1.

  Lemma ltn_div_trunc :
    forall m n d,
      d > 0 ->
      m %/ d < n %/ d ->
      m < n.
  Proof.
    intros m n d GT0 DIV; rewrite ltn_divLR in DIV; last by ins.
    by apply leq_trans with (n := n %/ d * d);
      [by ins| by apply leq_trunc_div].
  Qed.

  Lemma subndiv_eq_mod:
    forall n d, n - n %/ d * d = n %% d.
  Proof.
    by ins; rewrite {1}(divn_eq n d) addnC -addnBA // subnn addn0.
  Qed.

  Lemma divSn_cases :
    forall n d,
      d > 1 ->
      (n %/ d = n.+1 %/d /\ n %% d + 1 = n.+1 %% d) \/
      (n %/ d + 1 = n.+1 %/ d).
  Proof.
    ins; set x := n %/ d; set y := n %% d.
    assert (GT0: d > 0); first by apply ltn_trans with (n := 1).
    destruct (ltngtP y (d - 1)) as [LTN | BUG | GE]; [left | | right];
      first 1 last.
    {
      exploit (@ltn_pmod n d); [by apply GT0 | intro LTd; fold y in LTd].
      rewrite -(ltn_add2r 1) [y+1]addn1 ltnS in BUG.
      rewrite subh1 in BUG; last by apply GT0.
      rewrite -addnBA // subnn addn0 in BUG.
      by apply (leq_ltn_trans BUG) in LTd; rewrite ltnn in LTd.
    }

    {
      (* Case 1: y = d - 1*)
      move: GE => /eqP GE; rewrite -(eqn_add2r 1) in GE.
      rewrite subh1 in GE; last by apply GT0.
      rewrite -addnBA // subnn addn0 in GE.
      move: GE => /eqP GE.
      apply f_equal with (f := fun x => x %/ d) in GE.
      rewrite divnn GT0 /= in GE.
      unfold x; rewrite -GE.
      rewrite -divnMDl; last by apply GT0.
      f_equal; rewrite addnA.
      by rewrite -divn_eq addn1.
    }
    {
      assert (EQDIV: n %/ d = n.+1 %/ d).
      {
        apply/eqP; rewrite eqn_leq; apply/andP; split;
          first by apply leq_div2r, leqnSn.
        rewrite leq_divRL; last by apply GT0.
        rewrite -ltnS {2}(divn_eq n.+1 d).
        rewrite -{1}[_ %/ d * d]addn0 ltn_add2l.
        unfold y in *.
        rewrite ltnNge; apply/negP; unfold not; intro BUG.
        rewrite leqn0 in BUG; move: BUG => /eqP BUG.
        rewrite -(modnn d) -addn1 in BUG.
        destruct d; first by rewrite sub0n in LTN.
        move: BUG; move/eqP; rewrite -[d.+1]addn1 eqn_modDr [d+1]addn1; move => /eqP BUG.
        rewrite BUG -[d.+1]addn1 -addnBA // subnn addn0 in LTN.
        by rewrite modn_small in LTN;
          [by rewrite ltnn in LTN | by rewrite addn1 ltnSn].
      }
      (* Case 2: y < d - 1 *)
      split; first by rewrite -EQDIV.
      {
        unfold x, y in *.
        rewrite -2!subndiv_eq_mod.
        rewrite subh1 ?addn1; last by apply leq_trunc_div.
        rewrite EQDIV; apply/eqP.
        rewrite -(eqn_add2r (n%/d*d)).
        by rewrite subh1; last by apply leq_trunc_div.
      }
    }
  Qed.

  Lemma ceil_neq0 :
    forall x y,
      x > 0 ->
      y > 0 ->
      div_ceil x y > 0.
  Proof.
    unfold div_ceil; intros x y GEx GEy.
    destruct (y %| x) eqn:DIV; last by done.
    by rewrite divn_gt0; first by apply dvdn_leq.
  Qed.

  Lemma leq_divceil2r :
    forall d m n,
      d > 0 ->
      m <= n ->
      div_ceil m d <= div_ceil n d.
  Proof.
    unfold div_ceil; intros d m n GT0 LE.
    destruct (d %| m) eqn:DIVm, (d %| n) eqn:DIVn;
      [by apply leq_div2r | | | by apply leq_div2r].
    by apply leq_trans with (n := n %/ d); first by apply leq_div2r.
    {
      rewrite leq_eqVlt in LE; move: LE => /orP [/eqP EQ | LT];
        first by subst; rewrite DIVn in DIVm.
      rewrite ltn_divLR //.
      apply leq_trans with (n := n); first by done.
      by apply eq_leq; symmetry; apply/eqP; rewrite -dvdn_eq.
    }
  Qed.

(* Versions of eqn_modDl and eqn_modDl in Prop *)

  Lemma eq_modDl: forall p m n d, (p + m = p + n %[mod d]) <-> (m = n %[mod d]).
  Proof.
    split; intro G.
    - apply /eqP. rewrite <- eqn_modDl with (p:=p).
      by apply /eqP.
    - rewrite -modnDm G.
      by rewrite modnDm.
  Qed.

  Lemma eq_modDr: forall p m n d, (m + p = n + p %[mod d]) <-> (m = n %[mod d]).
  Proof.
    split; intro G.
    - apply /eqP. rewrite <- eqn_modDr with (p:=p).
      by apply /eqP.
    - rewrite -modnDm G.
      by rewrite modnDm.
  Qed.

  (* If a(n)= b+a (n) then b is a multiple of c
    Proposed name modnD_k *)

  Lemma modulo_exists: forall a b c,
    c>0 -> a = b + a %[mod c] -> exists k, b = k*c.
  Proof.
    intros* F G.
    change a with (0+a) in G.
    apply eq_modDr in G.
    rewrite mod0n in G.
    assert (X: b = b%/c *c + b%%c) by apply divn_eq.
    rewrite -G addn0 in X.
    by exists (b%/c).
  Qed.

  (* If (a+1)[n+1]=0 then a[n+1]=n *)
  Lemma modnS_eq : forall a n, a.+1 %% n.+1 =0 <-> a %% n.+1 = n.
  Proof.
    intros.
    rewrite -(modnn (n.+1)).
    change (a.+1) with (1+a).
    change (n.+1) with (1+n).
    assert (X:n<n.+1) by ssromega.
    apply modn_small in X.
    split; intros* G.
    - apply eq_modDl in G.
      by rewrite G.
    - apply eq_modDl.
      by rewrite G.
  Qed.

  (* Incrementing the integer under a modulo either increments the result or yields 0 *)

  Lemma modnSor': forall a n, a.+1 %% n = (a %% n).+1 \/ (a.+1 %% n =0).
  Proof.
    intros*.
    destruct (ltngtP ((a%%n).+1) (n)) as [G|G|G].
    - left. apply modn_small in G.
      by rewrite -G -addn1 -modnDml addn1.
    - destruct n.
      + left. reflexivity.
      + assert (X: a%%n.+1 < n.+1). by apply ltn_pmod. ssromega.
    - right. destruct n.
      + discriminate G.
      + apply modnS_eq. by injection G.
  Qed.

  Lemma modnSor: forall a n, a.+1 %% n.+1 = (a %% n.+1).+1 \/ (a.+1 %% n.+1 =0).
  Proof.
    intros.
    destruct (ltngtP ((a%%n.+1).+1) (n.+1)) as [G|G|G].
    - left. apply modn_small in G.
      by rewrite -G -addn1 -modnDml addn1.
    - assert (X: a%%n.+1 < n.+1). by apply ltn_pmod. ssromega.
    - right. apply modnS_eq. ssromega.
  Qed.

  (* Old version of the lemma which is now covered by modnSor and modnS_eq *)

  Lemma modulo_cases : forall a c,
    a.+1 %% c.+1 = (a %% c.+1).+1 \/ (a.+1 %% c.+1 =0 /\ a %% c.+1 =c).
  Proof.
    intros. destruct (modnSor a c) as [G|G]; try by left.
    right; split; try done.
    by apply modnS_eq.
  Qed.

  Lemma ceil_eq1: forall a c, a > 0 -> a <= c -> div_ceil a c = 1.
  Proof.
    intros* G1. unfold div_ceil.
    rewrite leq_eqVlt. move/orP => [G2|G2].
    - move/eqP :G2 => G2. subst.
      rewrite dvdnn. rewrite divnn.
      destruct c; ssromega.
    - rewrite gtnNdvd // divn_small //.
  Qed.

  Lemma ceil_suba: forall a c, c > 0 -> a > c -> div_ceil a c = (div_ceil (a-c) c).+1.
  Proof.
    intros* G1 G2. unfold div_ceil.
    assert (X:a=a-c+c) by (rewrite subnK //; ssromega).
    case E1:(c %| a); case E2:(c %| a - c); rewrite {1} X.
    - rewrite divnDl //. rewrite divnn. by rewrite G1 addn1.
    - rewrite X in E1. apply dvdn_add_eq in E1.
      rewrite dvdnn E2 in E1. inversion E1.
    - apply dvdn_addr with (n:=c) in E2.
      rewrite dvdnn in E2. rewrite X E2 in E1. inversion E1.
    - rewrite divnDr // divnn G1 addn1 //.
  Qed.

  Lemma mod_eq: forall a b, a%%b = a - a%/b * b.
  Proof.
    intros.
    rewrite {2}(divn_eq a b).
    ssromega.
  Qed.


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

Require Import ZArith Zpow_facts.

Open Scope Z_scope.

Fixpoint Ppow a z {struct z}:=
  match z with
    xH => a
  | xO z1 => let v := Ppow a z1 in (Pmult v v)
  | xI z1 => let v := Ppow a z1 in (Pmult a (Pmult v v))
  end.

Theorem Ppow_correct: forall a z,
  Zpos (Ppow a z) = (Zpos a) ^ (Zpos z).
intros a z; elim z; simpl Ppow; auto;
  try (intros z1 Hrec; repeat rewrite Zpos_mult_morphism; rewrite Hrec).
  rewrite Zpos_xI; rewrite Zpower_exp. 3: auto with zarith.
  2: rewrite <-Zpos_xO; red; simpl; intros; discriminate.
 rewrite Zpower_1_r; rewrite (Zmult_comm 2);
    try rewrite Zpower_mult by auto with zarith.
    change 2 with (1 + 1); rewrite Zpower_exp by auto with zarith.
    rewrite Zpower_1_r; rewrite Zmult_comm; auto.
  rewrite Zpos_xO; rewrite (Zmult_comm 2);
    rewrite Zpower_mult by auto with zarith.
    change 2 with (1 + 1); rewrite Zpower_exp by auto with zarith.
    rewrite Zpower_1_r; auto.
 rewrite Zpower_1_r; auto.
Qed.

Theorem Ppow_plus: forall a z1 z2,
 Ppow a (z1 + z2) = ((Ppow a z1) * (Ppow a z2))%positive.
intros a z1 z2.
  assert (tmp: forall x y, Zpos x = Zpos y -> x = y).
    intros x y H; injection H; auto.
  apply tmp.
  rewrite Zpos_mult_morphism; repeat rewrite Ppow_correct.
  rewrite Zpos_plus_distr; rewrite Zpower_exp; auto; red; simpl;
    intros; discriminate.
Qed.


Require Import HMAC_functional_prog.
Require Import SHA256.
Require Import ByteBitRelations.
Require Import Integers.
Require Import sha_padding_lemmas.
Require Import Recdef.
Require Import List.
Require Import Arith.
Require Import Coqlib.

Definition Blist := list bool.

Definition concat {A : Type} (l : list (list A)) : list A :=
  flat_map id l.

(* Replacing splitVector *)
Definition splitList {A : Type} (n : nat) (l : list A) : (list A * list A) :=
  (firstn n l, skipn n l).

(* Replacing BVxor *)
Definition BLxor (xs : Blist) (ys : Blist) :=
  map (fun p => xorb (fst p) (snd p)) (combine xs ys).

Function hash_blocks_bits (hash_block_bit : Blist -> Blist -> Blist) (r: Blist)
         (msg: Blist) {measure length msg} : Blist :=
  match msg with
  | nil => r
  | _ => hash_blocks_bits hash_block_bit (hash_block_bit r (firstn 512 msg)) (skipn 512 msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) 512).
 rewrite skipn_length_short. simpl; omega. rewrite <- teq; auto.
 rewrite skipn_length. simpl; omega. rewrite <- teq; omega.
Defined.

(* TODO use neater definition with conversion functions *)
(* TODO split out of HMAC_spec_pad *)

Definition c := (SHA256_.DigestLength * 8)%nat.
Definition p := (32 * 8)%nat.
Definition b := (c + p)%nat.
Definition BlockSize := 64.

Definition intsToBits (l : list int) : list bool :=
  bytesToBits (SHA256.intlist_to_Zlist l).

Definition bitsToInts (l : Blist) : list int :=
  SHA256.Zlist_to_intlist (bitsToBytes l).

Definition sha_iv : Blist :=
  intsToBits SHA256.init_registers.

Definition sha_h (regs : Blist) (block : Blist) : Blist :=
  intsToBits (SHA256.hash_block (bitsToInts regs) (bitsToInts block)).

Definition sha_splitandpad (msg : Blist) : Blist :=
  bytesToBits (sha_padding_lemmas.pad (bitsToBytes msg)).

(* modified version of sha_padding_lemmas.pad *)
Definition pad_inc (msg : list Z) : list Z :=
  let n := BlockSize + Zlength msg in
  msg ++ [128%Z]
      ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
      ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]).

Definition sha_splitandpad_inc (msg : Blist) : Blist :=
  bytesToBits (pad_inc (bitsToBytes msg)).

(* artifact of app_fpad definition *)
Definition fpad_inner (msg : list Z) : list Z :=
  let n := BlockSize + Zlength msg in
  [128%Z]
    ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
    ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]).

Definition fpad (msg : Blist) : Blist :=
  bytesToBits (fpad_inner (bitsToBytes msg)).

(* --------------- *)

Lemma firstn_exact :
  forall {A : Type} (l1 l2 : list A) (n : nat),
    (length l1 = n)%nat -> firstn n (l1 ++ l2) = l1.
Proof.
  induction l1; destruct n; intros; simpl; try reflexivity; inversion H.
  * f_equal. apply IHl1. reflexivity.
Qed.

Lemma skipn_exact :
  forall {A : Type} (l1 l2 : list A) (n : nat),
    (length l1 = n)%nat -> skipn n (l1 ++ l2) = l2.
Proof.
  induction l1; destruct n; intros; simpl; try reflexivity; inversion H.
  * apply IHl1. reflexivity.
Qed.

Lemma length_not_emp :
  forall {A B : Type} (l : list A) (z y : B),
    (Datatypes.length l > 0)%nat -> match l with [] => z | _ => y end = y.
Proof.
  intros.
  induction l as [ | x xs].
  - inversion H.
  - reflexivity.
Qed.

Lemma split_append_id : forall {A : Type} (len : nat) (l1 l2 : list A),
                               length l1 = len -> length l2 = len ->
                               splitList len (l1 ++ l2) = (l1, l2).
Proof.
  induction len; intros l1 l2 len1 len2.
  -
    assert (H: forall {A : Type} (l : list A), length l = 0%nat -> l = []).
      intros. destruct l.
      reflexivity. inversion H.
    apply H in len1. apply H in len2.
    subst. reflexivity.
  -
    unfold splitList.
    rewrite -> firstn_exact. rewrite -> skipn_exact.
    * reflexivity. * assumption. * assumption.
Qed.


   (* Демонстрация интуиционистских доказательств *)
   (* формул из задачи 1 (раздел 2)               *)
   (* ------------------------------------------- *)
   (* -------------------------------- *)
   (* (P -> Q) -> ((P -> R) -> Q) -> Q *)
   (* -------------------------------- *)
   Theorem s1: forall P Q R : Prop,
                  (P -> Q) -> (((P /\ ~R) \/ Q) -> Q).
   Proof.
     intros.
     elim H0.
     intros.
     apply H.
     apply H1.
     apply id.
   Qed.

   Print s1.

   (* --------------------------------------- *)
   (* ((P -> Q) -> R) -> (R -> P) -> (S -> P) *)
   (* --------------------------------------- *)
   Theorem s2: forall P Q R S : Prop,
                  (P /\ ~Q \/ R) -> (R -> P) -> (S -> P).
   Proof.
     intros.
     elim H.
     intros.
     apply H2.
     assumption.
  Qed.

  Print s2.

   (* ------------------------------------------------ *)
   (* ((P -> R) -> (S -> P))                           *)
   (*                   -> ((R -> Q) -> P) -> (S -> P) *)
   (* ------------------------------------------------ *)
   Theorem s3: forall P Q R S : Prop,
                  (P /\ ~R \/ (S -> P))
                      -> ((R -> Q) -> P) -> (S -> P).
   Proof.
     intros.
     elim H.
     intros.
     clear H.
     apply H2.
     intros.
     apply (H2 H1).
   Qed.

   Print s3.

   (* ---------------------------------------------- *)
   (* ((R -> Q) -> (S -> P)) -> (R -> P) -> (S -> P) *)
   (* ---------------------------------------------- *)
   Theorem s4: forall P Q R S: Prop,
                  (R /\ ~Q \/ (S -> P))
                                 -> (R -> P) -> (S -> P).
   Proof.
     intros.
     elim H.
     intros.
     apply H0.
     apply H2.
     intros.
     apply (H2 H1).
   Qed.

   Print s4.

   (* ---------------------------------------- *)
   (* (((R -> P) -> P) -> (S -> P))            *)
   (*           -> ((P -> Q) -> R) -> (S -> P) *)
   (* ---------------------------------------- *)
   Theorem s5: forall P Q R S : Prop,
                  ((R -> P) \/ ~S)
                      -> (R \/ P /\ ~Q) -> (S -> P).
   Proof.
     intros.
     elim H.
     intros.
     elim H0.
     assumption.
     intros.
     apply H3.
     intros.
     elim H2.
     assumption.
   Qed.

   Print s5.

   (* ---------------------------------- *)
   (* (((P -> R) -> Q) -> Q)             *)
   (*            -> (Q -> R) -> (P -> R) *)
   (* ---------------------------------- *)
   Theorem s6: forall P Q R : Prop,
                  ((P -> R) \/ Q) -> (Q -> R) -> (P -> R).
   Proof.
      intros.
      elim H.
      intros.
      apply (H2 H1).
      assumption.
   Qed.


Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Ordered Types = Types with a PreOrder
 ***)

(* NOTE: The idea with this approach is that each type uniquely determines its
ordered type, but we keep the types separate from the ordered types to make
type inference work properly... *)

Class OTRelation (A:Type) : Type := ot_R : relation A.
Class OType (A:Type) {R:OTRelation A} : Prop :=
  { ot_PreOrder :> PreOrder ot_R }.

Arguments OTRelation A%type.
Arguments OType A%type {R}.

Instance OType_Reflexive A `{OType A} : Reflexive ot_R.
Proof. typeclasses eauto. Qed.

Instance OType_Transitive A `{OType A} : Transitive ot_R.
Proof. typeclasses eauto. Qed.

(* The equivalence relation for an OrderedType *)
Definition ot_equiv {A} `{OTRelation A} : relation A :=
  fun x y => ot_R x y /\ ot_R y x.

Instance ot_equiv_Equivalence A `{OType A} : Equivalence ot_equiv.
Proof.
  constructor; intro; intros.
  { split; reflexivity. }
  { destruct H0; split; assumption. }
  { destruct H0; destruct H1; split; transitivity y; assumption. }
Qed.

Notation "x <o= y" :=
  (ot_R x y) (no associativity, at level 70).
Notation "x =o= y" :=
  (ot_equiv x y) (no associativity, at level 70).

(* FIXME: replace "ot_R" below with "<o=" notation *)

(* FIXME: figure out what versions of this we need for rewriting! *)
Instance Proper_ot_R_ot_R A `{OType A}
  : Proper (ot_R --> ot_R ==> Basics.impl) (@ot_R A _).
Proof.
  intros a1 a2 Ra b1 b2 Rb Rab.
  transitivity a1; [ assumption | ]. transitivity b1; assumption.
Qed.

Instance Subrelation_ot_equiv_ot_R A `{OTRelation A} :
  subrelation (@ot_equiv A _) ot_R.
Proof.
  intros a1 a2 Ra; destruct Ra; assumption.
Qed.

Instance Proper_ot_equiv_ot_R A `{OType A} :
  Proper (ot_equiv ==> ot_equiv ==> iff) (@ot_R A _).
Proof.
  intros x1 x2 Rx y1 y2 Ry; destruct Rx; destruct Ry; split; intro Rxy.
  transitivity x1; [ assumption | ]; transitivity y1; assumption.
  transitivity x2; [ assumption | ]; transitivity y2; assumption.
Qed.

Instance Proper_ot_equiv A `{OType A} :
  Proper (ot_equiv ==> ot_equiv ==> iff) (@ot_equiv A _).
Proof.
  intros x1 x2 Rx y1 y2 Ry. rewrite Rx. rewrite Ry. reflexivity.
Qed.

Instance Proper_ot_equiv_partial A `{OType A} a :
  Proper (ot_equiv ==> Basics.flip Basics.impl) (@ot_equiv A _ a).
Proof.
  intros x1 x2 Rx. rewrite Rx. reflexivity.
Qed.

(***
 *** Commonly-Used Ordered Types
 ***)

(* The ordered type of propositions *)
Instance OTProp_R : OTRelation Prop := Basics.impl.
Instance OTProp : OType Prop.
Proof. repeat constructor; typeclasses eauto. Qed.

(* The discrete ordered type, where things are only related to themselves; we
make this a definition, not an instance, so that it can be instantiated for
particular types. *)
Definition OTdiscrete_R (A:Type) : OTRelation A := eq.
Definition OTdiscrete A : @OType A (OTdiscrete_R A).
  repeat constructor. typeclasses eauto.
Qed.

(* The only ordered type over unit is the discrete one *)
Instance OTunit_R : OTRelation unit := OTdiscrete_R unit.
Instance OTunit : OType unit := OTdiscrete unit.

(* The ordered type that flips the ordering of an underlying OType; this becomes
a type itself in Coq *)
Inductive Flip A : Type := flip (a:A).
Definition unflip {A} (f:Flip A) : A := let (x) := f in x.

Instance OTFlip_R A (R:OTRelation A) : OTRelation (Flip A) :=
  fun x y => unflip y <o= unflip x.

Instance OTFlip A `{OType A} : OType (Flip A).
Proof.
  repeat constructor; intro; intros.
  - destruct x; compute; reflexivity.
  - destruct x; destruct y; destruct z; compute; transitivity a0; assumption.
Qed.

(* The pointwise relation on pairs *)
Instance OTpair_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A*B) :=
  fun p1 p2 => ot_R (fst p1) (fst p2) /\ ot_R (snd p1) (snd p2).

Instance OTpair A B `(OType A) `(OType B) : OType (A*B).
Proof.
  repeat constructor.
  - destruct x. reflexivity.
  - destruct x. reflexivity.
  - destruct x; destruct y; destruct z; destruct H1; destruct H2;
      transitivity a0; assumption.
  - destruct x; destruct y; destruct z; destruct H1; destruct H2;
      transitivity b0; assumption.
Qed.

(* The sort-of pointwise relation on sum types *)
Inductive sumR {A B} (RA:OTRelation A) (RB:OTRelation B) : A+B -> A+B -> Prop :=
| sumR_inl a1 a2 : RA a1 a2 -> sumR RA RB (inl a1) (inl a2)
| sumR_inr b1 b2 : RB b1 b2 -> sumR RA RB (inr b1) (inr b2).

Instance OTsum_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A+B) :=
  sumR RA RB.

Instance OTsum A B `(OType A) `(OType B) : OType (A+B).
Proof.
  repeat constructor; intro; intros.
  { destruct x; constructor; reflexivity. }
  { destruct H1; inversion H2.
    - constructor; transitivity a2; assumption.
    - constructor; transitivity b2; assumption. }
Qed.

(* NOTE: the following definition requires everything above to be polymorphic *)
(* NOTE: The definition we choose for OTType is actually deep: instead of
requiring ot_Type A = ot_Type B, we could just require a coercion function from
ot_Type A to ot_Type B, which would yield something more like HoTT... though
maybe it wouldn't work unless we assumed the HoTT axiom? As it is, we might need
UIP to hold if we want to use the definition given here... *)
(*
Program Definition OTType : OType :=
  {|
    ot_Type := OType;
    ot_R := (fun A B =>
               exists (e:ot_Type A = ot_Type B),
                 forall (x y:A),
                   ot_R A x y ->
                   ot_R B (rew [fun A => A] e in x)
                        (rew [fun A => A] e in y));
  |}.
*)

(***
 *** Proper Instances for Simple Ordered Types
 ***)

Instance Proper_pair A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R ==> ot_R) (pair : A -> B -> A*B).
Proof.
  repeat intro; split; assumption.
Qed.

Instance Proper_pair_equiv A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_equiv ==> ot_equiv ==> ot_equiv) (pair : A -> B -> A*B).
Proof.
  intros a1 a2 Ra b1 b2 Rb; destruct Ra; destruct Rb; split; split; assumption.
Qed.

Instance Proper_fst A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R) (fst : A*B -> A).
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_fst_equiv A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_equiv ==> ot_equiv) (fst : A*B -> A).
Proof.
  intros p1 p2 Rp. destruct Rp.
  split; eapply Proper_fst; assumption.
Qed.

Instance Proper_snd A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R) (snd : A*B -> B).
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_snd_equiv A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_equiv ==> ot_equiv) (snd : A*B -> B).
Proof.
  intros p1 p2 Rp. destruct Rp.
  split; eapply Proper_snd; assumption.
Qed.

(***
 *** The Ordered Type for Functions
 ***)

(* The type of continuous, i.e. Proper, functions between ordered types *)
Record Pfun A B {RA:OTRelation A} {RB:OTRelation B} :=
  {
    pfun_app : A -> B;
    pfun_Proper : Proper (ot_R ==> ot_R) pfun_app
  }.

Arguments pfun_app {_ _ _ _} _ _.
Arguments pfun_Proper [_ _ _ _] _ _ _ _.

Notation "A '-o>' B" :=
  (Pfun A B) (right associativity, at level 99).
Notation "x @o@ y" :=
  (pfun_app x y) (left associativity, at level 20).

(* The non-dependent function ordered type *)
Instance OTarrow_R A B {RA:OTRelation A} {RB:OTRelation B} : OTRelation (A -o> B) :=
  fun f g =>
    forall a1 a2, ot_R a1 a2 -> ot_R (pfun_app f a1) (pfun_app g a2).

Instance OTarrow A B `{OType A} `{OType B} : OType (A -o> B).
Proof.
  repeat constructor; intro; intros; intro; intros.
  { apply pfun_Proper; assumption. }
  { transitivity (pfun_app y a1).
    - apply H1; reflexivity.
    - apply H2; assumption. }
Qed.

(* FIXME: could also do a forall type, but need the second type argument, B, to
itself be proper, i.e., to be an element of OTarrow A OType. *)

(* pfun_app is always Proper *)
Instance Proper_pfun_app A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R ==> ot_R) (@pfun_app A B _ _).
Proof.
  intros f1 f2 Rf a1 a2 Ra. apply Rf; assumption.
Qed.

(* pfun_app is always Proper w.r.t. ot_equiv *)
Instance Proper_pfun_app_equiv A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_equiv ==> ot_equiv ==> ot_equiv) (@pfun_app A B _ _).
Proof.
  intros f1 f2 Rf a1 a2 Ra; destruct Rf; destruct Ra.
  split; apply Proper_pfun_app; assumption.
Qed.

Instance Proper_pfun_app_partial A B `{OTRelation A} `{OTRelation B} f :
  Proper (ot_R ==> ot_R) (pfun_app (A:=A) (B:=B) f).
Proof.
  apply pfun_Proper.
Qed.

Instance Proper_pfun_app_partial_equiv A B `{OTRelation A} `{OTRelation B} f :
  Proper (ot_equiv ==> ot_equiv) (@pfun_app A B _ _ f).
Proof.
  intros a1 a2 Ra; destruct Ra; split; apply pfun_Proper; assumption.
Qed.

(***
 *** Ordered Expressions
 ***)

(* Helper typeclass to control instantiation of Proper instances when we build
Proper functions in OExpr types *)
Class ProperPfun {A B} {RA:OTRelation A} {RB:OTRelation B} f : Prop :=
  properPFun : Proper (RA ==> RB) f.

(* Helper for building pfuns *)
Definition mkPfun {A B RA RB} f (prp:@ProperPfun A B RA RB f) : A -o> B :=
  {| pfun_app := f; pfun_Proper := prp |}.

Inductive OExpr : forall A {RA:OTRelation A} (a1 a2:A), Type :=
| Embed {A} {RA:OTRelation A} {a1 a2:A} (Ra:RA a1 a2) :
    @OExpr A RA a1 a2
| App {A B} {RA:OTRelation A} {RB:OTRelation B} {f1 f2 a1 a2}
       (e1: OExpr (A -o> B) f1 f2) (e2: OExpr A a1 a2) :
    OExpr B (f1 @o@ a1) (f2 @o@ a2)
| Lam {A B} {RA:OTRelation A} {RB:OTRelation B} {f1 f2}
      (e: forall (a1 a2:A), RA a1 a2 -> OExpr B (f1 a1) (f2 a2))
      {prp1 prp2} :
    OExpr (A -o> B) (mkPfun f1 prp1) (mkPfun f2 prp2)
.

(* An ordered expression is always indexed by related objects *)
Lemma Parametricity {A RA a1 a2} (e:@OExpr A RA a1 a2) : RA a1 a2.
Proof.
  induction e.
  - assumption.
  - apply Proper_pfun_app; assumption.
  - exact H.
Qed.

FIXME HERE NOW: this is not going to work!!

(* Instance to build a ProperPfun for the first function in a Lam constructor *)
Instance ProperPfun_Lam1 {A B} {RA:OTRelation A} {RB:OTRelation B} {f1 f2}
         (e: forall (a1 a2:A), RA a1 a2 -> OExpr B (f1 a1) (f2 a2)) :
  ProperPfun f1.
Proof.
  intros a1 a2 Ra. apply Parametricity. apply e.

Definition mkLam {A B} {RA:OTRelation A} {RB:OTRelation B} {f1 f2}
           (f: forall {a1 a2}, OExpr A a1 a2 -> OExpr B (f1 a1) (f2 a2)) :
  OExpr (A -> B) f1 f2 :=
  Lam (fun a1 a2 Ra => f (Embed Ra)).

Definition OConst A {RA:OTRelation A} {a} : Prop :=
  Proper RA a.

Definition ott : @OConst unit _ tt := eq_refl.

Definition opair {A} {RA:OTRelation A} {B} {RB:OTRelation B} :
  @OConst _ _ (pair (A:=A) (B:=B)).
Proof.
  repeat intro; split; assumption.
Qed.

Definition ofst A {RA:OTRelation A} B {RB:OTRelation B} :
  @OConst _ _ (fst (A:=A) (B:=B)).
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Check (fun A {RA:OTRelation A} => mkLam (fun (_:A) _ x => x)).
Check (mkLam (A:=unit) (fun _ _ x => Embed ott)).
Check (mkLam (A:=unit -> unit) (fun _ _ f => App f (Embed ott))).
Check (mkLam (fun _ _ f =>
                App f (App (App (Embed opair) (Embed ott)) (Embed ott)))).


Lemma Coq_02 : forall A B C:Prop, A /\ (B /\ C) -> (A /\ B) /\ C.
intros.
destruct H.
destruct H0.
split.
split.
apply H.
apply H0.
apply H1.
Qed.


(* https://coq-math-problems.github.io/Problem4/ *)

Require Import Hack.CMP.Fun.
Require Import Hack.CMP.Fin.
Require Import Basics.
Open Scope program_scope.

(* The proof of inj_to_surj uses four auxillary functions to
   implement a (bubble-sort like) "sort" algorithm that is applied
   to enable proof by induction on n.

   The auxillary functions (as a convenience here: Fin(n)={0..(n-1)})
   * flip (bijective): flips the first two elements in a Fin(n+2) set
   * extend: takes a function t: Fin(n)->Fin(n) and extends it to a function
             f: Fin(n+1)->F(n+1) with f(0)=0 and the rest follows the original:
             f(1+n)=1+t(n)
   * shuffle: uses flip and extend to make a bijection that given a specific
              element maps that element to 0. (Think: the element gets highest
              priority and the set is bubble-sorted up towards the top.)
   * shave: given an injective function f: Fin(n+1)->Fin(n+1) such that f(0)=0,
            then shave creates an injective function g: Fin(n)->Fin(n) such that
            1+g(n)=f(1+n). Notice that this reverses the action done by extend.
   Then inj_to_surj is proven by induction, using the above functions
   to assume without loss of generality that f(0)=0. If f(0) already mapped to
   the searched for value, were done, otherwise we shave f and use the
   induction hypothesis.

   surj_to_inj is then shown by observing that a surjective function has
   an injective right inverse (shown in Hack.CMP.Fun.right_inv), for which
   we use inj_to_surj to that it's surjective as well. Its surjectivity
   is used to show that our original function is indeed injective.
*)

Definition flip {n} := fun (y: Fin (S (S n))) => match y with
| inl _ => inr (inl tt)
| inr (inl _) => inl tt
| inr (inr z) => inr (inr z)
end.

Lemma flip_bij {n}: bij (flip (n:=n)).
Proof.
  split.
  + intros u u' G.
    case u, u' in *; try (case f in *; discriminate G).
      ++ case u, u0 in *. reflexivity.
      ++ case f, f0 in *; try discriminate G; [case u, u0|]; auto.
  + intro y. case y in *.
    ++ case u. exists (inr (inl tt)). reflexivity.
    ++ case s.
       +++ intro u. case u. exists (inl tt). reflexivity.
       +++ intro f0. exists (inr (inr f0)). reflexivity.
Qed.

Definition extend {n} (t: Fin n -> Fin n) :=
  fun (y: Fin (S n)) => match y with
| inl _ => inl tt
| inr z => inr (t z)
end.

Lemma extend_inj {n} {t: Fin n -> Fin n}:
  inj t -> inj (extend t).
Proof.
  intro ti.
  intros u u' G.
  case u, u' in *; try discriminate G.
  + case u, u0. reflexivity.
  + apply fin_inr_inj, ti in G. rewrite G. reflexivity.
Qed.

Lemma extend_surj {n} {t: Fin n -> Fin n}:
  surj t -> surj (extend t).
Proof.
  intros ts y. case y.
  + intro u. exists (inl tt). case u. reflexivity.
  + intro f0. destruct (ts f0) as [x0 x0p]. exists (inr x0).
    compute. rewrite x0p. reflexivity.
Qed.

Lemma extend_bij {n} {t: Fin n -> Fin n}:
  bij t -> bij (extend t).
Proof.
  intros [ti ts].
  constructor 1; [apply extend_inj| apply extend_surj]; assumption.
Qed.

Lemma shuffle {n}: forall x: Fin (S n),
  {s: Fin (S n) -> Fin (S n) & bij s & s x = inl tt}.
Proof.
  induction n.
  - intro x.
    exists id. all: cycle 1. {case x; intro u; case u; reflexivity. }
    split; [intros u u' H | intro v; exists v]; trivial.
  - intro x. case_eq x.
    + intros u H. dependent inversion u.
      exists id. all: cycle 1. trivial.
      split; [intros v v' G| intro v; exists v]; trivial.
    + intros f H.
      destruct (IHn f) as [t tb qt].
      pose (flip_bij (n:=n)).
      pose (extend_bij tb).
      exists (flip ∘ (extend t));
        [apply compose_bij| compute; rewrite qt]; trivial.
Qed.

Lemma shave {n m}:
  forall f: Fin (S n) -> Fin (S m),
  inj f -> f (inl tt) = inl tt ->
  {g | forall x, (inr ∘ g) x = (f ∘ inr) x & inj g }.
Proof.
  intros f I H.
  assert (forall x, {y | f (inr x) = inr y}) as F.
  {
    intro x.
    case (fin_dec (f (inr x)) (inl tt)).
    + intro G. rewrite <- G in H.
      discriminate (I _ _ H).
    + intro G.
      case_eq (f (inr x)).
      - intros u U0. case u in U0. contradiction.
      - intros f0 _. exists f0. reflexivity.
  }
  pose (g := fun x => proj1_sig (F x)).
  assert (forall x, inr (g x) = f (inr x)) as pg.
  {
    intro x.
    compute.
    pose (s := F x). replace (F x) with s by reflexivity.
    destruct s. symmetry. assumption.
  }
  exists g; [assumption|].
  intros x x' G.
  apply fin_inr_inj, I.
  fold Fin in pg.
  rewrite <- (pg x), <- (pg x'), G.
  reflexivity.
Qed.

Theorem inj_to_surj {n}: forall f: Fin n -> Fin n, inj f -> surj f.
Proof.
  intros f fi y.
  induction n.
  - case y.
  - destruct (shuffle (f (inl tt))) as [s [si ss] ps].
    fold Fin in *.
    case_eq (s y).
    + intros u H. exists (inl u). case u in *.
      rewrite <- ps in H.
      apply si. symmetry. assumption.
    + intros x' H.
      destruct (shave (s ∘ f) (compose_inj _ _ _ _ _ fi si) ps) as [g pg gi].
      fold Fin in *.
      destruct ((IHn g gi) x') as [x px].
      exists (inr x).
      unfold compose in pg.
      rewrite <- px, (pg x) in H.
      apply si. symmetry. assumption.
Qed.

Theorem surj_to_inj {n}: forall f : Fin n -> Fin n, surj f -> inj f.
Proof.
  intros f fs.
  intros x x' G.
  destruct (right_inv fs) as [g H gi].
  pose (inj_to_surj g gi) as gs.
  destruct (gs x) as [y py]. rewrite <- py, (H y) in G.
  destruct (gs x') as [y' py']. rewrite <- py', (H y') in G.
  transitivity (g y'); [rewrite G in py; symmetry|]; assumption.
Qed.


Require Import Setoid.

Require Import LeastFixpoint Wfd AngelicComposition.

Definition ftcl { T : Type } (R : T -> T -> Prop) X := (fun s s' => (X ⊡ R) s s' \/ R s s').

Theorem ftcl_monotonic : forall T R (X Y : T -> T -> Prop) , (forall s s', X s s' -> Y s s') -> forall s s', ftcl R X s s' -> ftcl R Y s s' .
Proof. firstorder. Qed.

Definition tcl { T : Type } (R : T -> T -> Prop) := lfp (ftcl R).

Theorem tcl_fix : forall { T : Type } (R : T -> T -> Prop), forall s s', tcl R s s' <-> (tcl R ⊡ R) s s' \/ R s s'.
Proof.
  intros *.
  unfold tcl.
  setoid_rewrite (lfp_fix (ftcl R) (ftcl_monotonic _ R)).
  reflexivity.
Qed.

Theorem tcl_rotate : forall { T : Type } (R : T -> T -> Prop), forall s s', (R ⊡ tcl R) s s' <-> (tcl R ⊡ R) s s'.
Proof.
  intros *.
  split.
  { intros * (sx,(HH1,HH2)).
    generalize s HH1; clear s HH1.
    pattern sx,s'.
    apply HH2; clear sx s' HH2.
    intros.
    unfold ftcl in H.
    destruct H.
    { destruct H as (x,(H,H')).
      exists x; split; auto.
      apply tcl_fix; auto.
    }
    { exists s; split; auto.
      apply tcl_fix; auto.
    }
  }
  { intros (sx,(HHtcl,HH)).
    generalize s' HH; clear s' HH.
    pattern s,sx; apply HHtcl; clear s sx HHtcl.
    intros * [ HH | HH ].
    { destruct HH as (x,(HH1,HH2)).
      intros.
      destruct (HH1 _ HH2) as (y,(HH3,HH4)).
      exists y; split; auto.
      apply tcl_fix; left; exists s'; auto.
    }
    { intros.
      exists s'; split; auto.
      apply tcl_fix; auto.
    }
  }
Qed.

Theorem tcl_trans :  forall { T : Type } (R : T -> T -> Prop), forall s s', (tcl R ⊡ tcl R) s s' -> tcl R s s'.
Proof.
  intros * (sx,(HHtcl1,HHtcl2)).
  generalize s HHtcl1; clear s HHtcl1.
  pattern sx,s'.
  apply HHtcl2; clear sx s' HHtcl2.
  intros.
  unfold ftcl in H.
  apply tcl_fix; left.
  destruct H.
  { destruct H as (sx,(HH1,HH2)).
    apply HH1 in HHtcl1.
    exists sx; auto.
  }
  { exists s; auto. }
Qed.

Theorem tcl_inv : forall T (R : T -> T -> Prop), forall s s', tcl (fun s s' => R s' s) s s' <-> tcl R s' s.
Proof.
  intros*.
  split.
  { intros HHtcl.
    pattern s,s'; apply HHtcl; clear s s' HHtcl.
    intros * HHtcl.
    unfold ftcl in HHtcl.
    destruct HHtcl.
    { destruct H as (x,(H1,H2)).
      assert ((R ⊡ tcl R) s' s) by firstorder; clear H1 H2.
      rewrite tcl_rotate in H.
      apply tcl_fix.
      auto.
    }
    { apply tcl_fix; auto. }
  }
  { intros H.
    pattern s',s; apply H; clear s' s H.
    intros.
    destruct H.
    { destruct H as (x,(H1,H2)).
      assert (((fun s s' => R s' s) ⊡ tcl (fun s s' => R s' s)) s' s) by firstorder; clear H1 H2.
      rewrite tcl_rotate in H.
      apply tcl_fix.
      auto.
    }
    { apply tcl_fix; auto. }
  }
Qed.

Theorem tcl_wfd : forall T (R : T -> T -> Prop), well_founded R -> well_founded (tcl R).
Proof.
  intros.
  apply (Wfd.by_simulation _ _ _ (fun s s' => ((tcl R) s s' \/ s = s')) R); auto.
  { intros x _; exists x; auto. }
  { intros * HH.
    rewrite rdistr_or, <- (rneutral_eq _ _ (tcl R)) in HH.
    rewrite ldistr_or, <- (lneutral_eq _ _ R).
    rewrite <- tcl_fix.
    destruct HH; auto.
    apply (tcl_trans _ _ _ H0).
  }
Qed.

Theorem tcl_dom : forall T (R : T -> T -> Prop) s, (exists s', R s s') <-> (exists s', tcl R s s').
Proof.
  intros *.
  split.
  { intros (s',HHr).
    exists s'; rewrite tcl_fix.
    auto.
  }
  { intros (s',HHtcl).
    pattern s,s'.
    apply HHtcl.
    clear HHtcl s s'.
    intros.
    destruct H.
    { destruct H as (_,(H',_)). auto. }
    { eauto. }
  }
Qed.

Theorem tcl_ran : forall T (R : T -> T -> Prop) s', (exists s, R s s') <-> (exists s, tcl R s s').
Proof.
  intros *.
  split.
  { intros (s,HHr).
    exists s; rewrite tcl_fix.
    auto.
  }
  { intros (s,HHtcl).
    pattern s,s'.
    apply HHtcl.
    clear HHtcl s s'.
    intros.
    destruct H.
    { destruct H as (k,(_,H'')). eauto. }
    { eauto. }
  }
Qed.


Require Import Arith.
Require Import Cubes.axioms
        Cubes.sprop_utils
        Cubes.arith_lemmas
        Cubes.hott_lemmas.

(** Definition of the cubes *)
(* we use the lawvere theory of 0, 1, ∨, ∧ with weakening, contraction and exchange
 n ~> m then corresponds to monotone functions 2^m -> 2^n *)

Definition finset (n : nat) : Set :=
  {m : nat | m < n}.

Theorem eq_finset {n : nat} (a b : finset n) : proj1_sig a = proj1_sig b -> a = b.
Proof.
  destruct a, b. simpl. intro H. etransitivity.
  apply (exist_transp (x := x) l H).
  rewrite (Peano_dec.le_unique (S x0) n (transport (fun m : nat => m < n) H l) l0). reflexivity.
Qed.

(* 2 ^ n *)
Definition cube (n : nat) : Set := finset n -> bool.

Definition degen_c {n : nat} (m : finset (S n)) : cube (S n) -> cube n.
  destruct m as [m p]. intros x [i q].
  destruct (lt_eq_lt_dec i m) as [[H | H] | H].
  - apply x. exists i. now apply le_S.
  - apply x. exists (S i). now apply le_n_S.
  - apply x. exists (S i). now apply le_n_S.
Defined.

Definition face_c {n : nat} (m : finset (S n)) (d : bool) : cube n -> cube (S n).
  destruct m as [m p]. intros x [i q].
  destruct (lt_eq_lt_dec i m) as [[H | H] | H].
  - apply x. exists i. eapply le_trans. exact H. now apply le_S_n.
  - exact d.
  - apply x. destruct i.
    + apply pos_ge_0 in H. destruct H.
    + exists i. apply le_S_n. exact q.
Defined.

Definition meet_c {n : nat} (m : finset n) : cube (S n) -> cube n.
  destruct m as [m p]. intros x [i q].
  destruct (lt_eq_lt_dec i m) as [[H | H] | H].
  - apply x. exists i. now apply le_S.
  - apply andb.
    + apply x. exists i. now apply le_S.
    + apply x. exists (S i). now apply le_n_S.
  - apply x. exists (S i). now apply le_n_S.
Defined.

Definition join_c {n : nat} (m : finset n) : cube (S n) -> cube n.
  destruct m as [m p]. intros x [i q].
  destruct (lt_eq_lt_dec i m) as [[H | H] | H].
  - apply x. exists i. now apply le_S.
  - apply orb.
    + apply x. exists i. now apply le_S.
    + apply x. exists (S i). now apply le_n_S.
  - apply x. exists (S i). now apply le_n_S.
Defined.

Definition exch_c {n : nat} (m : finset n) : cube (S n) -> cube (S n).
  destruct m as [m p]. intros x [i q].
  destruct (lt_eq_eq_lt_dec i m) as [[[H | H] | H] | H].
  - apply x. exists i. exact q.
  - apply x. exists (S m). now apply le_n_S.
  - apply x. exists m. now apply le_S.
  - apply x. exists i. exact q.
Defined.

Definition contr_c {n : nat} (m : finset n) : cube n -> cube (S n).
  destruct m as [m p]. intros x [i q].
  destruct (lt_eq_eq_lt_dec i m) as [[[H | H] | H] | H].
  - apply x. exists i. eapply le_trans. exact H. apply le_S_n. now apply le_S.
  - apply x. exists m. exact p.
  - apply x. exists m. exact p.
  - apply x. destruct i.
    + destruct (pos_ge_0 (S m) H).
    + exists i. now apply le_S_n.
Defined.

Inductive word : nat -> nat -> Type :=
| empty {a : nat} : word a a
| degen {a b : nat} : finset (S b) -> word a (S b) -> word a b
| face {a b : nat} : finset (S b) -> bool -> word a b -> word a (S b)
| meet {a b : nat} : finset b -> word a (S b) -> word a b
| join {a b : nat} : finset b -> word a (S b) -> word a b
| exch {a b : nat} : finset b -> word a (S b) -> word a (S b)
| contr {a b : nat} : finset b -> word a b -> word a (S b).

Fixpoint concat_word {a b c : nat} (w1 : word b c) (w2 : word a b) : word a c :=
  (match w1 in (word b c) return word a b -> word a c with
   | @empty x => (fun w : word a x => w)
   | @degen x y i w' => (fun w : word a x => degen i (concat_word w' w))
   | @face x y i d w' => (fun w : word a x => face i d (concat_word w' w))
   | @meet x y i w' => (fun w : word a x => meet i (concat_word w' w))
   | @join x y i w' => (fun w : word a x => join i (concat_word w' w))
   | @exch x y i w' => (fun w : word a x => exch i (concat_word w' w))
   | @contr x y i w' => (fun w : word a x => contr i (concat_word w' w))
   end) w2.

Fixpoint comp_word {a b : nat} (w : word a b) : cube a -> cube b :=
  match w with
  | empty => (fun x => x)
  | degen i w' => (degen_c i) o (comp_word w')
  | face i d w' => (face_c i d) o (comp_word w')
  | meet i w' => (meet_c i) o (comp_word w')
  | join i w' => (join_c i) o (comp_word w')
  | exch i w' => (exch_c i) o (comp_word w')
  | contr i w' => (contr_c i) o (comp_word w')
  end.

(** Lemmas about cubes *)

Theorem concat_id_left {a b : nat} (w : word a b) : concat_word empty w = w.
Proof.
  now compute.
Qed.

Theorem concat_id_right {a b : nat} (w : word a b) : concat_word w empty = w.
Proof.
  induction w ; simpl ; try rewrite IHw ; reflexivity.
Qed.

Theorem concat_assoc {a b c d : nat} (w1 : word c d) (w2 : word b c) (w3 : word a b) :
  concat_word w1 (concat_word w2 w3) = concat_word (concat_word w1 w2) w3.
Proof.
  induction w1 ; simpl ; try rewrite IHw1 ; reflexivity.
Qed.

Theorem comp_id {a : nat} : comp_word (@empty a) = fun x => x.
Proof.
  easy.
Qed.

Theorem concat_sound_s {a b c : nat} (w1 : word b c) (w2 : word a b) :
  comp_word w1 o comp_word w2 =s comp_word (concat_word w1 w2).
Proof.
  induction w1 ;
    simpl ;
    try (match goal with
         | |- ?XX o ?YY o ?ZZ =s ?RR => change (XX o (YY o ZZ) =s RR)
         end) ;
    try (specialize IHw1 with (w2:=w2)) ;
    try (destruct IHw1) ;
    apply refl_s.
Qed.

Theorem concat_sound {a b c : nat} (w1 : word b c) (w2 : word a b) :
  comp_word w1 o comp_word w2 = comp_word (concat_word w1 w2).
Proof.
  apply eqs_eq. apply concat_sound_s.
Qed.

Definition admissible {a b : nat} (f : cube a -> cube b) : SProp :=
  sexists_s (word a b) (fun w => (f =s comp_word w)).

Definition admissible' {a b : nat} (f : cube a -> cube b) :=
  { w : word a b | f = comp_word w }.

Theorem adm_id {a : nat} : admissible (fun x : cube a => x).
Proof.
  apply spair_s with (a:=empty). simpl.
  apply refl_s.
Qed.

Theorem adm_comp {a b c : nat} (f : cube a -> cube b) (g : cube b -> cube c) :
  admissible f -> admissible g -> admissible (g o f).
Proof.
  intros [w p] [w' q]. apply ssym in q. apply ssym in p.
  assert (admissible ((comp_word w') o (comp_word w))).
  - apply spair_s with (a:=concat_word w' w). apply concat_sound_s.
  - assert (admissible (g o (comp_word w))).
    apply (srewrite (fun g => admissible (g o comp_word w)) H q).
    apply (srewrite (fun f => admissible (g o f)) H0 p).
Qed.

Definition arrow (a b : nat) : Type :=
  @sexists (cube b -> cube a) admissible.

Definition compose {A B C : nat} (f : arrow B C) (g : arrow A B) : arrow A C :=
  (
    g.1s o f.1s ;
    adm_comp f.1s g.1s f.2s g.2s
  )s.

Notation "A ~> B" := (arrow A B) (at level 90, left associativity).

Notation "f 'ô' g" := (compose f g) (at level 50, left associativity).

Definition id {A : nat} : A ~> A :=
  (
    fun x => x ;
    adm_id
  )s.


Require Import prosa.classic.util.all.
Require Import prosa.classic.analysis.global.basic.bertogna_fp_theory.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop div path.

Module ResponseTimeIterationFP.

  Import ResponseTimeAnalysisFP.

  (* In this section, we define the algorithm of Bertogna and Cirinei's
     response-time analysis for FP 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_arrival: Job -> time.
    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.

    (* ..., and priorities based on an FP policy. *)
    Variable higher_priority: FP_policy sporadic_task.

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

    (* First, given a sequence of pairs R_prev = <..., (tsk_hp, R_hp)> of
       response-time bounds for the higher-priority tasks, we define an
       iteration that computes the response-time bound of the current task:

           R_tsk (0) = task_cost tsk
           R_tsk (step + 1) =  f (R step),

       where f is the response-time recurrence, step is the number of iterations,
       and R_tsk (0) is the initial state. *)
    Definition per_task_rta (tsk: sporadic_task)
                            (R_prev: seq task_with_response_time) (step: nat) :=
      iter step
        (fun t => task_cost tsk +
                  div_floor
                    (total_interference_bound_fp task_cost task_period tsk
                                                R_prev t)
                    num_cpus)
        (task_cost tsk).

    (* To ensure that the iteration converges, we will apply per_task_rta
       a "sufficient" number of times: task_deadline tsk - task_cost tsk + 1.
       This corresponds to the time complexity of the iteration. *)
    Definition max_steps (tsk: sporadic_task) := task_deadline tsk - task_cost tsk + 1.

    (* Next we compute the response-time bounds for the entire task set.
       Since high-priority tasks may not be schedulable, we allow the
       computation to fail.
       Thus, given the response-time bound of previous tasks, we either
       (a) append the computed response-time bound (tsk, R) of the current task
           to the list of pairs, or,
       (b) return None if the response-time analysis failed. *)
    Definition fp_bound_of_task hp_pairs tsk :=
      if hp_pairs is Some rt_bounds then
        let R := per_task_rta tsk rt_bounds (max_steps tsk) in
          if R <= task_deadline tsk then
            Some (rcons rt_bounds (tsk, R))
          else None
      else None.

    (* The response-time analysis for a given task set is defined
       as a left-fold (reduce) based on the function above.
       This either returns a list of task and response-time bounds, or None. *)
    Definition fp_claimed_bounds (ts: seq sporadic_task) :=
      foldl fp_bound_of_task (Some [::]) ts.

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

    (* In the following section, we prove several helper lemmas about the
       list of response-time bounds. The results seem trivial, but must be proven
       nonetheless since the list of response-time bounds is computed with
       a specific algorithm and there are no lemmas in the library for that. *)
    Section SimpleLemmas.

      (* First, we show that the first component of the computed list is the set of tasks. *)
      Lemma fp_claimed_bounds_unzip :
        forall ts hp_bounds,
          fp_claimed_bounds ts = Some hp_bounds ->
          unzip1 hp_bounds = ts.
      Proof.
        unfold fp_claimed_bounds in *; intros ts.
        induction ts using last_ind; first by destruct hp_bounds.
        {
          intros hp_bounds SOME.
          destruct (lastP hp_bounds) as [| hp_bounds'].
          {
            rewrite -cats1 foldl_cat /= in SOME.
            unfold fp_bound_of_task at 1 in SOME; simpl in *; desf.
            by destruct l.
          }
          rewrite -cats1 foldl_cat /= in SOME.
          unfold fp_bound_of_task at 1 in SOME; simpl in *; desf.
          move: H0 => /eqP EQSEQ.
          rewrite eqseq_rcons in EQSEQ.
          move: EQSEQ => /andP [/eqP SUBST /eqP EQSEQ]; subst.
          unfold unzip1; rewrite map_rcons; f_equal.
          by apply IHts.
        }
      Qed.

      (* Next, we show that some properties of the analysis are preserved for the
         prefixes of the list: (a) the tasks do not change, (b) R <= deadline,
         (c) R is computed using the response-time equation, ... *)
      Lemma fp_claimed_bounds_rcons :
        forall ts' hp_bounds tsk1 tsk2 R,
          (fp_claimed_bounds (rcons ts' tsk1) = Some (rcons hp_bounds (tsk2, R)) ->
           (fp_claimed_bounds ts' = Some hp_bounds /\
            tsk1 = tsk2 /\
            R = per_task_rta tsk1 hp_bounds (max_steps tsk1) /\
            R <= task_deadline tsk1)).
      Proof.
        intros ts hp_bounds tsk tsk' R.
        rewrite -cats1.
        unfold fp_claimed_bounds in *.
        rewrite foldl_cat /=.
        unfold fp_bound_of_task at 1; simpl; desf.
        intros EQ; inversion EQ; move: EQ H0 => _ /eqP EQ.
        rewrite eqseq_rcons in EQ.
        move: EQ => /andP [/eqP EQ /eqP RESP].
        by inversion RESP; repeat split; subst.
      Qed.

      (* ..., which implies that any prefix of the computation is the computation
         of the prefix. *)
      Lemma fp_claimed_bounds_take :
        forall ts hp_bounds i,
          fp_claimed_bounds ts = Some hp_bounds ->
          i <= size hp_bounds ->
          fp_claimed_bounds (take i ts) = Some (take i hp_bounds).
      Proof.
        intros ts hp_bounds i SOME LTi.
        have UNZIP := fp_claimed_bounds_unzip ts hp_bounds SOME.
        rewrite <- UNZIP in *.
        rewrite -[hp_bounds]take_size /unzip1 map_take in SOME.
        fold (unzip1 hp_bounds) in *; clear UNZIP.
        rewrite leq_eqVlt in LTi.
        move: LTi => /orP [/eqP EQ | LTi]; first by subst.
        remember (size hp_bounds) as len; apply eq_leq in Heqlen.
        induction len; first by rewrite ltn0 in LTi.
        {
          assert (TAKElen: fp_claimed_bounds (take len (unzip1 (hp_bounds))) =
                             Some (take len (hp_bounds))).
          {
            assert (exists p, p \in hp_bounds).
            {
              destruct hp_bounds; first by rewrite ltn0 in Heqlen.
              by exists t; rewrite in_cons eq_refl orTb.
            } destruct H as [[tsk R] _].
             rewrite (take_nth tsk) in SOME; last by rewrite size_map.
            rewrite (take_nth (tsk,R)) in SOME; last by done.
            destruct (nth (tsk, R) hp_bounds len) as [tsk_len R_len].
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
          rewrite ltnS leq_eqVlt in LTi.
          move: LTi => /orP [/eqP EQ | LESS]; first by subst.
          apply ltnW in Heqlen.
          by specialize (IHlen Heqlen TAKElen LESS).
        }
      Qed.

      (* If the analysis suceeds, the computed response-time bounds are no larger
         than the deadlines ... *)
      Lemma fp_claimed_bounds_le_deadline :
        forall ts' rt_bounds tsk R,
          fp_claimed_bounds ts' = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          R <= task_deadline tsk.
      Proof.
        intros ts; induction ts as [| ts' tsk_lst] using last_ind.
        {
          intros rt_bounds tsk R SOME IN.
          by inversion SOME; subst; rewrite in_nil in IN.
        }
        {
          intros rt_bounds tsk_i R SOME IN.
          destruct (lastP rt_bounds) as [|rt_bounds (tsk_lst', R_lst)];
            first by rewrite in_nil in IN.
          rewrite mem_rcons in_cons in IN; move: IN => /orP IN.
          destruct IN as [LAST | FRONT].
          {
            move: LAST => /eqP LAST.
            rewrite -cats1 in SOME.
            unfold fp_claimed_bounds in *.
            rewrite foldl_cat /= in SOME.
            unfold fp_bound_of_task in SOME.
            desf; rename H0 into EQ.
            move: EQ => /eqP EQ.
            rewrite eqseq_rcons in EQ.
            move: EQ => /andP [_ /eqP EQ].
            inversion EQ; subst.
            by apply Heq0.
          }
          {
            apply IHts with (rt_bounds := rt_bounds); last by ins.
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
        }
      Qed.

      (* ... and no smaller than the task costs. *)
      Lemma fp_claimed_bounds_ge_cost :
        forall ts' rt_bounds tsk R,
          fp_claimed_bounds ts' = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          R >= task_cost tsk.
      Proof.
        intros ts; induction ts as [| ts' tsk_lst] using last_ind.
        {
          intros rt_bounds tsk R SOME IN.
          by inversion SOME; subst; rewrite in_nil in IN.
        }
        {
          intros rt_bounds tsk_i R SOME IN.
          destruct (lastP rt_bounds) as [|rt_bounds (tsk_lst', R_lst)];
            first by rewrite in_nil in IN.
          rewrite mem_rcons in_cons in IN; move: IN => /orP IN.
          destruct IN as [LAST | FRONT].
          {
            move: LAST => /eqP LAST.
            rewrite -cats1 in SOME.
            unfold fp_claimed_bounds in *.
            rewrite foldl_cat /= in SOME.
            unfold fp_bound_of_task in SOME.
            desf; rename H0 into EQ.
            move: EQ => /eqP EQ.
            rewrite eqseq_rcons in EQ.
            move: EQ => /andP [_ /eqP EQ].
            inversion EQ; subst.
            by destruct (max_steps tsk_lst');
              [by apply leqnn | by apply leq_addr].
          }
          {
            apply IHts with (rt_bounds := rt_bounds); last by ins.
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
        }
      Qed.

      (* Short lemma about unfolding the iteration one step. *)
      Lemma per_task_rta_fold :
        forall tsk rt_bounds,
          task_cost tsk +
           div_floor (total_interference_bound_fp task_cost task_period tsk rt_bounds
                     (per_task_rta tsk rt_bounds (max_steps tsk))) num_cpus
          = per_task_rta tsk rt_bounds (max_steps tsk).+1.
      Proof.
          by done.
      Qed.

    End SimpleLemmas.

    (* In this section, we prove that if the task set is sorted by priority,
       the tasks in fp_claimed_bounds are interfering tasks.  *)
    Section HighPriorityTasks.

      (* Consider a list of previous tasks and a task tsk to be analyzed. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that the task set is sorted by unique priorities, ... *)
      Hypothesis H_task_set_is_sorted: sorted higher_priority ts.
      Hypothesis H_task_set_has_unique_priorities:
        FP_is_antisymmetric_over_task_set higher_priority ts.

      (* ...the priority order is transitive, ...*)
      Hypothesis H_priority_transitive: FP_is_transitive higher_priority.

      (* ... and that the response-time analysis succeeds. *)
      Variable hp_bounds: seq task_with_response_time.
      Variable R: time.
      Hypothesis H_analysis_succeeds: fp_claimed_bounds ts = Some hp_bounds.

      (* Let's refer to tasks by index. *)
      Variable elem: sporadic_task.
      Let TASK := nth elem ts.

      (* We prove that higher-priority tasks have smaller index. *)
      Lemma fp_claimed_bounds_hp_tasks_have_smaller_index :
        forall hp_idx idx,
          hp_idx < size ts ->
          idx < size ts ->
          hp_idx != idx ->
          higher_priority (TASK hp_idx) (TASK idx) ->
          hp_idx < idx.
      Proof.
        unfold TASK; clear TASK.
        rename ts into ts'; destruct ts' as [ts UNIQ]; simpl in *.
        intros hp_idx idx LThp LT NEQ HP.
        rewrite ltn_neqAle; apply/andP; split; first by done.
        by apply sorted_rel_implies_le_idx with (leT := higher_priority) (xs := ts) (default := elem).
      Qed.

    End HighPriorityTasks.

    (* In this section, we show that the fixed-point iteration converges. *)
    Section Convergence.

      (* Consider any list of higher-priority tasks. *)
      Variable ts_hp: list sporadic_task.

      (* Assume that the response-time analysis succeeds for the higher-priority tasks. *)
      Variable rt_bounds: seq task_with_response_time.
      Hypothesis H_test_succeeds: fp_claimed_bounds ts_hp = Some rt_bounds.

      (* Consider any task tsk to be analyzed, ... *)
      Variable tsk: sporadic_task.

      (* ... and assume all tasks have valid parameters. *)
      Hypothesis H_valid_task_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline (rcons ts_hp tsk).

      (* To simplify, let f denote the fixed-point iteration. *)
      Let f := per_task_rta tsk rt_bounds.

      (* Assume that f (max_steps tsk) is no larger than the deadline. *)
      Hypothesis H_no_larger_than_deadline: f (max_steps tsk) <= task_deadline tsk.

      (* First, we show that f is monotonically increasing. *)
      Lemma bertogna_fp_comp_f_monotonic :
        forall x1 x2, x1 <= x2 -> f x1 <= f x2.
      Proof.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
        rename H_test_succeeds into SOME,
               H_valid_task_parameters into VALID.
        intros x1 x2 LEx; unfold f, per_task_rta.
        apply fun_mon_iter_mon; [by ins | by ins; apply leq_addr |].
        clear LEx x1 x2; intros x1 x2 LEx.
        unfold div_floor, total_interference_bound_fp.
        rewrite big_seq_cond.
        rewrite [\sum_(_ <- _ | true) _]big_seq_cond.
        rewrite leq_add2l leq_div2r //.
        apply leq_sum; move => i /andP [IN _].
        destruct i as [i R].
        have GE_COST := fp_claimed_bounds_ge_cost ts_hp rt_bounds i R SOME IN.
        have UNZIP := fp_claimed_bounds_unzip ts_hp rt_bounds SOME.
        assert (IN': i \in ts_hp).
        {
          by rewrite -UNZIP; apply/mapP; exists (i,R).
        }
        unfold interference_bound_generic; simpl.
        rewrite leq_min; apply/andP; split.
        {
          apply leq_trans with (n := W task_cost task_period i R x1); first by apply geq_minl.
          exploit (VALID i); [by rewrite mem_rcons in_cons IN' orbT | ins; des].
          by apply W_monotonic; try (by done); apply GE_COST.
        }
        {
          apply leq_trans with (n := x1 - task_cost tsk + 1); first by apply geq_minr.
          by rewrite leq_add2r leq_sub2r //.
        }
      Qed.

      (* If the iteration converged at an earlier step, it remains as a fixed point. *)
      Lemma bertogna_fp_comp_f_converges_early :
        (exists k, k <= max_steps tsk /\ f k = f k.+1) ->
        f (max_steps tsk) = f (max_steps tsk).+1.
      Proof.
        by intros EX; des; apply fixedpoint.iter_fix with (k := k).
      Qed.

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

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

        (* By monotonicity, it follows that the value always increases. *)
        Lemma bertogna_fp_comp_f_increases :
          forall k,
            k <= max_steps tsk ->
            f k < f k.+1.
        Proof.
          intros k LT.
          rewrite ltn_neqAle; apply/andP; split.
            by apply H_keeps_diverging.
            by apply bertogna_fp_comp_f_monotonic, leqnSn.
        Qed.

        (* In the end, the response-time bound must exceed the deadline. Contradiction! *)
        Lemma bertogna_fp_comp_rt_grows_too_much :
          forall k,
            k <= max_steps tsk ->
            f k > k + task_cost tsk - 1.
        Proof.
          have INC := bertogna_fp_comp_f_increases.
          rename H_valid_task_parameters into TASK_PARAMS.
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *; des.
          exploit (TASK_PARAMS tsk);
            [by rewrite mem_rcons in_cons eq_refl orTb | intro PARAMS; des].
          induction k.
          {
            intros _; rewrite add0n -addn1 subh1;
              first by rewrite -addnBA // subnn addn0 /= leqnn.
            by apply PARAMS.
          }
          {
            intros LT.
            specialize (IHk (ltnW LT)).
            apply leq_ltn_trans with (n := f k); last by apply INC, ltnW.
            rewrite -addn1 -addnA [1 + _]addnC addnA -addnBA // subnn addn0.
            rewrite -(ltn_add2r 1) in IHk.
            rewrite subh1 in IHk;
              last by apply leq_trans with (n := task_cost tsk);
                [by apply PARAMS | by apply leq_addl].
            by rewrite -addnBA // subnn addn0 addn1 ltnS in IHk.
          }
        Qed.

      End DerivingContradiction.

      (* Using the lemmas above, we prove the convergence of the iteration after max_steps. *)
      Lemma per_task_rta_converges:
        f (max_steps tsk) = f (max_steps tsk).+1.
      Proof.
        have TOOMUCH := bertogna_fp_comp_rt_grows_too_much.
        have INC := bertogna_fp_comp_f_increases.
        rename H_no_larger_than_deadline into LE,
               H_valid_task_parameters into TASK_PARAMS.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *; des.

        (* Either f converges by the deadline or not. *)
        destruct ([exists k in 'I_(max_steps tsk).+1, f k == f k.+1]) eqn:EX.
        {
          move: EX => /exists_inP EX; destruct EX as [k _ ITERk].
          apply bertogna_fp_comp_f_converges_early.
          by exists k; split; [by rewrite -ltnS; apply ltn_ord | 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.
        rewrite leqNgt in LE; move: LE => /negP LE.
        exfalso; apply LE.

        assert (DIFF: forall k : nat, k <= max_steps tsk -> f k != f k.+1).
        {
          intros k LEk; rewrite -ltnS in LEk.
          by exploit (EX (Ordinal LEk)); [by done | intro DIFF; apply DIFF].
        }
        exploit TOOMUCH; [by apply DIFF | by apply leq_addr |].
        exploit (TASK_PARAMS tsk);
          [by rewrite mem_rcons in_cons eq_refl orTb | intro PARAMS; des].
        rewrite subh1; last by apply PARAMS2.
        rewrite -addnBA // subnn addn0 subn1 prednK //.
        intros LT; apply (leq_ltn_trans LT).
        by rewrite /max_steps [_ - _ + 1]addn1; apply INC, leq_addr.
      Qed.

    End Convergence.

    Section MainProof.

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

      (* Assume that 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.

      (* Assume that the task set is totally ordered by unique priorities,
         and that the priority order is transitive. *)
      Hypothesis H_task_set_is_sorted: sorted higher_priority ts.
      Hypothesis H_task_set_has_unique_priorities:
        FP_is_antisymmetric_over_task_set higher_priority ts.
      Hypothesis H_priority_is_total:
        FP_is_total_over_task_set higher_priority ts.
      Hypothesis H_priority_transitive: FP_is_transitive higher_priority.

      (* 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, arrives_in arr_seq j -> job_task j \in ts.

      (* ...jobs have valid parameters,...*)
      Hypothesis H_valid_job_parameters:
        forall j,
          arrives_in arr_seq j ->
          valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

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

      (* Then, consider any schedule of this arrival sequence such that... *)
      Variable sched: schedule Job num_cpus.
      Hypothesis H_at_least_one_cpu: num_cpus > 0.
      Hypothesis H_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched arr_seq.

      (* ...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 job_arrival sched.
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Also assume that jobs are sequential (as required by the workload bound). *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* Assume that the scheduler is work-conserving and respects the FP policy. *)
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
      Hypothesis H_respects_FP_policy:
        respects_FP_policy job_arrival job_cost job_task arr_seq sched higher_priority.

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

      (* In the following theorem, we prove that any response-time bound contained
         in fp_claimed_bounds is safe. The proof follows by induction on the task set:

           Induction hypothesis: assume all higher-priority tasks have safe response-time bounds.
           Inductive step: we prove that the response-time bound of the current task is safe.

         Note that the inductive step is a direct application of the main Theorem from
         bertogna_fp_theory.v. *)
      Theorem fp_analysis_yields_response_time_bounds :
        forall tsk R,
          (tsk, R) \In fp_claimed_bounds ts ->
          response_time_bounded_by tsk R.
      Proof.
        rename H_valid_job_parameters into JOBPARAMS, H_valid_task_parameters into TASKPARAMS.
        unfold valid_sporadic_taskset in *.
        intros tsk R MATCH.
        assert (SOME: exists hp_bounds, fp_claimed_bounds ts = Some hp_bounds /\
                                        (tsk, R) \in hp_bounds).
        {
          destruct (fp_claimed_bounds ts); last by done.
          by exists l; split.
        } clear MATCH; des; rename SOME0 into IN.

        have UNZIP := fp_claimed_bounds_unzip ts hp_bounds SOME.

        set elem := (tsk,R).
        move: IN => /(nthP elem) [idx LTidx EQ].
        set NTH := fun k => nth elem hp_bounds k.
        set TASK := fun k => (NTH k).1.
        set RESP := fun k => (NTH k).2.
        cut (response_time_bounded_by (TASK idx) (RESP idx));
          first by unfold TASK, RESP, NTH; rewrite EQ.
        clear EQ.

        assert (PAIR: forall idx, (TASK idx, RESP idx) = NTH idx).
          by intros i; unfold TASK, RESP; destruct (NTH i).

        assert (SUBST: forall i, i < size hp_bounds -> TASK i = nth tsk ts i).
          by intros i LTi; rewrite /TASK /NTH -UNZIP (nth_map elem) //.

        assert (SIZE: size hp_bounds = size ts).
          by rewrite -UNZIP size_map.

        induction idx as [idx IH'] using strong_ind.

        assert (IH: forall tsk_hp R_hp, (tsk_hp, R_hp) \in take idx hp_bounds -> response_time_bounded_by tsk_hp R_hp).
        {
          intros tsk_hp R_hp INhp.
          move: INhp => /(nthP elem) [k LTk EQ].
          rewrite size_take LTidx in LTk.
          rewrite nth_take in EQ; last by done.
          cut (response_time_bounded_by (TASK k) (RESP k));
            first by unfold TASK, RESP, NTH; rewrite EQ.
          by apply IH'; try (by done); apply (ltn_trans LTk).
        } clear IH'.

        unfold response_time_bounded_by in *.

        exploit (fp_claimed_bounds_rcons (take idx ts) (take idx hp_bounds) (TASK idx) (TASK idx) (RESP idx)).
        {
          by rewrite PAIR SUBST // -2?take_nth -?SIZE // (fp_claimed_bounds_take _ hp_bounds).
        }
        intros [_ [_ [REC DL]]].

        apply bertogna_cirinei_response_time_bound_fp with
              (task_cost0 := task_cost) (task_period0 := task_period)
              (task_deadline0 := task_deadline) (job_deadline0 := job_deadline) (tsk0 := (TASK idx))
              (job_task0 := job_task) (ts0 := ts) (hp_bounds0 := take idx hp_bounds)
              (higher_eq_priority := higher_priority); try (by done).
        {
          cut (NTH idx \in hp_bounds = true); [intros IN | by apply mem_nth].
          by rewrite set_mem -UNZIP; apply/mapP; exists (TASK idx, RESP idx); rewrite PAIR.
        }
        {
          intros hp_tsk IN INTERF.
          exists (RESP (index hp_tsk ts)).
          move: (IN) => INDEX; apply nth_index with (x0 := tsk) in INDEX.
          rewrite -{1}[hp_tsk]INDEX -SUBST; last by rewrite SIZE index_mem.
          assert (UNIQ: uniq hp_bounds).
          {
            apply map_uniq with (f := fst); unfold unzip1 in *; rewrite UNZIP.
            by destruct ts.
          }
          rewrite -filter_idx_lt_take //.
          {
            rewrite PAIR mem_filter; apply/andP; split;
              last by apply mem_nth; rewrite SIZE index_mem.
            {
              rewrite /NTH index_uniq; [| by rewrite SIZE index_mem | by done ].
              {
                move: INTERF => /andP [HP NEQ].
                apply fp_claimed_bounds_hp_tasks_have_smaller_index with
                  (ts := ts) (elem := tsk) (hp_bounds := hp_bounds);
                  try (by done);
                  [by rewrite index_mem | by rewrite -SIZE | | by rewrite INDEX -SUBST].
                apply/eqP; intro BUG; subst idx.
                rewrite SUBST -{1}INDEX in NEQ;
                  first by rewrite eq_refl in NEQ.
                by rewrite SIZE index_mem INDEX.
              }
            }
          }
        }
        {
          intros hp_tsk R_hp IN; apply mem_take in IN.
          by apply fp_claimed_bounds_ge_cost with (ts' := ts) (rt_bounds := hp_bounds).
        }
        {
          intros hp_tsk R_hp IN; apply mem_take in IN.
          by apply fp_claimed_bounds_le_deadline with (ts' := ts) (rt_bounds := hp_bounds).
        }
        {
          rewrite REC per_task_rta_fold.
          apply per_task_rta_converges with (ts_hp := take idx ts);
            [by apply fp_claimed_bounds_take; try (by apply ltnW) | | by rewrite -REC ].
          rewrite SUBST // -take_nth -?SIZE //.
          by intros i IN; eapply TASKPARAMS, mem_take, IN.
        }
      Qed.

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

      (*..., no task misses its deadline. *)
      Theorem taskset_schedulable_by_fp_rta :
        forall tsk, tsk \in ts -> no_deadline_missed_by_task tsk.
      Proof.
        have RLIST := (fp_analysis_yields_response_time_bounds).
        have UNZIP := (fp_claimed_bounds_unzip ts).
        have DL := (fp_claimed_bounds_le_deadline ts).

        unfold no_deadline_missed_by_task, task_misses_no_deadline,
               job_misses_no_deadline, completed,
               fp_schedulable, valid_sporadic_job in *.
        rename H_valid_job_parameters into JOBPARAMS.
        move => tsk INtsk j ARRj JOBtsk.
        destruct (fp_claimed_bounds ts) as [rt_bounds |]; last by ins.
        feed (UNZIP rt_bounds); first by done.
        assert (EX: exists R, (tsk, R) \in rt_bounds).
        {
          rewrite set_mem -UNZIP in INtsk; move: INtsk => /mapP EX.
          by destruct EX as [p]; destruct p as [tsk' R]; simpl in *; subst tsk'; exists R.
        } des.
        exploit (RLIST tsk R EX j ARRj); [by done | intro COMPLETED].
        exploit (DL rt_bounds tsk R); [by ins | by ins | clear DL; intro DL].
        apply leq_trans with (n := service sched j (job_arrival j + R)); first by done.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
        apply extend_sum; rewrite // leq_add2l.
        specialize (JOBPARAMS j ARRj); des; rewrite JOBPARAMS1.
          by rewrite JOBtsk.
      Qed.

      (* For completeness, since all jobs of the arrival sequence
         are spawned by the task set, we also conclude that no job in
         the schedule misses its deadline. *)
      Theorem jobs_schedulable_by_fp_rta :
        forall j, arrives_in arr_seq j -> no_deadline_missed_by_job j.
      Proof.
        intros j ARRj.
        have SCHED := taskset_schedulable_by_fp_rta.
        unfold no_deadline_missed_by_task, task_misses_no_deadline in *.
        apply SCHED with (tsk := job_task j); try (by done).
        by apply H_all_jobs_from_taskset.
      Qed.

    End MainProof.

  End Analysis.

End ResponseTimeIterationFP.