(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import XRbase.
Require Import XRfunctions.
Require Import XRanalysis1.
Require Import Omega.
Local Open Scope XR_scope.

(**********)
Lemma formule :
  forall (x h l1 l2:R) (f1 f2:R -> R),
    h <> R0 ->
    f2 x <> R0 ->
    f2 (x + h) <> R0 ->
    (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
    (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
    / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
    l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
    f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
    l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
Proof.
  intros; unfold Rdiv, Rminus, Rsqr.
  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
    repeat rewrite Rinv_mult_distr; try assumption.
  replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x)).
{
  repeat rewrite Ropp_plus_distr.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  repeat rewrite Ropp_involutive.
  set (a := f2 x).
  set (b := f1 (x+h)).
  set (c := f2 (x+h)).
  set (d := f1 x).
  symmetry.
  repeat rewrite <- Rmult_assoc.
  repeat rewrite <- Rplus_assoc.
  rewrite (Rmult_comm (/c)).
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rmult_assoc;rewrite (Rmult_comm (/c));repeat rewrite <- Rmult_assoc.
  repeat rewrite Rmult_assoc;rewrite (Rmult_comm c);repeat rewrite <- Rmult_assoc.
  repeat rewrite Rmult_assoc;rewrite Rinv_l. rewrite Rmult_1_r; repeat rewrite <- Rmult_assoc.
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rmult_1_r.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  symmetry.
  repeat rewrite Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  symmetry.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  rewrite <- Rplus_0_r.
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  rewrite (Rmult_comm (/a)).
  repeat rewrite Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm l1).
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  rewrite (Rmult_comm d);repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (/a));repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (/c));repeat rewrite Rmult_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  rewrite Rplus_comm.
  rewrite (Rmult_comm (/a)).
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm a).
  repeat rewrite Rmult_assoc.
  rewrite Rinv_l, Rmult_1_r.
  rewrite (Rmult_comm d).
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (/h)).
  rewrite Rplus_opp_r.
  reflexivity.
  assumption.
  assumption.
  assumption.
  assumption.
}
  replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
  (l1 * / f2 (x + h) * (f2 x * / f2 x)).
2:{
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  reflexivity.
  assumption.
  assumption.
}
  replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
  (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))).
{
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  rewrite Rmult_comm.
  reflexivity.
}
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))).
2:{
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  rewrite Rmult_comm.
  reflexivity.
}
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))).
2:{
  rewrite <- Ropp_mult_distr_l.
  rewrite <- Ropp_mult_distr_r.
  repeat rewrite Rmult_assoc.
  repeat rewrite Ropp_mult_distr_l.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  reflexivity.
}
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
  (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h))).
2:{
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  reflexivity.
}
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))).
2:{
  rewrite <- Ropp_mult_distr_r.
  repeat rewrite Ropp_mult_distr_l.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  reflexivity.
}
  repeat rewrite <- Rinv_r_sym; try assumption || ring.
{
  rewrite <- Ropp_mult_distr_r.
  repeat rewrite Ropp_mult_distr_l.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  rewrite Rinv_l.
  reflexivity.
  assumption.
}
  apply prod_neq_R0; assumption.
Qed.

(* begin hide *)
Notation Rmin_pos := Rmin_pos (only parsing). (* compat *)
(* end hide *)

Remark Rlt_0_8 : R0 < R8.
Proof.
  unfold R8.
  apply Rplus_lt_0_compat.
  exact Rlt_0_4.
  exact Rlt_0_4.
Qed.

Lemma maj_term1 :
  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal)
    (f1 f2:R -> R),
    R0 < eps ->
    f2 x <> R0 ->
    f2 (x + h) <> R0 ->
    (forall h:R,
      h <> R0 ->
      Rabs h < alp_f1d ->
      Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / R8)) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < R2 / Rabs (f2 x)) ->
    h <> R0 ->
    Rabs h < alp_f1d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / R4.
Proof.
  intros.
  assert (H7 := H3 h H6).
  assert (H8 := H2 h H4 H5).
  apply Rle_lt_trans with
    (R2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
  rewrite Rabs_mult.
  apply Rmult_le_compat_r.
  apply Rabs_pos.
  rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
  apply Rlt_le_trans with (R2 / Rabs (f2 x) * Rabs (eps * f2 x / R8)).
  apply Rmult_lt_compat_l.
{
  unfold Rdiv.
  apply Rmult_lt_0_compat.
  exact Rlt_0_2.
  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
}
  exact H8.
  right; unfold Rdiv.
  repeat rewrite Rabs_mult.

  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm R2).
  repeat rewrite Rmult_assoc.
  replace (Rabs (/R8)) with (/R8).
  replace (/R8 * R2) with (/R4).
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  replace (Rabs eps) with eps.
  rewrite Rmult_comm.
  rewrite <- Rabs_Rinv.
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rabs_mult.
  rewrite Rinv_r.
  rewrite Rabs_R1.
  rewrite Rmult_1_l.
  reflexivity.

  assumption.
  assumption.

  rewrite Rabs_right. reflexivity.
  left. assumption.

  replace R8 with (R4*R2).
  rewrite Rinv_mult_distr.
  rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
  reflexivity.
  exact Neq_2_0.
  apply Rlt_not_eq'. exact Rlt_0_4.
  exact Neq_2_0.
  rewrite Rmult_comm.
  rewrite double.
  unfold R8.
  reflexivity.

  rewrite Rabs_right.
  reflexivity.

  left.
  apply Rinv_0_lt_compat.
  exact Rlt_0_8.
Qed.

Lemma maj_term2 :
  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal)
    (f2:R -> R),
    R0 < eps ->
    f2 x <> R0 ->
    f2 (x + h) <> R0 ->
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (R8 * l1))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < R2 / Rabs (f2 x)) ->
    h <> R0 ->
    Rabs h < alp_f2t2 ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    l1 <> R0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / R4.
Proof.
  intros.
  assert (H8 := H3 h H6).
  assert (H9 := H2 h H5).
  apply Rle_lt_trans with
    (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (R8 * l1))).
  rewrite Rabs_mult; apply Rmult_le_compat_l.
  apply Rabs_pos.
  rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (R2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (R8 * l1))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
    try assumption || discrR.
  red; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
  unfold Rdiv.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs R2) with R2.
  apply Rlt_not_eq'. exact Rlt_0_8.
  rewrite Rabs_right. reflexivity. left. exact Rlt_0_2.
  rewrite (Rmult_comm R2).
  replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * R2) with
  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * R2))).
2:{
repeat rewrite Rmult_assoc.
reflexivity.
}
{
  unfold Rdiv.
  repeat rewrite Rabs_mult.
  repeat rewrite Rmult_assoc.
  apply Rmult_lt_compat_l.
  apply Rabs_pos_lt. assumption.
  repeat rewrite Rinv_mult_distr.
  repeat rewrite Rabs_mult.
  repeat rewrite Rmult_assoc.
  apply Rmult_lt_compat_l.
  apply Rabs_pos_lt.
  apply Rinv_neq_0_compat. assumption.
  replace (Rabs R2) with R2.
  rewrite Rmult_comm.
  Search (Rabs (/ _)).
  repeat rewrite Rabs_Rinv.
  assumption.
  assumption.
  assumption.
  rewrite Rabs_right. reflexivity. left. exact Rlt_0_2.
  assumption.
  assumption.
  assumption.
  assumption.
}
  right.
  unfold Rsqr, Rdiv.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs R8) with R8.
  replace (Rabs R2) with R2.
  replace R8 with (R4 * R2).
2:{
  rewrite Rmult_comm. rewrite double. unfold R8.
  reflexivity.
}
  rewrite Rinv_mult_distr; discrR.
  replace
  (R2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ R4 * / R2 * / Rabs l1))) with
  (eps * / R4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (R2 * / R2)).
2:{
  repeat rewrite Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm R2).
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (/R2)).
  repeat rewrite Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (Rabs l1)).
  repeat rewrite Rmult_assoc.
  rewrite Rinv_l.
  rewrite Rmult_1_r.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  symmetry.
  rewrite Rmult_comm.
  repeat rewrite <- Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_l.
  rewrite Rmult_comm.
  repeat rewrite <- Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_l.
  reflexivity.

  apply Rabs_no_R0. assumption.
  apply Rabs_no_R0. assumption.
  apply Rabs_no_R0. assumption.
  exact Neq_2_0.
  apply Rabs_no_R0. assumption.
  apply Rabs_no_R0. assumption.
  apply Rabs_no_R0. assumption.
  exact Neq_2_0.
}
  repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
{
  repeat rewrite Rmult_1_r.
  reflexivity.
}
exact Neq_2_0.
apply Rlt_not_eq'. exact Rlt_0_4.
exact Neq_2_0.
rewrite Rabs_right. reflexivity. left. apply Rlt_0_2.
rewrite Rabs_right. reflexivity. left. apply Rlt_0_8.
rewrite Rabs_right. reflexivity. left. assumption.
apply Rlt_not_eq'. exact Rlt_0_8.
apply Rlt_not_eq'. exact Rlt_0_8.
Qed.

Lemma maj_term3 :
  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal)
    (f1 f2:R -> R),
    R0 < eps ->
    f2 x <> R0 ->
    f2 (x + h) <> R0 ->
    (forall h:R,
      h <> R0 ->
      Rabs h < alp_f2d ->
      Rabs ((f2 (x + h) - f2 x) / h - l2) <
      Rabs (Rsqr (f2 x) * eps / (R8 * f1 x))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < R2 / Rabs (f2 x)) ->
    h <> R0 ->
    Rabs h < alp_f2d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> R0 ->
    Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
    eps / R4.
Proof.
  intros.
  assert (H8 := H2 h H4 H5).
  assert (H9 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (R8 * f1 x))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H8.
  apply Rlt_le_trans with
    (Rabs (R2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (R8 * f1 x))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
    try assumption.
  red; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat. apply prod_neq_R0. 2:assumption.
  apply Rlt_not_eq'. exact Rlt_0_8.
  unfold Rdiv.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs R2) with R2.
  rewrite (Rmult_comm R2).
  replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * R2) with
  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * R2))).
2:{
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  reflexivity.
}
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; assumption || idtac.
  rewrite <- (Rmult_comm R2).
  unfold Rdiv in H9; exact H9.
{
  rewrite Rabs_right.
  reflexivity.
  left. exact Rlt_0_2.
}
  right.
  unfold Rsqr, Rdiv.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs R8) with R8.
  replace (Rabs R2) with R2.
  replace R8 with (R4 * R2).
2:{
  rewrite Rmult_comm.
  rewrite double.
  unfold R8.
  reflexivity.
}
  rewrite Rinv_mult_distr; discrR.
  replace
  (R2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * eps * (/ R4 * / R2 * / Rabs (f1 x)))) with
  (eps * / R4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f1 x) * / Rabs (f1 x)) * (R2 * / R2)).
2:{
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ eps).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ (/R4)).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ R2).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ (/R2)).
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ (/R2)).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  rewrite Rmult_comm.
  reflexivity.
}
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).

repeat rewrite Rmult_1_r.
reflexivity.

exact Neq_2_0.
apply Rlt_not_eq'. exact Rlt_0_4.
exact Neq_2_0.
rewrite Rabs_right. reflexivity. left. exact Rlt_0_2.
rewrite Rabs_right. reflexivity. left. exact Rlt_0_8.
rewrite Rabs_right. reflexivity. left. assumption.
apply Rlt_not_eq'. exact Rlt_0_8.
apply Rlt_not_eq'. exact Rlt_0_8.
Qed.

Lemma maj_term4 :
  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal)
    (f1 f2:R -> R),
    R0 < eps ->
    f2 x <> R0 ->
    f2 (x + h) <> R0 ->
    (forall a:R,
      Rabs a < alp_f2c ->
      Rabs (f2 (x + a) - f2 x) <
      Rabs (Rsqr (f2 x) * f2 x * eps / (R8 * f1 x * l2))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < R2 / Rabs (f2 x)) ->
    h <> R0 ->
    Rabs h < alp_f2c ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> R0 ->
    l2 <> R0 ->
    Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
    eps / R4.
Proof.
  intros.
  assert (H9 := H2 h H5).
  assert (H10 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (R8 * f1 x * l2))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (R2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (R8 * f1 x * l2))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
    assumption || idtac.
  red; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0.
  apply prod_neq_R0.
  apply Rlt_not_eq'. exact Rlt_0_8.
  assumption.
  assumption.
  unfold Rdiv.
  repeat rewrite Rinv_mult_distr;
    try assumption || (unfold Rsqr; apply prod_neq_R0; assumption).
  repeat rewrite Rabs_mult.
  replace (Rabs R2) with R2.
  replace
  (R2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * R2)))).
2:{
  repeat rewrite <- Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  repeat apply Rmult_eq_compat_l.
  reflexivity.
}

  replace
  (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h))))).
2:{
  repeat rewrite Rmult_assoc.
  reflexivity.
}
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr;
    apply prod_neq_R0; assumption.
  repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
  rewrite <- (Rmult_comm R2).
  unfold Rdiv in H10; exact H10.
{
  rewrite Rabs_right. reflexivity. left. apply Rlt_0_2.
}
  right; unfold Rsqr, Rdiv.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs R8) with R8.
  replace (Rabs R2) with R2.
  replace R8 with (R4 * R2).
2:{
  rewrite Rmult_comm.
  rewrite double.
  unfold R8.
  reflexivity.
}
  rewrite Rinv_mult_distr; discrR.
  replace
  (R2 * Rabs l2 *
    (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
      (/ R4 * / R2 * / Rabs (f1 x) * / Rabs l2))) with
  (eps * / R4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (R2 * / R2)).
2:{
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ eps).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ (/R4)).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ R2).
  repeat rewrite Rmult_assoc.
  repeat apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ (/R2)).
  repeat rewrite Rmult_assoc.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rmult_comm _ (/R2)).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  rewrite Rmult_comm.
  repeat rewrite Rmult_assoc.
  repeat apply Rmult_eq_compat_l.
  rewrite Rmult_comm.
  reflexivity.
}
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).

repeat rewrite Rmult_1_r. reflexivity.
exact Neq_2_0.
apply Rlt_not_eq'. exact Rlt_0_4.
exact Neq_2_0.
symmetry. apply Rabs_right. left. exact Rlt_0_2.
symmetry. apply Rabs_right. left. exact Rlt_0_8.
symmetry. apply Rabs_right. left. assumption.
apply Rlt_not_eq'. exact Rlt_0_8.
apply Rlt_not_eq'. exact Rlt_0_8.

apply Rmult_integral_contrapositive_currified.
apply Rlt_not_eq'. exact Rlt_0_8.
assumption.

apply Rmult_integral_contrapositive_currified.
assumption.
assumption.
Qed.

Lemma D_x_no_cond : forall x a:R, a <> R0 -> D_x no_cond x (x + a).
Proof.
  intros.
  unfold D_x, no_cond.
  split.
  trivial.
  apply Rminus_not_eq.
  unfold Rminus.
  rewrite Ropp_plus_distr.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  apply Ropp_neq_0_compat; assumption.
Qed.

Lemma Rabs_4 :
  forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
Proof.
  intros.
  apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
  replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | idtac ].
repeat rewrite <- Rplus_assoc. reflexivity.
  apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
  apply Rplus_le_compat_r.
  apply Rabs_triang.
  repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
  apply Rabs_triang.
Qed.

Lemma Rlt_4 :
  forall a b c d e f g h:R,
    a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
Proof.
  intros; apply Rlt_trans with (b + c + e + g).
  repeat apply Rplus_lt_compat_r; assumption.
  repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
  apply Rlt_trans with (d + e + g).
  rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
  rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
  apply Rplus_lt_compat_r; assumption.
  apply Rplus_lt_compat_l; assumption.
Qed.

(* begin hide *)
Notation Rmin_2 := Rmin_glb_lt (only parsing).
(* end hide *)

Lemma quadruple : forall x:R, R4 * x = x + x + x + x.
Proof.
  intro.
  unfold R4. unfold R2.
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite Rmult_1_l.
  repeat rewrite <- Rplus_assoc.
  reflexivity.
Qed.

Lemma quadruple_var : forall x:R, x = x / R4 + x / R4 + x / R4 + x / R4.
Proof.
  intro; rewrite <- quadruple.
  unfold Rdiv; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
  reflexivity.
  apply Rlt_not_eq'.
  exact Rlt_0_4.
Qed.

(**********)
Lemma continuous_neq_0 :
  forall (f:R -> R) (x0:R),
    continuity_pt f x0 ->
    f x0 <> R0 ->
    exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> R0).
Proof.
  intros; unfold continuity_pt in H; unfold continue_in in H;
    unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / R2))).
  intros; elim H1; intros.
  exists (mkposreal x H2).
  intros; assert (H5 := H3 (x0 + h)).
  cut
    (dist R_met (x0 + h) x0 < x ->
      dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / R2)).
  unfold dist; simpl; unfold R_dist;
    replace (x0 + h - x0) with h.
  intros; assert (H7 := H6 H4).
  red; intro.
  rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
    rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
      pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
  cut (R0 < Rabs (f x0)).
  intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
  cut (Rabs (/ R2) = / R2).
  assert (Hyp : R0 < R2).
exact Rlt_0_2.
  intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l R2 _ _ Hyp H10);
    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12;
      [ idtac | discrR ].
2:{ exact Neq_2_0. }
change R2 with (IZR 2) in H12. change R1 with (IZR 1) in H12.
  now apply lt_IZR in H12.
  unfold Rabs; case (Rcase_abs (/ R2)) as [Hlt|Hge].
  assert (Hyp : R0 < R2).
exact Rlt_0_2.
  assert (H11 := Rmult_lt_compat_l R2 _ _ Hyp Hlt); rewrite Rmult_0_r in H11;
    rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
  elim (Rlt_irrefl R0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
exact Neq_2_0. reflexivity.
  apply (Rabs_pos_lt _ H0).
  unfold Rminus. rewrite Rplus_comm. repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l, Rplus_0_l; reflexivity.
  assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
  intro; rewrite <- H7. unfold R_met, dist; unfold R_dist;
    unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
      apply Rabs_pos_lt.
  unfold Rdiv; apply prod_neq_R0;
    [ assumption | apply Rinv_neq_0_compat; discrR ].
exact Neq_2_0.
  intro; apply H5.
  split.
  unfold D_x, no_cond.
  split; trivial || assumption.
  assumption.
  change (R0 < Rabs (f x0 / R2)).
  apply Rabs_pos_lt; unfold Rdiv; apply prod_neq_R0.
  assumption.
  apply Rinv_neq_0_compat; discrR.
exact Neq_2_0.
Qed.


Require Import rt.util.all.
Require Import rt.model.time rt.model.arrival.basic.task.
Require Import rt.model.schedule.apa.affinity.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import Time SporadicTaskset Affinity.

  Section Defs.

    (* Let num_cpus be the number of processors. *)
    Context {num_cpus: nat}.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: time;
      task_period: time;
      task_deadline: time;
      task_affinity: affinity num_cpus
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1  == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2) &&
      (task_affinity t1 == task_affinity t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP COST]] /eqP PERIOD] /eqP DL] /eqP ALPHA.
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        move: EQ => /orP [EQ | /eqP PERIOD]; last by apply PERIOD; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP COST]; last by apply COST; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP ALPHA]; last by apply ALPHA; inversion BUG.
        by apply ID; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    (* Let num_cpus be the number of processors. *)
    Variable num_cpus: nat.

    Definition concrete_taskset :=
      taskset_of (@concrete_task_eqType num_cpus).

  End ConcreteTaskset.

End ConcreteTask.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job
               prosa.classic.model.arrival.basic.task_arrival
               prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.uni.service
               prosa.classic.model.schedule.uni.workload
               prosa.classic.model.schedule.uni.schedule
               prosa.classic.model.schedule.uni.response_time
               prosa.classic.model.schedule.uni.schedule_of_task.
Require Import prosa.classic.model.schedule.uni.limited.platform.definitions
               prosa.classic.model.schedule.uni.limited.schedule
               prosa.classic.model.schedule.uni.limited.rbf
               prosa.classic.model.schedule.uni.limited.abstract_RTA.definitions
               prosa.classic.model.schedule.uni.limited.abstract_RTA.reduction_of_search_space
               prosa.classic.model.schedule.uni.limited.abstract_RTA.abstract_seq_rta
               prosa.classic.model.schedule.uni.limited.jlfp_instantiation.
Require Import prosa.classic.model.arrival.curves.bounds.
Require Import prosa.classic.analysis.uni.arrival_curves.workload_bound.
Require Import prosa.classic.model.schedule.uni.limited.busy_interval.

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

(** * Abstract RTA for FP-schedulers *)
(** In this module we propose the abstract response-time analysis (RTA) for
    FP uniprocessor scheduling of real-time tasks with arbitrary arrival models.  *)
Module AbstractRTAforFPwithArrivalCurves.

  Import Job ArrivalCurves TaskArrival Priority ScheduleOfTask
         UniprocessorSchedule Workload Service ResponseTime MaxArrivalsWorkloadBound
         LimitedPreemptionPlatform RBF BusyIntervalJLFP JLFPInstantiation.

  Section AbstractResponseTimeAnalysisForFP.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.

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

    (* Consider any arrival sequence with consistent, non-duplicate arrivals. *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_arr_seq_is_a_set: arrival_sequence_is_a_set arr_seq.

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

    (* ... where jobs do not execute before their arrival nor after completion. *)
    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.

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

    (* Assume we have sequential jobs, i.e, jobs from the
       same task execute in the order of their arrival. *)
    Hypothesis H_sequential_jobs: sequential_jobs job_arrival job_cost sched job_task.

    (* Assume that a job cost cannot be larger than a task cost. *)
    Hypothesis H_job_cost_le_task_cost:
      cost_of_jobs_from_arrival_sequence_le_task_cost
        task_cost job_cost job_task arr_seq.

    (* Consider an arbitrary task set ts. *)
    Variable ts: list Task.

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

   (* Let max_arrivals be a family of proper arrival curves, i.e., for any task tsk in ts
      [max_arrival tsk] is (1) an arrival bound of tsk, and (2) it is a monotonic function
      that equals 0 for the empty interval delta = 0. *)
    Variable max_arrivals: Task -> time -> nat.
    Hypothesis H_family_of_proper_arrival_curves:
      family_of_proper_arrival_curves job_task arr_seq max_arrivals ts.

    (* Let tsk be any task in ts that is to be analyzed. *)
    Variable tsk: Task.
    Hypothesis H_tsk_in_ts: tsk \in ts.

    (* Consider proper job lock-in service and task lock-in functions, i.e... *)
    Variable job_lock_in_service: Job -> time.
    Variable task_lock_in_service: Task -> time.

    (* ...we assume that for all jobs with positive cost in the arrival sequence the
       lock-in service is (1) positive, (2) no bigger than costs of the corresponding
       jobs, and (3) a job becomes nonpreemptive after it reaches its lock-in service... *)
    Hypothesis H_proper_job_lock_in_service:
      proper_job_lock_in_service job_cost arr_seq sched job_lock_in_service.

    (* ...and that [task_lock_in_service tsk] is (1) no bigger than tsk's cost, (2) for any
       job of task tsk job_lock_in_service is bounded by task_lock_in_service. *)
    Hypothesis H_proper_task_lock_in_service:
      proper_task_lock_in_service
        task_cost job_task arr_seq job_lock_in_service task_lock_in_service tsk.

    (* Consider an FP policy that indicates a higher-or-equal priority relation,
       and assume that the relation is reflexive. Note that we do not relate
       the FP policy with the scheduler. However, we define functions for
       Interference and Interfering Workload that actively use the concept of
       priorities. We require the FP policy to be reflexive, so a job cannot
       cause lower-priority interference (i.e. priority inversion) to itself. *)
    Variable higher_eq_priority: FP_policy Task.
    Hypothesis H_priority_is_reflexive: FP_is_reflexive higher_eq_priority.

    (* We also lift the FP priority relation to a corresponding JLFP priority relation. *)
     Let jlfp_higher_eq_priority j1 j2 := FP_to_JLFP job_task higher_eq_priority j1 j2.

    (* For clarity, let's define some local names. *)
    Let job_pending_at := pending job_arrival job_cost sched.
    Let job_scheduled_at := scheduled_at sched.
    Let job_completed_by := completed_by job_cost sched.
    Let job_backlogged_at := backlogged job_arrival job_cost sched.
    Let arrivals_between := jobs_arrived_between arr_seq.
    Let response_time_bounded_by := is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched.
    Let quiet_time := quiet_time job_arrival job_cost arr_seq sched jlfp_higher_eq_priority.
    Let busy_interval :=  busy_interval job_arrival job_cost arr_seq sched jlfp_higher_eq_priority.
    Let task_scheduled_at :=  task_scheduled_at job_task sched.
    Let cumulative_task_interference :=
      AbstractSeqRTA.cumul_task_interference job_task arr_seq sched.

    (* We introduce task_rbf as an abbreviation of the task request bound function,
       which is defined as [task_cost(tsk) × max_arrivals(tsk,Δ)]. *)
    Let task_rbf := task_request_bound_function task_cost max_arrivals tsk.

    (* Using the sum of individual request bound functions, we define the request bound
       function of all tasks with higher-or-equal priority (with respect to tsk). *)
    Let total_hep_rbf :=
      total_hep_request_bound_function_FP task_cost higher_eq_priority max_arrivals ts tsk.

    (* Similarly, we define the request bound function of all tasks other
       than tsk with higher-or-equal priority (with respect to tsk). *)
    Let total_ohep_rbf :=
      total_ohep_request_bound_function_FP task_cost higher_eq_priority max_arrivals ts tsk.

    (* Assume that there eixsts a constant priority_inversion_bound that bounds
       the length of any priority inversion experienced by any job of tsk.
       Sinse we analyze only task tsk, we ignore the lengths of priority
       inversions incurred by any other tasks. *)
    Variable priority_inversion_bound: time.
    Hypothesis H_priority_inversion_is_bounded:
      priority_inversion_is_bounded_by
        job_arrival job_cost job_task arr_seq sched jlfp_higher_eq_priority tsk priority_inversion_bound.

    (* Let L be any positive fixed point of the busy interval recurrence. *)
    Variable L: time.
    Hypothesis H_L_positive: L > 0.
    Hypothesis H_fixed_point: L = priority_inversion_bound + total_hep_rbf L.

    (* To reduce the time complexity of the analysis, recall the notion of search space.
       Intuitively, this corresponds to all "interesting" arrival offsets that the job under
       analysis might have with regard to the beginning of its busy-window. *)
    Let is_in_search_space A := (A < L) && (task_rbf A != task_rbf (A + ε)).

    (* Let R be a value that upper-bounds the solution of each response-time recurrence,
       i.e., for any relative arrival time A in the search space, there exists a corresponding
       solution F such that [F + (task cost - task lock-in service) <= R]. *)
    Variable R: time.
    Hypothesis H_R_is_maximum:
      forall A,
        is_in_search_space A ->
        exists F,
          A + F = priority_inversion_bound
                  + (task_rbf (A + ε) - (task_cost tsk - task_lock_in_service tsk))
                  + total_ohep_rbf (A + F) /\
          F + (task_cost tsk - task_lock_in_service tsk) <= R.

    (* Instantiation of Interference *)
    (* We say that job j incurs interference at time t iff it cannot execute due to
       a higher-or-equal-priority job being scheduled, or if it incurs a priority inversion.
       (for more details see file limited.jlfp_instantiation.v) *)
    Let interference (j: Job) (t: time) :=
      interference sched jlfp_higher_eq_priority j t.

    (* Instantiation of Interfering Workload *)
    (* The interfering workload, in turn, is defined as the sum of the priority inversion
       function and interfering workload of jobs with higher or equal priority.
       (for more details see file limited.limited.jlfp_instantiation.v) *)
    Let interfering_workload (j: Job) (t: time) :=
      interfering_workload job_cost arr_seq sched jlfp_higher_eq_priority j t.

    (* Finally, we define the interference bound function as the sum of the priority
       interference bound and the higher-or-equal-priority workload. *)
    Let IBF R := priority_inversion_bound + total_ohep_rbf R.

    (** ** Filling Out Hypotheses Of Abstract RTA Theorem *)
    (** In this section we prove that all preconditions necessary to use the abstract theorem are satisfied. *)
    Section FillingOutHypothesesOfAbstractRTATheorem.

      (* First, we prove that in the instantiation of interference and interfering workload,
         we really take into account everything that can interfere with tsk's jobs, and thus,
         the scheduler satisfies the abstract notion of work conserving schedule. *)
      Lemma instantiated_i_and_w_are_consistent_with_schedule:
        AbstractRTADefinitions.work_conserving
          job_arrival job_cost job_task arr_seq sched tsk interference interfering_workload.
      Proof.
        intros j t1 t2 t ARR TSK POS BUSY NEQ; split; intros HYP.
        unfold AbstractRTADefinitions.busy_interval, AbstractRTADefinitions.busy_interval_prefix in *.
        { move: HYP => /negP.
          rewrite negb_or /is_priority_inversion /BusyIntervalJLFP.is_priority_inversion
                  /is_interference_from_another_job_with_higher_eq_priority.
          move => /andP [HYP1 HYP2].
          case SCHED: (sched t) => [s | ].
          { rewrite SCHED in HYP1, HYP2.
            move: HYP1 HYP2.
            rewrite !Bool.negb_involutive negb_and Bool.negb_involutive.
            move => HYP1 /orP [/negP HYP2| /eqP HYP2].
            - by exfalso.
            - by subst s; rewrite /scheduled_at SCHED.
          }
          { exfalso; clear HYP1 HYP2.
            eapply instantiated_busy_interval_equivalent_edf_busy_interval in BUSY; try done; first last.
            { by intros x; apply H_priority_is_reflexive. }
            { by apply job_task. }
            have EQ:= not_quiet_implies_not_idle
                        job_arrival job_cost arr_seq _
                        sched jlfp_higher_eq_priority j _ _ _ _ _ t1 t2 _ t.
            feed_n 8 EQ; try done.
            - by rewrite /jlfp_higher_eq_priority /JLFP_is_reflexive /FP_to_JLFP.
            - by move: BUSY => [PREF _].
            - by apply EQ; apply/eqP.
          }
        }
        { move: HYP => /eqP HYP.
          apply/negP.
          rewrite /interference /JLFPInstantiation.interference /is_priority_inversion
                  /BusyIntervalJLFP.is_priority_inversion
                  /jlfp_higher_eq_priority /is_interference_from_another_job_with_higher_eq_priority HYP negb_or.
          apply/andP; split.
          - by rewrite Bool.negb_involutive /FP_to_JLFP.
          - by rewrite negb_and Bool.negb_involutive; apply/orP; right.
        }
      Qed.

      (* Next, we prove that the interference and interfering workload
         functions are consistent with sequential jobs. *)
      Lemma instantiated_interference_and_workload_consistent_with_sequential_jobs:
        AbstractSeqRTA.interference_and_workload_consistent_with_sequential_jobs
          job_arrival job_cost job_task arr_seq sched tsk interference interfering_workload.
      Proof.
        intros j t1 t2 ARR TSK POS BUSY.
        eapply instantiated_busy_interval_equivalent_edf_busy_interval in BUSY; first last; try by done.
        { by intros x; apply H_priority_is_reflexive. }
        { by apply job_task. }
        eapply all_jobs_have_completed_equiv_workload_eq_service; eauto 2; intros s ARRs TSKs.
        move: (BUSY) => [[_ [QT _]] _].
        apply QT.
        - by apply in_arrivals_implies_arrived in ARRs.
        - move: TSKs => /eqP TSKs.
            by rewrite /jlfp_higher_eq_priority /FP_to_JLFP TSK TSKs.
        - by eapply in_arrivals_implies_arrived_before; eauto 2.
      Qed.

      (* Recall that L is assumed to be a fixed point of the busy interval recurrence. Thanks to
         this fact, we can prove that every busy interval (according to the concrete definition)
         is bounded. In addition, we know that the conventional concept of busy interval and the
         one obtained from the abstract definition (with the interference and interfering
         workload) coincide. Thus, it follows that any busy interval (in the abstract sense)
         is bounded. *)
      Lemma instantiated_busy_intervals_are_bounded:
        AbstractRTADefinitions.busy_intervals_are_bounded_by
          job_arrival job_cost job_task arr_seq sched tsk interference interfering_workload L.
      Proof.
        intros j ARR TSK POS.
        have EX := exists_busy_interval
                     job_arrival job_cost arr_seq _ sched _
                     jlfp_higher_eq_priority j _ _ _ _ _ _ priority_inversion_bound _ L.
        feed_n 12 EX; try eauto 2.
        { by rewrite /JLFP_is_reflexive /jlfp_higher_eq_priority /FP_to_JLFP. }
        { intros.
          rewrite {2}H_fixed_point leq_add //.
          apply total_workload_le_total_rbf'; try done.
            by intros tsko INo;  move: (H_family_of_proper_arrival_curves tsko INo) => [ARRB _].
        }
        move: EX => [t1 [t2 [H1 [H2 GGG]]]].
        exists t1, t2; split; first by done.
        split; first by done.
        eapply instantiated_busy_interval_equivalent_edf_busy_interval; eauto 2.
          by intros x; apply H_priority_is_reflexive.
      Qed.

      (* Next, we prove that IBF is indeed an interference bound.

         Recall that in module abstract_seq_RTA hypothesis task_interference_is_bounded_by expects
         to receive a function that maps some task t, the relative arrival time of a job j of task t,
         and the length of the interval to the maximum amount of interference (for more details see
         files limited.abstract_RTA.definitions and limited.abstract_RTA.abstract_seq_rta).

         However, in this module we analyze only one task -- tsk, therefore it is “hardcoded”
         inside the interference bound function IBF. Moreover, in case of a model with fixed
         priorities, interference that some job j incurs from higher-or-equal priority jobs does not
         depend on the relative arrival time of job j. Therefore, in order for the IBF signature to
         match the required signature in module abstract_seq_RTA, we wrap the IBF function in a
         function that accepts, but simply ignores, the task and the relative arrival time. *)
      Lemma instantiated_task_interference_is_bounded:
        AbstractSeqRTA.task_interference_is_bounded_by
          job_arrival job_cost job_task arr_seq sched tsk interference interfering_workload
          (fun t A R => IBF R).
      Proof.
        intros ? ? ? ? ARR TSK ? NCOMPL BUSY.
        move: (posnP (job_cost j)) => [ZERO|POS].
        { exfalso.
          move: NCOMPL => /negP COMPL; apply: COMPL.
            by rewrite /is_response_time_bound_of_job /completed_by ZERO.
        }
        eapply instantiated_busy_interval_equivalent_edf_busy_interval in BUSY; first last; try done.
        { by intros x; apply H_priority_is_reflexive. }
        { by apply job_task. }
        have T123 := cumulative_task_interference_split.
        rewrite /cumulative_task_interference in T123.
        rewrite (T123 _ _ job_arrival job_cost _ _ _ _ _ _ _ j); eauto 2; last first.
        { move: BUSY => [[_ [_ [_ /andP [GE LT]]]] _].
            by eapply arrived_between_implies_in_arrivals; eauto 2. }
        { by apply any_reflexive_FP_respects_sequential_jobs. }
        unfold IBF, interference.
        rewrite leq_add; try done.
        { unfold is_priority_inversion, FP_to_JLFP.
          unfold priority_inversion_is_bounded_by in *.
          move: (H_priority_inversion_is_bounded j ARR TSK) => BOUND.
          apply leq_trans with (cumulative_priority_inversion sched jlfp_higher_eq_priority j t1 (t1 + R0)).
          { by done. }
          { apply leq_trans with (cumulative_priority_inversion sched jlfp_higher_eq_priority j t1 t2).
            { rewrite [X in _ <= X](@big_cat_nat _ _ _ (t1 + R0)) //=.
              - by rewrite leq_addr.
              - by rewrite leq_addr.
              - by rewrite ltnW.
            }
            { by apply BOUND; move: BUSY => [PREF QT2]. }
          }
        }
        { intros.
          rewrite
            (instantiated_cumulative_interference_of_hep_tasks_equal_total_interference_of_hep_tasks
               job_arrival job_cost _ arr_seq); last first; try done.
          { by unfold quiet_time; move: BUSY => [[_ [H1 H2]] _]. }
          apply leq_trans with
              (workload_of_jobs
                 job_cost (arrivals_between t1 (t1 + R0))
                 (fun jhp : Job => jlfp_higher_eq_priority jhp j && (job_task jhp != job_task j))).
          { by apply service_of_jobs_le_workload. }
          { rewrite  /workload_of_jobs
                    /total_ohep_rbf /total_ohep_request_bound_function_FP.
            rewrite -TSK; apply total_workload_le_total_rbf; try done.
              by intros tsko INo;  move: (H_family_of_proper_arrival_curves tsko INo) => [ARRB _].
          }
        }
      Qed.

      (* Finally, we show that there exists a solution for the response-time recurrence. *)
      Section SolutionOfResponseTimeReccurenceExists.

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

        (* Given any job j of task tsk that arrives exactly A units after the beginning of
           the busy interval, the bound of the total interference incurred by j within an
           interval of length Δ is equal to [task_rbf (A + ε) - task_cost tsk + IBF Δ]. *)
        Let total_interference_bound tsk A Δ :=
          task_rbf (A + ε) - task_cost tsk + IBF Δ.

        (* Next, consider any A from the search space (in the abstract sence). *)
        Variable A: time.
        Hypothesis H_A_is_in_abstract_search_space:
          AbstractRTAReduction.is_in_search_space tsk L total_interference_bound A.

        (* We prove that A is also in the concrete search space. *)
        Lemma A_is_in_concrete_search_space:
          is_in_search_space A.
        Proof.
          unfold total_interference_bound in *.
          move: H_A_is_in_abstract_search_space => [INSP | [/andP [POSA LTL] [x [LTx INSP2]]]].
          - rewrite INSP.
            apply/andP; split; first by done.
            rewrite neq_ltn; apply/orP; left.
            rewrite {1}/task_rbf; erewrite rbf.RBF.task_rbf_0_zero; eauto 2; try done.
            rewrite add0n /task_rbf.
            apply leq_trans with (task_cost tsk).
            + by apply leq_trans with (job_cost j); rewrite -?H_job_of_tsk; eauto 2.
            + by eapply rbf.RBF.task_rbf_1_ge_task_cost; eauto 2.
          - apply/andP; split; first by done.
            apply/negP; intros EQ; move: EQ => /eqP EQ.
            apply INSP2.
            rewrite subn1 addn1 prednK; last by done.
              by rewrite -EQ.
        Qed.

        (* Then, there exists a solution for the response-time recurrence (in the abstract sense). *)
        Corollary correct_search_space:
          exists F,
            A + F = task_rbf (A + ε) - (task_cost tsk - task_lock_in_service tsk) + IBF (A + F) /\
            F + (task_cost tsk - task_lock_in_service tsk) <= R.
        Proof.
          move: (H_R_is_maximum A) => FIX.
          feed FIX; first by apply A_is_in_concrete_search_space.
          move: FIX => [F [FIX NEQ]].
          exists F; split; last by done.
          apply/eqP; rewrite {1}FIX.
            by rewrite addnA [_ + priority_inversion_bound]addnC -!addnA.
        Qed.

      End SolutionOfResponseTimeReccurenceExists.

    End FillingOutHypothesesOfAbstractRTATheorem.

    (** ** Final Theorem *)
    (* Based on the properties established above, we apply the abstract analysis
       framework to infer that R is a response-time bound for tsk. *)
    Theorem uniprocessor_response_time_bound_fp:
      response_time_bounded_by tsk R.
    Proof.
      intros js ARRs TSKs.
      move: (posnP (job_cost js)) => [ZERO|POS].
      { by rewrite /is_response_time_bound_of_job /completed_by ZERO. }
      move: H_proper_job_lock_in_service => [T1 [T2 T3]].
      move: H_proper_task_lock_in_service => [T4 T5].
      eapply AbstractSeqRTA.uniprocessor_response_time_bound_seq with
          (interference0 := interference) (interfering_workload0 := interfering_workload)
          (task_interference_bound_function := fun _ A R => IBF R) (L0 := L) (ts0 := ts); eauto 3.
      - by apply instantiated_i_and_w_are_consistent_with_schedule.
      - by apply instantiated_interference_and_workload_consistent_with_sequential_jobs.
      - by apply instantiated_busy_intervals_are_bounded.
      - by apply instantiated_task_interference_is_bounded.
      - by eapply correct_search_space; eauto 2.
    Qed.

  End AbstractResponseTimeAnalysisForFP.

End AbstractRTAforFPwithArrivalCurves.


Require Import List Arith.
Import ListNotations.

Definition serializer (A: Type) := A -> list bool.
Definition deserializer (A: Type) := list bool -> option (A * list bool).
Definition ser_deser_spec_ (A: Type) (ser : serializer A) (deser : deserializer A) :=
  forall a : A, forall bools: list bool,
      (deser (ser a ++ bools)) = Some (a, bools).
Class Serializer (A : Type) : Type := {
    serialize : A -> list bool;
    deserialize : list bool -> option (A * list bool);
    ser_deser_identity : forall a : A, forall bools: list bool,
      (deserialize (serialize a ++ bools)) = Some (a, bools);
}.

Section ListSerializer.
Variable A : Type.
Variable serA : Serializer A.

Definition extract_bools (input : option (list A * list bool)) : list bool :=
  match input with
  | None => [] (* This return value probably doesn't make sense *)
  | Some (a, bools) => bools
  end.

Fixpoint list_deserialize_strange_match (bools : list bool) :  option (list A * list bool) :=
  match bools with
  | false :: _ => Some ([], 1)
  | true :: bools =>
    match (deserialize bools) with
    | None => None
    | Some (head, bools) =>
      match bools with
      | extract_bools (list_deserialize bools) ++ rest =>
        match (list_deserialize bools) with
        | None => None
        | Some (tail, bools) => Some (head :: tail, bools)
        end
      | _ => None
      end
    | _ => None
    end
  | _ => None
  end.

End ListSerializer.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.X25519.C32.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import PeanoNat.
Require Import Ensembles.

Require Import FO_Bi_Int_Syntax.
Require Import Set_FO_Bi_Int_calcs.
Require Import Set_FO_Bi_Int_logics.

Section Extens.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

Lemma extens_diff_sFOBIC : forall P vec,
    (sFOBIC_rules (Singleton _ (atom P vec), ¬ ∞ (atom P vec))).
Proof.
intros. apply DNs with (ps:=[(Singleton _ (atom P vec), atom P vec)]).
intros. inversion H. subst. apply Ids. apply IdRule_I. apply In_singleton.
inversion H0. apply DNsRule_I.
Qed.

Theorem sFOBIC_extens_wFOBIC : forall s,
    (wFOBIC_rules s) -> (sFOBIC_rules s).
Proof.
intros s D. induction D.
(* Id *)
- inversion H. subst. apply Ids. apply IdRule_I. auto.
(* Ax *)
- inversion H. subst. apply Axs. apply AxRule_I. auto.
(* MP *)
- inversion H1. subst. assert (J1: List.In (Γ, A --> B) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A --> B) J1). assert (J2: List.In (Γ, A) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2). apply MPs with (ps:=[(Γ, A --> B); (Γ, A)]).
  intros. inversion H1. subst. auto. apply MPRule_I.
(* DNw *)
- inversion H1. subst. assert (J1: List.In (Empty_set form, A) ((Empty_set _, A) :: nil)). apply in_eq.
  pose (H0 (Empty_set _ , A) J1). pose (sFOBIC_monot (Empty_set _ , A) s Γ). simpl in s0.
  apply DNs with (ps:=[(Γ, A)]). intros. inversion H2. subst. apply s0.
  intro. intro. inversion H3. inversion H3. apply DNsRule_I.
(* Gen *)
- inversion H1. subst. assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) J1). apply Gens with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A)]). intros. inversion H2. subst.
  assumption. inversion H3. apply GenRule_I.
(* EC *)
- inversion H1. subst. assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) J1). apply ECs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑])]). intros. inversion H2. subst.
  assumption. inversion H3. apply ECRule_I.
Qed.

Theorem pair_sFOBIC_extens_wFOBIC : forall P,
    (wpair_der P) -> (spair_der P).
Proof.
intros P wpair.
unfold spair_der. unfold wpair_der in wpair.
destruct wpair. destruct H. destruct H0. exists x. repeat split ; auto.
apply sFOBIC_extens_wFOBIC. auto.
Qed.

Theorem sFOBIC_same_thms_wFOBIC : forall s,
    (sFOBIC_rules s) ->
    (forall A, ((Empty_set _, A) = s) -> (wFOBIC_rules s)).
Proof.
intros s D. induction D.
(* Ids *)
- intros A id. inversion H. subst. inversion H2. subst.
  apply Id. apply IdRule_I. auto.
(* Axs *)
- intros A id. inversion H. subst. inversion H2. subst.
  apply Ax. apply AxRule_I. auto.
(* MPs *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (@Empty_set form, A0 --> A) ((Empty_set _, A0 --> A) :: (Empty_set _, A0) :: nil)). apply in_eq.
  pose (H0 (Empty_set _, A0 --> A) J1).
  assert (J2: List.In (@Empty_set form, A0) ((Empty_set _, A0 --> A) :: (Empty_set _, A0) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Empty_set _, A0) J2).
  apply MP with (ps:=[(Empty_set _, A0 --> A); (Empty_set _, A0)]).
  intros. inversion H2. subst. apply w with (A1:=A0 --> A). auto.
  inversion H4. subst. apply w0 with (A:=A0). auto. inversion H5. apply MPRule_I.
(* DNs *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (@Empty_set form, A0) ((Empty_set _, A0) :: nil)). apply in_eq.
  pose (H0 (Empty_set _, A0) J1).
  apply DNw with (ps:=[(Empty_set _, A0)]). intros. inversion H2. subst.
  apply w with (A:=A0). auto. inversion H4. apply DNwRule_I.
(* Gen *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0) ((fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0) J1 A0). apply Gen with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0)]). intros. inversion H2. subst.
  2: inversion H4. apply w ; auto. assert (Empty_set form = fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B).
  apply Extensionality_Ensembles. split ; intro ; intro ; inversion H4.
  destruct H5. subst. inversion H6. rewrite <- H4. auto. apply GenRule_I.
(* EC *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0 --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0 --> B[↑]) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0 --> B[↑]) J1 (A0 --> B[↑])). apply EC with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B, A0 --> B[↑])]). intros. inversion H2. subst.
  2: inversion H4. apply w ; auto.
  assert (Empty_set form = fun x : form => exists B : form, x = B[↑] /\ In form (Empty_set form) B).
  apply Extensionality_Ensembles. split ; intro ; intro ; inversion H4.
  destruct H5. subst. inversion H6. rewrite <- H4. auto. apply ECRule_I.
Qed.

Theorem wFOBIC_same_thms_sFOBIC : forall s,
    (wFOBIC_rules s) ->
    (forall A, ((Empty_set _, A) = s) -> (sFOBIC_rules s)).
Proof.
intros. apply sFOBIC_extens_wFOBIC. assumption.
Qed.

End Extens.


(* This file contains the formalisation of the properties of (s-)-reduction: lemmas 26 and 7 *)

Require Import general.
Require Import iterms.
Require Import lterms.
Require Import erase_facts.
Require Import sred.
Require Import erasure.
Require Import sn.

Lemma rcontr_clc_s_minus_inversion :
  forall t1 t2, RootContr_clc_s_minus t1 t2 ->
                (exists x y, t1 = C1 @l T1 @l x @l y /\ t2 = x) \/
                (exists x y, t1 = C1 @l F1 @l x @l y /\ t2 = y) \/
                (exists x y z, t1 = C2 @l z @l x @l y /\ t2 = x /\ ErasedEqv x y) \/
                (exists x, t1 = I1 @l x /\ t2 = x) \/
                (exists x y, t1 = K1 @l x @l y /\ t2 = x) \/
                (exists ns x ys zs, t1 = S1 ns @l x @l ys @l zs /\
                                    (forall n, In n ns -> n > 0) /\
                                    is_ltup ys = true /\ is_ltup zs = true /\
                                    let l1 := tuple_of_lterm ys in
                                    let l2 := tuple_of_lterm zs in
                                    (forall x, In x l2 -> is_ltup x = false) /\
                                    length l1 = length ns /\
                                    lst_sum ns < length l2 /\
                                    All_pairs l1 ErasedEqv /\
                                    All_pairs l2 ErasedEqv /\
                                    t2 = build_s_result ns x l1 l2) \/
                (exists n x y zs, t1 = S2 n @l x @l y @l zs /\
                                  is_ltup y = false /\ is_ltup zs = true /\
                                  let l := tuple_of_lterm zs in
                                  (forall x, In x l -> is_ltup x = false) /\
                                  n > 0 /\ n < length l /\
                                  All_pairs l ErasedEqv /\
                                  t2 = x @l (lterm_of_tuple (firstn n l)) @l
                                         (glue_iterms y (lterm_of_tuple (skipn n l)))).
Proof.
  intros; ydestruct t1; simpl in *; yisolve.
Qed.

Ltac invert_rcontr_clc_s_minus :=
  repeat match goal with
         | [ H : (RootContr_clc_s_minus ?x ?y) |- ?G ] =>
           generalize (rcontr_clc_s_minus_inversion x y H); yintro; clear H
         end.

Lemma lem_rcontr_s_minus_to_contr_s_minus :
  forall x y, RootContr_clc_s_minus x y -> Contr_clc_s_minus x y.
Proof.
  pose_s_minus; ycrush.
Qed.

Lemma lem_contr_s_minus_to_contr_s :
  forall t1 t2, Contr_clc_s_minus t1 t2 -> Contr_clc_s t1 t2.
Proof.
  intros.
  induction H.
  invert_rcontr_clc_s_minus.
  rename H0 into H.
  assert (RootContr_clc_s t1 t2).
  repeat (destruct H; ycrush).
  unfold Contr_clc_s; pose_ctx_l; ycrush.
  unfold Contr_clc_s; pose_ctx_l; ycrush.
  unfold Contr_clc_s; pose_ctx_l; ycrush.
Qed.

Lemma lem_red_s_minus_to_red_s :
  forall t1 t2, Red_clc_s_minus t1 t2 -> Red_clc_s t1 t2.
Proof.
  pose lem_contr_s_minus_to_contr_s.
  intros t1 t2 H; induction H; unfold Red_clc_s; pose_rt; ycrush.
Qed.

Lemma lem_contr_s_minus_to_red_s_minus :
  forall t1 t2, Contr_clc_s_minus t1 t2 -> Red_clc_s_minus t1 t2.
Proof.
  intros; unfold Red_clc_s_minus; pose_rt; ycrush.
Qed.

Lemma lem_red_s_minus_refl : forall x, Red_clc_s_minus x x.
Proof.
  unfold Red_clc_s_minus; pose_rt; ycrush.
Qed.

Lemma lem_red_s_minus_trans : forall x y z, Red_clc_s_minus x y -> Red_clc_s_minus y z ->
                                            Red_clc_s_minus x z.
Proof.
  unfold Red_clc_s_minus; pose_rt; ycrush.
Qed.

Definition sNFm x := not (exists y, Contr_clc_s_minus x y).

Lemma lem_red_s_minus_wn : forall x, exists y, Red_clc_s_minus x y /\ sNFm y.
Proof.
  intro.
  assert (Acc (fun x y : lterm => Contr_clc_s y x) x).
  pose lem_contr_clc_s_sn; unfold well_founded in *; eauto.
  induction H.
  assert ((exists y, Contr_clc_s_minus x y) \/ not (exists y, Contr_clc_s_minus x y)).
  apply classic.
  destruct H1.
  pose lem_contr_s_minus_to_contr_s; pose lem_contr_s_minus_to_red_s_minus;
    pose lem_red_s_minus_trans; ycrush.
  assert (sNFm x).
  unfold sNFm in *; ycrush.
  ycrush.
Qed.

Lemma lem_snfm_app : forall x y, sNFm (x @l y) -> sNFm x /\ sNFm y.
Proof.
  unfold sNFm; pose_s_minus; ycrush.
Qed.

Lemma lem_snfm_app_inv : forall x y, sNFm x -> sNFm y ->
                                     ~(exists z, RootContr_clc_s_minus (x @l y) z) ->
                                     sNFm (x @l y).
Proof.
  unfold sNFm, not; yintros; yinversion H2; ycrush.
Qed.

Lemma lem_snfm_not_s_redex : forall x y, sNFm x -> RootContr_clc_s x y -> False.
Proof.
  induction x; try solve [ unfold sNFm; yintuition ].
  ydestruct x1; try solve [ unfold sNFm; yintuition ].
  unfold sNFm; pose_s_minus; ycrush.
  ydestruct x1_1; try solve [ unfold sNFm; yintuition ].
  unfold sNFm; pose_s_minus; ycrush.
  ydestruct x1_1_1; try solve [ unfold sNFm; yintuition ].
  unfold sNFm; pose_s_minus; ycrush.
  intros.
  unfold sNFm in *.
  apply H.
  simpl in *; simp_hyps.
  clear -H2.
  exists x1_2; apply s_minus_base; ycrush.
  unfold sNFm; pose_s_minus; ycrush.
  unfold sNFm; pose_s_minus; ycrush.
Qed.

Inductive Contr_clc_s_in_tuple : lterm -> lterm -> Prop :=
| cituple_base : forall x y, is_ltup x = true -> Contr_clc_s x y -> Contr_clc_s_in_tuple x y
| cituple_app_l : forall x y x', Contr_clc_s_in_tuple x x' -> Contr_clc_s_in_tuple (x @l y) (x' @l y)
| cituple_app_r : forall x y y', Contr_clc_s_in_tuple y y' -> Contr_clc_s_in_tuple (x @l y) (x @l y').

Ltac pose_cituple := pose cituple_base; pose cituple_app_l; pose cituple_app_r.

Lemma lem_snfm_contr_s_in_tuple : forall x y, sNFm x -> Contr_clc_s x y -> Contr_clc_s_in_tuple x y.
Proof.
  intros.
  induction H0; fold Contr_clc_s in *.
  pose lem_snfm_not_s_redex; yelles 1.
  pose lem_snfm_app; pose_cituple; ycrush.
  pose lem_snfm_app; pose_cituple; ycrush.
  pose lem_contr_s_ltup_0; pose_cituple; ycrush.
  pose lem_contr_s_ltup_1; pose_cituple; ycrush.
  pose lem_contr_s_ltup_2; pose_cituple; ycrush.
Qed.

Lemma lem_contr_s_in_tuple_to_contr_s :
  forall x y, Contr_clc_s_in_tuple x y -> Contr_clc_s x y.
Proof.
  intros x y H; induction H; unfold Contr_clc_s; pose_ctx_l; ycrush.
Qed.

Lemma lem_all_pairs_expand :
  forall x2 y, All_pairs (tuple_of_lterm x2) ErasedEqv -> is_ltup y = true ->
               Contr_clc_s y x2 -> All_pairs (tuple_of_lterm y) ErasedEqv.
Proof.
  intros x2 y H5 H H8.
  ydestruct y; yintuition.
  yinversion H8; fold Contr_clc_s in *.
  yelles 1.
  simpl in *; unfold All_pairs in *.
  intros.
  assert (ErasedEqv y1 x') by auto using lem_contr_s_implies_erased_eqv.
  assert (In x' (x' :: y2 :: l)).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  assert (In y2 (x' :: y2 :: l)).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  assert (forall z, In z l -> In z (x' :: y2 :: l)).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  yinversion H.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H7.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H.
  ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H7.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  ycrush.

  simpl in *; unfold All_pairs in *.
  intros.
  assert (ErasedEqv y2 y') by auto using lem_contr_s_implies_erased_eqv.
  assert (In y' (y1 :: y' :: l)).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  assert (In y1 (y1 :: y' :: l)).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  assert (forall z, In z l -> In z (y1 :: y' :: l)).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  yinversion H.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H7.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H.
  ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H7.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  ycrush.

  simpl in *; unfold All_pairs in *.
  intros.
  assert (ErasedEqv z z') by auto using lem_contr_s_implies_erased_eqv.
  assert (In y1 (y1 :: y2 :: l0 ++ z' :: l')).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  assert (In y2 (y1 :: y2 :: l0 ++ z' :: l')).
  Reconstr.hobvious Reconstr.Empty
		    (@Coq.Lists.List.not_in_cons)
		    Reconstr.Empty.
  assert (forall z, In z l0 \/ In z l' -> In z (y1 :: y2 :: l0 ++ z' :: l')).
  Reconstr.htrivial Reconstr.Empty
		    (@Coq.Lists.List.in_or_app, @Coq.Lists.List.Add_in, @Coq.Lists.List.not_in_cons, @Coq.Lists.List.in_cons)
		    (@Coq.Lists.List.In, @Coq.Init.Datatypes.app).
  assert (In z' (y1 :: y2 :: l0 ++ z' :: l')).
  assert (In z' (z' :: l')).
  ycrush.
  pose @Coq.Lists.List.in_cons; pose @Coq.Lists.List.in_or_app.
  ycrush.
  yinversion H.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  assert (In y l0 \/ In y (z :: l')).
  Reconstr.htrivial (@H0)
		    (@Coq.Lists.List.NoDup_Add, @Coq.Lists.List.elements_in_partition, @Coq.Lists.List.in_app_or, @Coq.Lists.List.in_inv)
		    (@Coq.Lists.List.In).
  destruct H.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  destruct H; try subst.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H8.
  yinversion H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H.
  ycrush.
  assert (In y l0 \/ In y (z :: l')).
  Reconstr.htrivial (@H0)
		    (@Coq.Lists.List.NoDup_Add, @Coq.Lists.List.elements_in_partition, @Coq.Lists.List.in_app_or, @Coq.Lists.List.in_inv)
		    (@Coq.Lists.List.In).
  destruct H.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  destruct H; try subst.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H0.
  assert (In x l0 \/ In x (z :: l')).
  Reconstr.htrivial (@H)
		    (@Coq.Lists.List.NoDup_Add, @Coq.Lists.List.elements_in_partition, @Coq.Lists.List.in_app_or, @Coq.Lists.List.in_inv)
		    (@Coq.Lists.List.In).
  destruct H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  destruct H0; try subst.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H8.
  assert (In x l0 \/ In x (z :: l')).
  Reconstr.htrivial (@H)
		    (@Coq.Lists.List.NoDup_Add, @Coq.Lists.List.elements_in_partition, @Coq.Lists.List.in_app_or, @Coq.Lists.List.in_inv)
		    (@Coq.Lists.List.In).
  destruct H0.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  destruct H0; try subst.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  assert (In x l0 \/ In x (z :: l')).
  Reconstr.htrivial (@H)
		    (@Coq.Lists.List.NoDup_Add, @Coq.Lists.List.elements_in_partition, @Coq.Lists.List.in_app_or, @Coq.Lists.List.in_inv)
		    (@Coq.Lists.List.In).
  assert (In y l0 \/ In y (z :: l')).
  Reconstr.htrivial (@H0)
		    (@Coq.Lists.List.NoDup_Add, @Coq.Lists.List.elements_in_partition, @Coq.Lists.List.in_app_or, @Coq.Lists.List.in_inv)
		    (@Coq.Lists.List.In).
  destruct H8; destruct H9.
  clear -H6 H8 H9 H5.
  ycrush.
  destruct H9; try subst.
  assert (In x (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  assert (In z' (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  assert (In x (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  assert (In y (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  yinversion H8.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  assert (In x (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  assert (In y (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  destruct H8; destruct H9; try subst.
  ycrush.
  assert (In y (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  assert (In z' (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  assert (In x (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  assert (In z' (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
  assert (In x (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  assert (In y (y1 :: y2 :: l0 ++ z' :: l')) by ycrush.
  pose lem_erased_eqv_sym; pose lem_erased_eqv_trans; ycrush.
Qed.

Lemma lem_tuple_length_expand :
  forall x y, is_ltup x = true -> is_ltup y = true -> Contr_clc_s x y ->
              length (tuple_of_lterm x) = length (tuple_of_lterm y).
Proof.
  intros.
  ydestruct x; ydestruct y; try yelles 1.
  yinversion H1.
  ycrush.
  ycrush.
  ycrush.
  simpl.
  induction l1; ycrush.
Qed.

Lemma lem_expand_s_in_tuple : forall y x z, Contr_clc_s_in_tuple x y -> RootContr_clc_s_minus y z ->
                                            exists z', RootContr_clc_s_minus x z'.
Proof.
  Ltac mytac :=
    match goal with
    | [ H : Contr_clc_s_in_tuple _ _ |- _ ] =>
      yinversion H; try solve [ pose lem_contr_s_preserves_is_ltup; yauto 1 ]
    end.
  intros.
  invert_rcontr_clc_s_minus.
  yintuition; simp_hyps; try subst.
  repeat mytac.
  repeat mytac.
  mytac.
  mytac.
  mytac.
  mytac.
  pose lem_contr_s_in_tuple_to_contr_s; pose lem_contr_s_erased_eqv; pose lem_erased_eqv_sym; ycrush.
  pose lem_contr_s_in_tuple_to_contr_s; pose lem_contr_s_erased_eqv; pose lem_erased_eqv_sym; ycrush.
  repeat mytac.
  yinversion H.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H2.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H1.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  ycrush.
  ycrush.
  yinversion H.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H10.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H9.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H10.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  ycrush.

  assert (is_ltup y = true).
  ycrush.
  yinversion H9; yintuition.
  assert (All_pairs (tuple_of_lterm y) ErasedEqv).
  pose lem_all_pairs_expand; ycrush.
  pose lem_contr_s_length; ycrush.

  assert (is_ltup y = true).
  ycrush.
  yinversion H10; yintuition.
  assert (All_pairs (tuple_of_lterm y) ErasedEqv).
  pose lem_all_pairs_expand; ycrush.
  pose lem_exp_s_preserves_no_nested_tuple; pose lem_tuple_length_expand.
  ycrush.

  yinversion H.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H8.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H7.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  yinversion H8.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  ycrush.

  assert (is_ltup y = false).
  assert (is_ltup y = true -> False).
  yinversion H7; pose lem_contr_s_preserves_is_ltup; ycrush.
  ycrush.
  ycrush.
  yinversion H8; yintuition.
  assert (All_pairs (tuple_of_lterm y) ErasedEqv).
  pose lem_all_pairs_expand; ycrush.
  pose lem_exp_s_preserves_no_nested_tuple; pose lem_tuple_length_expand.
  ycrush.
Qed.

Lemma lem_snfm_contr_s_in_tuple_preserved :
  forall x y, sNFm x -> Contr_clc_s_in_tuple x y -> sNFm y.
Proof.
  assert (forall y z, Contr_clc_s_minus y z -> forall x, sNFm x -> Contr_clc_s_in_tuple x y -> False).
  unfold sNFm, not in *; intros y z H.
  induction H.
  pose lem_expand_s_in_tuple; pose lem_rcontr_s_minus_to_contr_s_minus; ycrush.
  yintros.
  yinversion H1.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  assert ((exists y0 : lterm, Contr_clc_s_minus x1 y0) -> False).
  yintro; pose_s_minus; ycrush.
  ycrush.
  pose_s_minus; ycrush.
  yintros.
  yinversion H1.
  pose lem_contr_s_preserves_is_ltup; ycrush.
  pose_s_minus; ycrush.
  assert ((exists y : lterm, Contr_clc_s_minus y0 y) -> False).
  yintro; pose_s_minus; ycrush.
  ycrush.
  unfold sNFm, not in *; yelles 1.
Qed.

Lemma lem_snfm_preserved : forall x y, sNFm x -> Contr_clc_s x y -> sNFm y.
Proof.
  eauto using lem_snfm_contr_s_in_tuple, lem_snfm_contr_s_in_tuple_preserved.
Qed.

(* lemma 26 *)
Lemma lem_contr_s_minus_to_f1 :
  forall t, (forall x, Red_clc_s t x -> sNF x -> x = F1) -> Red_clc_s_minus t F1.
Proof.
  intros.
  assert (forall x, Red_clc_s t x -> sNFm x -> x = F1).
  intro x.
  assert (HH: Acc (fun x y : lterm => Contr_clc_s y x) x).
  pose lem_contr_clc_s_sn; unfold well_founded in *; eauto.
  induction HH.
  intros.
  assert ((exists y, Contr_clc_s x y) \/ ~(exists y, Contr_clc_s x y)).
  apply classic.
  destruct H4.
  simp_hyps.
  assert (sNFm x0) by eauto using lem_snfm_preserved.
  assert (Red_clc_s t x0).
  Reconstr.hobvious (@H4, @H2)
		    (lem_contr_s_minus_to_contr_s, sred.lem_red_s_trans, lem_rcontr_s_minus_to_contr_s_minus, lem_red_s_minus_to_red_s, sred.lem_contr_s_to_red_s)
		    Reconstr.Empty.
  assert (x0 = F1) by ycrush.
  assert (Contr_clc_s_in_tuple x x0) by eauto using lem_snfm_contr_s_in_tuple.
  yinversion H8; pose lem_contr_s_preserves_is_ltup; ycrush.
  assert (sNF x).
  Reconstr.htrivial (@H4)
		    (sred.lem_subterm_redex, sred.lem_basic_is_snf)
		    (sred.lterm_basic, sred.sNF, lterms.Redex_clc_s).
  ycrush.
  assert (exists x, Red_clc_s_minus t x /\ sNFm x) by auto using lem_red_s_minus_wn.
  pose lem_red_s_minus_to_red_s; ycrush.
Qed.

(* lemma 7 *)
Lemma lem_erase_contr_s_minus :
  forall t t' q, Erasure t q -> Contr_clc_s_minus t t' ->
                 exists q', Contr_clc q q' /\ Erasure t' q'.
Proof.
  Ltac mytac1 := eexists; unfold RootContr_clc; split; [ exists 0 | idtac ]; pose_erasure; yelles 1.
  assert (forall t t', Contr_clc_s_minus t t' -> forall q, Erasure t q ->
                         exists q', Contr_clc q q' /\ Erasure t' q').
  intros t t' H.
  induction H; intros.

  assert (exists q' : iterm, RootContr_clc q q' /\ Erasure t2 q').
  invert_rcontr_clc_s_minus; yintuition; simp_hyps; try subst; invert_erasure; try mytac1.
  exists y'0; unfold RootContr_clc; split; [ exists 1; simpl | auto ].
  assert (EqvClose_i (RootContr_clc_base eq) y'0 y').
  pose lem_erasure_eqv; unfold Eqv_clc0, RootContr_clc0 in *.
  ycrush.
  ydestruct y'1; yelles 1.

  exists (y'1 @i y' @i (y'0 @i y')).
  split.
  unfold RootContr_clc; exists 0; ycrush.
  ydestruct x1; ydestruct x2; yintuition.
  invert_erasure.
  assert (forall y, In y (x1_1 :: x1_2 :: l) -> Erasure y y'0).
  Reconstr.hcrush (@H3, @H10, @H11)
		  (@Coq.Lists.List.Add_in, @Coq.Lists.List.not_in_cons, @Coq.Lists.List.in_inv, @Coq.Lists.List.NoDup_Add, @Coq.Init.Peano.f_equal_nat)
		  (@Coq.Lists.List.In, @All_pairs).
  assert (forall z, In z (x2_1 :: x2_2 :: l0) -> Erasure z y').
  Reconstr.hcrush (@H9, @H15, @H16)
		  (@Coq.Lists.List.Add_in, @Coq.Lists.List.not_in_cons, @Coq.Lists.List.in_inv, @Coq.Lists.List.NoDup_Add, @Coq.Init.Peano.f_equal_nat)
		  (@Coq.Lists.List.In, @All_pairs).
  assert (is_nonempty x).
  ydestruct x; yisolve; simpl in *; omega.
  apply (lem_s_result_erasure x x0 (x1_1 :: x1_2 :: l) (x2_1 :: x2_2 :: l0) y'1 y'0 y');
    ycrush.

  exists (y'1 @i y' @i (y'0 @i y')).
  split.
  unfold RootContr_clc; exists 0; ycrush.
  ydestruct x2; yintuition.
  invert_erasure.
  assert (forall y, In y (x2_1 :: x2_2 :: l) -> Erasure y y').
  Reconstr.hcrush (@H7, @H9, @H13)
		  (@Coq.Lists.List.Add_in, @Coq.Lists.List.not_in_cons, @Coq.Lists.List.in_inv, @Coq.Lists.List.NoDup_Add, @Coq.Init.Peano.f_equal_nat)
		  (@Coq.Lists.List.In, @All_pairs).
  auto using lem_s2_result_erasure.

  unfold Contr_clc; pose_ctx_i; ycrush.
  invert_erasure; pose_erasure; unfold Contr_clc; pose_ctx_i; ycrush.
  invert_erasure; pose_erasure; unfold Contr_clc; pose_ctx_i; ycrush.
  ycrush.
Qed.

Lemma lem_erase_red_s_minus :
  forall t t' q, Erasure t q -> Red_clc_s_minus t t' ->
                 exists q', Red_clc q q' /\ Erasure t' q'.
Proof.
  assert (forall t t', Red_clc_s_minus t t' ->
                       forall q, Erasure t q ->
                                 exists q', Red_clc q q' /\ Erasure t' q').
  intros t t' H.
  induction H.
  pose lem_erase_contr_s_minus; pose_rt; ycrush.
  ycrush.
  unfold Red_clc in *; pose_rt; ycrush.
  ycrush.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * Tactics for typeclass-based setoids.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

(* $Id: SetoidTactics.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Import Coq.Classes.Morphisms Coq.Classes.Morphisms_Prop.
Require Export Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.Equivalence Coq.Program.Basics.

Generalizable Variables A R.

Export ProperNotations.

Set Implicit Arguments.
Unset Strict Implicit.

(** Default relation on a given support. Can be used by tactics
   to find a sensible default relation on any carrier. Users can
   declare an [Instance def : DefaultRelation A RA] anywhere to
   declare default relations. *)

Class DefaultRelation A (R : relation A).

(** To search for the default relation, just call [default_relation]. *)

Definition default_relation `{DefaultRelation A R} := R.

(** Every [Equivalence] gives a default relation, if no other is given
  (lowest priority). *)

Instance equivalence_default `(Equivalence A R) : DefaultRelation R | 4.

(** The setoid_replace tactics in Ltac, defined in terms of default relations
  and the setoid_rewrite tactic. *)

Ltac setoidreplace H t :=
  let Heq := fresh "Heq" in
    cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq ; clear Heq | t ].

Ltac setoidreplacein H H' t :=
  let Heq := fresh "Heq" in
    cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq in H' ; clear Heq | t ].

Ltac setoidreplaceinat H H' t occs :=
  let Heq := fresh "Heq" in
    cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq in H' at occs ; clear Heq | t ].

Ltac setoidreplaceat H t occs :=
  let Heq := fresh "Heq" in
    cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq at occs ; clear Heq | t ].

Tactic Notation "setoid_replace" constr(x) "with" constr(y) :=
  setoidreplace (default_relation x y) idtac.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "at" int_or_var_list(o) :=
  setoidreplaceat (default_relation x y) idtac o.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "in" hyp(id) :=
  setoidreplacein (default_relation x y) id idtac.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "in" hyp(id)
  "at" int_or_var_list(o) :=
  setoidreplaceinat (default_relation x y) id idtac o.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "by" tactic3(t) :=
  setoidreplace (default_relation x y) ltac:t.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "at" int_or_var_list(o)
  "by" tactic3(t) :=
  setoidreplaceat (default_relation x y) ltac:t o.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "in" hyp(id)
  "by" tactic3(t) :=
  setoidreplacein (default_relation x y) id ltac:t.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "in" hyp(id)
  "at" int_or_var_list(o)
  "by" tactic3(t) :=
  setoidreplaceinat (default_relation x y) id ltac:t o.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel) :=
  setoidreplace (rel x y) idtac.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel)
  "at" int_or_var_list(o) :=
  setoidreplaceat (rel x y) idtac o.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel)
  "by" tactic3(t) :=
  setoidreplace (rel x y) ltac:t.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel)
  "at" int_or_var_list(o)
  "by" tactic3(t) :=
  setoidreplaceat (rel x y) ltac:t o.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel)
  "in" hyp(id) :=
  setoidreplacein (rel x y) id idtac.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel)
  "in" hyp(id)
  "at" int_or_var_list(o) :=
  setoidreplaceinat (rel x y) id idtac o.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel)
  "in" hyp(id)
  "by" tactic3(t) :=
  setoidreplacein (rel x y) id ltac:t.

Tactic Notation "setoid_replace" constr(x) "with" constr(y)
  "using" "relation" constr(rel)
  "in" hyp(id)
  "at" int_or_var_list(o)
  "by" tactic3(t) :=
  setoidreplaceinat (rel x y) id ltac:t o.

(** The [add_morphism_tactic] tactic is run at each [Add Morphism]
   command before giving the hand back to the user to discharge the
   proof. It essentially amounts to unfold the right amount of
   [respectful] calls and substitute leibniz equalities. One can
   redefine it using [Ltac add_morphism_tactic ::= t]. *)

Require Import Coq.Program.Tactics.

Open Local Scope signature_scope.

Ltac red_subst_eq_morphism concl :=
  match concl with
    | @Logic.eq ?A ==> ?R' => red ; intros ; subst ; red_subst_eq_morphism R'
    | ?R ==> ?R' => red ; intros ; red_subst_eq_morphism R'
    | _ => idtac
  end.

Ltac destruct_proper :=
  match goal with
    | [ |- @Proper ?A ?R ?m ] => red
  end.

Ltac reverse_arrows x :=
  match x with
    | @Logic.eq ?A ==> ?R' => revert_last ; reverse_arrows R'
    | ?R ==> ?R' => do 3 revert_last ; reverse_arrows R'
    | _ => idtac
  end.

Ltac default_add_morphism_tactic :=
  unfold flip ; intros ;
  (try destruct_proper) ;
  match goal with
    | [ |- (?x ==> ?y) _ _ ] => red_subst_eq_morphism (x ==> y) ; reverse_arrows (x ==> y)
  end.

Ltac add_morphism_tactic := default_add_morphism_tactic.

Obligation Tactic := program_simpl.

(* Notation "'Morphism' s t " := (@Proper _ (s%signature) t) (at level 10, s at next level, t at next level). *)