Require Import Fiat.BinEncoders.NoEnv.Specs.

Set Implicit Arguments.

Definition bin_t := list bool.

Definition bin_encode_correct
           (data_t : Type)
           (encode : data_t -> bin_t)
           (decode : bin_t -> data_t * bin_t) :=
    forall data ext, decode (encode data ++ ext) = (data, ext).

Global Instance bin_encode_decoder
       (data_t : Type)
       (encode : data_t -> bin_t)
       (decode : bin_t -> data_t * bin_t)
       (encode_correct : bin_encode_correct encode decode)
  : decoder (fun _ => True) encode :=
  { decode := fun bin => fst (decode bin) }.
Proof.
  unfold encode_decode_correct.
  intros data pred.
  rewrite <- app_nil_r with (l:=encode data).
  rewrite encode_correct; eauto.
Defined.

Definition bin_encode_transform_pair
           (data_t : Type)
           (encode : data_t -> bin_t) :=
  fun bundle : data_t * bin_t => let (_data, _bin) := bundle
                                 in  encode _data ++ _bin.

Global Instance bin_encode_transform_pair_decoder
       (data_t : Type)
       (encode : data_t -> bin_t)
       (decode : bin_t -> data_t * bin_t)
       (encode_correct : bin_encode_correct encode decode)
  : decoder (fun _ => True) (bin_encode_transform_pair encode) :=
  { decode := decode }.
Proof.
  unfold encode_decode_correct, bin_encode_transform_pair.
  intros [data bin] pred.
  rewrite encode_correct; eauto.
Defined.


Require Export Iron.Language.SystemF2.Ki.
Require Export Iron.Language.SystemF2.TyEnv.
Require Export Iron.Language.SystemF2Store.ExpBase.
Require Export Iron.Language.SystemF2Store.ExpLift.
Require Export Iron.Language.SystemF2Store.ExpSubst.
Require Export Iron.Language.SystemF2Store.ExpAlt.

(********************************************************************)
(* Builtin expressions *)
Definition xUnit := XCon (DataCon 0 0) nil nil.

(********************************************************************)
(* Weak normal forms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XLoc
   : forall i
   , wnfX (XLoc i)

 | Wnf_XLAM
   : forall x1
   , wnfX (XLAM x1)

 | Wnf_XLam
   : forall t1 x2
   , wnfX (XLam t1 x2).

Hint Constructors wnfX.

(* Well formed expressions are closed under the given environment. *)
Inductive wfX (kn: nat) (tn: nat) (sn: nat) : exp -> Prop :=
 | WfX_XVar
   :  forall ti
   ,  ti < tn
   -> wfX kn tn sn (XVar ti)

 | WfX_XLoc
   :  forall li
   ,  li < sn
   -> wfX kn tn sn (XLoc li)

 | WfX_XLAM
   :  forall x
   ,  wfX (S kn) tn sn x
   -> wfX kn tn sn (XLAM x)

 | WfX_XAPP
   :  forall x1 t2
   ,  wfX kn tn sn x1 -> wfT kn t2
   -> wfX kn tn sn (XAPP x1 t2)

 | WfX_XLam
   :  forall t1 x2
   ,  wfT kn t1 -> wfX kn (S tn) sn x2
   -> wfX kn tn sn (XLam t1 x2)

 | WfX_XApp
   :  forall x1 x2
   ,  wfX kn tn sn x1 -> wfX kn tn sn x2
   -> wfX kn tn sn (XApp x1 x2)

 | WfX_XCon
   :  forall dc ts xs
   ,  Forall (wfT kn)       ts
   -> Forall (wfX kn tn sn) xs
   -> wfX kn tn sn (XCon dc ts xs)

 | WfX_XCase
   :  forall x alts
   ,  wfX kn tn sn x
   -> Forall (wfA kn tn sn) alts
   -> wfX kn tn sn (XCase x alts)

  | WfX_XUpdate
    :  forall c i ts x1 x2
    ,  wfX kn tn sn x1
    -> wfX kn tn sn x2
    -> wfX kn tn sn (XUpdate c i ts x1 x2)

with    wfA (kn: nat) (tn: nat) (sn: nat) : alt -> Prop :=
 | WfA_AAlt
   :  forall dc ds x tsArgs tResult
   ,  hasDef ds (DefData dc tsArgs tResult)
   -> wfX kn (tn + length tsArgs) sn x
   -> wfA kn tn sn (AAlt dc x).

Hint Constructors wfX.
Hint Constructors wfA.

(* Closed expressions are well formed under
   empty type and kind environments, but may contain store locations. *)
Definition closedX (xx: exp) : Prop
 := exists sn, wfX O O sn xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further. *)
Inductive value : exp -> Prop :=
 | Value
   :  forall xx
   ,  wnfX xx -> closedX xx
   -> value xx.
Hint Constructors value.

Lemma value_wnfX
 : forall xx, value xx -> wnfX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_wnfX.

Lemma value_closedX
 : forall xx, value xx -> closedX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_closedX.


Require Import VST.floyd.proofauto.
Require Import VST.progs.union.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Import Memdata.

Definition Gprog : funspecs :=
    ltac:(with_library prog (@nil(ident*funspec))).

Definition g_spec :=
 DECLARE _g
 WITH i: Z
 PRE [ size_t]
   PROP() PARAMS(Vptrofs (Ptrofs.repr i)) SEP()
 POST [ size_t ]
   PROP() RETURN (Vptrofs (Ptrofs.repr i)) SEP().

Lemma body_g: semax_body Vprog Gprog f_g g_spec.
Proof.
start_function.
forward.
forward.
forward.
cancel.
Qed.

Lemma decode_float32_int32:
  forall (bl: list memval) (x: float32),
 size_chunk Mfloat32 = Z.of_nat (Datatypes.length bl) ->
 decode_val Mfloat32 bl = Vsingle x ->
 decode_val Mint32 bl = Vint (Float32.to_bits x).
Proof.
intros.
unfold decode_val,decode_int,rev_if_be in *.
destruct (proj_bytes bl) eqn:?H.
inv H0.
rewrite Float32.to_of_bits. auto.
inv H0.
Qed.

Lemma NOT_decode_int32_float32:
  Archi.ptr64=false ->
 ~ (forall (bl: list memval) (x: float32),
     size_chunk Mfloat32 = Z.of_nat (Datatypes.length bl) ->
     decode_val Mint32 bl = Vint (Float32.to_bits x) ->
     decode_val Mfloat32 bl = Vsingle x).
(* This lemma illustrates a problem: it is NOT the case that
   if (bl: list memval) decodes to Vint (Float32.to_bits x)
  then it also decodes to  Vsingle x.
  See https://github.com/AbsInt/CompCert/issues/207  for a description
  of the problem; and see https://github.com/PrincetonUniversity/VST/issues/429
  for a description of the solution,  forward_store_union_hack  *)
Proof.
intro Hp.
intro.
set (x := Float32.zero). (* nothing special about zero, any value would do *)
set (i := Float32.to_bits x).
set (bl := [Fragment (Vint i) Q32 3; Fragment (Vint i) Q32 2; Fragment (Vint i) Q32 1; Fragment (Vint i) Q32 0]).
specialize (H bl x).
specialize (H (eq_refl _)).
assert (decode_val Mint32 bl = Vint (Float32.to_bits x)).
unfold decode_val, bl.
rewrite Hp.
simpl.
destruct (Val.eq (Vint i) (Vint i)); [ | congruence].
destruct (quantity_eq Q32 Q32); [ | congruence].
simpl.
reflexivity.
specialize (H H0).
clear - H. subst bl i.
unfold decode_val in H.
simpl in H. inversion H.
Qed.

Module FABS_STUFF.

Lemma shift_pos_succ:
  forall k j, (shift_pos (Pos.succ k) j = (shift_pos k j)~0)%positive.
Proof.
intros.
change ((shift_pos k j)~0)%positive
with (2 * (shift_pos k j))%positive.
apply Pos2Z.inj.
rewrite Pos2Z.inj_mul.
rewrite !shift_pos_correct.
rewrite Z.mul_assoc.
f_equal.
rewrite <- !two_power_pos_correct.
rewrite <- Pos.add_1_l.
rewrite two_power_pos_is_exp.
reflexivity.
Qed.

Lemma nan_pl_range:
 forall k p, Binary.nan_pl k p = true ->
 Z.pos p < 2 ^ (k-1).
Proof.
intros.
unfold Binary.nan_pl in H.
apply Z.ltb_lt in H.
revert k H; induction p; simpl; intros.
-
rewrite Pos2Z.inj_succ in H.
specialize (IHp (k-1)).
spec IHp; [lia | ].
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
rewrite Pos2Z.inj_xI.
lia.
-
rewrite Pos2Z.inj_succ in H.
specialize (IHp (k-1)).
spec IHp; [lia | ].
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
rewrite Pos2Z.inj_xO.
lia.
-
replace (2^(k-1)) with (2^1 * 2^(k-1-1)).
2:{ rewrite <- Z.pow_add_r by lia. f_equal. lia. }
change (2^1) with 2.
assert (0 < 2 ^ (k-1-1)).
apply Z.pow_pos_nonneg; lia.
lia.
Qed.

Definition abs_nan (any_nan: {x : Bits.binary32 | Binary.is_nan 24 128 x = true}) (f: Binary.binary_float 24 128)   :=
match f with
| @Binary.B754_nan _ _ _ p H =>
    exist (fun x : Binary.binary_float 24 128 => Binary.is_nan 24 128 x = true)
      (Binary.B754_nan 24 128 false p H) eq_refl
| _ => any_nan
end.

Lemma bounded_mantissa:
  forall prec emax m e, Binary.bounded prec emax m e = true ->
    Z.pos m < 2 ^ prec.
Proof.
intros.
unfold Binary.bounded in H.
rewrite andb_true_iff in H.
destruct H as [H H0].
apply Z.leb_le in H0.
unfold Binary.canonical_mantissa in H.
apply Zeq_bool_eq in H.
unfold FLT.FLT_exp in H.
rewrite Digits.Zpos_digits2_pos in H.
pose proof (Z.max_lub_l (Digits.Zdigits Zaux.radix2 (Z.pos m) + e - prec)
      (3 - emax - prec) e).
spec H1; [ lia | ].
clear H.
assert (Digits.Zdigits Zaux.radix2 (Z.pos m) <= prec) by lia.
clear - H.
apply Digits.Zpower_gt_Zdigits in H.
apply H.
Qed.

Lemma binary32_abs_lemma:
 forall (x : Bits.binary32)
      (any_nan : {x : Bits.binary32 | Binary.is_nan 24 128 x = true}),
  Bits.b32_of_bits (Bits.bits_of_b32 x mod 2 ^ 31) =
  Binary.Babs 24 128 (abs_nan any_nan) x.
Proof.
intros.
destruct x.
- (* B754_zero *)
destruct s; reflexivity.
- (* B754_infinity *)
destruct s; reflexivity.
- (* B754_nan *)
assert (Hpl := nan_pl_range _ _ e).
unfold Bits.b32_of_bits, Binary.Babs, Bits.bits_of_b32, Bits.bits_of_binary_float.
assert (Bits.join_bits 23 8 s (Z.pos pl) (2 ^ 8 - 1) mod 2 ^ 31 =
            Bits.join_bits 23 8 false (Z.pos pl) (2 ^ 8 - 1)).  {
 unfold Bits.join_bits.
rewrite !Z.shiftl_mul_pow2 by computable.
rewrite Z.add_0_l.
rewrite Z.mul_add_distr_r.
rewrite <- Z.add_assoc.
rewrite Z.add_mod by (compute; lia).
replace (((if s then 2 ^ 8 else 0) * 2 ^ 23) mod 2 ^ 31) with 0
  by (destruct s; reflexivity).
rewrite Z.add_0_l.
rewrite Z.mod_mod by lia.
apply Z.mod_small.
lia.
}
rewrite H; clear H.
transitivity (Binary.B754_nan 24 128 false pl e); [ | reflexivity].
clear.
replace (Bits.join_bits 23 8 false (Z.pos pl) (2 ^ 8 - 1))
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_nan 24 128 false pl e)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
reflexivity.
- (* B754_finite *)
unfold Binary.Babs.
clear.
unfold Bits.b32_of_bits, Binary.Babs, Bits.bits_of_b32, Bits.bits_of_binary_float.
pose proof (bounded_mantissa _ _ _ _ e0).
destruct (0 <=? Z.pos m - 2 ^ 23) eqn:?H.
+
apply Z.leb_le in H0.
assert (Z.pos m - 2^23 < 2^23) by lia.
replace (Bits.join_bits 23 8 s (Z.pos m - 2 ^ 23)
                 (e - (3 - 2 ^ (8 - 1) - (23 + 1)) + 1) mod  2 ^ 31)
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_finite 24 128 false m e e0)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
unfold Bits.bits_of_binary_float.
pose proof H0.
apply Z.leb_le in H2. rewrite H2. clear H2.
forget (Z.pos m - 2^23)  as i.
unfold Binary.bounded in e0.
rewrite andb_true_iff in e0.
destruct e0 as [H' ?H].
assert (-149 <= e). {
 clear - H'.
 unfold Binary.canonical_mantissa in H'.
apply Zeq_bool_eq in H'.
unfold FLT.FLT_exp in H'.
rewrite Digits.Zpos_digits2_pos in H'.
pose proof (Z.max_lub_r (Digits.Zdigits Zaux.radix2 (Z.pos m) + e - 24)
      (3 - 128 - 24) e).
spec H; lia.
}
clear H'.
apply Z.leb_le in H2.
simpl Z.sub.
replace (e - -149 + 1) with (e+150) by lia.
unfold Bits.join_bits.
rewrite !Z.shiftl_mul_pow2 by lia.
rewrite Z.add_0_l.
set (e' := e+150).
rewrite Z.mul_add_distr_r.
rewrite <- Z.add_assoc.
rewrite Z.add_mod by (compute; lia).
replace (((if s then 2 ^ 8 else 0) * 2 ^ 23) mod 2 ^ 31)
  with 0 by (destruct s; reflexivity).
rewrite Z.add_0_l.
rewrite Z.mod_mod by lia.
rewrite (Z.mod_small); auto.
subst e'.
lia.
+
replace (Bits.join_bits 23 8 s (Z.pos m) 0 mod 2 ^ 31)
 with (Bits.join_bits 23 8 false (Z.pos m) 0).
replace (Bits.join_bits 23 8 false (Z.pos m) 0)
   with (Bits.bits_of_binary_float 23 8 (Binary.B754_finite 24 128 false m e e0)).
apply (Bits.binary_float_of_bits_of_binary_float 23 8 eq_refl eq_refl eq_refl).
unfold Bits.bits_of_binary_float.
rewrite H0. auto.
clear H0.
unfold Bits.join_bits.
rewrite Z.add_mod by (compute; lia).
rewrite (Z.mod_small (Z.pos m)) by lia.
rewrite !Z.add_0_r.
replace (Z.shiftl (if s then 2 ^ 8 else 0) 23 mod 2 ^ 31) with 0 by (destruct s; reflexivity).
simpl Z.shiftl.
symmetry.
apply Z.mod_small.
lia.
Qed.

Lemma fabs_float32_lemma:
  forall x: float32,
  Float32.of_bits (Int.and (Float32.to_bits x) (Int.repr 2147483647)) =
  Float32.abs x.
Proof.
intros.
Transparent Float32.of_bits.
Transparent Float32.to_bits.
Transparent Float32.abs.
unfold Float32.of_bits, Float32.to_bits, Float32.abs.
Opaque Float32.of_bits.
Opaque Float32.to_bits.
Opaque Float32.abs.
rewrite and_repr.
change 2147483647 with (Z.ones 31).
rewrite Z.land_ones by computable.
rewrite Int.unsigned_repr
 by (pose proof (Z_mod_lt (Bits.bits_of_b32 x) (2 ^ 31) (eq_refl _)); rep_lia).
apply binary32_abs_lemma.
Qed.

End FABS_STUFF.

Module Single.

Definition fabs_single_spec :=
 DECLARE _fabs_single
 WITH x: float32
 PRE [ Tfloat F32 noattr]
   PROP() PARAMS (Vsingle x) SEP()
 POST [ Tfloat F32 noattr ]
   PROP() RETURN (Vsingle (Float32.abs x)) SEP().

Lemma body_fabs_single: semax_body Vprog Gprog f_fabs_single fabs_single_spec.
Proof.
start_function.
forward.
forward.
forward.
forward.
forward.
entailer!.
f_equal.
apply FABS_STUFF.fabs_float32_lemma.
Qed.
End Single.

Module Float.

 (* This experiment shows what kind of error message you get
   if you put the wrong LOCAL precondition.
   In fact, Vfloat x is wrong, leading to an unsatisfying precondition,
   it must be Vsingle. *)

Definition fabs_single_spec :=
 DECLARE _fabs_single
 WITH x: float
 PRE [ Tfloat F32 noattr]
   PROP() PARAMS (Vfloat x) SEP()
 POST [ Tfloat F32 noattr ]
   PROP() RETURN (Vfloat (Float.abs x)) SEP().

Lemma body_fabs_single: semax_body Vprog Gprog f_fabs_single fabs_single_spec.
Proof.
try (start_function; fail 99).
Abort.

End Float.


Require Import Coq.Bool.Sumbool.
Require Import Coq.FSets.FMapInterface.
Require Import Coq.FSets.FMapFacts.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.ContextDefinitions.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Equality.

Module FMapContextFun (E : DecidableType) (W : WSfun E).
  Module Import Properties := WProperties_fun E W.
  Import F.
  Section ctx.
    Context (E_eq_l : forall x y, E.eq x y -> x = y)
            base_type_code (var : base_type_code -> Type)
            (base_type_code_beq : base_type_code -> base_type_code -> bool)
            (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y)
            (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true).

    Definition var_cast {a b} (x : var a) : option (var b)
      := match Sumbool.sumbool_of_bool (base_type_code_beq a b), Sumbool.sumbool_of_bool (base_type_code_beq b b) with
         | left pf, left pf' => match eq_trans (base_type_code_bl_transparent _ _ pf) (eq_sym (base_type_code_bl_transparent _ _ pf')) with
                                | eq_refl => Some x
                                end
         | right _, _ | _, right _ => None
         end.
    Definition FMapContext : @Context base_type_code W.key var
      := {| ContextT := W.t { t : _ & var t };
            lookupb ctx n t
            := match W.find n ctx with
               | Some (existT t' v)
                 => var_cast v
               | None => None
               end;
            extendb ctx n t v
            := W.add n (existT _ t v) ctx;
            removeb ctx n t
            := W.remove n ctx;
            empty := W.empty _ |}.
    Lemma FMapContextOk : @ContextOk base_type_code W.key var FMapContext.
    Proof.
      split;
        repeat first [ reflexivity
                     | progress simpl in *
                     | progress intros
                     | rewrite add_eq_o by reflexivity
                     | progress rewrite ?add_neq_o, ?remove_neq_o in * by intuition
                     | progress rewrite empty_o in *
                     | progress unfold var_cast
                     | progress break_innermost_match_step
                     | rewrite concat_pV
                     | congruence
                     | rewrite base_type_code_lb in * by reflexivity ].
    Qed.
  End ctx.

  Section ctx_nd.
    Context {base_type_code var : Type}.

    Definition FMapContext_nd : @Context base_type_code W.key (fun _ => var)
      := {| ContextT := W.t var;
            lookupb ctx n t := W.find n ctx;
            extendb ctx n t v := W.add n v ctx;
            removeb ctx n t := W.remove n ctx;
            empty := W.empty _ |}.
  End ctx_nd.
End FMapContextFun.

Module FMapContext (W : WS) := FMapContextFun W.E W.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.arrival_sequence
               prosa.classic.model.priority prosa.classic.model.suspension.
Require Import prosa.classic.model.schedule.uni.schedule prosa.classic.model.schedule.uni.schedulability.
Require Import prosa.classic.model.schedule.uni.basic.platform.
Require Import prosa.classic.model.schedule.uni.susp.suspension_intervals
               prosa.classic.model.schedule.uni.susp.schedule prosa.classic.model.schedule.uni.susp.platform.
Require Import prosa.classic.model.schedule.uni.transformation.construction.
Require Import prosa.classic.implementation.uni.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop path.

Module ReductionToBasicSchedule.

  Import Job SporadicTaskset Suspension Priority SuspensionIntervals
         Schedulability ScheduleConstruction.

  (* Recall the platform constraints for suspension-oblivious and suspension-aware schedules. *)
  Module susp := ScheduleWithSuspensions.
  Module susp_oblivious := Platform.
  Module susp_aware := PlatformWithSuspensions.

  (* In this section, we perform a reduction from a suspension-aware schedule
     to a suspension-oblivious schedule, in which jobs have inflated execution costs. *)
  Section Reduction.

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

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

    (* Let ts be any task set to be analyzed. *)
    Variable ts: seq Task.

    (* Next, consider any consistent job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.

    (* ...whose jobs come from task set ts. *)
    Hypothesis H_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* Consider any JLDP policy that is reflexive, transitive and total, i.e., that
       indicates "higher or equal priority". *)
    Variable higher_eq_priority: JLDP_policy Job.
    Hypothesis H_priority_is_reflexive: JLDP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: JLDP_is_transitive higher_eq_priority.
    Hypothesis H_priority_is_total: JLDP_is_total arr_seq higher_eq_priority.

    (* Consider the original job and task costs. *)
    Variable original_job_cost: Job -> time.
    Variable original_task_cost: Task -> time.

    (* Assume that the maximum suspension time of any job is bounded according
       to the dynamic suspension model. *)
    Variable next_suspension: job_suspension Job.
    Variable task_suspension_bound: Task -> time.
    Hypothesis H_dynamic_suspensions:
      dynamic_suspension_model original_job_cost job_task next_suspension task_suspension_bound.

    (* Next, consider any suspension-aware schedule of this arrival sequence. *)
    Variable sched_susp: schedule Job.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched_susp arr_seq.

    (* Assume that jobs only execute after they arrive... *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched_susp.

    (* ...and no longer than their execution costs. *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute original_job_cost sched_susp.

    (* Also assume that the schedule is work-conserving if there are non-suspended jobs, ... *)
    Hypothesis H_work_conserving:
      susp_aware.work_conserving job_arrival original_job_cost next_suspension arr_seq sched_susp.

    (* ...that the schedule respects job priority... *)
    Hypothesis H_respects_priority:
      susp_aware.respects_JLDP_policy job_arrival original_job_cost next_suspension
                                      arr_seq sched_susp higher_eq_priority.

    (* ...and that suspended jobs are not allowed to be scheduled. *)
    Hypothesis H_respects_self_suspensions:
      respects_self_suspensions job_arrival original_job_cost next_suspension sched_susp.

    (* Now we proceed with the reduction. First, we formalize the inflation of job and task costs. *)
    Section CostInflation.

      (* Recall the total suspension time of a job in the original schedule. *)
      Let job_total_suspension :=
        total_suspension original_job_cost next_suspension.

      (* To inflate job costs, we just add the total suspension of the job. *)
      Definition inflated_job_cost (j: Job) :=
        original_job_cost j + job_total_suspension j.

      (* Similarly, to inflate task costs, we just add its suspension bound. *)
      Definition inflated_task_cost (tsk: Task) :=
        original_task_cost tsk + task_suspension_bound tsk.

      (* As shown next, this inflation produces job valid parameters. *)
      Section NewParametersAreValid.

        (* Recall the definition of valid sporadic jobs and tasks. *)
        Let jobs_are_valid job_cost task_cost :=
          forall j,
            arrives_in arr_seq j ->
            valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.
        Let tasks_are_valid task_cost :=
          valid_sporadic_taskset task_cost task_period task_deadline ts.

        (* If the inflated task costs are no larger than the deadline nor period of each task, ... *)
        Hypothesis H_inflated_cost_le_deadline_and_period:
          forall tsk,
            tsk \in ts ->
            inflated_task_cost tsk <= task_deadline tsk /\
            inflated_task_cost tsk <= task_period tsk.

        (* ...then we can prove that job parameters remain valid after the inflation. *)
        Lemma suspension_oblivious_job_parameters_remain_valid:
          jobs_are_valid original_job_cost original_task_cost ->
          jobs_are_valid inflated_job_cost inflated_task_cost.
        Proof.
          rename H_inflated_cost_le_deadline_and_period into LEdl,
                 H_dynamic_suspensions into DYN, H_jobs_from_taskset into FROMTS.
          unfold jobs_are_valid, valid_sporadic_job, valid_realtime_job.
          intros VALIDjob j ARRj; specialize (VALIDjob j ARRj); des.
          split.
          {
            split;
              first by apply leq_trans with (n := original_job_cost j);
                last by apply leq_addr.
            split; last by done.
            rewrite /job_cost_le_deadline /inflated_job_cost.
            feed (LEdl (job_task j)); [by apply FROMTS | move: LEdl => [LEdl _]].
            apply leq_trans with (n := inflated_task_cost (job_task j));
              last by rewrite VALIDjob1 LEdl.
            by apply leq_add; last by apply DYN.
          }
          split; last by done.
          by apply leq_add; last by apply DYN.
        Qed.

        (* The same applies for task parameters. *)
        Lemma suspension_oblivious_task_parameters_remain_valid:
          tasks_are_valid original_task_cost -> tasks_are_valid inflated_task_cost.
        Proof.
          rename H_inflated_cost_le_deadline_and_period into LEdl.
          unfold tasks_are_valid, valid_sporadic_taskset, is_valid_sporadic_task.
          intros VALIDtask tsk IN; specialize (VALIDtask tsk IN); des.
          split;
            first by apply: (leq_trans VALIDtask); last by apply leq_addr.
          specialize (LEdl tsk IN); move: LEdl => [LEdl LEp].
          by repeat split.
        Qed.

      End NewParametersAreValid.

    End CostInflation.

    (* Now, we are going to generate a suspension-oblivious schedule with the inflated
       job costs. For that, we always try to copy the original schedule, as long as that
       doesn't break the priority enforcement in the generated schedule. *)

    Section ScheduleConstruction.

      (* In this section, we define the schedule construction function. *)
      Section ConstructionStep.

        (* For any time t, suppose that we have generated the schedule prefix in the
           interval [0, t). Then, we must define what should be scheduled at time t. *)
        Variable sched_prefix: schedule Job.
        Variable t: time.

        (* First, consider the list of pending jobs at time t in the generated schedule. *)
        Let job_is_pending := pending job_arrival inflated_job_cost sched_prefix.
        Definition pending_jobs :=
          [seq j <- jobs_arrived_up_to arr_seq t | job_is_pending j t].

        (* From the list of pending jobs, we take one of the (possibly many) highest-priority
           jobs, or None, in case there are no pending jobs. *)
        Definition highest_priority_job := seq_min (higher_eq_priority t) pending_jobs.

        (* Then, we construct the schedule at time t as follows.
           a) If there's a job scheduled in the original schedule at time t that is also a
              highest-priority pending job in the generated schedule, copy this job.
           b) Else, pick one of the highest priority pending jobs in the generated schedule. *)

        Definition build_schedule : option Job :=
          (* If there is a highest-priority job j_hp in the generated schedule, ...*)
          if highest_priority_job is Some j_hp then
            (* ...and there is some job scheduled in the original schedule... *)
            if (sched_susp t) is Some j_sched then
              (* ...that is a highest-priority pending job,...*)
              if job_is_pending j_sched t && higher_eq_priority t j_sched j_hp then
                Some j_sched (* ...copy this scheduled job. *)
              else
                highest_priority_job     (* In the remaining cases, just pick the           *)
            else highest_priority_job    (* highest-priority job in the generated schedule. *)
          else highest_priority_job.

      End ConstructionStep.

      (* Next, starting from the empty schedule, ...*)
      Let empty_schedule : schedule Job := fun t => None.

      (* ...we use the recursive definition above to construct the suspension-oblivious schedule. *)
      Definition sched_new := build_schedule_from_prefixes build_schedule empty_schedule.

      (* Then, by showing that the construction function depends only on the previous service, ... *)
      Lemma sched_new_depends_only_on_service:
        forall sched1 sched2 t,
          (forall j, service sched1 j t = service sched2 j t) ->
          build_schedule sched1 t = build_schedule sched2 t.
      Proof.
        intros sched1 sched2 t ALL.
        rewrite /build_schedule /highest_priority_job.
        have SAME: pending_jobs sched1 t = pending_jobs sched2 t.
        {
          apply eq_in_filter.
          intros j IN.
          eapply in_arrivals_implies_arrived_before in IN; last by eauto.
          rewrite /arrived_before ltnS in IN.
          rewrite /pending /has_arrived IN 2!andTb.
          by rewrite /completed_by ALL.
        }
        have SAME': forall j, pending job_arrival inflated_job_cost sched1 j t =
                              pending job_arrival inflated_job_cost sched2 j t.
        {
          intros j; rewrite /pending.
          case: (has_arrived _ j t); [rewrite 2!andTb | by done].
          by rewrite /completed_by ALL.
        }
        rewrite SAME.
        desf; try (by done).
        - by rewrite SAME' in Heq1.
        - by rewrite -SAME' in Heq2.
      Qed.

      (* ...we infer that the generated schedule is indeed based on the construction function. *)
      Corollary sched_new_uses_construction_function:
        forall t,
          sched_new t = build_schedule sched_new t.
      Proof.
        by ins; apply service_dependent_schedule_construction,
                      sched_new_depends_only_on_service.
      Qed.

    End ScheduleConstruction.

    (* Next, we prove that the generated schedule is well-formed. *)
    Section GeneratedScheduleIsValid.

      (* First, we show that scheduled jobs come from the arrival sequence. *)
      Lemma sched_newjobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched_new arr_seq.
      Proof.
        rename H_jobs_come_from_arrival_sequence into FROM.
        move => j t /eqP SCHED.
        rewrite sched_new_uses_construction_function in SCHED.
        rewrite /build_schedule in SCHED.
        destruct (highest_priority_job sched_new t) as [j_hp|] eqn:HP; last by done.
        have ARRhp: arrives_in arr_seq j_hp.
        {
          rewrite /highest_priority_job in HP.
          apply seq_min_in_seq in HP.
          rewrite mem_filter in HP; move: HP => /andP [_ ARR].
          by eapply in_arrivals_implies_arrived, ARR.
        }
        destruct (sched_susp t) eqn:SUSP; last by case: SCHED => SAME; subst.
        by move: SCHED; case PEND: (_ && _); case => EQ; subst;
          first by apply (FROM j t); apply/eqP.
      Qed.

      (* Next, we show that jobs do not execute before their arrival times... *)
      Lemma sched_new_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched_new.
      Proof.
        move => j t /eqP SCHED.
        rewrite sched_new_uses_construction_function in SCHED.
        rewrite /build_schedule in SCHED.
        destruct (highest_priority_job sched_new t) as [j_hp|] eqn:HP; last by done.
        have IN: has_arrived job_arrival j_hp t.
        {
          suff IN: j_hp \in pending_jobs sched_new t.
            by rewrite mem_filter in IN; move: IN => /andP [/andP [ARR _] _].
          by apply: (seq_min_in_seq (higher_eq_priority t)).
        }
        destruct (sched_susp t) eqn:SUSP; last by move: SCHED; case => EQ; subst.
        move: SCHED; case: ifP; last by move => _; case => SAME; subst.
        by move => /andP [/andP [ARR _] _]; case => SAME; subst.
      Qed.

      (* ...nor longer than their execution costs. *)
      Lemma sched_new_completed_jobs_dont_execute:
        completed_jobs_dont_execute inflated_job_cost sched_new.
      Proof.
        intros j t.
        induction t;
          first by rewrite /service /service_during big_geq //.
        rewrite /service /service_during big_nat_recr //=.
        rewrite leq_eqVlt in IHt; move: IHt => /orP [/eqP EQ | LT]; last first.
        {
          apply: leq_trans LT; rewrite -addn1.
            by apply leq_add; last by apply leq_b1.
        }
        rewrite -[inflated_job_cost _]addn0; apply leq_add; first by rewrite -EQ.
        rewrite leqn0 eqb0 /scheduled_at.
        rewrite sched_new_uses_construction_function.
        rewrite /build_schedule.
        destruct (highest_priority_job sched_new t) as [j_hp|] eqn:HP; last by done.
        rewrite /highest_priority_job in HP.
        destruct (sched_susp t) eqn:SUSP.
        {
          case: ifP => [PEND | NOTPEND].
          {
            apply/eqP; case => SAME; subst.
            move: PEND => /andP [PEND _].
              by rewrite /pending /completed_by EQ leqnn andbF in PEND.
          }
          {
            apply/eqP; case => SAME; subst.
            suff IN: j \in pending_jobs sched_new t.
            {
              rewrite mem_filter in IN; move: IN => /andP [/andP [_ NOTCOMP] _].
              by rewrite /completed_by EQ leqnn in NOTCOMP.
            }
            by apply: (seq_min_in_seq (higher_eq_priority t)).
          }
        }
        {
          apply/eqP; case => SAME; subst.
          suff IN: j \in pending_jobs sched_new t.
          {
            rewrite mem_filter in IN; move: IN => /andP [/andP [_ NOTCOMP] _].
            by rewrite /completed_by EQ leqnn in NOTCOMP.
          }
          by apply: (seq_min_in_seq (higher_eq_priority t)).
        }
      Qed.

      (* In addition, we prove that the schedule is (suspension-oblivious) work-conserving... *)
      Lemma sched_new_work_conserving:
        susp_oblivious.work_conserving job_arrival inflated_job_cost arr_seq sched_new.
      Proof.
        intros j t ARRj BACK.
        move: BACK => /andP [/andP [ARR NOTCOMP] NOTSCHED].
        rewrite /scheduled_at sched_new_uses_construction_function /build_schedule in NOTSCHED.
        rewrite /scheduled_at sched_new_uses_construction_function /build_schedule.
        destruct (highest_priority_job sched_new t) as [j_hp|] eqn:HP.
        {
          destruct (sched_susp t) as [j0 |] eqn:SUSP; last by exists j_hp.
          by case: ifP => [_ | _]; [exists j0 | exists j_hp].
        }
        {
          rewrite /highest_priority_job in HP.
          have IN: j \in pending_jobs sched_new t.
          {
            rewrite mem_filter /pending ARR NOTCOMP 2!andTb.
            by eapply arrived_between_implies_in_arrivals, ARR.
          }
          by apply seq_min_exists with (rel := higher_eq_priority t) in IN; rewrite HP eq_refl in IN.
        }
      Qed.

      (* ...and respects job priorities. *)
      Lemma sched_new_respects_policy:
        susp_oblivious.respects_JLDP_policy job_arrival inflated_job_cost
                                            arr_seq sched_new higher_eq_priority.
      Proof.
        rename H_priority_is_transitive into TRANS, H_priority_is_total into TOTAL,
               H_priority_is_reflexive into REFL.
        move => j1 j2 t ARRj1 BACK /eqP SCHED.
        move: BACK => /andP [/andP [ARR NOTCOMP] NOTSCHED].
        rewrite /scheduled_at sched_new_uses_construction_function /build_schedule in NOTSCHED.
        rewrite /scheduled_at sched_new_uses_construction_function /build_schedule in SCHED.
        destruct (highest_priority_job sched_new t) as [j_hp|] eqn:HP; last by done.
        rewrite /highest_priority_job in HP.
        have ALL: forall j, j \in pending_jobs sched_new t -> higher_eq_priority t j_hp j.
        {
          intros j IN; apply seq_min_computes_min with (y := j) in HP; try (by done).
          intros x y; rewrite 2!mem_filter; move => /andP [_ INx] /andP [_ INy].
          by apply TOTAL; eapply in_arrivals_implies_arrived; eauto 1.
        }
        have IN: j1 \in pending_jobs sched_new t.
        {
          rewrite mem_filter /pending ARR NOTCOMP 2!andTb.
          by eapply arrived_between_implies_in_arrivals, ARR.
        }
        destruct (sched_susp t) as [j0|] eqn:SUSP;
          last by case: SCHED => SAME; subst; apply ALL; last by done.
        destruct (pending job_arrival inflated_job_cost sched_new j0 t
                          && higher_eq_priority t j0 j_hp) eqn:PEND;
          last by case: SCHED => SAME; subst; apply ALL.
        move: PEND => /andP [PEND HPj]; case: SCHED => SAME; subst.
        by apply: (TRANS _ j_hp); last by apply ALL.
      Qed.

      (* In addition, due to the copy step in the schedule construction, we show that in case
         there are multiple highest-priority jobs, we pick the same job as in the original
         schedule. *)
      Lemma sched_new_breaks_ties:
        forall j1 j2 t,
          higher_eq_priority t j1 j2 ->
          higher_eq_priority t j2 j1 ->
          scheduled_at sched_susp j1 t ->
          pending job_arrival inflated_job_cost sched_new j1 t ->
          scheduled_at sched_new j2 t ->
          j1 = j2.
      Proof.
        move => j1 j2 t HP1 HP2 /eqP SCHEDs PEND /eqP SCHEDn.
        rewrite sched_new_uses_construction_function /build_schedule in SCHEDn.
        destruct (highest_priority_job sched_new t) as [j_hp|] eqn:HP; last by done.
        destruct (sched_susp t) eqn:SUSP; last by done.
        case: SCHEDs => SAME; subst.
        rewrite PEND andTb in SCHEDn.
        move: SCHEDn; case: ifP => HP'; case => SAME; subst; first by done.
        by rewrite HP1 in HP'.
      Qed.

      (* To reason about schedulability, we now prove that the generated schedule
         preserves the service received by each job. *)
      Section Service.

        (* Recall the definitions of suspended job, cumulative service and
         cumulative suspension time in the suspension-aware schedule. *)
        Let job_suspended_at (sched: schedule Job) :=
          suspended_at job_arrival original_job_cost next_suspension sched.
        Let job_cumulative_suspension :=
          cumulative_suspension job_arrival original_job_cost next_suspension sched_susp.
        Let job_service_with_suspensions := service sched_susp.

        (* Also recall the definition of cumulative service in the generated schedule. *)
        Let job_service_without_suspensions := service sched_new.

        (* We are going to prove that for any job j, at any time t, the service received by j
           in the generated schedule (without suspensions) is no larger than the sum of the
           cumulative service plus suspension time in the original schedule (with suspensions).
           The proof follows by induction on time. Since the base case is trivial, we focus
           on the inductive step.  *)
        Section InductiveStep.

          (* Assume that the claim we want to prove holds for the interval [0, t). *)
          Variable t: time.
          Hypothesis H_induction_hypothesis:
            forall j,
              arrives_in arr_seq j ->
              job_service_without_suspensions j t <=
              job_service_with_suspensions j t + job_cumulative_suspension j t.

          (* Now, let j be any job in arrival sequence. We are going to prove that the claim
           continues to hold for job j in the interval [0, t + 1). *)
          Variable j: Job.
          Hypothesis H_comes_from_arrival_sequence: arrives_in arr_seq j.

          (* If j has not arrived by time t, then the proof is trivial, ... *)
          Lemma reduction_inductive_step_not_arrived:
            ~~ has_arrived job_arrival j t ->
            job_service_without_suspensions j t.+1 <=
            job_service_with_suspensions j t.+1 + job_cumulative_suspension j t.+1.
          Proof.
            rewrite -ltnNge; intro NOTARR.
            rewrite /job_service_without_suspensions /job_service_with_suspensions
                    /service /service_during.
            rewrite (cumulative_service_before_job_arrival_zero job_arrival) //.
            by apply sched_new_jobs_must_arrive_to_execute.
          Qed.

          (* ...so let's assume instead that j has arrived by time t. *)
          Hypothesis H_j_has_arrived: has_arrived job_arrival j t.

          (* We begin by performing a case analysis on whether j has completed in the
           suspension-aware schedule. *)
          Section CompletedInSuspensionAwareSchedule.

            (* Case 1) If j has completed by time t in the suspension-aware schedule, ... *)
            Hypothesis H_j_has_completed:
              completed_by original_job_cost sched_susp j t.

            (* ...then it follows from the induction hypothesis that the service
             received by j is preserved up in the interval [0, t + 1). *)
            Lemma reduction_inductive_step_case1_completed:
              job_service_without_suspensions j t.+1 <=
              job_service_with_suspensions j t.+1 + job_cumulative_suspension j t.+1.
            Proof.
              rename H_j_has_completed into COMP, H_induction_hypothesis into IH.
              apply leq_trans with (n := original_job_cost j +
                                         total_suspension original_job_cost next_suspension j).
              { by apply leq_trans with (n := inflated_job_cost j);
                  first apply cumulative_service_le_job_cost,
                  sched_new_completed_jobs_dont_execute.
              }
              rewrite leq_add //; first by apply completion_monotonic with (t0 := t).
              apply completion_monotonic with (t' := t.+1) in COMP; try done.
              rewrite /job_cumulative_suspension.
                by rewrite -> cumulative_suspension_eq_total_suspension with
                    (job_cost := original_job_cost).
            Qed.

          End CompletedInSuspensionAwareSchedule.

          (* Next, consider the complementary case. *)
          Section PendingInSuspensionAwareSchedule.

            (* Case 2) Since job j has arrived by time t, let's assume that j has not completed
               by time t in the suspension-aware schedule, i.e., j is still pending. *)
            Hypothesis H_j_is_pending:
              ~~ completed_by original_job_cost sched_susp j t.

            (* Since we know from the induction hypothesis that the service received by j is
               preserved in the interval [0, t), now we only have to consider the state of job j
               at time t in both schedules. That is, we need to prove the following property:

                scheduled_at sched_new j t <=
                    job_suspended_at sched_susp j t + scheduled_at sched_susp j t.               *)

            (* If j is not scheduled in the suspension-oblivious schedule, then the claim follows. *)
            Lemma reduction_inductive_step_not_scheduled_in_new:
              ~~ scheduled_at sched_new j t ->
              scheduled_at sched_new j t <=
              job_suspended_at sched_susp j t + scheduled_at sched_susp j t.
            Proof.
                by case: scheduled_at.
            Qed.

            (* Likewise, if j is scheduled in the suspension-aware schedule, then the claim is also
               trivial. *)
            Lemma reduction_inductive_step_scheduled_in_susp:
              scheduled_at sched_susp j t ->
              scheduled_at sched_new j t <=
              job_suspended_at sched_susp j t + scheduled_at sched_susp j t.
            Proof.
                by move ->; case: scheduled_at; [by apply leq_addl | by rewrite addn1].
            Qed.

            (* Having proved the simple cases, let's now move to the harder case. *)
            Section NotScheduledInSuspensionAware.

              (* Assume that j is scheduled in the suspension-oblivious schedule, but
                 not in the suspension-aware schedule. *)
              Hypothesis H_j_scheduled_in_new: scheduled_at sched_new j t.
              Hypothesis H_j_not_scheduled_in_susp: ~~ scheduled_at sched_susp j t.

              (* It remains to show that j is suspended at time t in the suspension-aware schedule.
                 We are going to prove that by contradiction. *)
              Section ProofByContradiction.

                (* Assume that j it not suspended at time t in the suspension-aware schedule, ... *)
                Hypothesis H_j_is_not_suspended: ~~ job_suspended_at sched_susp j t.

                (* ...which implies that j is backlogged at time t in the suspension-aware schedule. *)
                Lemma reduction_inductive_step_j_is_backlogged:
                  susp.backlogged job_arrival original_job_cost next_suspension sched_susp j t.
                Proof.
                  by repeat (apply/andP; split).
                Qed.

                (* By work conservation, there must be a scheduled job with higher or equal
                   priority in the suspension-aware schedule. *)
                Lemma reduction_inductive_step_exists_hep_job:
                  exists j_hp, arrives_in arr_seq j_hp /\
                               scheduled_at sched_susp j_hp t /\
                               higher_eq_priority t j_hp j.
                Proof.
                  rename H_work_conserving into WORKs, H_respects_priority into PRIOs,
                         H_jobs_come_from_arrival_sequence into FROM.
                  have BACKs := reduction_inductive_step_j_is_backlogged.
                  move: (BACKs) => BACKs'; apply WORKs in BACKs; last by done.
                  move: BACKs => [j_hp SCHEDhp]; exists j_hp.
                  split; first by apply (FROM j_hp t).
                  by split; last by apply PRIOs.
                Qed.

                (* Let j_hp be this job with higher-or-equal priority. *)
                Variable j_hp: Job.
                Hypothesis H_j_hp_comes_from_sequence: arrives_in arr_seq j_hp.
                Hypothesis H_j_hp_is_scheduled: scheduled_at sched_susp j_hp t.
                Hypothesis H_higher_or_equal_priority: higher_eq_priority t j_hp j.

                (* First, note that j and j_hp cannot be the same job, since j is not scheduled
                   in the suspension-aware schedule at time t. Moreover, since the generated
                   schedule breaks ties when there are multiple highest-priority jobs (by copying
                   the original schedule), it follows that the higher-priority job j_hp must have
                   completed earlier in the suspension-oblivious schedule. *)
                Lemma reduction_inductive_step_j_hp_completed_in_new:
                  completed_by inflated_job_cost sched_new j_hp t.
                Proof.
                  rename H_j_not_scheduled_in_susp into NOTSCHEDs, H_j_scheduled_in_new into SCHEDn.
                  move: H_j_hp_is_scheduled (H_j_hp_is_scheduled) => SCHEDhp PENDhp.
                  apply scheduled_implies_pending with (job_arrival0 := job_arrival)
                                   (job_cost := original_job_cost) in PENDhp; try (by done).
                  move: PENDhp => /andP [ARRhp _].
                  apply contraT; intro NOTCOMPhp.
                  have PENDhp: pending job_arrival inflated_job_cost sched_new j_hp t
                    by apply/andP; split.
                  destruct (boolP (scheduled_at sched_new j_hp t)) as [SCHEDhp' | NOTSCHEDhp'].
                  {
                    have SAME: j = j_hp by apply only_one_job_scheduled with (j1 := j) in SCHEDhp'.
                    by subst; rewrite SCHEDhp in NOTSCHEDs.
                  }
                  have BACKhp: backlogged job_arrival inflated_job_cost sched_new j_hp t by apply/andP.
                  have HP': higher_eq_priority t j j_hp by apply sched_new_respects_policy.
                  apply sched_new_breaks_ties in HP'; try (by done).
                  by subst; rewrite SCHEDn in NOTSCHEDhp'.
                Qed.

                (* However, recall from the induction hypothesis how the service in the two schedules
                   are related. From that, we can conclude that j_hp must have completed in the
                   suspension-aware schedule as well, ... *)
                Lemma reduction_inductive_step_j_hp_completed_in_susp:
                  completed_by original_job_cost sched_susp j_hp t.
                Proof.
                  have COMPNEW := reduction_inductive_step_j_hp_completed_in_new.
                  rename H_induction_hypothesis into IHt.
                  rewrite /completed_by.
                  rewrite -(leq_add2r (total_suspension original_job_cost next_suspension j_hp)).
                  rewrite -/(inflated_job_cost _).
                  apply leq_trans with (n := job_service_without_suspensions j_hp t).
                  apply COMPNEW.
                  feed (IHt j_hp); first by done.
                  apply: (leq_trans IHt).
                    by rewrite leq_add2l; apply cumulative_suspension_le_total_suspension.
                Qed.

                (* ...which of course is a contradiction, since we assumed that j_hp was scheduled
                   in the the suspension-aware schedule at time t. *)
                Lemma reduction_inductive_step_contradiction: False.
                Proof.
                  have COMPhp' := reduction_inductive_step_j_hp_completed_in_susp.
                  rename H_j_hp_is_scheduled into SCHEDhp.
                  apply completed_implies_not_scheduled in COMPhp'; try (by done).
                  by rewrite SCHEDhp in COMPhp'.
                Qed.

              End ProofByContradiction.

            End NotScheduledInSuspensionAware.

            (* From the lemmas above, we infer that the claim to be proven holds if job j
               is pending in the suspension-aware schedule. *)
            Lemma reduction_inductive_step_case2_pending:
              job_service_without_suspensions j t.+1 <=
              job_service_with_suspensions j t.+1 + job_cumulative_suspension j t.+1.
            Proof.
              have CONTRA := reduction_inductive_step_contradiction.
              have HP := reduction_inductive_step_exists_hep_job.
              rename H_induction_hypothesis into IHt.
              rewrite /job_service_without_suspensions /job_service_with_suspensions
                      /job_cumulative_suspension /cumulative_suspension
                      /cumulative_suspension_during /service /service_during /service_at.
              rewrite !big_nat_recr //=.
              rewrite -addnA [scheduled_at sched_susp _ _ + _]addnC !addnA -addnA.
              apply leq_add; first by apply IHt.
              destruct (boolP (scheduled_at sched_new j t)) as [SCHEDn |]; last by done.
              destruct (boolP (scheduled_at sched_susp j t)) as [SCHEDs | NOTSCHEDs];
                [by apply leq_addl | rewrite addn0].
              apply eq_leq; symmetry; apply/eqP; rewrite eqb1.
              apply contraT; intro NOTSUSP.
              specialize (HP NOTSCHEDs NOTSUSP); specialize (CONTRA SCHEDn NOTSCHEDs NOTSUSP).
              move: HP => [j_hp [INhp [SCHEDhp HP]]].
              by exfalso; apply CONTRA with (j_hp := j_hp).
            Qed.

          End PendingInSuspensionAwareSchedule.

        End InductiveStep.

        (* Using the proof by induction, we show that the service received by any
           job j at any time t is preserved in the suspension-aware schedule. *)
        Theorem suspension_oblivious_preserves_service:
          forall j t,
            arrives_in arr_seq j ->
            job_service_without_suspensions j t <= job_service_with_suspensions j t
                                                   + job_cumulative_suspension j t.
        Proof.
          have CASE1 := reduction_inductive_step_case1_completed.
          have CASE2 := reduction_inductive_step_case2_pending.
          move => j t; move: t j.
          induction t;
            first by ins; rewrite /job_service_without_suspensions/service/service_during big_geq.
          intros j ARRj.
          destruct (boolP (has_arrived job_arrival j t)) as [ARR | NOTARR];
            last by apply reduction_inductive_step_not_arrived.
          destruct (boolP (completed_by original_job_cost sched_susp j t)) as [COMP | NOTCOMP];
            first by apply CASE1.
          by apply CASE2.
        Qed.

        (* As a corollary, we show that if a job has completed in the suspension-oblivious
           schedule, it must have completed in the suspension-aware schedule as well. *)
        Corollary suspension_oblivious_preserves_completion:
          forall j t,
            arrives_in arr_seq j ->
            completed_by inflated_job_cost sched_new j t ->
            completed_by original_job_cost sched_susp j t.
        Proof.
          have COMP := sched_new_completed_jobs_dont_execute.
          have SERV := suspension_oblivious_preserves_service.
          intros j t ARRj COMPLETED.
          unfold completed_by in *.
          rewrite -(leq_add2r (total_suspension original_job_cost next_suspension j)).
          rewrite -/(inflated_job_cost j).
          apply leq_trans with (service sched_new j t); first by done.
          apply: (leq_trans (SERV j t ARRj)); rewrite leq_add2l.
            by apply cumulative_suspension_le_total_suspension.
        Qed.

      End Service.

    End GeneratedScheduleIsValid.

    (* To conclude, based on the definition of schedulability, ...*)
    Let schedulable_without_suspensions :=
      job_misses_no_deadline job_arrival inflated_job_cost job_deadline sched_new.
    Let schedulable_with_suspensions :=
      job_misses_no_deadline job_arrival original_job_cost job_deadline sched_susp.

    (* ...we prove that if no job misses a deadline in the suspension-oblivious schedule, ... *)
    Hypothesis H_schedulable_without_suspensions:
      forall j,
        arrives_in arr_seq j ->
        schedulable_without_suspensions j.

    (* ...then no job misses a deadline in the suspension-aware schedule. *)
    Corollary suspension_oblivious_preserves_schedulability:
      forall j,
        arrives_in arr_seq j ->
        schedulable_with_suspensions j.
    Proof.
      rename H_schedulable_without_suspensions into SCHED.
      by intros j ARRj; apply suspension_oblivious_preserves_completion, SCHED.
    Qed.

  End Reduction.

End ReductionToBasicSchedule.


(** * Well-scoped rules *)

Require Import HoTT.
Require Import Auxiliary.General.
Require Import Auxiliary.Family.
Require Import Auxiliary.WellFounded.
Require Import Syntax.ScopeSystem.
Require Import Auxiliary.Coproduct.
Require Import Auxiliary.Closure.
Require Import Syntax.All.
Require Import Typing.Context.
Require Import Typing.Judgement.
Require Import Presented.AlgebraicExtension.
Require Import Typing.RawRule.

(** A well-scoped rule is given by the following data:

   - [rule]: the data one gives to specify a logical rule (before any typechecking)
   - [associated_congruence_rule]
   - [flatten]
*)

(** Specification of well-scoped rules *)
Section WellScopedRule.

Context {σ : scope_system}.

(** An (ordered, raw) rule consists of premises and a conclusion. For various
    reasons, we abstract the form of the premises as an _algebraic extension_.

    Such an extension can add both object premises (introducing type/term
    premises) and equality premises.

    Besides being viewed as the premises of a rule, the premises can be seen as
    particularly simple rules themselves for extending a type theory. Viewed
    this way, they are _algebraic_ in the sense that it does not introduce any
    new binders, and only take term arguments (no type arguments). This is the
    raw-syntax analogue of an arity seen as specifying the metavariable-extension
    of a signature.
*)

(** The parameters of a rule, beyond its ambient signature, may be a little
    counter-intuitive. The point is that they are just what is required to
    determine the arity of the symbol introduced by the rule (if it’s an object
    rule), and in any case the arity of its associated raw rule. *)
Record rule
  {Σ : signature σ}
  {a : arity σ}
    (* arity listing the _object_ premises of the rule *)
  {jf_conclusion : Judgement.form}
    (* judgement form of the conclusion *)
:=
  {
    rule_premise : algebraic_extension Σ a
  ; rule_conclusion_hypothetical_boundary_expressions
      : Judgement.hypothetical_boundary_expressions
          (Metavariable.extend Σ a)
          jf_conclusion
          (scope_empty σ)
  }.

(* NOTE 1. One could generalise rules by allowing the context of the conclusion to be non-empty.

 This would slightly complicate this definition, and subsequent constructions, and would (one expects) not add any real generality, since one can always move variables from that context to become extra premises, giving an equivalent rule with empty conclusion context (where the equivalence makes use of the “cut”/substitution rule).

  However, it could be nice (a) since rules are sometimes written this way in practice, and (b) to allow a precise theorem stating the claim above about it being equivalent to move variables into the premises.

  On the other hand, so long as the _flattened_ rules [raw_rule] allow arbitrary conclusion judgements, one can still use those to give a lemma about the equivalence. *)

  (* NOTE 2. Perhaps the parameters of the definition of [rule] could be profitably abstracted into a “proto-rule” (probably including also the arity [ae_equality_premise]), fitting the pattern of the stratificaiton of objects into proto ≤ raw ≤ typed. *)

  Arguments rule _ _ _ : clear implicits.

  Local Definition conclusion_boundary_expressions
        {Σ} {a} {jf} (R : rule Σ a jf)
    : hypothetical_boundary_expressions
        (Metavariable.extend Σ a) jf (scope_empty σ)
  := rule_conclusion_hypothetical_boundary_expressions R.

  Local Lemma eq
      {Σ} {a} {jf_concl} (R R' : rule Σ a jf_concl)
      (e_prem : rule_premise R = rule_premise R')
      (e_concl : rule_conclusion_hypothetical_boundary_expressions R
                 = rule_conclusion_hypothetical_boundary_expressions R')
    : R = R'.
  Proof.
    destruct R'; simpl in *.
    destruct e_prem, e_concl.
    apply idpath.
  Defined.

  Local Definition fmap
      {Σ} {Σ'} (f : Signature.map Σ Σ')
      {a} {jf_concl}
      (R : rule Σ a jf_concl)
    : rule Σ' a jf_concl.
  Proof.
    simple refine (Build_rule Σ' a jf_concl _ _).
    - (* premises *)
      exact (AlgebraicExtension.fmap f (rule_premise R)).
    - (* conclusion *)
      simple refine
        (fmap_hypothetical_boundary_expressions
          _ (rule_conclusion_hypothetical_boundary_expressions R)).
      apply Metavariable.fmap1, f.
  Defined.

  Context `{Funext}.

  Local Definition fmap_idmap
      {Σ} {a} {jf_concl} (R : rule Σ a jf_concl)
    : fmap (Signature.idmap _) R = R.
  Proof.
    apply eq.
    - apply AlgebraicExtension.fmap_idmap.
    - cbn.
      eapply concat.
      { eapply (ap_3back fmap_hypothetical_boundary_expressions).
        apply Metavariable.fmap1_idmap. }
      apply fmap_hypothetical_boundary_expressions_idmap.
  Defined.

  Local Definition fmap_compose
      {Σ Σ' Σ''} (f' : Signature.map Σ' Σ'') (f : Signature.map Σ Σ')
      {a} {jf_concl} (R : rule Σ a jf_concl)
    : fmap (Signature.compose f' f) R = fmap f' (fmap f R).
  Proof.
    apply eq.
    - apply AlgebraicExtension.fmap_compose.
    - cbn.
      eapply concat.
      { eapply (ap_3back fmap_hypothetical_boundary_expressions).
        apply Metavariable.fmap1_compose. }
      apply fmap_hypothetical_boundary_expressions_compose.
  Defined.

  Local Definition fmap_fmap
      {Σ Σ' Σ''} (f' : Signature.map Σ' Σ'') (f : Signature.map Σ Σ')
      {a} {jf_concl} (R : rule Σ a jf_concl)
    : fmap f' (fmap f R) = fmap (Signature.compose f' f) R.
  Proof.
    apply inverse, fmap_compose.
  Defined.

  Local Lemma conclusion_boundary_expressions_fmap
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {a} {jf_concl} (R : rule Σ a jf_concl)
    : conclusion_boundary_expressions (fmap f R)
      = fmap_hypothetical_boundary_expressions (Metavariable.fmap1 f a)
                                        (conclusion_boundary_expressions R).
  Proof.
    apply idpath.
  Defined.

  (** Auxiliary access functions *)
  Local Definition conclusion_hypothetical_boundary
        {Σ} {a} {jf} (R : rule Σ a jf)
    : hypothetical_boundary
        (Metavariable.extend Σ a) (scope_empty σ)
  := Build_hypothetical_boundary _
        (rule_conclusion_hypothetical_boundary_expressions R).

  Local Definition conclusion_hypothetical_boundary_fmap
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {a} {jf_concl} (R : rule Σ a jf_concl)
    : conclusion_hypothetical_boundary (fmap f R)
      = fmap_hypothetical_boundary (Metavariable.fmap1 f a)
                                        (conclusion_hypothetical_boundary R).
  Proof.
    apply idpath.
  Defined.

  Local Definition conclusion_boundary
        {Σ} {a} {jf} (R : rule Σ a jf)
    : boundary (Metavariable.extend Σ a)
  := Build_boundary [::] (conclusion_hypothetical_boundary R).

  Local Definition conclusion_boundary_fmap
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {a} {jf} (R : rule Σ a jf)
    : conclusion_boundary (fmap f R)
      = Judgement.fmap_boundary (Metavariable.fmap1 f a)
                                (conclusion_boundary R).
  Proof.
    apply (ap (fun Γ
                  => Build_boundary
                      (Build_raw_context _ Γ) _)).
    apply path_forall; refine (empty_rect _ scope_is_empty _).
  Defined.

End WellScopedRule.

(* globalise argument declarations *)
Arguments rule {_} _ _ _.

Module Span.
(** Some auxiliary constructions for defining the ordering of the premises in
    the associated congruence rule of a constructor. *)

  Inductive span : Type :=
    left | right | top.

  Local Definition lt_relation : Relation span
  := fun x y => match x, y with
                | left, top => True
                | right, top => True
                | _, _ => False
  end.

  Definition lt_well_founded : is_well_founded lt_relation.
  Proof.
    intros P P_hereditary.
    assert (Pl : P left). { apply P_hereditary. intros [ | | ] []. }
    assert (Pr : P right). { apply P_hereditary. intros [ | | ] []. }
    intros [ | | ]; try assumption.
    apply P_hereditary. intros [ | | ] left; try assumption; destruct left.
  Defined.

  Definition lt_transitive : Transitive lt_relation.
  Proof.
    intros [ | | ] [ | | ] [ | | ] l l'; destruct l, l'; exact tt.
  Defined.

  Definition lt : well_founded_order span.
  Proof.
    exists lt_relation.
    - apply lt_well_founded.
    - apply lt_transitive.
  Defined.

End Span.

(* Each (ordered) rule induces one or two raw rules: the logical rule itself,
   and (if it was an object rule) its associated congruence rule.*)

Section Flattening.

  Context {σ : scope_system}.
  Context {Σ : signature σ}.

  (* TODO: consider whether this can be unified with [judgement_of_premise] *)
  Local Definition judgement_of_conclusion
    {a} {jf_concl}
    (R : rule Σ a jf_concl)
    (Sr : Judgement.is_object jf_concl
          -> { S : Σ & (symbol_arity S = a)
                       * (symbol_class S = class_of jf_concl) })
      : judgement (Metavariable.extend Σ a).
  Proof.
    exists [::], jf_concl.
    apply hypothetical_judgement_expressions_from_boundary_and_head.
    - exact (conclusion_boundary_expressions R).
    - intros H_obj.
      destruct jf_concl as [ ocl | ecl ]; simpl in *.
      + (* case: R an object rule *)
        destruct (Sr tt) as [S_R [e_a e_cl]]. clear Sr H_obj.
        destruct e_cl. (* TODO: can we simplify here with [raw_symbol']? *)
        refine (raw_symbol (inl S_R : Metavariable.extend _ _) _).
        change (symbol_arity (inl S_R : Metavariable.extend _ _))
          with (symbol_arity S_R).
        set (aR := symbol_arity S_R) in *. destruct (e_a^); clear e_a.
        intros p.
        cbn in p.
        refine (raw_symbol (inr p : Metavariable.extend _ _) _).
        intros i.
        apply raw_variable.
        apply (coproduct_inj1 scope_is_sum).
        exact (coproduct_inj2 scope_is_sum i).
      + (* case: R an equality rule *)
        destruct H_obj. (* ruled out by assumption *)
  Defined.

  (* Flattening a rule requires no extra information in the case of an
  equality-rule; in the case of an object-rule, it requires a symbol of
  appropriate arity to give the object introduced. *)
  Local Definition flatten
    {a} {jf_concl}
    (R : rule Σ a jf_concl)
    (SR : Judgement.is_object jf_concl
        -> { S : Σ & (symbol_arity S = a)
                     * (symbol_class S = Judgement.class_of jf_concl) })
  : raw_rule Σ.
  (* This construction involves essentially two aspects:

     - translate the syntax of each expression in the rule from its “local”
       signatures to the overall signature;

     - reconstruct the head terms of the object premises and the conclusion *)
  Proof.
    exists a.
    - exact (AlgebraicExtension.flatten (rule_premise R)).
    - exact (judgement_of_conclusion R SR).
  Defined.

End Flattening.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall P Q R S T U V W X Y : Universe, ((wd_ P T /\ (wd_ T Q /\ (wd_ R T /\ (wd_ T S /\ (wd_ Q U /\ (wd_ U R /\ (wd_ P W /\ (wd_ P Y /\ (wd_ P Q /\ (wd_ Q S /\ (wd_ P S /\ (wd_ Q R /\ (wd_ R S /\ (wd_ P R /\ (wd_ R V /\ (wd_ P V /\ (wd_ P X /\ (col_ Q P U /\ (col_ P Q Y /\ (col_ X Q Y /\ (col_ P U Y /\ (col_ P V X /\ (col_ U W V /\ (col_ P W Q /\ (col_ Q U R /\ (col_ R T S /\ (col_ P T Q /\ col_ P R V))))))))))))))))))))))))))) -> col_ P Q S)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Type.Predicate.
Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Category.Prod.
Require Import Blech.Groupoid.
Require Import Blech.Groupoid.Core.
Require Import Blech.Bicategory.
Require Import Blech.Functor.
Require Import Blech.Category.Funct.
Require Import Blech.Groupoid.
Require Import Blech.Type.Truncate.
Require Blech.Reflect.
Require Blech.Functor.Id.
Require Blech.Functor.Curry.
Require Blech.Functor.Compose.

Import BishopNotations.
Import CategoryNotations.
Import GroupoidNotations.
Import CoreNotations.
Import TruncateNotations.
Import ProdNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Weak (C: Bicategory): Category := {|
  Category.Obj := C ;
  Category.Mor A B := C A B ;
  Category.Mor_Setoid A B := {| equiv x y := | x <~> y | |} ;

  Category.id := Bicategory.id ;
  Category.compose _ _ _ f g := Bicategory.compose (f, g) ;
|}.

Next Obligation.
Proof.
Admitted.

Next Obligation.
Proof.
  exists.
  apply Bicategory.compose_assoc.
Defined.

Next Obligation.
Proof.
  exists.
  apply Bicategory.compose_id_left.
Defined.

Next Obligation.
Proof.
  exists.
  apply Bicategory.compose_id_right.
Defined.

Next Obligation.
Proof.
  intros ? ? [p] ? ? [q].
  exists.
  eexists.
  Unshelve.
  3: {
    apply map.
    cbn.
    apply (to p, to q).
  }
  3: {
    apply map.
    cbn.
    apply (from p, from q).
  }
  - rewrite <- map_id.
    rewrite map_composes.
    apply map_compat.
    cbn.
    split.
    + rewrite to_from.
      reflexivity.
    + rewrite to_from.
      reflexivity.
  - rewrite <- map_id.
    rewrite map_composes.
    apply map_compat.
    cbn.
    split.
    + rewrite from_to.
      reflexivity.
    + rewrite from_to.
      reflexivity.
Qed.


Require Import Coqlib.
Require Import Maps.
Require Import LibTactics.

Require Import Integers.
Open Scope Z_scope.
Import ListNotations.

Set Asymmetric Patterns.

Require Import state.
Require Import language.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import logic.

Require Import lemmas.
Require Import lemmas_ins.

Require Import Coq.Logic.FunctionalExtensionality.

Require Import integer_lemma.

Require Import sep_lemma.
Require Import reg_lemma.
Require Import derived_rule.

Require Import tm_dly_lemma.

Require Import code.
Require Import spec.

Open Scope nat.
Open Scope code_scope.
Open Scope mem_scope.

Definition spec := convert_spec nil.

Theorem FunAddProof :
  forall vl,
    spec |- {{ add_pre vl }}
             f # funcadd
           {{ add_post vl }}.
Proof.
  intros.
  unfold add_pre.
  unfold add_post.
  hoare_ex_intro_pre.
  renames x' to x, x'0 to y, x'1 to z, x'3 to fret.
  eapply Pure_intro_rule; intros.
  unfold funcadd.

  (** add i0 i1 l7 *)
  eapply seq_rule.
  ins_tm_reduce_bas.
  eapply add_rule; eauto.
  instantiate (2 := W x); instantiate (1 := W y); simpl; eauto.
  introv Hs.
  split.
  {
    destruct_state s.
    eapply rn_st_v_eval_reg_v in Hs.
    simpl; eauto.
    unfold get_R.
    simpl; eauto.
    rewrite Hs; eauto.
  }
  {
    simpl_sep_liftn_in Hs 2.
    destruct_state s.
    eapply rn_st_v_eval_reg_v in Hs; eauto.
    simpl; eauto.
    unfold get_R.
    simpl; eauto.
    rewrite Hs; eauto.
  }
  introv Hs.
  simpl_sep_liftn_in Hs 4; eauto.

  (** add l7 i2 l7 *)
  eapply seq_rule.
  ins_tm_reduce_bas.
  eapply add_rule; eauto.
  instantiate (2 := W x +ᵢ y); instantiate (1 := W z); simpl; eauto.
  introv Hs.
  split.
  {
    destruct_state s.
    eapply rn_st_v_eval_reg_v in Hs; eauto.
    simpl.
    unfold get_R.
    simpl; eauto.
    rewrite Hs; eauto.
  }
  {
    simpl_sep_liftn_in Hs 4.
    destruct_state s.
    eapply rn_st_v_eval_reg_v in Hs.
    simpl.
    unfold get_R.
    simpl; eauto.
    rewrite Hs; eauto.
  }

  (** retl ;; nop *)
  eapply retl_rule; eauto.
  ins_tm_reduce_bas.
  ins_tm_reduce_bas.
  eapply nop_rule; eauto.
  introv Hs.
  sep_ex_intro.
  eapply sep_pure_l_intro; eauto.
  sep_cancel1 2 1.
  sep_cancel1 2 1.
  sep_cancel1 2 1.
  eauto.

  unfold fretSta.
  introv Hs Hs'.
  eapply asrt_time_reduce in Hs.
  TimReduce_simpl_in_bas Hs.
  eapply asrt_time_reduce in Hs.
  TimReduce_simpl_in_bas Hs.
  simpl_sep_liftn_in Hs 5.
  sep_ex_elim_in Hs'.
  eapply sep_pure_l_elim in Hs'.
  simpljoin1.
  symmetry in H0.
  inversion H0; eauto; subst.
  simpl_sep_liftn_in H1 5.
  destruct_state s.
  eapply rn_st_v_eval_reg_v in Hs; eauto.
  destruct_state s'.
  eapply rn_st_v_eval_reg_v in H1; eauto.
Qed.


Require Import Coq.NArith.BinNat Coq.Relations.Relations Coq.MSets.MSets Coq.MSets.MSetRBT
        Coq.Lists.List Coq.micromega.Lia Coq.Sets.Ensembles.

Require Import LambdaANF.cps LambdaANF.eval LambdaANF.cps_util LambdaANF.identifiers LambdaANF.ctx LambdaANF.set_util
        LambdaANF.Ensembles_util LambdaANF.List_util LambdaANF.size_cps LambdaANF.tactics LambdaANF.relations LambdaANF.rel_comp
        LambdaANF.uncurry LambdaANF.uncurry_proto LambdaANF.bounds LambdaANF.shrink_cps LambdaANF.shrink_cps_toplevel
        LambdaANF.closure_conversion LambdaANF.closure_conversion_util LambdaANF.hoisting
        LambdaANF.lambda_lifting LambdaANF.lambda_lifting_correct LambdaANF.uncurry_correct
        LambdaANF.dead_param_elim LambdaANF.dead_param_elim_correct.
Require Export LambdaANF.logical_relations LambdaANF.logical_relations_cc LambdaANF.alpha_conv
        LambdaANF.inline_letapp LambdaANF.inline LambdaANF.inline_correct LambdaANF.algebra LambdaANF.state.
Require Import Common.compM.
Require Import compcert.lib.Coqlib.

Import ListNotations.

Close Scope Z_scope.

Section ToplevelTheorems.

  Context (cenv : ctor_env).
  Context (clo_tag : ctor_tag).
  Context (clo_itag : ind_tag).

  (* TODO use John's definition  *)
  Definition well_scoped e :=
    unique_bindings e /\ Disjoint _ (bound_var e) (occurs_free e).

  Definition fv_pres e1 e2 :=
    occurs_free e2 \subset occurs_free e1.

  Definition post_prop P1 PG :=
    Post_properties cenv P1 P1 PG /\
    post_upper_bound P1.

  (** Correctness spec for (composition of) "identity" transformations *)

  Definition correct (trans :  exp -> comp_data -> error exp * comp_data) :=
    forall e c,
      well_scoped e ->                                            (* src is well-scoped *)
      max_var e 1 < state.next_var c ->                           (* the pool of identifiers is fresh *)
      exists (e' : exp) (c' : state.comp_data),
        trans e c = (Ret e', c') /\                               (* the transformation successfully terminates *)
        well_scoped e' /\                                         (* trg is well-scoped *)
        max_var e' 1 < state.next_var c' /\                       (* the pool of identifiers is fresh for the target *)
        exists n, preord_exp_n cenv wf_pres post_prop n e e'.     (* src and trg are in the logical relation  *)

  (** Correctness spec for closure conversion tranformations *)

  Definition correct_cc (trans : exp -> comp_data ->  error exp * comp_data) :=
    forall e c,
      well_scoped e ->                                            (* src is well-scoped *)
      max_var e 1 < state.next_var c ->                           (* the pool of identifiers is fresh *)
      exists (e' : exp) (c' : state.comp_data),
        trans e c = (Ret e', c') /\                               (* the transformation successfully terminates *)
        well_scoped e' /\                                         (* trg is well-scoped *)
        max_var e' 1 < state.next_var c' /\                       (* the pool of identifiers is fresh for the target *)
        exists n m,  R_n_exp cenv clo_tag wf_pres post_prop       (* src and trg are in the logical relation  *)
                             (simple_bound 0) (simple_bound 0) n m e e'.

Section Inline.

 Lemma inline_correct St IH e d st c z :
   well_scoped e ->
   exists (e' : exp) (c' : state.comp_data) click,
     inline_top' St IH z d st e c = (Ret e', c', click) /\
     wf_pres e e' /\
     well_scoped e' /\
     max_var e' 1 < state.next_var c' /\
     (forall (k : nat) (rho1 rho2 : env),
         preord_env_P cenv (inline_bound d d) (occurs_free e) k rho1 rho2 ->
         preord_exp cenv (inline_bound d d) (inline_bound d d) k (e, rho1) (e', rho2)).
 Proof.
   intros H.
   edestruct inline_correct_top with (P1 := fun L => inline_bound L d)
                                     (PG := inline_bound d d).
   - intros. eapply inline_bound_compat. eassumption.
   - intros. eapply inline_bound_post_Eapp_l.
   - intros. eapply inline_bound_remove_steps_letapp.
   - intros. rewrite plus_comm. eapply inline_bound_remove_steps_letapp_OOT.
   - reflexivity.
   - intro; intros. exact H0.
   - eapply H.
   - eapply H.
   - destructAll. do 3 eexists. split. eassumption.
     split. eassumption. split.
     split; eassumption. split. eassumption.
     eassumption.
 Qed.

 Corollary inline_correct_cor St IH d st z :
   correct (inline_top St IH z d st).
 Proof.
   intro; intros.
   edestruct inline_correct; eauto. destructAll.
   do 2 eexists. split.

   unfold inline_top. rewrite H1. reflexivity.
   repeat (split; [ eassumption | ]).
   eexists. econstructor. now eauto. eassumption.
   split.
   unfold inline_bound_top. eapply inline_bound_compat. lia.
   eapply inline_bound_post_upper_bound.
 Qed.

 Corollary inline_uncurry_cor x n m :
   correct (inline_uncurry x n m).
 Proof.
   intro; intros.
   edestruct inline_correct; eauto. destructAll.
   do 2 eexists. split.

   unfold inline_uncurry, inline_top. rewrite H1. reflexivity.
   repeat (split; [ eassumption | ]).
   eexists. econstructor. now eauto. eassumption.
   split.
   unfold inline_bound_top. eapply inline_bound_compat. lia.
   eapply inline_bound_post_upper_bound.
 Qed.

End Inline.

Section LambdaLift.

  Lemma lambda_lift_correct e c k l b :
   well_scoped e ->
   max_var e 1 < state.next_var c ->
   exists (e' : exp) (c' : state.comp_data),
     lambda_lift k l b e c = (Ret e', c') /\
     max_var e' 1 < state.next_var c' /\
     wf_pres e e' /\
     well_scoped e'  /\
     (forall (k : nat) (rho1 rho2 : env),
         preord_env_P cenv (ll_bound 0) (occurs_free e) k rho1 rho2 ->
         binding_in_map (occurs_free e) rho1 ->
         preord_exp cenv (ll_bound 0) (ll_bound 0) k (e, rho1) (e', rho2)).
  Proof.
    intros.
    edestruct lambda_lift_correct_top with (P1 := ll_bound)
                                           (PG := ll_bound 0).
    - intros. eapply ll_bound_compat.
    - intros. eapply ll_bound_compat.
      exact (M.empty _). exact 0%nat.
    - eapply ll_bound_mon. lia.
    - intros. eapply ll_bound_local_steps; eauto.
    - intros. eapply ll_bound_local_app.
    - intros. eapply ll_bound_local_steps_let_app; eauto.
    - intros. eapply ll_bound_local_steps_let_app_OOT; eauto.
    - intros. eapply ll_bound_local_steps_app; eauto.
    - intros. eapply ll_bound_ctx_r; eauto.
    - eapply H.
    - eassumption.
    - eapply H.
    - destructAll. do 2 eexists. split. eassumption.
      split. eassumption.
      split. eassumption. split.
      split; eassumption.
      eassumption.
  Qed.

  Corollary lambda_lift_correct_corr k l b :
    correct (lambda_lift k l b).
  Proof.
    intro; intros.
    edestruct lambda_lift_correct; eauto. destructAll.
    do 2 eexists. repeat (split; [ eassumption | ]).
    eexists. econstructor. now eauto. eassumption. split.
    eapply ll_bound_compat. eapply simple_bound_post_upper_bound.
  Qed.

End LambdaLift.

(* TODO move *)
Section Refl.

  Context (wf_pres : exp -> exp -> Prop)
          (wf_pres_refl : forall e, wf_pres e e)
          (lf : var).

  Context (fuel trace : Type)  {Hf : @fuel_resource fuel} {Ht : @trace_resource trace}.

  Lemma preord_exp_n_refl e :
    preord_exp_n cenv wf_pres post_prop 1 e e.
  Proof.
    econstructor; eauto.
    2:{ split. eapply simple_bound_compat. eapply simple_bound_post_upper_bound. }
    intros.
    eapply preord_exp_refl; eauto.
    eapply simple_bound_compat.
  Qed.

End Refl.

Section CCHoist.

  Lemma closure_conversion_hoist_correct :
    correct_cc (closure_conversion_hoist clo_tag clo_itag).
  Proof.
    intros e c Hws Hmvar.
    edestruct closure_conversion_correct.exp_closure_conv_correct
      with (boundL := simple_bound) (boundG := simple_bound 0).
    (* CC bounds *)
    - eapply simple_bound_compat.
    - eapply Hpost_locals_r.
    - eapply Hpost_locals_l.
    - eapply Hpost_locals_l0.
    - eapply HOOT.
    - eapply HPost_letapp_cc.
    - eapply HPost_letapp_OOT_cc.
    - eapply bounds.HPost_app.
    - eapply Hbase.
    (* scoping *)
    - eapply Hws.
    - eapply Hws.
    - eassumption.
    - destructAll.

      edestruct (exp_hoist x) as [e' m] eqn:Hhoist.

      edestruct exp_hoist_correct_top with
          (e := x)
          (P1 := fun n =>  hoisting_bound n m)
          (P2 := hoisting_bound m m)
          (PG := hoisting_bound m m).

      (* Hoisting bounds *)
      + intros. eapply hoisting_bound_compat. eassumption.
      + intros. eapply hoisting_bound_mon. eassumption.
      + intros. eapply hoisting_bound_post_Efun_l.
      + intros. eapply hoisting_bound_post_Efun_r. eassumption.
      + eapply hoisting_bound_compat; eauto.
      + intros. eapply hoisting_bound_mon. eassumption.
      + reflexivity.
      (* scoping *)
      + easy.
      + eapply Disjoint_sym. eassumption.
      + eassumption.
      + eassumption.
      + destructAll. do 2 eexists. split; [| split; [| split ] ].
        * unfold closure_conversion_hoist. rewrite H. rewrite Hhoist. simpl. reflexivity.
        * split. eassumption. sets.
        * eapply Pos.le_lt_trans; [| eassumption ].
          eapply dead_param_elim_correct.max_var_le. eapply Included_Union_compat. eassumption. eassumption.
        * do 2 eexists. econstructor. split.
          ++ eapply preord_exp_n_refl.
             clear; firstorder.
          ++ eexists. split. split.
             2:{ eassumption. }
             2:{ econstructor. intros. eapply H6. eassumption.
                 eassumption.
                 split. eapply hoisting_bound_compat. lia.
                 eapply hoisting_bound_post_upper_bound. }
             intros. eassumption.
  Qed.

End CCHoist.

Section Shrink.

  Lemma shrink_top_correct e e' m :
    well_scoped e ->
    shrink_top e = (e', m) ->
    exists m,
      well_scoped e' /\
      occurs_free e' \subset occurs_free e /\
      bound_var e' \subset bound_var e /\
      preord_exp_n cenv wf_pres post_prop m e e'.
  Proof.
    intros.
    intros. intros.
    assert (Hs := shrink_corresp_top cenv (fun L => inline_bound L 1) (inline_bound 1 1)).
    inv H.

    assert (Ha : let (e', n) := shrink_top e in
                 (exists m : nat,
                     (m >= n)%nat /\
                     preord_exp_n cenv shrink_cps_toplevel.wf_pres (shrink_cps_toplevel.post_prop cenv) m e e') /\
                 unique_bindings e' /\
                 Disjoint var (occurs_free e') (bound_var e') /\
                 occurs_free e' \subset occurs_free e /\ bound_var e' \subset bound_var e).
    { eapply Hs.

      - intros. eapply inline_bound_compat. eassumption.
      - intros. eapply inline_bound_compat. lia.
      - intros. eapply inline_bound_post_Eapp_l.
      - eapply inline_bound_remove_steps_letapp.
      - assert (Hs' := inline_bound_remove_steps_letapp_OOT cenv 0 0 1).
        eassumption.
      - eapply inline_bound_ctx1.
      - eapply inline_bound_Ecase.
      - eapply inline_bound_post_upper_bound.
      - eapply inline_bound_post_upper_bound.
      - eassumption.
      - eassumption. }

    rewrite H0 in Ha. destructAll. eexists. split.
    split. eassumption. sets.
    eauto.
  Qed.

  Corollary shrink_err_correct :
    correct shrink_err.
  Proof.
    intro; intros.
    destruct (shrink_top e) eqn:Hres.
    exists e0, c.
    edestruct shrink_top_correct; eauto. destructAll.
    eexists.
    unfold shrink_err.
    unfold shrink_err. rewrite Hres. reflexivity.
    split; [| split ]; eauto.

    eapply Pos.le_lt_trans. eapply max_var_le. 2: eassumption.

    sets.
  Qed.

End Shrink.

Section InlineLoop.

  Lemma inline_loop_correct z bound d :
    correct (inline_shrink_loop z bound d).
  Proof.
    intros e c. unfold inline_shrink_loop, inline_loop.
    revert e c. generalize 1000%nat.
    induction n; intros.
   - simpl. do 2 eexists.
     split. reflexivity.
     split. eassumption. split. eassumption.
     eexists. eapply preord_exp_n_refl.
     intros. unfold wf_pres. sets.
   - destructAll. simpl.
     edestruct inline_correct with (e := e). eassumption.
     destructAll.
     destruct (shrink_top x) eqn:Hshrink.
     edestruct shrink_top_correct; [| eassumption | ]. eassumption.
     destructAll.
     destruct x1.
     + edestruct (IHn e0). eassumption.
       eapply Pos.le_lt_trans. eapply max_var_le. 2: eassumption. sets.
       destructAll.
       do 2 eexists. erewrite H1. split; [| split ].
       rewrite Hshrink. simpl. eassumption. eassumption.
       split. eassumption. eexists.
       econstructor 2.
       * econstructor 1. now eauto. eassumption.
         split. eapply inline_bound_compat. lia.
         eapply inline_bound_post_upper_bound.
       * econstructor 2. eassumption. eassumption.
     + do 2 eexists. rewrite H1.
       split. reflexivity.
       split. rewrite Hshrink. eassumption.
       split. rewrite Hshrink.
       eapply Pos.le_lt_trans. eapply max_var_le. 2: eassumption. sets.
       rewrite Hshrink. eexists. simpl.
       econstructor 2.
       * econstructor 1. now eauto. eassumption.
         split. eapply inline_bound_compat. lia.
         eapply inline_bound_post_upper_bound.
       * eassumption.
  Qed.

End InlineLoop.

Section Uncurry.

  Lemma test : (forall b e c r, uncurry_top b e c = r -> uncurry_top b e c = r).
  Proof. intros. Abort.

  Lemma uncurry_top_correct e c b :
   well_scoped e ->
   max_var e 1 < state.next_var c ->
   exists (e' : exp) (c' : state.comp_data),
     uncurry_top b e c = (Ret e', c') /\
     max_var e' 1 < state.next_var c' /\
     wf_pres e e' /\
     well_scoped e'  /\
     (forall (k : nat) (rho1 rho2 : env),
         preord_env_P cenv (simple_bound 0) (occurs_free e) k rho1 rho2 ->
         binding_in_map (occurs_free e) rho1 ->
         preord_exp cenv (simple_bound 0) (simple_bound 0) k (e, rho1) (e', rho2)).
  Proof.
    intros.
    edestruct (@uncurry_correct_top cenv nat _ (nat * nat) _ (simple_bound 0)
                                    (simple_bound 0)) with (cps := b).
    - intros. eapply simple_bound_compat.
    - intros. eapply simple_bound_compat.
    - eapply Hpost_curry.
    - eapply Hpost_idemp.
    - clear. unfold comp, simple_bound. intro; intros.
      destructAll.
      destruct x as [[[? ?] ?] [? ? ]].
      destruct y as [[[? ?] ?] [? ? ]].
      destruct x0 as [[[? ?] ?] [? ? ]]. lia.
    - inv H. eassumption.
    - inv H. eassumption.
    - eassumption.
    - destructAll. exists x, x0.
      split. assumption.
      split. eassumption.
      split. eassumption.
      split. split; eassumption.
      now eauto.
  Qed.

  Corollary uncurry_top_correct_corr b :
    correct (uncurry_top b).
  Proof.
    intro; intros.
    edestruct uncurry_top_correct. eassumption. eassumption.
    destructAll.
    do 2 eexists. split.
    eassumption.
    repeat (split; [ eassumption | ]).
    eexists. econstructor. now eauto. eassumption. split.
    eapply simple_bound_compat. eapply simple_bound_post_upper_bound.
  Qed.

End Uncurry.

Section DPE.

  Lemma DPE_correct e c :
    well_scoped e ->
    max_var e 1 < state.next_var c ->
    exists (e' : exp) (c' : state.comp_data),
      DPE e c = (Ret e', c') /\
      max_var e' 1 < state.next_var c' /\
      wf_pres e e' /\
      well_scoped e'  /\
      (forall (k : nat) (rho1 rho2 : env),
          preord_env_P cenv (ll_bound 0) (occurs_free e) k rho1 rho2 ->
          binding_in_map (occurs_free e) rho1 ->
          preord_exp cenv (simple_bound 0) (simple_bound 0) k (e, rho1) (e', rho2)).
  Proof.
    intros.
    edestruct DPE_correct_top with (PL := simple_bound 0)
                                   (PG := simple_bound 0).
    - intros. eapply simple_bound_compat.
    - eapply H.
    - eassumption.
    - eapply H.
    - destructAll. do 2 eexists. split. eassumption.
      split. eassumption.
      split. eassumption. split.
      split; eassumption.
      eassumption.
  Qed.

  Corollary DPE_correct_corr :
    correct DPE.
  Proof.
    intro; intros.
    edestruct DPE_correct; eauto. destructAll.
    do 2 eexists. repeat (split; [ eassumption | ]).
    eexists. econstructor. now eauto. eassumption. split.
    eapply simple_bound_compat. eapply simple_bound_post_upper_bound.
  Qed.

End DPE.

End ToplevelTheorems.

Require Import ExtLib.Structures.Monad LambdaANF.toplevel.
Import MonadNotation.

Section Compose.

  Context (cenv : ctor_env).

  Transparent bind.

  Lemma correct_compose (t1 t2 : anf_trans) :
    correct cenv t1 ->
    correct cenv t2 ->
    correct cenv (fun e => e <- t1 e;; t2 e).
  Proof.
    intros Ht1 Ht2. intro; intros.
    edestruct Ht1; eauto. destructAll.
    edestruct Ht2. eapply H2. eassumption. destructAll.
    do 2 eexists. split; [| split; [| split ]].
    - simpl. unfold bind.
      rewrite H1. rewrite H5. reflexivity.
    - eassumption.
    - assumption.
    - eexists. econstructor 2; eauto.
  Qed.

  Lemma correct_cc_compose_l (t1 t2 : anf_trans) :
    correct cenv t1 ->
    correct_cc cenv clo_tag t2 ->
    correct_cc cenv clo_tag (fun e => e <- t1 e;; t2 e).
  Proof.
    intros Ht1 Ht2. intro; intros.
    edestruct Ht1; eauto. destructAll.
    edestruct Ht2. eapply H2. eassumption. destructAll.
    do 2 eexists. split; [| split; [| split ]].
    - simpl. unfold bind.
      rewrite H1. rewrite H5. reflexivity.
    - eassumption.
    - assumption.
    - inv H8. destructAll. inv H9. destructAll.
      do 3 eexists. split.
      econstructor 2. eassumption. eassumption.
      eexists. split. split; [| eassumption ]. eassumption.
      eassumption.
  Qed.

  Lemma correct_cc_compose_r (t1 t2 : anf_trans) :
    correct_cc cenv clo_tag t1 ->
    correct cenv t2 ->
    correct_cc cenv clo_tag (fun e => e <- t1 e;; t2 e).
  Proof.
    intros Ht1 Ht2. intro; intros.
    edestruct Ht1; eauto. destructAll.
    edestruct Ht2. eapply H2. eassumption. destructAll.
    do 2 eexists. split; [| split; [| split ]].
    - simpl. unfold bind.
      rewrite H1. rewrite H5. reflexivity.
    - eassumption.
    - assumption.
    - inv H4. destructAll. inv H9. destructAll.
      do 3 eexists. split. eassumption.
      eexists. split. split; [| eassumption ]. eassumption.
      econstructor 2; eassumption.
  Qed.

  Lemma correct_time (t : anf_trans) o s :
    correct cenv t ->
    correct cenv (time_anf o s t).
  Proof.
    unfold time_anf.
    intros.
    destruct (time o); eauto.
  Qed.

  Lemma correct_cc_time (t : anf_trans) o s :
    correct_cc cenv clo_tag t ->
    correct_cc cenv clo_tag (time_anf o s t).
  Proof.
    unfold time_anf.
    intros.
    destruct (time o); eauto.
  Qed.

  Opaque uncurry_top.

  Lemma correct_id_trans :
    correct cenv id_trans.
  Proof.
    intro; intros.
    do 2 eexists. split. reflexivity.
    split. eassumption.
    split. eassumption.
    eexists. econstructor 1.
    3:{ split. eapply simple_bound_compat. eapply simple_bound_post_upper_bound. }
    intros. eapply preord_exp_refl.
    eapply simple_bound_compat. eassumption.
    clear. firstorder.
  Qed.

  Theorem anf_pipeline_correct opts v :
    correct_cc cenv clo_tag (anf_pipeline v opts).
  Proof.
    intros Heq.
    unfold anf_pipeline.
    eapply correct_cc_compose_l.

    eapply correct_time.
    now eapply shrink_err_correct.

    eapply correct_cc_compose_l.

    eapply correct_time. now eapply uncurry_top_correct_corr.

    eapply correct_cc_compose_l.

    eapply correct_time.
    now eapply inline_uncurry_cor.

    eapply correct_cc_compose_l.

    destruct (inl_before opts).
    eapply correct_time. now eapply inline_loop_correct.
    now eapply correct_id_trans.

    eapply correct_cc_compose_l.

    destruct (do_lambda_lift opts).
    eapply correct_time. now eapply lambda_lift_correct_corr.
    now eapply correct_id_trans.

    eapply correct_cc_compose_l.

    eapply correct_time. now eapply shrink_err_correct.

    eapply correct_cc_compose_r.

    eapply correct_cc_time. now eapply closure_conversion_hoist_correct.

    eapply correct_compose.

    eapply correct_time. now eapply shrink_err_correct.

    eapply correct_compose.

    destruct (inl_after opts).
    eapply correct_time. now eapply inline_loop_correct.
    now eapply correct_id_trans.

    eapply correct_compose.

    destruct (dpe opts).

    eapply correct_time. now eapply DPE_correct_corr.
    now eapply correct_id_trans.

    eapply correct_compose.

    eapply correct_time. now eapply shrink_err_correct.

    eapply correct_compose.

    destruct (inl_known opts).
    eapply correct_time.
    unfold inline_lifted. now eapply inline_correct_cor.
    now eapply correct_id_trans.

    now eapply correct_id_trans.
  Qed.

  (* Top-level correctness for whole programs *)
  Corollary anf_pipeline_whole_program_correct var opts e c :

    closed_exp e ->

    well_scoped e ->
    (max_var e 1 < state.next_var c)%positive ->

    exists (e' : exp) (c' : state.comp_data),
      anf_pipeline var opts e c = (Ret e', c') /\

      refines cenv value_ref_cc e e'.
  Proof.
    intros.
    edestruct anf_pipeline_correct; eauto. destructAll.
    do 2 eexists.

    split. eassumption.

    eapply R_n_exp_in_refines; eauto.

    clear; now firstorder.
    clear; now firstorder.
    eapply simple_bound_post_upper_bound.
  Qed.

  Lemma preord_exp_n_wf_mon wf1 wf2 p k e1 e2 :
    inclusion _ wf1 wf2 ->
    preord_exp_n cenv wf1 p k e1 e2 ->
    preord_exp_n cenv wf2 p k e1 e2.
  Proof.
    intros H1 H2. induction H2; eauto.
    now econstructor 1; eauto.
    now econstructor 2; eauto.
  Qed.

  Lemma R_n_exp_wf_mon ctag wf1 wf2 p P PG k m e1 e2 :
    inclusion _ wf1 wf2 ->
    R_n_exp cenv ctag wf1 p P PG k m e1 e2 ->
    R_n_exp cenv ctag wf2 p P PG k m e1 e2.
  Proof.
    intros H1 H2. inv H2. inv H. inv H2. destructAll.
    eexists. split. now eapply preord_exp_n_wf_mon.
    eexists. split; eauto. now eapply preord_exp_n_wf_mon.
  Qed.

  (* Top-level correctness for linking *)
  Corollary anf_pipeline_linking_correct lf x v1 v2 o1 o2 e1 e2 c1 c2 :

    closed_exp e1 ->
    well_scoped e1 ->
    (max_var e1 1 < state.next_var c1)%positive ->

    occurs_free e2 \subset [set x] ->
    well_scoped e2 ->
    (max_var e2 1 < state.next_var c2)%positive ->

    exists (e1' e2' : exp) (c1' c2' : state.comp_data),
      anf_pipeline v1 o1 e1 c1 = (Ret e1', c1') /\
      anf_pipeline v2 o2 e2 c2 = (Ret e2', c2') /\

      refines cenv value_ref_cc (link lf x e1 e2) (link lf x e1' e2').
  Proof.
    intros.
    edestruct anf_pipeline_correct with (e := e1) (opts := o1); eauto. destructAll.
    edestruct anf_pipeline_correct with (e := e2) (opts := o2); eauto. destructAll.

    do 4 eexists.

    split. eassumption.
    split. eassumption.

    eapply R_n_exp_in_refines.

    6:{ eapply Rel_exp_n_preserves_linking; eauto.
        - intros. eapply H13.
        - eapply simple_bound_compat. }

    now eauto.
    clear; now firstorder.
    clear; now firstorder.
    eapply simple_bound_post_upper_bound.

    eapply link_closed; eauto.
  Qed.

End Compose.

Print Assumptions anf_pipeline_whole_program_correct.
Print Assumptions anf_pipeline_linking_correct.

(*

Prints :

Axioms:
ProofIrrelevance.proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2
FunctionalExtensionality.functional_extensionality_dep : forall (A : Type) (B : A -> Type)
                                                           (f g : forall x : A, B x),
                                                         (forall x : A, f x = g x) -> f = g
*)