Require Import SQIR.UnitarySem.
Require Export RzQGateSet.
Require Import List.
Require Import MappingConstraints.
Import RzQList.
Open Scope ucom.

Local Close Scope C_scope.
Local Close Scope R_scope.
Local Close Scope Q_scope.

(**********************************************************************)
(** Optimization: simple cancellation and combination w/ commutation **)
(**********************************************************************)

(* Cancel and combine gates, checking for cancellations across commuting
   subcircuits. We determine whether a gate commutes through a subcircuit
   using the following circuits identities from Nam et al.

   - Rz b ; H b ; CNOT a b ; H b ≡ H b ; CNOT a b ; H b ; Rz b
   - Rz b ; CNOT a b ; Rz' b ; CNOT a b ≡ CNOT a b ; Rz' b ; CNOT a b ; Rz b
   - Rz a ; CNOT a b ≡ CNOT a b ; Rz a
   - X b ; CNOT a b ≡ CNOT a b ; X b
   - CNOT a c ; CNOT b c ≡ CNOT b c ; CNOT a c
   - CNOT a c ; CNOT a b ≡ CNOT a b ; CNOT a c
   - CNOT a b; H b; CNOT b c; H b ≡ H b; CNOT b c; H b; CNOT a b

   This optimization should have the same behavior as Nam et al.'s single/
   two-qubit gate cancellation routines (with some added 'not propagation').
*)

(** Propagation rules for Rz **)
Definition Rz_commute_rule1 {dim} q (l : RzQ_ucom_l dim) :=
  match (next_single_qubit_gate l q) with
  | Some (l1, URzQ_H, l2) =>
      match (next_two_qubit_gate l2 q) with
      | Some (l3, URzQ_CNOT, q1, q2, l4) =>
          if q =? q2
          then match (next_single_qubit_gate l4 q) with
               | Some (l5, URzQ_H, l6) => Some (l1 ++ [H q] ++ l3 ++ [CNOT q1 q] ++ l5 ++ [H q], l6)
               | _ => None
               end
          else None
      | _ => None
      end
  | _ => None
  end.

Definition Rz_commute_rule2 {dim} q (l : RzQ_ucom_l dim) :=
  match (next_two_qubit_gate l q) with
  | Some (l1, URzQ_CNOT, q1, q2, l2) =>
      if q =? q2
      then match (next_single_qubit_gate l2 q) with
           | Some (l3, URzQ_Rz _ as u, l4) =>
               match (next_two_qubit_gate l4 q) with
               | Some (l5, URzQ_CNOT, q3, q4, l6) =>
                   if (q =? q4) && (q1 =? q3) && (does_not_reference (l3 ++ l5) q3)
                   then Some (l1 ++ [CNOT q1 q] ++ l3 ++ [App1 u q] ++ l5 ++ [CNOT q1 q], l6)
                   else None
               | _ => None
               end
           | _ => None
           end
      else None
  | _ => None
  end.

Definition Rz_commute_rule3 {dim} q (l : RzQ_ucom_l dim) :=
  match (next_two_qubit_gate l q) with
  | Some (l1, URzQ_CNOT, q1, q2, l2) =>
      if q =? q1
      then Some (l1 ++ [CNOT q1 q2], l2)
      else None
  | _ => None
  end.

Definition Rz_commute_rules {dim} q :=
  @Rz_commute_rule1 dim q :: Rz_commute_rule2 q :: Rz_commute_rule3 q :: [].

Definition Rz_cancel_rule {dim} q a (l : RzQ_ucom_l dim) :=
  match (next_single_qubit_gate l q) with
  | Some (l1, URzQ_Rz a', l2) =>
      Some ((combine_rotations a a' q) ++ l1 ++ l2)
  | _ => None
  end.

(** Propagation rules for H **)
(* (Currently no  rules for commuting.) *)

Definition H_cancel_rule {dim} q (l : RzQ_ucom_l dim)  :=
  match next_single_qubit_gate l q with
  | Some (l1, URzQ_H, l2) => Some (l1 ++ l2)
  | _ => None
  end.

(** Propagation rules for X **)

Definition X_commute_rule {dim} q (l : RzQ_ucom_l dim) :=
  match (next_two_qubit_gate l q) with
  | Some (l1, URzQ_CNOT, q1, q2, l2) =>
      if q =? q2
      then Some (l1 ++ [CNOT q1 q2], l2)
      else None
  | _ => None
  end.

Definition X_cancel_rule {dim} q (l : RzQ_ucom_l dim) :=
  match (next_single_qubit_gate l q) with
  | Some (l1, URzQ_X, l2) => Some (l1 ++ l2)
  | _ => None
  end.

(** Propagation rules for CNOT **)

Definition CNOT_commute_rule1 {dim} q1 (l : RzQ_ucom_l dim) : option (RzQ_ucom_l dim * RzQ_ucom_l dim) :=
  match (next_single_qubit_gate l q1) with
  | Some (l1, URzQ_Rz _ as u, l2) => Some ([App1 u q1], l1 ++ l2)
  | _ => None
  end.

Definition CNOT_commute_rule2 {dim} q1 q2 (l : RzQ_ucom_l dim) :=
  match (next_two_qubit_gate l q2) with
  | Some (l1, URzQ_CNOT, q1', q2', l2) =>
      if q2 =? q2'
      then if (does_not_reference l1 q1)
           then Some (l1 ++ [CNOT q1' q2], l2)
           else None
      else None
  | _ => None
  end.

Definition CNOT_commute_rule3 {dim} q1 q2 (l : RzQ_ucom_l dim) :=
  match (next_two_qubit_gate l q1) with
  | Some (l1, URzQ_CNOT, q1', q2', l2) =>
      if q1 =? q1'
      then if (does_not_reference l1 q2)
           then Some (l1 ++ [CNOT q1 q2'], l2)
           else None
      else None
  | _ => None
  end.

Definition CNOT_commute_rule4 {dim} q1 q2 (l : RzQ_ucom_l dim) :=
  match (next_single_qubit_gate l q2) with
  | Some (l1, URzQ_H, l2) =>
      match (next_two_qubit_gate l2 q2) with
      | Some (l3, URzQ_CNOT, q1', q2', l4) =>
          if (q2 =? q1') && (¬ (q1 =? q2')) && (does_not_reference (l1 ++ l3) q1)
          then match (next_single_qubit_gate l4 q2) with
               | Some (l5, URzQ_H, l6) => Some (l1 ++ [H q2] ++ l3 ++ [CNOT q2 q2'] ++ [H q2], l5 ++ l6)
               | _ => None
               end
          else None
      | _ => None
      end
  | _ => None
  end.

Definition CNOT_commute_rule5 {dim} q1 q2 (l : RzQ_ucom_l dim) :=
  match next_single_qubit_gate l q2 with
  | Some (l1, URzQ_Rz _ as u, l2) =>
      match next_two_qubit_gate l2 q2 with
      | Some (l3, URzQ_CNOT, q1', q2', l4) =>
          if (q1 =? q1') && (q2 =? q2') && (does_not_reference (l1 ++ l3) q1)
          then match next_single_qubit_gate l4 q2 with
               | Some (l5, URzQ_Rz _ as u', l6) =>
                   Some (l1 ++ [App1 u' q2] ++ l3 ++ [CNOT q1' q2'] ++ [App1 u q2], l5 ++ l6)
               | _ => None
               end
          else None
      | _ => None
      end
  | _ => None
  end.

Definition CNOT_commute_rules {dim} q1 q2 :=
  @CNOT_commute_rule1 dim q1 :: CNOT_commute_rule2 q1 q2 :: CNOT_commute_rule3 q1 q2 :: CNOT_commute_rule4 q1 q2 :: CNOT_commute_rule5 q1 q2 :: [].

Definition CNOT_cancel_rule {dim} q1 q2 (l : RzQ_ucom_l dim) :=
  match next_two_qubit_gate l q1 with
  | Some (l1, URzQ_CNOT, q1', q2', l2) =>
      if (q1 =? q1') && (q2 =? q2') && (does_not_reference l1 q2)
      then Some (l1 ++ l2)
      else None
  | _ => None
  end.

(** Gate Cancellation Routines **)
Definition propagate_Rz {dim} a (l : RzQ_ucom_l dim) q :=
  propagate l (Rz_commute_rules q) [Rz_cancel_rule q a] (length l).

Definition propagate_H {dim} (l : RzQ_ucom_l dim) q :=
  propagate l [] [H_cancel_rule q] 1%nat.

Definition propagate_X {dim} (l : RzQ_ucom_l dim) q :=
  propagate l [X_commute_rule q] [X_cancel_rule q] (length l).

Definition propagate_CNOT {dim} (l : RzQ_ucom_l dim) (q1 q2 : nat) :=
  propagate l (CNOT_commute_rules q1 q2) [CNOT_cancel_rule q1 q2] (length l).

Fixpoint cancel_single_qubit_gates' {dim} (l : RzQ_ucom_l dim) (n: nat) acc : RzQ_ucom_l dim :=
  match n with
  | 0 => rev_append acc l
  | S n' => match l with
           | App1 (URzQ_Rz a) q :: t =>
               match propagate_Rz a t q with
               | None => cancel_single_qubit_gates' t n' (Rzq a q :: acc)
               | Some l' => cancel_single_qubit_gates' l' n' acc
               end
           | App1 URzQ_H q :: t =>
               match propagate_H t q with
               | None => cancel_single_qubit_gates' t n' (H q :: acc)
               | Some l' => cancel_single_qubit_gates' l' n' acc
               end
           | App1 URzQ_X q :: t =>
               match propagate_X t q  with
               | None => cancel_single_qubit_gates' t n' (X q :: acc)
               | Some l' => cancel_single_qubit_gates' l' n' acc
               end
           | u :: t => cancel_single_qubit_gates' t n' (u :: acc)
           | [] => rev_append acc []
           end
  end.

Definition cancel_single_qubit_gates {dim} (l : RzQ_ucom_l dim) :=
  cancel_single_qubit_gates' l (length l) [].

Fixpoint cancel_two_qubit_gates' {dim} (l : RzQ_ucom_l dim) (n: nat) acc : RzQ_ucom_l dim :=
  match n with
  | 0 => rev_append acc l
  | S n' => match l with
           | App2 URzQ_CNOT q1 q2 :: t =>
               match propagate_CNOT t q1 q2 with
               | None => cancel_two_qubit_gates' t n' (CNOT q1 q2 :: acc)
               | Some l' => cancel_two_qubit_gates' l' n' acc
               end
           | u :: t => cancel_two_qubit_gates' t n' (u :: acc)
           | [] => rev_append acc []
           end
  end.

Definition cancel_two_qubit_gates {dim} (l : RzQ_ucom_l dim) :=
  cancel_two_qubit_gates' l (length l) [].

(** semantics preservation **)

Lemma propagate_Rz_sound : forall {dim} a (l : RzQ_ucom_l dim) q l',
  q < dim ->
  propagate_Rz a l q = Some l' ->
  Rzq a q :: l =l= l'.
Proof.
  unfold propagate_Rz.
  intros dim a l q l' Hq res.
  apply (propagate_preserves_semantics l (Rz_commute_rules q) [Rz_cancel_rule q a] (length l)). 5: apply res.
  apply uc_equiv_l_rel.
  apply uc_app_mor_Proper.
  - clear l l' res.
    intros rules Hin l l' res.
    destruct_In; subst.
    unfold Rz_cancel_rule in res.
    destruct_list_ops.
    rewrite app_assoc.
    rewrite <- does_not_reference_commutes_app1 by assumption.
    rewrite combine_rotations_semantics by assumption.
    reflexivity.
  - clear l l' res Hq.
    intros rules Hin l l1 l2 res.
    destruct_In; subst.
    + unfold Rz_commute_rule1 in res.
      destruct_list_ops.
      rewrite cons_to_app.
      rewrite (cons_to_app _ (g2 ++ _)).
      rewrite (cons_to_app _ (g4 ++ _)).
      repeat rewrite app_assoc.
      setoid_rewrite (does_not_reference_commutes_app1 g0 (URzQ_Rz a)); auto.
      rewrite <- (app_assoc _ _ g2).
      rewrite (does_not_reference_commutes_app1 g2 URzQ_H) by assumption.
      rewrite (app_assoc _ g2), <- (app_assoc _ _ g2).
      rewrite (does_not_reference_commutes_app1 g2 (URzQ_Rz a)) by assumption.
      rewrite <- (app_assoc _ g4).
      rewrite <- (does_not_reference_commutes_app1 g4 URzQ_H) by assumption.
      rewrite <- (app_assoc _ _ g2).
      setoid_rewrite (does_not_reference_commutes_app1 g2 URzQ_H); auto.
      rewrite <- (app_assoc _ g4).
      setoid_rewrite <- (does_not_reference_commutes_app1 g4 URzQ_H); auto.
      rewrite <- 2 (app_assoc _ _ [Rzq a n]).
      setoid_rewrite <- (does_not_reference_commutes_app1 g4 (URzQ_Rz a)); auto.
      apply_app_congruence.
      unfold_uc_equiv_l.
      apply Rz_comm_H_CNOT_H.
    + unfold Rz_commute_rule2 in res.
      destruct_list_ops.
      destruct (does_not_reference (g2 ++ g3) n2) eqn:dnr; try discriminate.
      apply does_not_reference_app in dnr.
      apply andb_true_iff in dnr as [? ?].
      inversion res; clear res; subst.
      rewrite cons_to_app.
      rewrite (cons_to_app _ (g2 ++ _)).
      rewrite (cons_to_app _ (g3 ++ _)).
      repeat rewrite app_assoc.
      setoid_rewrite (does_not_reference_commutes_app1 g0 (URzQ_Rz a)); auto.
      rewrite <- (app_assoc _ _ g2).
      rewrite does_not_reference_commutes_app2 by assumption.
      rewrite (app_assoc _ g2), <- (app_assoc _ _ g2).
      rewrite does_not_reference_commutes_app1 by assumption.
      rewrite <- (app_assoc _ g3).
      rewrite <- (does_not_reference_commutes_app2 g3) by assumption.
      rewrite <- (app_assoc _ _ g2).
      setoid_rewrite (does_not_reference_commutes_app2 g2); auto.
      rewrite <- (app_assoc _ g3).
      setoid_rewrite <- (does_not_reference_commutes_app2 g3); auto.
      rewrite <- (app_assoc _ (_ ++ g3) [Rzq a n1]), <- (app_assoc _ g3).
      setoid_rewrite <- (does_not_reference_commutes_app1 g3); auto.
      apply_app_congruence.
      unfold_uc_equiv_l.
      apply Rz_comm_CNOT_Rz_CNOT.
    + unfold Rz_commute_rule3 in res.
      destruct_list_ops.
      rewrite cons_to_app.
      repeat rewrite app_assoc.
      setoid_rewrite (does_not_reference_commutes_app1 g0); auto.
      apply_app_congruence.
      unfold_uc_equiv_l.
      apply Rz_comm_CNOT.
Qed.

Lemma propagate_Rz_WT : forall {dim} a (l : RzQ_ucom_l dim) q l',
  q < dim ->
  uc_well_typed_l l ->
  propagate_Rz a l q = Some l' ->
  uc_well_typed_l l'.
Proof.
  intros.
  specialize (propagate_Rz_sound a l q l' H H1) as H2.
  apply (uc_equiv_l_implies_WT _ _ H2).
  constructor; assumption.
Qed.

Lemma propagate_H_sound : forall {dim} (l : RzQ_ucom_l dim) q l',
  q < dim ->
  propagate_H l q = Some l' ->
  H q :: l =l= l'.
Proof.
  unfold propagate_H.
  intros dim l q l' Hq res.
  eapply propagate_preserves_semantics; try apply res.
  apply uc_equiv_l_rel.
  apply uc_app_mor_Proper.
  - clear l l' res.
    intros rules Hin l l' res.
    destruct_In; subst.
    unfold H_cancel_rule in res.
    destruct_list_ops.
    rewrite app_assoc.
    rewrite <- does_not_reference_commutes_app1 by assumption.
    rewrite cons_to_app.
    rewrite <- app_nil_l.
    apply_app_congruence.
    unfold_uc_equiv_l.
    rewrite <- (ID_equiv_SKIP dim q) by assumption.
    apply H_H_id.
  - clear l l' res.
    intros rules Hin l l' res.
    destruct_In.
Qed.

Lemma propagate_H_WT : forall {dim} (l : RzQ_ucom_l dim) q l',
  q < dim ->
  uc_well_typed_l l ->
  propagate_H l q = Some l' ->
  uc_well_typed_l l'.
Proof.
  intros.
  specialize (propagate_H_sound l q l' H H1) as H2.
  apply (uc_equiv_l_implies_WT _ _ H2).
  constructor; assumption.
Qed.

Lemma propagate_X_sound : forall {dim} (l : RzQ_ucom_l dim) q l',
  q < dim ->
  propagate_X l q = Some l' ->
  X q :: l =l= l'.
Proof.
  unfold propagate_X.
  intros dim l q l' Hq res.
  eapply propagate_preserves_semantics; try apply res.
  apply uc_equiv_l_rel.
  apply uc_app_mor_Proper.
  - clear l l' res.
    intros rules Hin l l' res.
    destruct_In; subst.
    unfold X_cancel_rule in res.
    destruct_list_ops.
    rewrite app_assoc.
    rewrite <- does_not_reference_commutes_app1 by assumption.
    rewrite cons_to_app.
    rewrite <- app_nil_l.
    apply_app_congruence.
    unfold_uc_equiv_l.
    rewrite <- (ID_equiv_SKIP dim q) by assumption.
    apply X_X_id.
  - clear l l' res Hq.
    intros rules Hin l l1 l2 res.
    destruct_In; subst.
    unfold X_commute_rule in res.
    destruct_list_ops.
    rewrite cons_to_app.
    repeat rewrite app_assoc.
    setoid_rewrite (does_not_reference_commutes_app1 g0); auto.
    apply_app_congruence.
    unfold_uc_equiv_l.
    apply X_comm_CNOT_target.
Qed.

Lemma propagate_X_WT : forall {dim} (l : RzQ_ucom_l dim) q l',
  q < dim ->
  uc_well_typed_l l ->
  propagate_X l q = Some l' ->
  uc_well_typed_l l'.
Proof.
  intros.
  specialize (propagate_X_sound l q l' H H1) as H2.
  apply (uc_equiv_l_implies_WT _ _ H2).
  constructor; assumption.
Qed.

Lemma propagate_CNOT_sound : forall {dim} (l : RzQ_ucom_l dim) q1 q2 l',
  q1 < dim ->
  q2 < dim ->
  q1 <> q2 ->
  propagate_CNOT l q1 q2 = Some l' ->
  CNOT q1 q2 :: l =l= l'.
Proof.
  unfold propagate_CNOT.
  intros dim l q1 q2 l' Hq1 Hq2 Hq1q2 res.
  eapply propagate_preserves_semantics; try apply res.
  apply uc_equiv_l_rel.
  apply uc_app_mor_Proper.
  - clear l l' res.
    intros rules Hin l l' res.
    destruct_In; subst.
    unfold CNOT_cancel_rule in res.
    destruct_list_ops.
    destruct (does_not_reference g0 n) eqn:?; try discriminate.
    inversion res; subst; clear res.
    rewrite app_assoc.
    rewrite <- does_not_reference_commutes_app2 by assumption.
    rewrite cons_to_app.
    rewrite <- app_nil_l.
    apply_app_congruence.
    unfold_uc_equiv_l.
    apply CNOT_CNOT_id; assumption.
  - clear l l' res.
    intros rules Hin l l1 l2 res.
    destruct_In; subst.
    + unfold CNOT_commute_rule1 in res.
      destruct_list_ops.
      rewrite app_assoc.
      rewrite <- does_not_reference_commutes_app1 by assumption.
      rewrite cons_to_app.
      apply_app_congruence.
      symmetry.
      unfold_uc_equiv_l.
      apply Rz_comm_CNOT.
    + unfold CNOT_commute_rule2 in res.
      destruct_list_ops.
      destruct (does_not_reference g0 q1) eqn:?; try discriminate.
      inversion res; subst; clear res.
      rewrite cons_to_app.
      repeat rewrite app_assoc.
      setoid_rewrite (does_not_reference_commutes_app2 g0); auto.
      apply_app_congruence.
      unfold_uc_equiv_l.
      apply CNOT_comm_CNOT_sharing_target.
    + unfold CNOT_commute_rule3 in res.
      destruct_list_ops.
      destruct (does_not_reference g0 q2) eqn:?; try discriminate.
      inversion res; subst; clear res.
      rewrite cons_to_app.
      repeat rewrite app_assoc.
      setoid_rewrite (does_not_reference_commutes_app2 g0); auto.
      apply_app_congruence.
      unfold_uc_equiv_l.
      apply CNOT_comm_CNOT_sharing_control.
    + unfold CNOT_commute_rule4 in res.
      destruct_list_ops; simpl in res.
      destruct (does_not_reference (g0 ++ g2) q1) eqn:dnr; try discriminate.
      destruct_list_ops.
      apply does_not_reference_app in dnr.
      apply andb_true_iff in dnr as [? ?].
      rewrite cons_to_app.
      rewrite (cons_to_app _ (g2 ++ _)).
      rewrite (cons_to_app _ [_]).
      repeat rewrite app_assoc.
      setoid_rewrite (does_not_reference_commutes_app2 g0); auto.
      rewrite <- (app_assoc _ _ g2).
      rewrite does_not_reference_commutes_app1 by assumption.
      rewrite <- (app_assoc _ _ (g2 ++ _)), (app_assoc _ g2).
      rewrite (does_not_reference_commutes_app2 g2) by assumption.
      rewrite <- (app_assoc _ g3).
      rewrite <- (does_not_reference_commutes_app1 g3) by assumption.
      rewrite <- (app_assoc _ _ g2).
      setoid_rewrite (does_not_reference_commutes_app1 g2); auto.
      apply_app_congruence.
      unfold_uc_equiv_l.
      apply CNOT_comm_H_CNOT_H.
      assumption.
    + unfold CNOT_commute_rule5 in res.
      destruct_list_ops.
      destruct (does_not_reference (g0 ++ g2) n0) eqn:dnr; try discriminate.
      simpl in res.
      destruct_list_ops.
      apply does_not_reference_app in dnr.
      apply andb_true_iff in dnr as [? ?].
      rewrite cons_to_app.
      rewrite (cons_to_app _ (g2 ++ _)).
      rewrite (cons_to_app _ [_]).
      repeat rewrite app_assoc.
      setoid_rewrite (does_not_reference_commutes_app2 g0); auto.
      rewrite <- (app_assoc _ _ g2).
      rewrite does_not_reference_commutes_app1 by assumption.
      rewrite <- (app_assoc _ _ (g2 ++ _)), (app_assoc _ g2).
      rewrite (does_not_reference_commutes_app2 g2) by assumption.
      rewrite <- (app_assoc _ g3).
      rewrite <- (does_not_reference_commutes_app1 g3) by assumption.
      rewrite <- (app_assoc _ _ g2).
      setoid_rewrite (does_not_reference_commutes_app1 g2); auto.
      apply_app_congruence.
      symmetry.
      unfold_uc_equiv_l.
      apply Rz_comm_CNOT_Rz_CNOT.
Qed.

Lemma propagate_CNOT_WT : forall {dim} (l : RzQ_ucom_l dim) q1 q2 l',
  q1 < dim ->
  q2 < dim ->
  q1 <> q2 ->
  uc_well_typed_l l ->
  propagate_CNOT l q1 q2 = Some l' ->
  uc_well_typed_l l'.
Proof.
  intros.
  specialize (propagate_CNOT_sound l q1 q2 l' H H0 H1 H3) as H4.
  apply (uc_equiv_l_implies_WT _ _ H4).
  constructor; assumption.
Qed.

Lemma cancel_single_qubit_gates_sound : forall {dim} (l : RzQ_ucom_l dim),
  uc_well_typed_l l -> cancel_single_qubit_gates l =l= l.
Proof.
  intros dim l WT.
  assert (H: forall n acc, cancel_single_qubit_gates' l n acc =l= rev acc ++ l).
  { intros n.
    generalize dependent l.
    induction n; intros l WT acc; simpl.
    rewrite rev_append_rev. reflexivity.
    destruct l; simpl.
    rewrite rev_append_rev. reflexivity.
    destruct g as [u | | u]; inversion WT; subst.
    - dependent destruction u.
      + destruct (propagate_H l n0) eqn:prop.
        rewrite (propagate_H_sound _ _ _ H1 prop).
        apply IHn.
        apply (propagate_H_WT _ _ _ H1 H3 prop).
        rewrite IHn; auto.
        simpl. rewrite <- app_assoc. reflexivity.
      + destruct (propagate_X l n0) eqn:prop.
        rewrite (propagate_X_sound _ _ _ H1 prop).
        apply IHn.
        apply (propagate_X_WT _ _ _ H1 H3 prop).
        rewrite IHn; auto.
        simpl. rewrite <- app_assoc. reflexivity.
      + destruct (propagate_Rz a l n0) eqn:prop.
        rewrite (propagate_Rz_sound _ _ _ _ H1 prop).
        apply IHn.
        apply (propagate_Rz_WT _ _ _ _ H1 H3 prop).
        rewrite IHn; auto.
        simpl. rewrite <- app_assoc. reflexivity.
    - rewrite IHn; auto.
      simpl. rewrite <- app_assoc. reflexivity.
    - inversion u. }
  apply H.
Qed.

Lemma cancel_single_qubit_gates_WT: forall {dim} (l : RzQ_ucom_l dim),
  uc_well_typed_l l -> uc_well_typed_l (cancel_single_qubit_gates l).
Proof.
  intros dim l WT.
  specialize (cancel_single_qubit_gates_sound l WT) as H.
  symmetry in H.
  apply uc_equiv_l_implies_WT in H; assumption.
Qed.

Lemma cancel_two_qubit_gates_sound : forall {dim} (l : RzQ_ucom_l dim),
  uc_well_typed_l l -> cancel_two_qubit_gates l =l= l.
Proof.
  intros dim l WT.
  assert (H : forall n acc, cancel_two_qubit_gates' l n acc =l= rev acc ++ l).
  { intros n.
    generalize dependent l.
    induction n; intros l WT acc; simpl.
    rewrite rev_append_rev. reflexivity.
    destruct l; simpl.
    rewrite rev_append_rev. reflexivity.
    destruct g as [ | u | u]; inversion WT; subst.
    - rewrite IHn; auto.
      simpl. rewrite <- app_assoc. reflexivity.
    - dependent destruction u.
      destruct (propagate_CNOT l n0 n1) eqn:prop.
      rewrite (propagate_CNOT_sound _ _ _ _ H3 H4 H5 prop).
      apply IHn.
      apply (propagate_CNOT_WT _ _ _ _ H3 H4 H5 H6 prop).
      rewrite IHn; auto.
      simpl. rewrite <- app_assoc. reflexivity.
    - inversion u. }
  apply H.
Qed.

Lemma cancel_two_qubit_gates_WT: forall {dim} (l : RzQ_ucom_l dim),
  uc_well_typed_l l -> uc_well_typed_l (cancel_two_qubit_gates l).
Proof.
  intros dim l WT.
  specialize (cancel_two_qubit_gates_sound l WT) as H.
  symmetry in H.
  apply uc_equiv_l_implies_WT in H; assumption.
Qed.

(** mapping preservation **)

Lemma Rz_commute_rule1_respects_constraints: forall {dim} q  (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) ,
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @Rz_commute_rule1 dim q in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold Rz_commute_rule1 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as [respects_g0 respects_g].
  assert_and_prove_next_gate.
  destruct H1 as [respects_g2 [respects_g1 iiggn0n]].
  assert_and_prove_next_gate.
  destruct H1 as [respects_g4 respects_g3].
  split.
  - inversion H0; subst.
    repeat (try apply respects_constraints_directed_app; auto; try constructor).
    symmetry in HeqH2.
    rewrite Nat.eqb_eq in HeqH2.
    subst.
    assumption.
  - inversion H0; subst.
    assumption.
Qed.

Lemma Rz_commute_rule2_respects_constraints: forall {dim} q (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @Rz_commute_rule2 dim q in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold Rz_commute_rule2 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as  [respects_g0 [respects_g iiggn0n]].
  assert_and_prove_next_gate.
  destruct H1 as [respects_g2 respects_g1].
  assert_and_prove_next_gate.
  destruct H1 as  [respects_g4 [respects_g3 iiggn2n1]].
  symmetry in HeqH0.
  rewrite Nat.eqb_eq in HeqH0.
  subst.
  split; inversion H0; subst;
  repeat (try apply respects_constraints_directed_app; try constructor; auto).
Qed.

Lemma Rz_commute_rule3_respects_constraints: forall {dim} q  (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @Rz_commute_rule3 dim q in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold Rz_commute_rule3 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as  [respects_g4 [respects_g3 iiggn2n1]].
  split;
  inversion H0; subst;
  repeat (try apply respects_constraints_directed_app; try constructor; auto).
Qed.

Lemma X_commute_rule_respects_constraints: forall {dim} q (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @X_commute_rule dim q in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold X_commute_rule in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as  [respects_g4 [respects_g3 iiggn2n1]].
  split; inversion H0; subst;
  repeat (try apply respects_constraints_directed_app; auto; try constructor).
Qed.

Lemma CNOT_commute_rule1_respects_constraints: forall {dim} q (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @CNOT_commute_rule1 dim q in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold CNOT_commute_rule1 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1.
  split;
    inversion H0; subst;
      repeat (try apply respects_constraints_directed_app; auto; try constructor).
Qed.

Lemma CNOT_commute_rule2_respects_constraints: forall {dim} q1 q2 (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @CNOT_commute_rule2 dim q1 q2 in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold CNOT_commute_rule2 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as [respects_g0 [ respects_g is_in_graphn0n]].
  split;
    inversion H0; subst;
      repeat (try apply respects_constraints_directed_app; auto; try constructor).
  symmetry in HeqH0.
  rewrite Nat.eqb_eq in HeqH0.
  subst.
  assumption.
Qed.

Lemma CNOT_commute_rule3_respects_constraints: forall {dim} q1 q2 (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @CNOT_commute_rule3 dim q1 q2 in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold CNOT_commute_rule3 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as [respects_g0 [ respects_g is_in_graphn0n]].
  split;
    inversion H0; subst;
      repeat (try apply respects_constraints_directed_app; auto; try constructor).
  symmetry in HeqH0.
  rewrite Nat.eqb_eq in HeqH0.
  subst.
  assumption.
Qed.

Lemma CNOT_commute_rule4_respects_constraints: forall {dim} q1 q2  (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @CNOT_commute_rule4 dim q1 q2 in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold CNOT_commute_rule4 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as [respects_g0 respects_g].
  assert_and_prove_next_gate.
  destruct H1 as [respects_g2  [respects_g1 is_in_n0_n]].
  assert_and_prove_next_gate.
  destruct H1 as [respects_g4  respects_g3].
  split;
    inversion H0; subst;
      repeat (try apply respects_constraints_directed_app; auto; try constructor).
  symmetry in HeqH2.
  rewrite <- andb_assoc in HeqH2.
  apply andb_true_iff in HeqH2.
  destruct HeqH2 as [q2n0 q1ndnrf].
  apply andb_true_iff in q1ndnrf.
  destruct q1ndnrf as [q1n dnr].
  rewrite Nat.eqb_eq in q2n0.
  subst.
  assumption.
Qed.

Lemma CNOT_commute_rule5_respects_constraints: forall {dim} q1 q2  (in_l out_l1 out_l2 : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT in_l ->
  @CNOT_commute_rule5 dim q1 q2 in_l = Some (out_l1, out_l2) ->
  respects_constraints_directed is_in_graph URzQ_CNOT out_l1
    /\ respects_constraints_directed is_in_graph URzQ_CNOT out_l2.
Proof.
  intros.
  unfold CNOT_commute_rule5 in H0.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H1 as [respects_g0  respects_g].
  assert_and_prove_next_gate.
  destruct H1 as [respects_g2  [respects_g1 is_in_n0_n]].
  assert_and_prove_next_gate.
  destruct H1 as [respects_g4  respects_g3].
  split;
    inversion H0; subst;
      repeat (try apply respects_constraints_directed_app; auto; try constructor).
Qed.

Lemma Rz_cancel_rule_respects_constraints: forall {dim} (is_in_graph : nat -> nat -> bool) a q,
  @cancel_rules_respect_constraints dim _ [Rz_cancel_rule q a] is_in_graph URzQ_CNOT.
Proof.
  intros.
  unfold cancel_rules_respect_constraints.
  intros.
  unfold Rz_cancel_rule in H.
  destruct_In.
  rewrite <- H2 in H1.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H as [respects_g0  respects_g].
  inversion H1.
  apply respects_constraints_directed_app.
  unfold combine_rotations.
  destruct (Qeq_bool (bound (a + a0)) zero_Q); repeat constructor.
  apply respects_constraints_directed_app.
  assumption.
  assumption.
Qed.

Lemma H_cancel_rule_respects_constraints: forall {dim} (is_in_graph : nat -> nat -> bool) q,
  @cancel_rules_respect_constraints dim _ [H_cancel_rule q] is_in_graph URzQ_CNOT.
Proof.
  intros.
  unfold cancel_rules_respect_constraints.
  intros.
  unfold H_cancel_rule in H.
  destruct_In.
  rewrite <- H2 in H1.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H as [respects_g0  respects_g].
  inversion H1.
  apply respects_constraints_directed_app.
  assumption.
  assumption.
Qed.

Lemma X_cancel_rule_respects_constraints: forall {dim} (is_in_graph : nat -> nat -> bool) q,
  @cancel_rules_respect_constraints dim _ [X_cancel_rule q] is_in_graph URzQ_CNOT.
Proof.
  intros.
  unfold cancel_rules_respect_constraints.
  intros.
  unfold X_cancel_rule in H.
  destruct_In.
  rewrite <- H2 in H1.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H as [respects_g0  respects_g].
  inversion H1.
  apply respects_constraints_directed_app.
  assumption.
  assumption.
Qed.

Lemma CNOT_cancel_rule_respects_constraints: forall {dim} (is_in_graph : nat -> nat -> bool) q1 q2,
  @cancel_rules_respect_constraints dim _ [CNOT_cancel_rule q1 q2] is_in_graph URzQ_CNOT.
Proof.
  intros.
  unfold cancel_rules_respect_constraints.
  intros.
  unfold CNOT_cancel_rule in H.
  destruct_In.
  rewrite <- H2 in H1.
  repeat destruct_matches.
  assert_and_prove_next_gate.
  destruct H as [respects_g0 [ respects_g is_inn0n]].
  inversion H1.
  apply respects_constraints_directed_app.
  assumption.
  assumption.
Qed.

Lemma Rz_commute_rules_respect_constraints: forall {dim} n (is_in_graph : nat -> nat -> bool),
  @commute_rules_respect_constraints dim _ (Rz_commute_rules n) is_in_graph URzQ_CNOT.
Proof.
  intros.
  unfold commute_rules_respect_constraints.
  intros.
  unfold Rz_commute_rules in H.
  destruct_In.
  - rewrite <- H2 in H1.
    eapply Rz_commute_rule1_respects_constraints.
    apply H0.
    apply H1.
  - rewrite <- H in H1.
    eapply Rz_commute_rule2_respects_constraints.
    apply H0.
    apply H1.
  - rewrite <-  H2 in H1.
    eapply Rz_commute_rule3_respects_constraints.
    apply H0.
    apply H1.
Qed.

Lemma CNOT_commute_rules_respect_constraints: forall {dim} n1 n2 (is_in_graph : nat -> nat -> bool),
  @commute_rules_respect_constraints dim _ (CNOT_commute_rules n1 n2) is_in_graph URzQ_CNOT.
Proof.
  intros.
  unfold commute_rules_respect_constraints.
  intros.
  unfold CNOT_commute_rules in H.
  destruct_In.
  - rewrite <- H2 in H1.
    eapply CNOT_commute_rule1_respects_constraints.
    apply H0.
    apply H1.
  - rewrite <- H in H1.
    eapply CNOT_commute_rule2_respects_constraints.
    apply H0.
    apply H1.
  - rewrite <-  H2 in H1.
    eapply CNOT_commute_rule3_respects_constraints.
    apply H0.
    apply H1.
  - rewrite <-  H in H1.
    eapply CNOT_commute_rule4_respects_constraints.
    apply H0.
    apply H1.
  - rewrite <-  H2 in H1.
    eapply CNOT_commute_rule5_respects_constraints.
    apply H0.
    apply H1.
Qed.

Lemma propagate_Rz_respects_constraints : forall {dim} a (l : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) (q : nat) l',
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  propagate_Rz a l q = Some l' ->
  respects_constraints_directed is_in_graph URzQ_CNOT l'.
Proof.
  intros.
  unfold propagate_Rz in H0.
  eapply propagate_respects_constraints.
  apply H.
  apply Rz_cancel_rule_respects_constraints.
  apply Rz_commute_rules_respect_constraints.
  apply H0.
Qed.

Lemma propagate_H_respects_constraints : forall {dim} (l : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) (q : nat) l',
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  propagate_H l q = Some l' ->
  respects_constraints_directed is_in_graph URzQ_CNOT l'.
Proof.
  intros.
  unfold propagate_H in H0.
  eapply propagate_respects_constraints.
  apply H.
  apply H_cancel_rule_respects_constraints.
  assert (@commute_rules_respect_constraints dim _ [] is_in_graph URzQ_CNOT).
  unfold commute_rules_respect_constraints.
  intros.
  destruct_In.
  apply H1.
  apply H0.
Qed.

Lemma propagate_X_respects_constraints : forall {dim} (l : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) (q : nat) l',
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  propagate_X l q = Some l' ->
  respects_constraints_directed is_in_graph URzQ_CNOT l'.
Proof.
  intros.
  unfold propagate_X in H0.
  eapply propagate_respects_constraints.
  apply H.
  apply X_cancel_rule_respects_constraints.
  assert (@commute_rules_respect_constraints dim _ [X_commute_rule q] is_in_graph URzQ_CNOT).
  unfold commute_rules_respect_constraints.
  intros.
  destruct_In.
  rewrite <- H4 in H3.
  eapply X_commute_rule_respects_constraints.
  apply H2.
  apply H3.
  apply H1.
  apply H0.
Qed.

Lemma propagate_CNOT_respects_constraints : forall {dim} (l : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) (q1 q2 : nat) l',
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  propagate_CNOT l q1 q2 = Some l' ->
  respects_constraints_directed is_in_graph URzQ_CNOT l'.
Proof.
  intros.
  unfold propagate_Rz in H0.
  eapply propagate_respects_constraints.
  apply H.
  apply CNOT_cancel_rule_respects_constraints.
  apply CNOT_commute_rules_respect_constraints.
  apply H0.
Qed.

Lemma cancel_single_qubit_gates'_respects_constraints : forall {dim} (l acc : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) (n : nat) ,
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  respects_constraints_directed is_in_graph URzQ_CNOT acc ->
  respects_constraints_directed is_in_graph URzQ_CNOT (cancel_single_qubit_gates' l n acc).
Proof.
  intros.
  generalize dependent acc.
  generalize dependent l.
  induction n.
  - intros.
    unfold cancel_single_qubit_gates'. rewrite rev_append_rev.
    apply respects_constraints_directed_app.
    apply rev_respects_constraints.
    assumption.
    assumption.
  - intros.
    destruct l.
    + apply rev_append_respects_constraints; assumption.
    + simpl. destruct g; dependent destruction r; inversion H; subst.
      * destruct (propagate_H l n0) eqn:pH.
        eapply IHn; try reflexivity; auto.
        eapply propagate_H_respects_constraints; try apply pH; auto.
        eapply IHn; try reflexivity; auto.
        constructor; auto.
      * destruct (propagate_X l n0) eqn:pX.
        eapply IHn; try reflexivity; auto.
        eapply propagate_X_respects_constraints; try apply pX; auto.
        eapply IHn; try reflexivity; auto.
        constructor; auto.
      * destruct (propagate_Rz a l n0) eqn:pRz.
        eapply IHn; try reflexivity; auto.
        eapply propagate_Rz_respects_constraints; try apply pRz; auto.
        eapply IHn; try reflexivity; auto.
        constructor; auto.
      * eapply IHn; try reflexivity; auto.
        constructor; auto.
Qed.

Lemma cancel_single_qubit_gates_respects_constraints : forall {dim} (l : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) ,
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  respects_constraints_directed is_in_graph URzQ_CNOT (cancel_single_qubit_gates l).
Proof.
  intros.
  eapply cancel_single_qubit_gates'_respects_constraints.
  assumption.
  constructor.
Qed.

Lemma cancel_two_qubit_gates'_respects_constraints : forall {dim} (l acc : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool) (n : nat) ,
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  respects_constraints_directed is_in_graph URzQ_CNOT acc ->
  respects_constraints_directed is_in_graph URzQ_CNOT (cancel_two_qubit_gates' l n acc).
Proof.
  intros.
  generalize dependent acc.
  generalize dependent l.
  induction n.
  - intros.
    unfold cancel_two_qubit_gates'.
    apply rev_append_respects_constraints; assumption.
  - intros.
    simpl.
    destruct l.
    + subst.
      apply rev_append_respects_constraints; assumption.
    + destruct g; dependent destruction r; inversion H; subst.
      * eapply IHn; try reflexivity; auto.
        constructor; auto.
      * eapply IHn; try reflexivity; auto.
        constructor; auto.
      * eapply IHn; try reflexivity; auto.
        constructor; auto.
      * destruct (propagate_CNOT l n0 n1) eqn:pCX.
        eapply IHn; try reflexivity; auto.
        eapply propagate_CNOT_respects_constraints; try apply pCX; auto.
        eapply IHn; try reflexivity; auto.
        constructor; auto.
Qed.

Lemma cancel_two_qubit_gates_respects_constraints : forall {dim} (l : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  respects_constraints_directed is_in_graph URzQ_CNOT (cancel_two_qubit_gates l).
Proof.
  intros.
  eapply cancel_two_qubit_gates'_respects_constraints.
  assumption.
  constructor.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Bool.Bool.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Prop.
Require Import ExtLib.Data.List.
Require Import ExtLib.Relations.TransitiveClosure.
Require Import ExtLib.Recur.Relation.
Require Import ExtLib.Tactics.

Set Implicit Arguments.
Set Strict Implicit.

Section env.
  Variable typ : Set.
  Variable func : Set.
  Definition var := nat.
  Definition uvar := nat.

  (** NOTE: Putting [typ] and [func] in a module would
   ** reduce the number of parameters here.
   **)
  Inductive expr : Set :=
  | Var : var -> expr
  | Inj : func -> expr
  | App : expr -> expr -> expr
  | Abs : typ -> expr -> expr
  | UVar : uvar -> expr.

  Inductive expr_acc : expr -> expr -> Prop :=
  | acc_App_l : forall f a, expr_acc f (App f a)
  | acc_App_r : forall f a, expr_acc a (App f a)
  | acc_Abs : forall t e, expr_acc e (Abs t e).

  Definition exprs : Set := list expr.

  Theorem wf_expr_acc : well_founded expr_acc.
  Proof.
    clear. red.
    induction a; simpl; intros; constructor; intros;
    try solve [ inversion H ].
    { inversion H; clear H; subst; auto. }
    { inversion H; clear H; subst; auto. }
  Defined.

  Theorem expr_strong_ind
  : forall (P : expr -> Prop),
      (forall v, P (Var v)) ->
      (forall u, P (UVar u)) ->
      (forall i, P (Inj i)) ->
      (forall a b, (forall e, (leftTrans expr_acc) e (App a b) -> P e) -> P (App a b)) ->
      (forall t a, (forall e, (leftTrans expr_acc) e (Abs t a) -> P e) -> P (Abs t a)) ->
      forall e, P e.
  Proof.
    intros P Hvar Huvar Hinj Happ Habs.
    eapply Fix. eapply wf_leftTrans. eapply wf_expr_acc.
    destruct x; auto.
  Qed.

  Theorem expr_strong_ind_no_case
  : forall (P : expr -> Prop),
      (forall e, (forall e', (leftTrans expr_acc) e' e -> P e') -> P e) ->
      forall e, P e.
  Proof.
    intros P H.
    eapply Fix.
    exact (wf_leftTrans wf_expr_acc).
    eauto.
  Qed.

  Section sdec.
    Variable RelDec_eq_typ : RelDec (@eq typ).
    Variable func_eq : func -> func -> bool.

    Fixpoint expr_eq_sdec (e1 e2 : expr) : bool :=
      match e1 , e2 with
      | Var v1 , Var v2 => EqNat.beq_nat v1 v2
      | UVar v1 , UVar v2 => EqNat.beq_nat v1 v2
      | Inj f1 , Inj f2 => func_eq f1 f2
      | App f1 e1 , App f2 e2 =>
        if expr_eq_sdec f1 f2 then
          expr_eq_sdec e1 e2
        else
          false
      | Abs t1 e1 , Abs t2 e2 =>
        if t1 ?[ eq ] t2 then expr_eq_sdec e1 e2
        else false
      | _ , _ => false
      end.

    Variable RelDec_Correct_typ : RelDec_Correct RelDec_eq_typ.
    Variable func_eq_ok : forall a b, func_eq a b = true -> a = b.

    Theorem expr_eq_sdec_ok : forall e1 e2,
        expr_eq_sdec e1 e2 = true ->
        e1 = e2.
    Proof.
      induction e1; destruct e2; simpl; intros; try congruence.
      { eapply EqNat.beq_nat_true in H. congruence. }
      { eapply func_eq_ok in H. congruence. }
      { apply Bool.andb_true_iff in H.
        destruct H. eapply IHe1_1 in H. eapply IHe1_2 in H0. congruence. }
      { consider (t ?[ eq ] t0).
        intros. apply IHe1 in H0. congruence. }
      { eapply EqNat.beq_nat_true in H. congruence. }
    Qed.
  End sdec.

  Variable RelDec_eq_typ : RelDec (@eq typ).
  Variable RelDec_eq_func : RelDec (@eq func).

  Definition variables := list typ.

  Fixpoint expr_eq_dec (e1 e2 : expr) : bool :=
    match e1 , e2 with
      | Var v1 , Var v2 => EqNat.beq_nat v1 v2
      | UVar v1 , UVar v2 => EqNat.beq_nat v1 v2
      | Inj f1 , Inj f2 =>
        f1 ?[ eq ] f2
      | App f1 e1 , App f2 e2 =>
        if expr_eq_dec f1 f2 then
          expr_eq_dec e1 e2
        else
          false
      | Abs t1 e1 , Abs t2 e2 =>
        if t1 ?[ eq ] t2 then expr_eq_dec e1 e2
        else false
      | _ , _ => false
    end.

  Variable RelDec_Correct_typ : RelDec_Correct RelDec_eq_typ.
  Variable RelDec_Correct_func : RelDec_Correct RelDec_eq_func.

  Theorem expr_eq_dec_eq : forall e1 e2,
    expr_eq_dec e1 e2 = true <-> e1 = e2.
  Proof.
    induction e1; destruct e2; simpl; intros;
    repeat match goal with
             | |- context [ if ?X then ?Y else false ] =>
               change (if X then Y else false) with (andb X Y)
             | |- context [ EqNat.beq_nat ?X ?Y ] =>
               change (EqNat.beq_nat X Y) with (X ?[ eq ] Y) ;
                 rewrite rel_dec_correct
             | |- context [ ?X ?[ ?Z ] ?Y ] =>
               rewrite rel_dec_correct
             | |- context [ ?X ?[ @eq ?T ]?Y ] =>
               change (X ?[ @eq T ] Y) with (X ?[ eq ] Y) ;
                 rewrite rel_dec_correct
             | |- context [ List.list_eqb RelDec_eq_typ ?X ?Y ] =>
               change (List.list_eqb RelDec_eq_typ X Y) with (X ?[ eq ] Y) ;
                 rewrite rel_dec_correct
             | |- _ => rewrite andb_true_iff
             | H : forall x, (_ = true) <-> _ |- _ => rewrite H
           end; try solve [ intuition congruence ].
  Qed.

  Global Instance RelDec_eq_expr : RelDec (@eq expr) :=
  { rel_dec := expr_eq_dec }.

  Global Instance RelDecCorrect_eq_expr : RelDec_Correct RelDec_eq_expr.
  Proof.
    constructor. eapply expr_eq_dec_eq.
  Qed.

  Section mentionsAny.
    Variable (uP : uvar -> bool).

    Fixpoint mentionsAny (vP : var -> bool) (e : expr) : bool :=
      match e with
        | Var v => vP v
        | Inj _ => false
        | UVar u => uP u
        | App f e => if mentionsAny vP f then true else mentionsAny vP e
        | Abs _ e => mentionsAny (fun v => match v with
                                             | 0 => false
                                             | S v => vP v
                                           end) e
      end.
  End mentionsAny.

  Lemma Proper_mentionsAny
  : Proper ((@eq uvar ==> @eq bool) ==>
            (@eq var ==> @eq bool) ==>
            @eq _ ==> @eq bool) mentionsAny.
  Proof.
    repeat red. intros; subst.
    revert x0 y0 x y H0 H.
    induction y1; simpl; intros; auto.
    { erewrite IHy1_1; eauto. erewrite IHy1_2; eauto. }
    { eapply IHy1; eauto.
      red. intros; subst. destruct y2; eauto. }
  Qed.

  Lemma mentionsAny_factor
  : forall (fu fu' : uvar -> bool) (e : expr) (fv fv' : var -> bool),
      mentionsAny (fun u : uvar => fu u || fu' u)
                  (fun v : var => fv v || fv' v) e =
      mentionsAny fu fv e || mentionsAny fu' fv' e.
  Proof.
    induction e; simpl; auto; intros; Cases.rewrite_all_goal.
    { forward. simpl. rewrite orb_true_r. reflexivity. }
    { rewrite <- IHe. eapply Proper_mentionsAny; eauto.
      reflexivity. clear. red. intros; subst.
      destruct y; auto. }
  Qed.

  Section mentionsU.
    Variable u : uvar.

    Fixpoint _mentionsU (e : expr) : bool :=
      match e with
        | Var _
        | Inj _ => false
        | UVar u' => EqNat.beq_nat u u'
        | App f e => if _mentionsU f then true else _mentionsU e
        | Abs _ e => _mentionsU e
      end.

    Theorem _mentionsU_mentionsU
    : forall e,
        _mentionsU e = mentionsAny (fun u' => u ?[ eq ] u') (fun _ => false) e.
    Proof.
      induction e; simpl; intros; auto.
      - rewrite <- IHe1. rewrite <- IHe2. reflexivity.
      - rewrite IHe. eapply Proper_mentionsAny; eauto.
        reflexivity. red. intros; subst; destruct y; reflexivity.
    Qed.
  End mentionsU.

  Section mentionsV.
    Fixpoint _mentionsV (v : var) (e : expr) : bool :=
      match e with
        | Var v' => v ?[ eq ] v'
        | Inj _
        | UVar _ => false
        | App a b => if _mentionsV v a then true else _mentionsV v b
        | Abs _ e => _mentionsV (S v) e
      end.

    Theorem _mentionsV_mentionsV
    : forall e v,
        _mentionsV v e = mentionsAny (fun _ => false) (fun v' => v ?[ eq ] v') e.
    Proof.
      induction e; simpl; intros; auto.
      - rewrite <- IHe1. rewrite <- IHe2. reflexivity.
      - rewrite IHe. eapply Proper_mentionsAny; eauto.
        reflexivity. red. intros; subst; destruct y; reflexivity.
    Qed.
  End mentionsV.

  Lemma mentionsAny_complete
  : forall (pu : uvar -> bool) (e : expr) (pv : var -> bool),
      mentionsAny pu pv e = true <->
      (exists u : uvar, _mentionsU u e = true /\ pu u = true) \/
      (exists v : var, _mentionsV v e = true /\ pv v = true).
  Proof.
    induction e; simpl; intros.
    { split.
      - right.
        eexists; split; try eassumption.
        eapply rel_dec_correct. reflexivity.
      - destruct 1.
        + forward_reason; congruence.
        + forward_reason.
          eapply (@rel_dec_correct _ (@eq var)) in H;
            eauto with typeclass_instances. }
    { split; try congruence. destruct 1; forward_reason; congruence. }
    { specialize (IHe1 pv); specialize (IHe2 pv).
      destruct (mentionsAny pu pv e1).
      - split; eauto. intro. apply IHe1 in H.
        destruct H; forward_reason.
        + left; eexists. split; try eassumption. rewrite H. reflexivity.
        + right; eexists; split; try eassumption. rewrite H. reflexivity.
      - rewrite IHe2; clear IHe2.
        split.
        + destruct 1; forward_reason;
          try first [ left ; eexists; split; [ | eassumption ]
                    | right ; eexists; split; [ | eassumption ] ].
          * rewrite H. destruct (_mentionsU x e1); reflexivity.
          * rewrite H. destruct (_mentionsV x e1); reflexivity.
        + destruct 1; forward_reason.
          { consider (_mentionsU x e1); intros.
            - left; eexists; split; try eauto.
              consider (_mentionsU x e2); auto.
              intro. apply IHe1. left; eauto.
            - left; eexists; split; try eauto. }
          { consider (_mentionsV x e1); intros.
            - cut (false = true); try congruence.
              apply IHe1. right; eauto.
            - right. eauto. } }
    { rewrite IHe.
      eapply or_iff_compat_l.
      clear. split; intros; forward_reason.
      - forward. subst. eauto.
      - exists (S x). eauto. }
    { split; intros.
      - left; eexists; split; try eassumption.
        consider (EqNat.beq_nat u u); auto.
      - destruct H; forward_reason; try congruence.
        consider (EqNat.beq_nat x u); auto.
        destruct 1. assumption. }
  Qed.

  Lemma mentionsAny_weaken
  : forall pu pu' pv pv' e,
      (forall u, _mentionsU u e = true -> pu u = false -> pu' u = false) ->
      (forall v, _mentionsV v e = true -> pv v = false -> pv' v = false) ->
      mentionsAny pu pv e = false ->
      mentionsAny pu' pv' e = false.
  Proof.
    intros pu pu' pv pv' e Hu Hv; revert pv pv' Hv.
    induction e; simpl; intros; auto.
    { eapply Hv. eapply rel_dec_eq_true; eauto with typeclass_instances.
      eauto. }
    { forward. simpl in *.
      erewrite IHe1; try eassumption.
      eapply IHe2; try eassumption.
      - intros. eapply Hu.
        rewrite H1. destruct (_mentionsU u e1); auto. auto.
      - intros. eapply Hv. rewrite H1. destruct (_mentionsV v e1); auto. auto.
      - intros. eapply Hu; eauto. rewrite H1; auto.
      - intros. eapply Hv. rewrite H1; eauto. eauto. }
    { eapply IHe. eauto. 2: eassumption. simpl.
      destruct v; eauto. }
    { eapply Hu; auto. simpl.
      symmetry. eapply EqNat.beq_nat_refl. }
  Qed.

End env.

Arguments Var {typ func} _.
Arguments Inj {typ func} _.
Arguments UVar {typ func} _.
Arguments App {typ func} _ _.
Arguments Abs {typ func} _ _.
Arguments mentionsAny {typ func} uP vP _.
Arguments _mentionsU {typ func} _ _.
Arguments _mentionsV {typ func} _ _.

Hint Constructors TransitiveClosure.leftTrans : acc_db.
Hint Constructors TransitiveClosure.rightTrans : acc_db.
Hint Constructors expr_acc : acc_db.


From mathcomp Require Import ssrnat ssrbool fintype.
Require Export prosa.model.schedule.edf.
Require Export prosa.analysis.definitions.schedulability.
Require Export prosa.analysis.transform.edf_trans.
Require Export prosa.analysis.facts.transform.swaps.
Require Export prosa.analysis.facts.readiness.basic.

(** This file contains the main argument of the EDF optimality proof,
    starting with an analysis of the individual functions that drive
    the piece-wise transformation of a given reference schedule in an
    EDF schedule, and ending with proofs of individual properties of
    the obtained EDF schedule. *)

(** Throughout this file, we assume ideal uniprocessor schedules. *)
Require Import prosa.model.processor.ideal.
(** Throughout this file, we assume the basic (i.e., Liu & Layland) readiness model. *)
Require Import prosa.model.readiness.basic.

(** We start by analyzing the helper function [find_swap_candidate],
    which is a problem-specific wrapper around [search_arg]. *)
Section FindSwapCandidateFacts.

  (** For any given type of jobs... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ...consider an ideal uniprocessor schedule... *)
  Variable sched: schedule (ideal.processor_state Job).

  (** ...that is well-behaved (i.e., in which jobs execute only after
     having arrived and only if they are not yet complete). *)
  Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute sched.

  (** Suppose we are given a job [j1]... *)
  Variable j1: Job.

  (** ...and a point in time [t1]... *)
  Variable t1: instant.

  (** ...at which [j1] is scheduled... *)
  Hypothesis H_not_idle: scheduled_at sched j1 t1.

  (** ...and that is before its deadline. *)
  Hypothesis H_deadline_not_missed: t1 < job_deadline j1.

  (** First, we observe that under these assumptions the processor
     state at time [t1] is "relevant" according to the notion of
     relevance underlying the EDF transformation, namely
     [relevant_pstate]. *)
  Lemma t1_relevant: relevant_pstate t1 (sched t1).
  Proof.
    move: H_not_idle. rewrite scheduled_at_def => /eqP ->.
    rewrite /relevant_pstate -/(has_arrived j1 t1).
    move: (H_jobs_must_arrive_to_execute j1 t1) => SCHED_ARR.
      by apply SCHED_ARR.
  Qed.

  (** Since [t1] is relevant, we conclude that a search for a relevant
     state succeeds (if nothing else, it finds [t1]). *)
  Lemma fsc_search_successful:
    exists t, search_arg sched (relevant_pstate t1) earlier_deadline t1 (job_deadline j1) = Some t.
  Proof.
    apply search_arg_not_none.
    exists t1. split.
    - by apply /andP; split.
    - by apply t1_relevant.
  Qed.

  (** For rewriting purposes, we observe that the [search_arg]
     operation within [find_swap_candidate] yields the final result of
     [find_swap_candidate]. *)
  Corollary fsc_search_result:
    search_arg sched (relevant_pstate t1) earlier_deadline t1 (job_deadline j1) = Some (find_swap_candidate sched t1 j1).
  Proof.
    move: fsc_search_successful => [t FOUND].
    by rewrite /find_swap_candidate FOUND.
  Qed.

  (** There is a job that is scheduled at the time that
     [find_swap_candidate] returns, and that job arrives no later than
     at time [t1]. *)
  Lemma fsc_not_idle:
    exists j', (scheduled_at sched j' (find_swap_candidate sched t1 j1))
               /\ job_arrival j' <= t1.
  Proof.
    move: fsc_search_successful => [t FOUND].
    move: (search_arg_pred _ _ _ _ _ _ FOUND).
    rewrite /relevant_pstate.
    destruct (sched t) as [j'|] eqn:SCHED_t => // ARR_j'.
    exists j'. split => //.
    rewrite /find_swap_candidate FOUND.
    rewrite scheduled_at_def //.
      by apply /eqP.
  Qed.

  (** Since we are considering a uniprocessor model, only one job is
     scheduled at a time. Hence once we know that a job is scheduled
     at the time that [find_swap_candidate] returns, we can conclude
     that it arrives not later than at time t1. *)
  Corollary fsc_found_job_arrival:
    forall j2,
      scheduled_at sched j2 (find_swap_candidate sched t1 j1) ->
      job_arrival j2 <= t1.
  Proof.
    move=> j2 SCHED_j2.
    move: fsc_not_idle => [j' [SCHED_j' ARR]].
    by rewrite -(ideal_proc_model_is_a_uniprocessor_model _ _ _ _ SCHED_j' SCHED_j2).
  Qed.

  (** We observe that [find_swap_candidate] returns a value within a
     known finite interval. *)
  Lemma fsc_range:
    t1 <= find_swap_candidate sched t1 j1 < job_deadline j1.
  Proof. move: fsc_search_result. by apply search_arg_in_range. Qed.

  (** For convenience, since we often only require the lower bound on
     the interval, we re-state it as a corollary. *)
  Corollary fsc_range1:
    t1 <= find_swap_candidate sched t1 j1.
  Proof. by move: fsc_range => /andP [LE _]. Qed.

  (** The following lemma is a key step of the overall proof: the job
     scheduled at the time found by [find_swap_candidate] has the
     property that it has a deadline that is no later than that of any
     other job in the window given by time [t1] and the deadline of
     the job scheduled at time [t1]. *)
  Lemma fsc_found_job_deadline:
    forall j2,
      scheduled_at sched j2 (find_swap_candidate sched t1 j1) ->
      forall j t,
        t1 <= t < job_deadline j1 ->
        scheduled_at sched j t ->
        job_arrival j <= t1 ->
        job_deadline j2 <= job_deadline j.
  Proof.
    move=> j2 SCHED_j2 j t /andP [t1_le_t t_lt_dl1] SCHED_j ARR_j.
    have TOTAL: total earlier_deadline
      by rewrite /earlier_deadline => s1 s2; apply leq_total.
    have TRANS: transitive earlier_deadline
      by rewrite /earlier_deadline => s1 s2 s3; apply leq_trans.
    have REFL: reflexive earlier_deadline
      by rewrite /earlier_deadline => s; apply leqnn.
    move: SCHED_j SCHED_j2. rewrite !scheduled_at_def => /eqP SCHED_j /eqP SCHED_j2.
    have ED: earlier_deadline (sched (find_swap_candidate sched t1 j1)) (sched t).
    {
      move: (search_arg_extremum _ _ _ REFL TRANS TOTAL _ _ _ fsc_search_result) => MIN.
      apply (MIN t).
      - by apply /andP; split.
      - by rewrite /relevant_pstate SCHED_j.
    }
    by move: ED; rewrite /earlier_deadline /oapp SCHED_j SCHED_j2.
  Qed.

  (** As a special case of the above lemma, we observe that the job
     scheduled at the time given by [find_swap_candidate] in
     particular has a deadline no later than the job scheduled at time
     [t1]. *)
  Corollary fsc_no_later_deadline:
    forall j2,
      scheduled_at sched j2 (find_swap_candidate sched t1 j1) ->
      job_deadline j2 <= job_deadline j1.
  Proof.
    move=> j2 SCHED_j2.
    apply fsc_found_job_deadline with (t := t1) => //.
    - by apply /andP; split.
    - by apply H_jobs_must_arrive_to_execute.
  Qed.

End FindSwapCandidateFacts.

(** In the next section, we analyze properties of [make_edf_at], which
    we abbreviate as "[mea]" in the following. *)
Section MakeEDFAtFacts.

  (** For any given type of jobs... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ...consider an ideal uniprocessor schedule... *)
  Variable sched: schedule (ideal.processor_state Job).

  (** ...that is well-behaved...  *)
  Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute sched.

  (** ...and in which no scheduled job misses a deadline. *)
  Hypothesis H_no_deadline_misses: all_deadlines_met sched.

  (** Since we will require this fact repeatedly, we briefly observe
     that, since no scheduled job misses its deadline, if a job is
     scheduled at some time [t], then its deadline is later than
     [t]. *)
  Fact scheduled_job_in_sched_has_later_deadline:
    forall j t,
      scheduled_at sched j t ->
      job_deadline j > t.
  Proof.
    move=> j t SCHED.
    apply (scheduled_at_implies_later_deadline sched) => //.
    - by apply ideal_proc_model_ensures_ideal_progress.
    - by apply (H_no_deadline_misses _ t).
  Qed.

  (** We analyze [make_edf_at] applied to an arbitrary point in time,
     which we denote [t_edf] in the following. *)
  Variable t_edf: instant.

  (** For brevity, let [sched'] denote the schedule obtained from
     [make_edf_at] applied to [sched] at time [t_edf]. *)
  Let sched' := make_edf_at sched t_edf.

  (** First, we observe that in [sched'] jobs still don't execute past
     completion. *)
  Lemma mea_completed_jobs:
    completed_jobs_dont_execute sched'.
  Proof.
    have IDEAL := @ideal_proc_model_ensures_ideal_progress Job.
    have UNIT := @ideal_proc_model_provides_unit_service Job.
    rewrite /sched' /make_edf_at.
    destruct (sched t_edf) as [j_orig|] eqn:SCHED; last by done.
    have SCHED': scheduled_at sched j_orig t_edf
      by rewrite scheduled_at_def; apply /eqP.
    apply swapped_completed_jobs_dont_execute => //.
    apply fsc_range1 => //.
    by apply scheduled_job_in_sched_has_later_deadline.
  Qed.

  (** Importantly, [make_edf_at] does not introduce any deadline
     misses, which is a crucial step in the EDF optimality
     argument. *)
  Lemma mea_no_deadline_misses:
    all_deadlines_met sched'.
  Proof.
    move=> j t SCHED.
    rewrite /sched' /make_edf_at.
    destruct (sched t_edf) as [j_orig|] eqn:SCHED_orig; last first.
    {
      apply (H_no_deadline_misses _ t).
      move: SCHED.
      by rewrite /sched' /make_edf_at SCHED_orig.
    }
    {
      have SCHED': scheduled_at sched j_orig t_edf
        by rewrite scheduled_at_def; apply /eqP.
      move: (scheduled_job_in_sched_has_later_deadline _ _ SCHED') => DL_orig.
      apply edf_swap_no_deadline_misses_introduced => //.
      - by apply ideal_proc_model_ensures_ideal_progress.
      - by apply fsc_range1 => //.
      - move=> j1 j2 SCHED_j1 SCHED_j2.
        apply: (fsc_found_job_deadline sched _ j_orig t_edf _ _ _ _ _ t_edf) => //.
        + by apply /andP; split.
        + by apply H_jobs_must_arrive_to_execute.
      - move=> j1 SCHED_j1.
        move: (fsc_not_idle sched H_jobs_must_arrive_to_execute j_orig t_edf SCHED' DL_orig) => [j' [SCHED_j' ARR_j']].
        exists j'. split => //.
        by apply scheduled_job_in_sched_has_later_deadline.
      - have EX: (exists t', scheduled_at sched j t').
        {
          apply swap_job_scheduled with (t1 := t_edf) (t2 := find_swap_candidate sched t_edf j_orig) (t0 := t).
          by move: SCHED; rewrite /sched' /make_edf_at SCHED_orig.
        }
        move: EX => [t' SCHED_t'].
        by apply H_no_deadline_misses with (t := t').
    }
  Qed.

  (** As a result, we may conclude that any job scheduled at a time t has a deadline later than t. *)
  Corollary mea_scheduled_job_has_later_deadline:
    forall j t,
      scheduled_at sched' j t ->
      job_deadline j > t.
  Proof.
    move=> j t SCHED.
    apply (scheduled_at_implies_later_deadline sched') => //.
    - by apply mea_completed_jobs.
    - by apply ideal_proc_model_ensures_ideal_progress.
    - by apply mea_no_deadline_misses with (t := t).
  Qed.

  (** Next comes a big step in the optimality proof: we observe that
     [make_edf_at] indeed ensures that [EDF_at] holds at time [t_edf] in
     [sched']. As this is a larger argument, we proceed by case analysis and
     first establish a couple of helper lemmas in the following section. *)
  Section GuaranteeCaseAnalysis.

    (** Let [j_orig] denote the job scheduled in [sched] at time
        [t_edf], let [j_edf] denote the job scheduled in [sched'] at
        time [t_edf], and let [j'] denote any job scheduled in
        [sched'] at some time [t'] after [t_edf]...  *)
    Variable j_orig j_edf j': Job.

    Variable t': instant.
    Hypothesis H_t_edf_le_t' : t_edf <= t'.

    Hypothesis H_sched_orig: scheduled_at sched  j_orig t_edf.
    Hypothesis H_sched_edf: scheduled_at sched' j_edf t_edf.
    Hypothesis H_sched': scheduled_at sched' j' t'.

    (** ... and that arrives before time [t_edf]. *)
    Hypothesis H_arrival_j' : job_arrival j' <= t_edf.

    (** We begin by observing three simple facts that will be used repeatedly in
        the case analysis. *)

    (** First, the deadline of [j_orig] is later than [t_edf]. *)
    Fact mea_guarantee_dl_orig: t_edf < job_deadline j_orig.
    Proof. by apply (scheduled_job_in_sched_has_later_deadline j_orig t_edf H_sched_orig). Qed.

    (** Second, by the definition of [sched'], [j_edf] is scheduled in
        [sched] at the time returned by [find_swap_candidate]. *)
    Fact mea_guarantee_fsc_is_j_edf: sched (find_swap_candidate sched t_edf j_orig) = Some j_edf.
    Proof.
      move: (H_sched_orig). rewrite scheduled_at_def => /eqP SCHED.
      move: (H_sched_edf). rewrite /sched' /make_edf_at /swapped /replace_at {1}SCHED //=.
      rewrite scheduled_at_def.
      destruct (find_swap_candidate sched t_edf j_orig == t_edf) eqn:FSC.
      - by move: FSC => /eqP -> /eqP.
      - by rewrite ifT // => /eqP.
    Qed.

    (** Third, the deadline of [j_edf] is no later than the deadline
        of [j_orig]. *)
    Fact mea_guarantee_deadlines: job_deadline j_edf <= job_deadline j_orig.
    Proof.
      apply: (fsc_no_later_deadline sched _ _ t_edf) => //.
      - by exact mea_guarantee_dl_orig.
      - by rewrite scheduled_at_def mea_guarantee_fsc_is_j_edf //=.
    Qed.

    (** With the setup in place, we are now ready to begin the case analysis. *)

    (** First, we consider the simpler case where [t'] is no earlier
        than the deadline of [j_orig]. This case is simpler because
        [t'] being no earlier than [j_orig]'s deadline implies that
        [j'] has deadline no earlier than [j_orig] (since no scheduled
        job in [sched] misses a deadline), which in turn has a
        deadline no earlier than [j_edf].  *)
    Lemma mea_guarantee_case_t'_past_deadline:
      job_deadline j_orig <= t' ->
      job_deadline j_edf <= job_deadline j'.
    Proof.
      move: (mea_scheduled_job_has_later_deadline j' t' H_sched') => DL_j' BOUND_t'.
      apply leq_trans with (n := job_deadline j_orig) => // ;
        first by exact mea_guarantee_deadlines.
      apply leq_trans with (n := t') => //.
      by apply ltnW.
    Qed.

    (** Next, we consider the more difficult case, where [t'] is
        before the deadline of [j_orig]. *)
    Lemma mea_guarantee_case_t'_before_deadline:
      t' < job_deadline j_orig ->
      job_deadline j_edf <= job_deadline j'.
    Proof.
      move: (H_sched_orig). rewrite scheduled_at_def => /eqP SCHED BOUND_t'.
      move: (mea_guarantee_fsc_is_j_edf) => FSC.
      have EX: (exists x, scheduled_at sched j' x /\ t_edf <= x < job_deadline j_orig).
      {
        case: (boolP(t_edf == t')) => [/eqP EQ| /eqP NEQ].
        - exists (find_swap_candidate sched t_edf j_orig).
          split; last by apply fsc_range => //; exact mea_guarantee_dl_orig.
          subst. rewrite -(ideal_proc_model_is_a_uniprocessor_model _ _ _ _ H_sched_edf H_sched').
          by rewrite scheduled_at_def FSC //=.
        - case: (boolP(find_swap_candidate sched t_edf j_orig == t')) => [/eqP EQ' | /eqP NEQ'].
          + exists t_edf.
            split; last by apply /andP; split => //; exact mea_guarantee_dl_orig.
            rewrite -(swap_job_scheduled_t2 _  _ (find_swap_candidate sched t_edf j_orig) _).
            move: H_sched'. rewrite /sched' /make_edf_at SCHED.
            by rewrite EQ'.
          + move: NEQ NEQ' => /eqP NEQ /eqP NEQ'. exists t'.
            split; last by  apply /andP; split.
            rewrite -(swap_job_scheduled_other_times _ t_edf (find_swap_candidate sched t_edf j_orig)) //.
            move: H_sched'.
            by rewrite /sched' /make_edf_at SCHED.
      }
      move: EX => [t'' [SCHED'' RANGE]].
      apply: (fsc_found_job_deadline sched _ j_orig t_edf _ _ _ _ _ t'') => // ;
        first by exact mea_guarantee_dl_orig.
      by rewrite scheduled_at_def FSC //=.
    Qed.

  End GuaranteeCaseAnalysis.

  (** Finally, putting the preceding cases together, we obtain the
      result that [make_edf_at] establishes [EDF_at] at time
      [t_edf]. *)
  Lemma make_edf_at_guarantee:
    EDF_at sched' t_edf.
  Proof.
    move=> j_edf H_sched_edf t' j' t_edf_le_t' H_sched' H_arrival_j'.
    destruct (sched t_edf) as [j_orig|] eqn:SCHED;
      last by move: (H_sched_edf); rewrite /sched' /make_edf_at scheduled_at_def => /eqP; rewrite !SCHED.
    have H_sched: scheduled_at sched j_orig t_edf
      by rewrite scheduled_at_def; apply /eqP.
    case: (boolP (t' < job_deadline j_orig)).
    - by apply mea_guarantee_case_t'_before_deadline.
    - rewrite -leqNgt => BOUND_t'.
      by apply: (mea_guarantee_case_t'_past_deadline j_orig j_edf j' t').
  Qed.

  (** We observe that [make_edf_at] maintains the property that jobs
      must arrive to execute. *)
  Lemma mea_jobs_must_arrive:
    jobs_must_arrive_to_execute sched'.
  Proof.
    move=> j t.
    rewrite /has_arrived /sched' /make_edf_at.
    destruct (sched t_edf) as [j_orig|] eqn:SCHED_orig;
      last by move=> SCHED; by apply H_jobs_must_arrive_to_execute.
    have SCHED': scheduled_at sched j_orig t_edf
      by rewrite scheduled_at_def; apply /eqP.
    move: (scheduled_job_in_sched_has_later_deadline j_orig t_edf SCHED') => DL_orig.
    rewrite scheduled_at_def /swapped /replace_at.
    case: (boolP((find_swap_candidate sched t_edf j_orig) == t)) => [/eqP EQ| /eqP NEQ].
    - rewrite SCHED_orig => /eqP j_is_orig.
      injection j_is_orig => <-.
      apply leq_trans with (n := t_edf).
      + by apply H_jobs_must_arrive_to_execute.
      + by rewrite -EQ; apply fsc_range1.
    - case (boolP(t_edf == t)) => [/eqP EQ'| /eqP NEQ'].
      + move=> SCHED_j.
        have ARR_j: job_arrival j <= t_edf by apply fsc_found_job_arrival with (sched0 := sched) (j1 := j_orig) => //; rewrite scheduled_at_def.
        by rewrite -EQ'.
      + move=> SCHED_j.
        apply H_jobs_must_arrive_to_execute.
        by rewrite scheduled_at_def /scheduled_in /pstate_instance.
  Qed.

  (** We connect the fact that a job is scheduled in [sched'] to the
     fact that it must be scheduled somewhere in [sched], too, since
     [make_edf_at] does not introduce any new jobs.  *)
  Lemma mea_job_scheduled:
    forall j t,
      scheduled_at sched' j t ->
      exists t', scheduled_at sched j t'.
  Proof.
    rewrite /sched' /make_edf_at.
    move=> j t SCHED_j.
    destruct (sched t_edf) as [j_orig|] eqn:SCHED_orig; last by exists t.
    eapply swap_job_scheduled.
    by exact SCHED_j.
  Qed.

  (** Conversely, if a job is scheduled in [sched], it is also
     scheduled somewhere in [sched'] since [make_edf_at] does not lose
     any jobs. *)
  Lemma mea_job_scheduled':
    forall j t,
      scheduled_at sched j t ->
      exists t', scheduled_at sched' j t'.
  Proof.
    move=> j t SCHED_j.
    rewrite /sched' /make_edf_at.
    destruct (sched t_edf) as [j_orig|] eqn:SCHED_orig;
      last by exists t.
    eapply swap_job_scheduled_original.
    by exact SCHED_j.
  Qed.

  (** Next, we observe that if all jobs in [sched] come from a given
     arrival sequence, then that's still the case in [sched'], too. *)
  Section ArrivalSequence.

    (** For given arrival sequence,... *)
    Variable arr_seq: arrival_sequence Job.

    (** ...if all jobs in [sched] come from the arrival sequence,... *)
    Hypothesis H_from_arr_seq: jobs_come_from_arrival_sequence sched arr_seq.

    (** ...then all jobs in [sched'] do, too. *)
    Lemma mea_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched' arr_seq.
    Proof.
      rewrite /sched' /make_edf_at.
      destruct (sched t_edf) as [j_orig|] eqn:SCHED_orig;
        last by done.
      by apply swapped_jobs_come_from_arrival_sequence.
    Qed.

  End ArrivalSequence.

  (** For the final claim, assume that [EDF_at] already holds
     everywhere prior to time [t_edf], i.e., that [sched] consists of
     an EDF prefix. *)
  Hypothesis H_EDF_prefix: forall t, t < t_edf -> EDF_at sched t.

  (** We establish a key property of [make_edf_at]: not only does it
     ensure [EDF_at] at time [t_edf], it also maintains the fact that
     the schedule has an EDF prefix prior to time [t_edf]. In other
     words, it grows the EDF prefix by one time unit. *)
  Lemma mea_EDF_widen:
    forall t, t <= t_edf -> EDF_at sched' t.
  Proof.
    move=> t.
    rewrite leq_eqVlt => /orP [/eqP EQ|LT] ;
      first by rewrite EQ; apply make_edf_at_guarantee.
    rewrite /sched' /make_edf_at.
    destruct (sched t_edf) as [j_orig|] eqn:SCHED_edf; last by apply H_EDF_prefix.
    move=> j SCHED_j t' j' LE_t_t' SCHED_j' ARR_j'.
    have SCHED_edf': scheduled_at sched j_orig t_edf
      by rewrite scheduled_at_def; apply /eqP.
    have LT_t_fsc:  t < find_swap_candidate sched t_edf j_orig.
    {
      apply ltn_leq_trans with (n := t_edf) => //.
      apply fsc_range1 => //.
      by apply scheduled_job_in_sched_has_later_deadline.
    }
    move: SCHED_j.
    have ->: scheduled_at (swapped sched t_edf (find_swap_candidate sched t_edf j_orig)) j t = scheduled_at sched j t
      by apply swap_job_scheduled_other_times; [move: LT | move: LT_t_fsc]; rewrite ltn_neqAle => /andP [NEQ _]; rewrite eq_sym.
    move => SCHED_j.
    move: (H_EDF_prefix t LT). rewrite /EDF_at => EDF.
    move: (SCHED_j').
    move: (swap_job_scheduled_cases _ _ _ _ _ SCHED_j') => [->|[[EQ ->]|[EQ ->]]] SCHED_j'_orig.
    - by apply EDF with (t' := t').
    - by apply EDF with (t' := (find_swap_candidate sched t_edf j_orig)) => //; apply ltnW.
    - by apply EDF with (t' := t_edf) => //; apply ltnW.
  Qed.

End MakeEDFAtFacts.

(** In the following section, we establish properties of [edf_transform_prefix]. *)
Section EDFPrefixFacts.

  (** For any given type of jobs... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ...consider an ideal uniprocessor schedule... *)
  Variable sched: schedule (ideal.processor_state Job).

  (** ...that is well-behaved...  *)
  Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute sched.

  (** ...and in which no scheduled job misses a deadline. *)
  Hypothesis H_no_deadline_misses: all_deadlines_met sched.

  (** Consider any point in time, denoted [horizon], and... *)
  Variable horizon: instant.

  (** ...let [sched'] denote the schedule obtained by transforming
     [sched] up to the horizon. *)
  Let sched' := edf_transform_prefix sched horizon.

  (** To start, we observe that [sched'] is still well-behaved and
     without deadline misses. *)
  Lemma edf_prefix_well_formedness:
    completed_jobs_dont_execute sched'
    /\
    jobs_must_arrive_to_execute sched'
    /\
    all_deadlines_met sched'.
  Proof.
    rewrite /sched' /edf_transform_prefix.
    apply prefix_map_property_invariance; last by split.
    move=> sched'' t [COMP [ARR DL_MET]].
    split; last split.
    - apply mea_completed_jobs => //.
    - apply mea_jobs_must_arrive => //.
    - apply mea_no_deadline_misses => //.
  Qed.

  (** Because it is needed frequently, we extract the second clause of
     the above conjunction as a corollary. *)
  Corollary edf_prefix_jobs_must_arrive:
    jobs_must_arrive_to_execute sched'.
  Proof. by move: edf_prefix_well_formedness => [_ [ARR _]]. Qed.

  (** We similarly observe that the absence of deadline misses implies
     that any scheduled job must have a deadline at a time later then
     when it is scheduled. *)
  Corollary edf_prefix_scheduled_job_has_later_deadline:
    forall j t,
      scheduled_at sched' j t ->
      job_deadline j > t.
  Proof.
    move=> j t SCHED.
    move: edf_prefix_well_formedness => [COMP [ARR DL_MET]].
    apply (scheduled_at_implies_later_deadline sched') => //.
    - by apply ideal_proc_model_ensures_ideal_progress.
    - by apply (DL_MET j t).
  Qed.

  (** Since no jobs are lost or added to the schedule by
     [edf_transform_prefix], we if a job is scheduled in the
     transformed schedule, then it is also scheduled at some point in
     the original schedule. *)
  Lemma edf_prefix_job_scheduled:
    forall j t,
      scheduled_at sched' j t ->
      exists t', scheduled_at sched j t'.
  Proof.
    rewrite /sched' /edf_transform_prefix.
    move=> j.
    apply prefix_map_property_invariance;
      last by move=> t SCHED; exists t.
    move=> sched'' t'' EX t''' SCHED_mea.
    move: (mea_job_scheduled _ _ _ _ SCHED_mea) => [t'''' SCHED''''].
      by apply: (EX t'''' SCHED'''').
  Qed.

  (** Conversely, if a job is scheduled in the original schedule, it is
     also scheduled at some point in the transformed schedule. *)
  Lemma edf_prefix_job_scheduled':
    forall j t,
      scheduled_at sched j t ->
      exists t', scheduled_at sched' j t'.
  Proof.
    move=> j t SCHED_j.
    rewrite /sched' /edf_transform_prefix.
    apply prefix_map_property_invariance; last by exists t.
    move=> schedX tx [t' SCHEDX_j].
    eapply mea_job_scheduled'.
    by exact SCHEDX_j.
  Qed.

  (** Next, we note that [edf_transform_prefix] maintains the
     property that all jobs stem from a given arrival sequence. *)
  Section ArrivalSequence.

    (** For any arrival sequence,... *)
    Variable arr_seq: arrival_sequence Job.

    (** ...if all jobs in the original schedule come from the arrival sequence,... *)
    Hypothesis H_from_arr_seq: jobs_come_from_arrival_sequence sched arr_seq.

    (** ...then all jobs in the transformed schedule still come from
       the same arrival sequence. *)
    Lemma edf_prefix_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched' arr_seq.
    Proof.
      rewrite /sched' /edf_transform_prefix.
      apply prefix_map_property_invariance; last by done.
      move => schedX t ARR.
      by apply mea_jobs_come_from_arrival_sequence.
    Qed.

  End ArrivalSequence.

  (** We establish the key property of [edf_transform_prefix]: that it indeed
     ensures that the resulting schedule ensures the EDF invariant up to the
     given [horizon].  *)
  Lemma edf_prefix_guarantee:
    forall t,
      t < horizon ->
      EDF_at sched' t.
  Proof.
    move=> t IN_PREFIX.
    rewrite /sched' /edf_transform_prefix.
    apply prefix_map_pointwise_property
      with (Q := EDF_at)
           (P := (fun sched => completed_jobs_dont_execute sched
                               /\
                               jobs_must_arrive_to_execute sched
                               /\
                               all_deadlines_met sched))=> //.
    - move=> schedX t_ref [COMP [ARR DL]].
      split; last split.
      + by apply mea_completed_jobs => //.
      + by apply mea_jobs_must_arrive => //.
      + by apply mea_no_deadline_misses => //.
    - move=> schedX t_ref [COMP [ARR DL]].
      by apply mea_EDF_widen.
  Qed.

End EDFPrefixFacts.

(** Finally, we observe that [edf_transform_prefix] is prefix-stable, which
   allows us to replace an earlier horizon with a later horizon.  Note: this is
   in a separate section because we need [edf_prefix_jobs_must_arrive]
   generalized for any schedule. *)
Section EDFPrefixInclusion.

  (** For any given type of jobs... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ...consider an ideal uniprocessor schedule... *)
  Variable sched: schedule (ideal.processor_state Job).

  (** ...that is well-behaved...  *)
  Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute sched.

  (** ...and in which no scheduled job misses a deadline. *)
  Hypothesis H_no_deadline_misses: all_deadlines_met sched.

  Lemma edf_prefix_inclusion:
    forall h1 h2,
      h1 <= h2 ->
      forall t,
        t < h1 ->
        (edf_transform_prefix sched h1) t = (edf_transform_prefix sched h2) t.
  Proof.
    move=> h1 h2 LE_h1_h2 t LT_t_h1.
    induction h2; first by move: (ltn_leq_trans LT_t_h1 LE_h1_h2).
    move: LE_h1_h2. rewrite leq_eqVlt => /orP [/eqP ->|LT]; first by done.
    move: LT. rewrite ltnS => LE_h1_h2.
    rewrite [RHS]/edf_transform_prefix /prefix_map -/prefix_map IHh2 //.
    rewrite {1}/make_edf_at.
    destruct (prefix_map sched make_edf_at h2 h2) as [j|] eqn:SCHED; last by done.
    rewrite -(swap_before_invariant _  h2 (find_swap_candidate (edf_transform_prefix sched h2) h2 j)) // ;
      last by apply ltn_leq_trans with (n := h1).
    have SCHED_j: scheduled_at (edf_transform_prefix sched h2) j h2
      by rewrite scheduled_at_def /edf_transform_prefix; apply /eqP.
    apply fsc_range1 => //.
    - by apply edf_prefix_jobs_must_arrive.
    - apply edf_prefix_scheduled_job_has_later_deadline with (sched0 := sched) (horizon := h2) => //.
  Qed.

End EDFPrefixInclusion.

(** In the following section, we finally establish properties of the
    overall EDF transformation[edf_transform]. *)
Section EDFTransformFacts.

  (** For any given type of jobs... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ...consider an ideal uniprocessor schedule... *)
  Variable sched: schedule (ideal.processor_state Job).

  (** ...that is well-behaved...  *)
  Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute sched.

  (** ...and in which no scheduled job misses a deadline. *)
  Hypothesis H_no_deadline_misses: all_deadlines_met sched.

  (** In the following, let [sched_edf] denote the EDF schedule obtained by
     transforming the given reference schedule. *)
  Let sched_edf := edf_transform sched.

  (** We begin with the first key property: the resulting schedule is actually
     an EDF schedule. *)
  Theorem edf_transform_ensures_edf:
    EDF_schedule sched_edf.
  Proof.
    rewrite /EDF_schedule /sched_edf  /edf_transform => t.
    rewrite /EDF_at //=  => j SCHED_j t' j' LE_t_t' SCHED_j' ARR_j'.
    move: SCHED_j.
    rewrite scheduled_at_def.
    have ->: edf_transform_prefix sched t.+1 t = edf_transform_prefix sched t'.+1 t
      by apply edf_prefix_inclusion.
    rewrite -scheduled_at_def.
    move=> SCHED_j.
    move: (edf_prefix_guarantee sched H_jobs_must_arrive_to_execute H_completed_jobs_dont_execute H_no_deadline_misses t'.+1 t) => EDF.
    feed EDF; first by done.
    by apply (EDF j SCHED_j t' j' LE_t_t').
  Qed.

  (** Next, we observe that completed jobs still don't execute in the resulting
     EDF schedule. This observation is needed to establish that the resulting
     EDF schedule is valid. *)
  Lemma edf_transform_completed_jobs_dont_execute:
    completed_jobs_dont_execute sched_edf.
  Proof.
    move=> j t.
    rewrite /sched_edf /edf_transform /service /service_during.
    have ->: \sum_(0 <= t0 < t) service_at (fun t1 : instant => edf_transform_prefix sched t1.+1 t1) j t0 =
             \sum_(0 <= t0 < t) service_at (edf_transform_prefix sched t.+1) j t0.
    {
      apply eq_big_nat => t' /andP [_ LT_t].
      rewrite /service_at.
      rewrite (edf_prefix_inclusion _ _ _ _ t'.+1 t.+1) => //.
      by apply ltn_trans with (n := t).
    }
    set S := (edf_transform_prefix sched t.+1).
    rewrite -/(service_during S j 0 t) -/(service S j t) {}/S.
    move: (edf_prefix_well_formedness sched H_jobs_must_arrive_to_execute H_completed_jobs_dont_execute H_no_deadline_misses t.+1) => [COMP _].
    by apply COMP.
  Qed.

  (** Similarly, we observe that no job is scheduled prior to its arrival. *)
  Lemma edf_transform_jobs_must_arrive:
    jobs_must_arrive_to_execute sched_edf.
  Proof.
    move=> j t.
    rewrite /sched_edf /edf_transform.
    move: (edf_prefix_well_formedness sched H_jobs_must_arrive_to_execute H_completed_jobs_dont_execute H_no_deadline_misses t.+1) => [_ [ARR _]].
    by apply ARR.
  Qed.

  (** We next establish the second key property: in the transformed EDF
     schedule, no scheduled job misses a deadline. *)
  Theorem edf_transform_deadlines_met:
    all_deadlines_met sched_edf.
  Proof.
    move=> j t.
    rewrite /sched_edf /edf_transform /job_meets_deadline /completed_by /service /service_during  => SCHED.
    have LT_t_dl: t < job_deadline j
      by apply edf_prefix_scheduled_job_has_later_deadline with (sched0 := sched) (horizon := t.+1).
    set t_dl := (job_deadline j).
    have ->: \sum_(0 <= t0 < t_dl) service_at (fun t1 : instant => edf_transform_prefix sched t1.+1 t1) j t0 =
             \sum_(0 <= t0 < t_dl) service_at (edf_transform_prefix sched t_dl) j t0.
    {
      apply eq_big_nat => t' /andP [_ LT_t].
      rewrite /service_at.
      by rewrite (edf_prefix_inclusion _ _ _ _ t'.+1 t_dl).
    }
    move: SCHED. rewrite scheduled_at_def (edf_prefix_inclusion _ _ _ _ t.+1 t_dl) => // SCHED.
    move: (edf_prefix_well_formedness sched H_jobs_must_arrive_to_execute H_completed_jobs_dont_execute H_no_deadline_misses t_dl) => [_ [_ DL]]. move: DL.
    rewrite /all_deadlines_met /job_meets_deadline /completed_by /service /service_during => DL.
    apply: (DL j t)=>//=.
      by rewrite scheduled_at_def.
  Qed.

  (** We observe that no new jobs are introduced: any job scheduled in the EDF
     schedule were also present in the reference schedule. *)
  Lemma edf_transform_job_scheduled:
    forall j t, scheduled_at sched_edf j t -> exists t', scheduled_at sched j t'.
  Proof.
    move=> j t.
    rewrite /sched_edf /edf_transform {1}scheduled_at_def -scheduled_at_def.
    by apply edf_prefix_job_scheduled.
  Qed.

  (** Conversely, we observe that no jobs are lost: any job scheduled in the
     reference schedule is also present in the EDF schedule. *)
  Lemma edf_transform_job_scheduled':
    forall j t, scheduled_at sched j t -> exists t', scheduled_at sched_edf j t'.
  Proof.
    move=> j t SCHED_j.
    have EX: exists t', scheduled_at (edf_transform_prefix sched (job_deadline j)) j t'
      by apply edf_prefix_job_scheduled' with (t0 := t).
    move: EX => [t' SCHED'].
    exists t'.
    rewrite /sched_edf /edf_transform scheduled_at_def.
    rewrite (edf_prefix_inclusion _ _ _ _ t'.+1 (job_deadline j)) -?scheduled_at_def=> //.
    by apply edf_prefix_scheduled_job_has_later_deadline with (sched0 := sched) (horizon := job_deadline j).
  Qed.

  (** Next, we note that [edf_transform] maintains the property that all jobs
     stem from a given arrival sequence. *)
  Section ArrivalSequence.

    (** For any arrival sequence,... *)
    Variable arr_seq: arrival_sequence Job.

    (** ...if all jobs in the original schedule come from the arrival sequence,... *)
    Hypothesis H_from_arr_seq: jobs_come_from_arrival_sequence sched arr_seq.

    (** ...then all jobs in the transformed EDF schedule still come from the
       same arrival sequence. *)
    Lemma edf_transform_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched_edf arr_seq.
    Proof.
      rewrite /sched_edf /edf_transform.
      move=> j t.
      rewrite scheduled_at_def - scheduled_at_def.
      by apply (edf_prefix_jobs_come_from_arrival_sequence sched t.+1 arr_seq H_from_arr_seq).
    Qed.

  End ArrivalSequence.

End EDFTransformFacts.

(** Finally, we state the theorems that jointly make up the EDF optimality claim. *)
Section Optimality.
  (** For any given type of jobs... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ... consider an arbitrary valid job arrival sequence ... *)
  Variable arr_seq: arrival_sequence Job.
  Hypothesis H_arr_seq_valid: valid_arrival_sequence arr_seq.

  (** ... and an ideal uniprocessor schedule... *)
  Variable sched: schedule (ideal.processor_state Job).

  (** ... that corresponds to the given arrival sequence. *)
  Hypothesis H_sched_valid: valid_schedule sched arr_seq.

  (** In the following, let [equivalent_edf_schedule] denote the schedule that
     results from the EDF transformation. *)
  Let equivalent_edf_schedule := edf_transform sched.

  Section AllDeadlinesMet.

    (** Suppose no job scheduled in the given reference schedule misses a deadline. *)
    Hypothesis H_no_deadline_misses: all_deadlines_met sched.

    (** Then the resulting EDF schedule is a valid schedule for the given
       arrival sequence... *)
    Theorem edf_schedule_is_valid:
      valid_schedule equivalent_edf_schedule arr_seq.
    Proof.
      move: H_sched_valid => [COME READY].
      rewrite /valid_schedule; split;
        first by apply edf_transform_jobs_come_from_arrival_sequence.
      have ARR  := jobs_must_arrive_to_be_ready sched READY.
      have COMP := completed_jobs_are_not_ready sched READY.
      apply basic_readiness_compliance.
      - by apply edf_transform_jobs_must_arrive.
      - by apply edf_transform_completed_jobs_dont_execute.
    Qed.

    (** ...and no scheduled job misses its deadline. *)
    Theorem edf_schedule_meets_all_deadlines:
      all_deadlines_met equivalent_edf_schedule.
    Proof.
      move: H_sched_valid => [COME READY].
      have ARR  := jobs_must_arrive_to_be_ready sched READY.
      have COMP := completed_jobs_are_not_ready sched READY.
      by apply edf_transform_deadlines_met.
    Qed.

  End AllDeadlinesMet.

  (** Next, we strengthen the above "no deadline misses" claim by relating it
     not just to all scheduled jobs, but to all jobs in the given arrival
     sequence. *)
  Section AllDeadlinesOfArrivalsMet.

    (** Suppose no job that's part of the arrival sequence misses a deadline in
       the given reference schedule. *)
    Hypothesis H_no_deadline_misses_of_arrivals: all_deadlines_of_arrivals_met arr_seq sched.

    (** Then no job that's part of the arrival sequence misses a deadline in the
       EDF schedule, either. *)
    Theorem edf_schedule_meets_all_deadlines_wrt_arrivals:
      all_deadlines_of_arrivals_met arr_seq equivalent_edf_schedule.
    Proof.
      move=> j ARR_j.
      move: H_sched_valid => [COME READY].
      have ARR  := jobs_must_arrive_to_be_ready sched READY.
      have COMP := completed_jobs_are_not_ready sched READY.
      destruct (job_cost j ==  0) eqn:COST.
      - move: COST => /eqP COST.
        rewrite /job_meets_deadline /completed_by COST.
        by apply leq0n.
      - move: (neq0_lt0n COST) => NONZERO.
        move: (H_no_deadline_misses_of_arrivals j ARR_j). rewrite {1}/job_meets_deadline => COMP_j.
        move: (completed_implies_scheduled_before sched j NONZERO ARR (job_deadline j) COMP_j) => [t' [_ SCHED']].
        move: (all_deadlines_met_in_valid_schedule arr_seq sched COME H_no_deadline_misses_of_arrivals) => NO_MISSES.
        move: (edf_transform_job_scheduled' sched ARR COMP NO_MISSES j t' SCHED') => [t'' SCHED''].
        move: (edf_schedule_meets_all_deadlines NO_MISSES) => DL_MET.
        by apply: (DL_MET j t'' SCHED'').
    Qed.

  End AllDeadlinesOfArrivalsMet.

End Optimality.


From fae_gtlc_mu.stlc_mu Require Import types types_notations.
Require Import fae_gtlc_mu.prelude.

(* This file defines the static type duped Universe (eq. 1 in paper) into which values of the unknown type will be backtranslated. *)

Definition Universe_body : type :=
  (
    TUnit +
    (TVar 0 + TVar 0) +
    (TVar 0 × TVar 0) +
    (TArrow (TVar 0) (TVar 0)) +
    (TVar 0)
  )%types.

Definition Universe : type :=
  TRec Universe_body.

Lemma Universe_closed : Closed Universe.
Proof. intro σ. by asimpl. Qed.