Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition asc_mark_realm_spec0 (addr: Z64) (adt: RData) : option (RData * Z64) :=
    match addr with
    | VZ64 _addr =>
      let _ret := 0 in
      rely is_int64 _addr;
      when' _idx == addr_to_gidx_spec (VZ64 _addr) adt;
      rely is_int64 _idx;
      when _t'4 == check_granule_idx_spec (VZ64 _idx) adt;
      rely is_int _t'4;
      if (_t'4 =? 0) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        when'' _lock_base, _lock_ofst == find_spinlock_spec (VZ64 _addr) adt;
        rely is_int _lock_ofst;
        when adt == spinlock_acquire_spec (_lock_base, _lock_ofst) adt;
        when' _t'3 == get_pas_spec (VZ64 _idx) adt;
        rely is_int64 _t'3;
        rely is_int _t'3;
        let _pas := _t'3 in
        if (negb (_pas =? 9)) then
          let _ret := 1 in
          when adt == spinlock_release_spec (_lock_base, _lock_ofst) adt;
          Some (adt, (VZ64 _ret))
        else
          when adt == set_pas_spec (VZ64 _idx) (VZ64 11) adt;
          when adt == tlbi_by_pa_spec (VZ64 _addr) adt;
          when adt == spinlock_release_spec (_lock_base, _lock_ofst) adt;
          Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


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 O A B C Aprime Bprime Cprime : Universe, ((wd_ O Aprime /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ Aprime Bprime /\ (wd_ B C /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ O C /\ (wd_ O B /\ (wd_ O A /\ (wd_ B Aprime /\ (wd_ Bprime C /\ (wd_ Aprime C /\ (wd_ Bprime A /\ (col_ O A B /\ (col_ Aprime Bprime Cprime /\ (col_ O Aprime Bprime /\ col_ A B C)))))))))))))))))))) -> col_ B C O)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj28synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) (plus lv1 (mult lv1 lv2))) (plus lv3 (mult lv2 lv1))).
Admitted.
QuickChick conj28synthconj3.


From Undecidability Require Import MaxList.
From Undecidability Require Import TM.Util.TM_facts TM.Code.CodeTM.

From Undecidability Require Import TM.Util.VectorPrelim.

(* MOVE : this file contains general lemmas from is all over the place... *)

Lemma max_list_rec_eq_foldl (a : nat) (xs : list nat) :
  fold_left max xs a = max_list_rec a xs.
Proof.
  revert a. induction xs as [ | x xs IH]; intros; cbn in *.
  - reflexivity.
  - rewrite IH. rewrite !max_list_rec_max. nia.
Qed.

Lemma sizeOfmTapes_max_list_map (sig : Type) (n : nat) (T : tapes sig n) :
  sizeOfmTapes T = max_list_map (@sizeOfTape _) (vector_to_list T).
Proof.
  unfold sizeOfmTapes.
  rewrite fold_left_vector_to_list.
  rewrite <- vector_to_list_map.
  unfold max_list_map, max_list.
  apply max_list_rec_eq_foldl.
Qed.

Lemma sizeOfmTapes_upperBound (sig : Type) (n : nat) (tps : tapes sig n) :
  forall t, Vector.In t tps -> sizeOfTape t <= sizeOfmTapes tps.
Proof. intros. rewrite sizeOfmTapes_max_list_map. apply max_list_map_ge. now apply vector_to_list_In. Qed.

From Undecidability Require Import L.Prelim.MoreList.

Lemma max_list_sumn l : max_list l <= sumn l.
Proof.
  unfold max_list.
  induction l;cbn. 2:rewrite max_list_rec_max'. all:nia.
Qed.

Lemma right_sizeOfTape sig' (t:tape sig') :
  length (right t) <= sizeOfTape t.
Proof.
  destruct t;cbn. all:autorewrite with list;cbn. all:nia.
Qed.

Lemma length_tape_local_right sig' (t:tape sig') :
  length (tape_local (tape_move_right t)) <= sizeOfTape t.
Proof.
  destruct t;cbn.  1-3:nia. rewrite tape_local_move_right'. autorewrite with list;cbn. all:nia.
Qed.

Lemma size_list X sigX (cX: codable sigX X) (l:list X) :
  size l = sumn (map size l) + length l + 1.
Proof.
  unfold size. cbn. rewrite encode_list_concat.
  rewrite app_length, length_concat, map_map. cbn.
  change S with (fun x => 1 + x). rewrite sumn_map_add,sumn_map_c. setoid_rewrite map_length.
  cbn.  nia.
Qed.

Lemma size_rev X sigX (cX: codable sigX X) (l:list X) :
  size (rev l) = size l.
Proof.
  rewrite !size_list. now rewrite rev_length,map_rev,<- sumn_rev.
Qed.

Lemma destruct_vector1 (X : Type) (v : Vector.t X 1) :
  exists x, v = [| x |].
Proof. destruct_vector. eauto. Qed.


Require Export RelDefinitions.
Require Import RelClasses.
Require Import Relators.

(** ** Union of relations *)

Definition rel_union {A B} (R1 R2: rel A B): rel A B :=
  fun x y => R1 x y \/ R2 x y.

Arguments rel_union {_ _} R1%rel R2%rel _ _.

Infix "\/" := rel_union : rel_scope.

Global Instance rel_union_subrel {A B}:
  Monotonic (@rel_union A B) (subrel ++> subrel ++> subrel).
Proof.
  clear.
  firstorder.
Qed.

Global Instance rel_union_subrel_params:
  Params (@rel_union) 4.

(** Since we're forced to commit to a branch, we can't use [RIntro],
  but can still provide [RExists] instances. *)

Lemma rel_union_rexists_l {A B} (R1 R2: rel A B) x y:
  RExists (R1 x y) (R1 \/ R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (_ \/ _) _ _) =>
  eapply rel_union_rexists_l : typeclass_instances.

Lemma rel_union_rexists_r {A B} (R1 R2: rel A B) x y:
  RExists (R2 x y) (R1 \/ R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (_ \/ _) _ _) =>
  eapply rel_union_rexists_r : typeclass_instances.

(** More often, we can solve a [rel_union] goal using a monotonicity
  property, and the [subrel] instances below. *)

Lemma rel_union_introl {A B} (R1 R2: rel A B):
  Related R1 (R1 \/ R2)%rel subrel.
Proof.
  firstorder.
Qed.

Hint Extern 0 (Related _ (_ \/ _)%rel _) =>
  eapply rel_union_introl : typeclass_instances.

Lemma rel_union_intror {A B} (R1 R2: rel A B):
  Related R2 (R1 \/ R2)%rel subrel.
Proof.
  firstorder.
Qed.

Hint Extern 0 (Related _ (_ \/ _)%rel _) =>
  eapply rel_union_introl : typeclass_instances.

Lemma rel_union_lub {A B} (R1 R2 R: rel A B):
  RIntro (subrel R1 R /\ subrel R2 R) subrel (R1 \/ R2)%rel R.
Proof.
  firstorder.
Qed.

Hint Extern 2 (RIntro _ subrel (_ \/ _)%rel _) =>
  eapply rel_union_lub : typeclass_instances.

Lemma rel_union_refl_l {A} (R1 R2: rel A A):
  Reflexive R1 ->
  Reflexive (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Reflexive (_ \/ _)) =>
  eapply rel_union_refl_l : typeclass_instances.

Lemma rel_union_refl_r {A} (R1 R2: rel A A):
  Reflexive R2 ->
  Reflexive (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Reflexive (_ \/ _)) =>
  eapply rel_union_refl_r : typeclass_instances.

Lemma rel_union_corefl {A} (R1 R2: rel A A):
  Coreflexive R1 ->
  Coreflexive R2 ->
  Coreflexive (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Coreflexive (_ \/ _)) =>
  eapply rel_union_corefl : typeclass_instances.

Lemma rel_union_sym {A} (R1 R2: rel A A):
  Symmetric R1 ->
  Symmetric R2 ->
  Symmetric (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Symmetric (_ \/ _)) =>
  eapply rel_union_sym : typeclass_instances.

(** ** Intersection of relations *)

Definition rel_inter {A B} (R1 R2: rel A B): rel A B :=
  fun x y => R1 x y /\ R2 x y.

Arguments rel_inter {_ _} R1%rel R2%rel _ _.

Infix "/\" := rel_inter : rel_scope.

Global Instance rel_inter_subrel {A B}:
  Monotonic (@rel_inter A B) (subrel ++> subrel ++> subrel).
Proof.
  clear.
  firstorder.
Qed.

Global Instance rel_inter_params:
  Params (@rel_inter) 4.

(** In some cases, the relation in the goal will cause existential
  variables to be instantiated accordingly; for instance, [rstep] run
  on [?R x y |- (R1 /\ R2) x y] will instantiate [?R := R1 /\ R2].
  Because of this, splitting a [rel_inter] goal into two subgoals may
  cause a dead-end and we have to use [RExists] for the following
  rule. *)

Lemma rel_inter_rexists {A B} (R1 R2: rel A B) x y:
  RExists (R1 x y /\ R2 x y) (R1 /\ R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (_ /\ _) _ _) =>
  eapply rel_inter_rexists : typeclass_instances.

Lemma rel_inter_eliml {A B} (R1 R2: rel A B):
  Related (R1 /\ R2)%rel R1 subrel.
Proof.
  firstorder.
Qed.

Hint Extern 0 (Related (_ /\ _)%rel _ _) =>
  eapply rel_inter_eliml : typeclass_instances.

Lemma rel_inter_elimr {A B} (R1 R2: rel A B):
  Related (R1 /\ R2)%rel R2 subrel.
Proof.
  firstorder.
Qed.

Hint Extern 0 (Related (_ /\ _)%rel _ _) =>
  eapply rel_inter_elimr : typeclass_instances.

Lemma rel_inter_glb {A B} (R R1 R2: rel A B):
  RIntro (subrel R R1 /\ subrel R R2) subrel R (R1 /\ R2)%rel.
Proof.
  firstorder.
Qed.

Hint Extern 2 (RIntro _ subrel _ (_ /\ _)%rel) =>
  eapply rel_inter_glb : typeclass_instances.

Lemma rel_inter_refl {A} (R1 R2: rel A A):
  Reflexive R1 ->
  Reflexive R2 ->
  Reflexive (R1 /\ R2).
Proof.
  intros H1 H2.
  split; reflexivity.
Qed.

Hint Extern 2 (Reflexive (_ /\ _)) =>
  eapply rel_inter_refl : typeclass_instances.

Lemma rel_inter_corefl_l {A} (R1 R2: rel A A):
  Coreflexive R1 ->
  Coreflexive (R1 /\ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Coreflexive (_ /\ _)) =>
  eapply rel_inter_corefl_l : typeclass_instances.

Lemma rel_inter_corefl_r {A} (R1 R2: rel A A):
  Coreflexive R2 ->
  Coreflexive (R1 /\ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Coreflexive (_ /\ _)) =>
  eapply rel_inter_corefl_r : typeclass_instances.

Lemma rel_inter_trans {A} (R1 R2: rel A A):
  Transitive R1 ->
  Transitive R2 ->
  Transitive (R1 /\ R2).
Proof.
  intros H1 H2 x y z [Hxy1 Hxy2] [Hyz1 Hyz2].
  split; etransitivity; eassumption.
Qed.

Hint Extern 2 (Transitive (_ /\ _)) =>
  eapply rel_inter_trans : typeclass_instances.

Lemma rel_inter_sym {A} (R1 R2: rel A A):
  Symmetric R1 ->
  Symmetric R2 ->
  Symmetric (R1 /\ R2).
Proof.
  intros H1 H2 x y [Hxy1 Hxy2].
  split; symmetry; assumption.
Qed.

Hint Extern 2 (Symmetric (_ /\ _)) =>
  eapply rel_inter_sym : typeclass_instances.

Global Instance rel_inter_flip_sym {A} (R: rel A A):
  Symmetric (R /\ flip R).
Proof.
  intros x y [Hxy Hyx].
  split; assumption.
Qed.

(** ** Implication *)

Definition rel_impl {A B} (R1 R2: rel A B): rel A B :=
  fun x y => R1 x y -> R2 x y.

Global Instance rel_impl_subrel {A B}:
  Monotonic (@rel_impl A B) (subrel --> subrel ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance rel_impl_subrel_params:
  Params (@rel_impl) 4.

Lemma rel_impl_rintro {A B} (R1 R2: rel A B) x y:
  RIntro (R1 x y -> R2 x y) (rel_impl R1 R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ (rel_impl _ _) _ _) =>
  eapply rel_impl_rintro : typeclass_instances.

Lemma rel_impl_relim {A B} (R1 R2: rel A B) x y:
  RElim (rel_impl R1 R2) x y (R1 x y) (R2 x y).
Proof.
  firstorder.
Qed.

Hint Extern 0 (RElim (rel_impl _ _) _ _ _ _) =>
  eapply rel_impl_relim : typeclass_instances.

Lemma rel_impl_subrel_codomain {A B} (R1 R2: rel A B):
  Related R2 (rel_impl R1 R2) subrel.
Proof.
  firstorder.
Qed.

(** ** The bottom and top relations *)

Definition rel_bot {A B}: rel A B :=
  fun x y => False.

Notation "⊥" := rel_bot : rel_scope.

Lemma rel_bot_relim {A B} (x: A) (y: B) P:
  RElim ⊥ x y True P.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RElim ⊥ _ _ _ _) =>
  eapply rel_bot_relim : typeclass_instances.

Definition rel_top {A B}: rel A B :=
  fun x y => True.

Notation "⊤" := rel_top : rel_scope.

Lemma rel_top_rintro {A B} (x: A) (y: B):
  RIntro True ⊤ x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ ⊤ _ _) =>
  eapply rel_top_rintro : typeclass_instances.

(** ** Relation equivalence *)

Definition eqrel {A B}: rel (rel A B) (rel A B) :=
  (subrel /\ flip subrel)%rel.

Arguments eqrel {_ _} RA%rel RB%rel.

Global Instance eqrel_equivalence A B:
  Equivalence (@eqrel A B).
Proof.
  unfold eqrel.
  split; typeclasses eauto.
Qed.

(** ** Relation composition *)

Definition rel_compose {A B C} (RAB: rel A B) (RBC: rel B C): rel A C :=
  fun x z => exists y, RAB x y /\ RBC y z.

Global Instance rel_compose_subrel {A B C}:
  Monotonic (@rel_compose A B C) (subrel ++> subrel ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance rel_compose_eqrel {A B C}:
  Monotonic (@rel_compose A B C) (eqrel ==> eqrel ==> eqrel).
Proof.
  firstorder.
Qed.

Global Instance rel_compose_params:
  Params (@rel_compose) 4.

Lemma rel_compose_id_left {A B} (R: rel A B):
  eqrel (rel_compose R eq) R.
Proof.
  unfold rel_compose.
  split; intros x y; firstorder; congruence.
Qed.

Lemma rel_compose_id_right {A B} (R: rel A B):
  eqrel (rel_compose eq R) R.
Proof.
  unfold rel_compose.
  split; intros x y; firstorder; congruence.
Qed.

Lemma rel_compose_assoc {A B C D} (RAB: rel A B) (RBC: rel B C) (RCD: rel C D):
  eqrel
    (rel_compose (rel_compose RAB RBC) RCD)
    (rel_compose RAB (rel_compose RBC RCD)).
Proof.
  unfold rel_compose.
  split; intros x y; firstorder; congruence.
Qed.

(** ** Pulling a relation along functions *)

Definition rel_pull {A B A' B'} f g (R: rel A' B'): rel A B :=
  fun x y => R (f x) (g y).

(** We use the following notation. Left associativity would make more
  sense but we have to match [Coq.Classes.RelationPairs]. *)

Notation "R @@ ( f , g )" := (rel_pull f g R)
  (at level 30, right associativity) : rel_scope.

Notation "R @@ f" := (rel_pull f f R)
  (at level 30, right associativity) : rel_scope.

Notation "R @@ ( f )" := (rel_pull f f R)
  (at level 30, right associativity) : rel_scope.

Global Instance rel_pull_subrel {A B A' B'} (f: A -> A') (g: B -> B'):
  Monotonic (rel_pull f g) (subrel ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance rel_pull_subrel_params:
  Params (@rel_pull) 3.

(** In the restricted case where [f = g], [rel_pull] preserves many
  properties of the underlying relation. *)

Lemma rel_pull_refl {A B} (f: A -> B) (R: rel B B):
  Reflexive R ->
  Reflexive (R @@ f).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Reflexive (rel_pull _ _ _)) =>
  eapply rel_pull_refl : typeclass_instances.

Lemma rel_pull_sym {A B} (f: A -> B) R:
  Symmetric R ->
  Symmetric (R @@ f).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Symmetric (rel_pull _ _ _)) =>
  eapply rel_pull_sym : typeclass_instances.

Lemma rel_pull_trans {A B} (f: A -> B) R:
  Transitive R ->
  Transitive (R @@ f).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Transitive (rel_pull _ _ _)) =>
  eapply rel_pull_trans : typeclass_instances.

(** The introduction rule is straightforward, but changes the head
  terms to the functions used with [rel_pull]. This means that an
  [RIntro] rule would short-circuit any relational property formulated
  for the original terms, even if the codomain is a matching
  [rel_pull] relation and we have an appropriate [RElim] instance.
  To avoid shadowing such properties, we define our introduction rule
  as an [RStep] with a low priority. See test [rel_pull_2]. *)

Lemma rel_pull_rintro {A B A' B'} (f: A -> A') (g: B -> B') R x y:
  RStep (R (f x) (g y)) ((R @@ (f, g))%rel x y).
Proof.
  firstorder.
Qed.

Hint Extern 60 (RStep _ ((_ @@ (_, _))%rel _ _)) =>
  eapply rel_pull_rintro : typeclass_instances.

(** We can reuse an instance of [RElim] for the underlying relation to
  provide corresponding instances for the pulled relation. *)

Lemma rel_pull_relim {A B A' B'} (f: A -> A') (g: B -> B') R x y P Q:
  RElim R (f x) (g y) P Q ->
  RElim (R @@ (f, g)) x y P Q.
Proof.
  firstorder.
Qed.

Hint Extern 1 (RElim (_ @@ (_, _)) _ _ _ _) =>
  eapply rel_pull_relim : typeclass_instances.

(** ** Pushing a relation along functions *)

Inductive rel_push {A1 A2 B1 B2} f g (R: rel A1 A2): rel B1 B2 :=
  rel_push_rintro x y: RIntro (R x y) (rel_push f g R) (f x) (g y).

Hint Extern 1 (RIntro _ (rel_push _ _ _) _ _) =>
  eapply rel_push_rintro : typeclass_instances.

(** The level we choose here is to match the notation used for
  [PTree.get] in Compcert's [Maps] library. *)

Notation "R !! ( f , g )" := (rel_push f g R)
  (at level 1) : rel_scope.

Notation "R !! f" := (rel_push f f R)
  (at level 1) : rel_scope.

Notation "R !! ( f )" := (rel_push f f R)
  (at level 1) : rel_scope.

Global Instance rel_push_subrel {A1 A2 B1 B2} (f: A1 -> B1) (g: A2 -> B2):
  Proper (subrel ++> subrel) (rel_push f g).
Proof.
  intros R1 R2 HR x y Hxy.
  destruct Hxy.
  rintro; eauto.
Qed.

Lemma rel_push_corefl {A B} (f: A -> B) (R: rel A A):
  Coreflexive R ->
  Coreflexive (R !! f).
Proof.
  intros H _ _ [x y Hxy].
  f_equal.
  eauto using coreflexivity.
Qed.

Hint Extern 1 (Coreflexive (_ !! _)) =>
  eapply rel_push_corefl : typeclass_instances.

(** When using [R !! fst] or [R !! snd], if [rel_push_intro] does not
  apply, we can use the following instances instead. *)

Lemma rel_push_fst_rexists {A1 A2 B1 B2} (x1:A1) (x2:A2) (y1:B1) (y2:B2) R:
  RExists (R (x1, y1) (x2, y2)) (R !! fst) x1 x2.
Proof.
  intros H.
  change x1 with (fst (x1, y1)).
  change x2 with (fst (x2, y2)).
  rintro.
  assumption.
Qed.

Hint Extern 1 (RExists _ (_ !! fst) _ _) =>
  eapply rel_push_fst_rexists : typeclass_instances.

Lemma rel_push_snd_rexists {A1 A2 B1 B2} (x1:A1) (x2:A2) (y1:B1) (y2:B2) R:
  RExists (R (x1, y1) (x2, y2)) (R !! snd) y1 y2.
Proof.
  intros H.
  change y1 with (snd (x1, y1)).
  change y2 with (snd (x2, y2)).
  rintro.
  assumption.
Qed.

Hint Extern 1 (RExists _ (_ !! snd) _ _) =>
  eapply rel_push_snd_rexists : typeclass_instances.

(** ** Relation currying *)

(* An interesting special case of [rel_pull] is [rel_curry], which
  takes a relation over [A * B -> C] and turns it into a relation
  over [A -> B -> C].

  [rel_curry] is particularly useful when two (curried) arguments
  to a given function have to be related in a dependent way. For
  example in Compcert, memory injections relate memory blocks and
  offsets jointly, but many operations have those as two separate
  arguments. To state the relational property of such operations, we
  can uncurry a joint relation on (block, offset) pairs.

  [rel_curry] can be obtained by pulling back the original relation
  along [uncurry]: *)

Definition curry {A B C} (f: A * B -> C): A -> B -> C :=
  fun a b => f (a, b).

Definition uncurry {A B C} (f: A -> B -> C): A * B -> C :=
  fun ab => match ab with (a, b) => f a b end.

Definition rel_curry {A1 B1 C1 A2 B2 C2} (R: rel (A1*B1->C1) (A2*B2->C2)) :=
  (R @@ uncurry)%rel.

Definition rel_uncurry {A1 B1 C1 A2 B2 C2} (R: rel (A1->B1->C1) (A2->B2->C2)) :=
  (R @@ curry)%rel.

(** We use the following notation for [rel_curry], which evokes
  splitting a pair into two separate arguments. Note that we use the
  same priority as for [++>], [-->], and [==>], because we usually
  want [rel_curry] to nest in such a way that for instance,
  [S ++> % R --> % R ++> impl] will be interpreted as
  [S ++> rel_curry (R --> rel_curry (R ++> impl))]. *)

Notation "% R" := (rel_curry R) (at level 55, right associativity) : rel_scope.

(** In order to provide an [RElim] instance for [rel_curry], we will
  rely on the fact that:

      uncurry f (x1, x2) x3 ... xn = f x1 x2 x3 ... xn,

  and that:

      rel_curry R f g <-> R (uncurry f) (uncurry g),

  so that when the instance of [RElim] associated with [R] allows us
  to show:

      Rcod (uncurry f (x1, x2) x3 ... xn) (uncurry g (y1, y2) y3 ... yn)

  we can convert it into an instance for proving:

      Rcod (f x1 x2 x3 ... xn) (g y1 y2 y3 ... yn),

  which is what will be expected for [monotonicity]. To accomplish
  this, we need to [unfold uncurry] in the result provided for [R]
  before we use it to solve the [rel_uncurry] case. This helper class
  does this. *)

Class UnfoldUncurry {A} (before: A) (after: A) :=
  unfold_uncurry_before_after: before = after.

Ltac unfold_uncurry :=
  match goal with
    | |- context C[uncurry ?f ?p] =>
      is_evar p;
      let T := type of p in
      let Av := fresh in evar (Av: Type);
      let A := eval red in Av in clear Av;
      let Bv := fresh in evar (Bv: Type);
      let B := eval red in Bv in clear Bv;
      unify T (prod A B)%type;
      let av := fresh in evar (av : A);
      let a := eval red in av in clear av;
      let bv := fresh in evar (bv : B);
      let b := eval red in bv in clear bv;
      let G := context C[f a b] in
      unify p (a, b);
      change G
  end.

Hint Extern 1 (UnfoldUncurry ?P ?Q) =>
  repeat unfold_uncurry; constructor : typeclass_instances.

(** Now we can provide a somewhat general [RElim] instance for
  [rel_uncurry]. *)

Lemma rel_curry_relim {A1 B1 C1 A2 B2 C2} R f g P Q Q':
  @RElim (A1 * B1 -> C1) (A2 * B2 -> C2) R (uncurry f) (uncurry g) P Q ->
  UnfoldUncurry Q Q' ->
  @RElim (A1 -> B1 -> C1) (A2 -> B2 -> C2) (% R) f g P Q'.
Proof.
  unfold UnfoldUncurry.
  intros; subst.
  assumption.
Qed.

Hint Extern 60 (RStep _ ((% _)%rel _ _)) =>
  eapply rel_pull_rintro : typeclass_instances.

Hint Extern 1 (RElim (% _) _ _ _ _) =>
  eapply rel_curry_relim : typeclass_instances.

(** ** The [req] relation *)

(** The relation [req a] asserts that both elements are equal to [a].
  This comes in handy when expressing the relational properties of
  functions: it can be used to fix the value of an argument, or
  parametrize it using a variable with a broader scope. *)

Inductive req {A} (a: A): rel A A :=
  req_intro: req a a a.

Lemma req_rintro {A} (a: A):
  RIntro True (req a) a a.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ (req _) _ _) =>
  eapply req_rintro : typeclass_instances.

Lemma req_corefl {A} (a: A):
  Coreflexive (req a).
Proof.
  destruct 1.
  reflexivity.
Qed.

Hint Extern 0 (Coreflexive (req _)) =>
  eapply req_corefl : typeclass_instances.

(** ** Checking predicates on the left and right elements *)

Definition lsat {A B} (P: A -> Prop): rel A B :=
  fun x y => P x.

Definition rsat {A B} (P: B -> Prop): rel A B :=
  fun x y => P y.

(** ** Relation versions of [ex] and [all] *)

(** Ideally we would overload the [forall] and [exists] notation to
  use the relation version under the [rel] scope. But as long as
  we keep [rel_scope] open globally, we can't really do that
  without breaking everything. So we use our own keyword [rexists] and
  [rforall] instead. *)

Definition rel_all {A B C} (R: C -> rel A B): rel A B :=
  fun x y => forall c, R c x y.

Notation "'rforall' x .. y , p" :=
  (rel_all (fun x => .. (rel_all (fun y => p%rel)) .. ))
  (at level 200, x binder, right associativity)
  : rel_scope.

Lemma rel_all_rintro {A B C} (R: C -> rel A B) m n:
  RIntro (forall c : C, R c m n) (rel_all R) m n.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ (rel_all _) _ _) =>
  eapply rel_all_rintro : typeclass_instances.

Lemma rel_all_relim {A B C} (R: C -> rel A B) x y P Q:
  (exists c, RElim (R c) x y P Q) ->
  RElim (rel_all R) x y P Q.
Proof.
  firstorder.
Qed.

Hint Extern 1 (RElim (rel_all _) _ _ _ _) =>
  eapply rel_all_relim; eexists : typeclass_instances.

Definition rel_ex {A B C} (R: C -> rel A B): rel A B :=
  fun x y => exists c, R c x y.

Notation "'rexists' x .. y , p" :=
  (rel_ex (fun x => .. (rel_ex (fun y => p%rel)) ..))
  (at level 200, x binder, right associativity)
  : rel_scope.

Lemma rel_ex_rintro {A B C} (R: C -> rel A B) c m n:
  RExists (R c m n) (rel_ex R) m n.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (rel_ex _) _ _) =>
  eapply rel_ex_rintro : typeclass_instances.

Lemma rel_ex_relim {A B C} (R: C -> rel A B) x y P Q:
  (forall c, RElim (R c) x y P Q) ->
  RElim (rel_ex R) x y P Q.
Proof.
  firstorder.
Qed.

Hint Extern 1 (RElim (rel_ex _) _ _ _ _) =>
  eapply rel_ex_relim : typeclass_instances.

(** ** The [rel_incr] construction *)

(** When dealing with Kripke logical relations, we have a family of
  relations indexed by a type of worlds, as well as an accessibility
  relation over this type of worlds. We often want to state that there
  exists a world accessible from a base one in which the relation
  holds. The following construction expresses this. *)

Definition rel_incr {W A B} (acc: rel W W) (R: W -> rel A B): W -> rel A B :=
  fun w a b => exists w', acc w w' /\ R w' a b.

(** While it's possible to define a more general monotonicity property
  for [rel_incr], this one is well-behaved and usually corresponds to
  what we want. *)

Global Instance rel_incr_subrel {W A B} acc:
  Transitive acc ->
  Monotonic (@rel_incr W A B acc) ((- ==> subrel) ++> acc --> subrel).
Proof.
  intros Hacc R1 R2 HR w1 w2 Hw a b (w1' & Hw1' & Hab).
  eexists; split.
  - transitivity w1;
    eassumption.
  - apply HR.
    assumption.
Qed.

Global Instance rel_incr_subrel_params:
  Params (@rel_incr) 4.

(** Note the order of the premises in our intro rule. We want to first
  determine what [w'] should be, then prove [acc w w']. *)

Lemma rel_incr_rintro {W A B} (acc: rel W W) (R: W -> rel A B) w w' m n:
  RExists (R w' m n /\ acc w w') (rel_incr acc R w) m n.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (rel_incr _ _ _) _ _) =>
  eapply rel_incr_rintro : typeclass_instances.

Lemma rel_incr_rdestruct {W A B} acc R w T:
  (forall w, exists Tw, RDestruct (R w) Tw /\ Convertible (T w) Tw) ->
  RDestruct
    (@rel_incr W A B acc R w)
    (fun P => forall w', acc w w' -> Delay.unpack (T w' P)).
Proof.
  clear.
  intros HR m n (w' & Hw' & Hmn) P H.
  destruct (HR w') as (Tw & HRw' & HTw).
  eapply rdestruct; eauto.
  destruct HTw.
  eapply H; eauto.
Qed.

Hint Extern 2 (RDestruct (rel_incr _ _ _) _) =>
  eapply rel_incr_rdestruct; intro; eexists; split : typeclass_instances.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.
Require Import Wf.Wf.

Require Import Complete.InfGenComplete.
Require Import Complete.SameShape.
Require Import Complete.InfGenRename.
Require Import Complete.Unification.

Require Import Complete.DEnvComplRel.
Require Import Complete.Sch_or_Obj.

Require Import Complete.Generalisation.

(*** Lemmas *)

Lemma complete_var__helper : forall denv dsch dty dsub sch env,
    SubSump denv dsch (DS_Mono dty)
  -> DSub_app sch dsub = emb_Sch dsch
  -> DSub_wf denv dsub
  -> exists ty dsub',
      env |= sch ≤ ⟨DSub_to_A dsub'⟩ ty
    /\ DSub_app_t ty (dsub' ++ dsub) = emb_Ty dty
    /\ DSub_wf denv (dsub' ++ dsub).
Proof.
  introv SS EMB WF__sub. gen sch env dsub. dependent induction SS; intros.
  - destruct sch; crush.
    exists Ty5 (nil:DSub). crush.
  - emb_auto.
    forwards [exA NIl]: atom_fresh (Env_Obj_exvars env \u DSub_dom dsub \u free_exvars_Sch sch0).
    forwards [dskA NIl']: atom_fresh (L \u free_skvars_Sch sch0 \u DSub_codom_dskvars dsub).
    (** forwards with a generated dskA here, because we don't get access to the
    "actual" dskA until we call the Inst constructor but then we won't have the
    result available in the other branches of the conjunction conclusion *)
    forwards [ty [dsub' [SS' [EMB WF__sub']]]]:
      H dskA (subst_skvar_Sch (T_ExVar exA) dskA (open_Sch_wrt_Ty sch0 (T_SkVar_f dskA))) (env ::a [exA]) (dsub ++ [(exA, DTy1)]).
      fsetdec. reflexivity. subdist.
      rewrite subst_exvar_Sch_subst_skvar_Sch. 2:{ rewrite free_exvars_Sch_open_Sch_wrt_Ty_upper. rewr. fsetdec. }
      rewrite subst_skvar_Sch_open_Sch_wrt_Ty. 2:eauto.
      rewrite subst_dskvar_DSch_open_DSch_wrt_DTy. 2:eauto. simpl. if_taut.
      rewrite DSub_app_open_comm. 2:eauto. 2:eauto.
      rewrite embed_Sch_open_comm. rewr.
      rewrite DSub_app_susbst_skvar_Sch. 2:fsetdec.
      rewr. rewrite EMB0. rewrite embed_Sch_subst_dskvar_DSch. reflexivity.
      apply DSub_wf_snoc. eassumption. fsetdec. eassumption.
    exists ty (dsub' ++ [(exA, DTy1)]). splits.
    + rewr. applys InstPoly (free_skvars_Sch sch0). simpl. fsetdec. intros dskB NIL''. rewr.
      (** repeat the trick of getting rid of the dskvar (dskB here) to apply the forwards IH*)
      rewrite subst_skvar_Sch_open_Sch_wrt_Ty in *. 2,3:eauto. simpl. simpl in SS'. if_taut.
      rewrite subst_skvar_Sch_not_in_Sch_idempotent in *. 2,3:fsetdec. eassumption.
    + rewr. rewrite DSub_app_t_app_distr in *. rewrite DSub_app_t_app_symm in EMB. eassumption.
      eauto.
    + eapply DSub_wf_rewr. eassumption. crush. rewr_dsrel. fsetdec'.
Qed.

(*** Trash to be moved *)

(*** Acutal theorem *)

Theorem Inf_Gen_complete : Inf_complete__def /\ Gen_complete__def.
Proof.
  forwards: (Mon_DGen_mut Inf_complete__prop Gen_complete__prop)
  ; unfold Inf_complete__prop in *; unfold Gen_complete__prop in *
  .
  7:{ jauto. }

  (*var*)
  - introv IN SS [dsub INST] SUB__denv WF SOO NN. rename env__in into env.
    (**)
    forwards IN': DEnvComplRel_lookup. eassumption. eassumption. destruct IN' as [dsch' [IN' SS']].
    (**)
    assert (DEnv5 [<=]de denv__obj). eauto. rewrite H in SS. clear H.
    (**)
    forwards SS'': (SubSump_transitive denv__obj). apply SS'. eassumption.
    (**)
    assert (exists sch, SchPSI.In (x, sch) (Env_bindings env) /\ DSub_app sch dsub = emb_Sch dsch').
      EInst_props__base. eassumption.
      forwards [sch [EMB IN'']]: IN__dsch.
      eassumption. exists sch. rewr in IN''. rewr in EMB.
      eauto.
    destr.
    (**)
    inv_EInst.
    forwards WF__sub: EInst_props__wf. apply INST0. auto. auto. crush. rewr in WF__sub.
    (**)
    (** Strengthening embedding of sch *)
    assert (EMB__sch: DSub_app sch DSub1 = emb_Sch dsch').
    { forwards: EInst_WfTy_impl_emb. apply INST0. apply in_wf_env_impls_wf. eauto. auto.
      destr. subdist in H0. rewrite H1 in H0. rewr in H0. apply emb_Sch_inj in H0. crush.
    }
    clear H0.
    (**)
    (** helper here*)
    (* forwards [a [ty [dsub' [Inst [EMB__ty WF__dsub]]]]]: complete_var__helper'. *)
    forwards [ty [dsub' [Inst [EMB__ty WF__dsub]]]]: complete_var__helper.
    apply SS''. eassumption. eauto.
    (**)
    (** Now there is a split depending on if dsub' is empty or not*)
    destruct (list_rev_destr dsub'); destr.
    + exists. splits.
      * econstructor. eassumption. eassumption.
      * forwards: AInst_NN_create. apply NN. destr.
        exists. constructor. econstructor. econstructor. eassumption. simpl. auto. auto. rewr. rewr in EMB__ty. crush.
        rewr. eassumption.
      * simpl. reflexivity.
    + destruct x0 as [exA dty]. rename xs' into dsub'. exists. splits.
      * econstructor. eassumption. eassumption.
      * forwards: AInst_trivial. destr.
        exists. constructor. econstructor. econstructor. eassumption.
        rewr. instantiate (1 := dsub' ++ [(exA, dty)]). instantiate (1 := DA5).
        applys_eq AInst_merge. instantiate (2 := []). reflexivity.
        simpl. rewr. applys_eq AInstCons. instnil. crush. rewr. apply WF__dsub. rewr_dsrel. fsetdec.
        auto. apply AInst_DSub_wf. eauto. auto. rewr. crush. eassumption.
      * crush.

  (*unit*)
  - introv _ [dsub INST] _ _ _ _. rename env__in into env.
    inv_EInst'. rewr in INSTA.
    (**)
    exists. splits. auto. exists. constructor. econstructor. constructor. eassumption. auto. auto. rewr. crush. rewr. eauto using AInst_init_DEnv_sub. crush.

  (*lam*)
  - introv WFDTY DMON IH [dsub__in INST__in] SUB__denv WF__in SOO NN.
    (**)
    forwards [exA NI__exA]: atom_fresh (L \u Env_Obj_exvars env__in \u DSub_dom dsub__in).
    forwards [x NI__x]: atom_fresh (L \u free_xs_e e5 \u Env_boundvars (env__in ::a [exA])).
    assert (WF__in': wf((env__in ::a [exA]) ::x x :- S_Mono (T_ExVar exA))).
      constructor. constructor. assumption. constructor. auto. rewr. fsetdec. constructor. rewr. fsetdec.
    inv_EInst'.
    forwards IH1: IH x (DEnv_5 :::a DA5 :::x x :- DS_Mono DTy1) (env__in ::a [exA] ::x x :- S_Mono (T_ExVar exA)) a__in. fsetdec.
      forwards: AInst_trivial a__in. destr.
      exists. applys_eq EInstA. instnil. reflexivity. constructor. constructor. eassumption.
      applys_eq AInstCons. instnil. rewr. reflexivity. rewr. eapply WfDTy_DEnv_sub. eassumption. eauto.
      auto. rewr. subdist. rewrite DSub_app_t_exA_notinsub. rewr. reflexivity. rewr in NI__exA. fsetdec. eassumption.
      rewr. apply DEnvComplRel__consvar. eassumption. auto.
      assumption.  SOO_auto. assumption.
    clear IH. destruct IH1 as [env__out [a [ty [denv__obj' [da' [MON [[dsub__out INST__out] EQ]]]]]]].
    (**)
    forwards WF__out: Inf_Wf. eassumption. assumption. clear WF__in WF__in'.
    (**)
    destruct da'. 2:inverts EQ. simpl in *. subst. forwards: Inf_SameShape. eassumption. inv_SS.
    (**)
    inv_EInst'. clear H. rewr*.
    destruct DA0. 2:inverts H5. simpl in H5. inverts H5.
    destruct DA2. 2:inverts H0. simpl in H0. inverts H0.
    emb_auto''.
    (**)
    exists. splits.
    + applys InfAbs empty exA. fsetdec. intros y NI__y.
      rewr. forwards: Inf_rename_binding' y. apply MON. rewr. fsetdec.
      rewrite subst_tm_e_open_e_wrt_e in H. simpl in H. if_taut.
      assert (subst_tm_e (e_Var_f y) x e5 = e5). crush. rewrite H0 in H. eassumption. auto.
    + forwards: AInst_trivial a__in. destr.
      exists. constructor. econstructor. econstructor. eassumption. rewr. apply AInst_merge. eassumption.
      rewr. eapply AInst_init_DEnv_sub. eassumption. rewr_derel. fsetdec. auto.
      rewr. subdist. subdist in EMB. subdist in EMB1. rewrite EMB. rewrite EMB1. crush.
      rewr. eassumption.
    + rewr. reflexivity.

  (*app*)
  - introv MON__e1 IH__e1 MON__e2 IH__e2 INST SUB__denv WF__in SOO NN.
    (**)
    forwards IH1: IH__e1; eauto. clear INST. clear IH__e1.
    destruct IH1 as [env1 [a1 [ty [denv__obj' [da' [INF__e1 [[dsub INST1] EQ]]]]]]]. subst.
    inv_EInst'. clear H. emb_auto''.
    forwards: DSODO_cons_DA' H4. 1,2:SOO_auto. clear H4. destr. inverts H.
    rewr in EMB0. rewr in INSTA. rename DSub2 into dsub__ain.
    rename DEnv_5 into denv. rename DSub0 into dsub__e1.
    rewr in INSTA1. rename DA1 into da1. rename DSub3 into dsub__a1.
    (**)
    forwards WF1: Inf_Wf; eauto. clear WF__in.
    (**)
    forwards IH2: IH__e2 (denv :::o ⟦⟨da1⟩ DS_Mono (DT_Fun DTy1 DTy2)⟧d :::a (da' ++ da1)) (env1 ::o ⟦⟨a1⟩ S_Mono ty⟧) (a__in ++ a1).
      exists. econstructor. econstructor. eassumption. rewr. eassumption. crush.
      rewr. eapply AInst_merge; eapply AInst_init_DEnv_sub. eassumption. crush. apply INSTA. rewr_derel. reflexivity.
      norm in SUB__denv.
      forwards: DEnvComplRel__apphelper denv (oneDA (da' ++ da1)) DEnv5. norm. eassumption.
      norm. norm in H. eassumption.
      eauto. SOO_auto. destruct (a__in ++ a1 == []). destruct a__in. contradiction. inverts e. auto.
    clear IH__e2 INSTA INST. destruct IH2 as [env2' [a2 [ty1 [denv__obj [da [INF__e2 [[dsub INST2] EQ]]]]]]]. subst.
    (**)
    forwards: Inf_SameShape. eassumption. inv_SS. clear H2. rename a3 into a1'. rename ty2 into ty'.
    forwards WF2: Inf_Wf. eassumption. eauto. clear WF1.
    eapply DSODO_cons_DA in EQ. 2:SOO_auto. destr. rename H into EQ.
    (**)
    inv_EInst'. rewr*. emb_auto''. clear H.
    apply DSODO_cons_DA' in H4. 2,3:SOO_auto. destr. inverts H.
    apply DSODO_cons_DA' in H1. 2,3:SOO_auto. destr. inverts H.
    rename da2 into da__in. rename dsub0 into dsub__in.
    rename da1' into da2. rename DSub3 into dsub__a2.
    rename da1 into da1'. rename DSub'0 into dsub__a1'.
    rename dsub__a1 into dsub__a1old. rename da0 into da1. rename dsub into dsub__a1.
    (**)
    forwards [exB NI__exB]: atom_fresh (Env_Obj_exvars (env2 ::a (a2 ++ a1')) \u DSub_dom (dsub__a1' ++ dsub__a2 ++ DSub0)).
    assert (UNI: DSub_unique ([(exB, DTy1)] ++ dsub__a1' ++ dsub__a2 ++ DSub0)).
      simpl. apply DSub_unique_cons. 2:fsetdec.
      forwards WF__dsub: EInst_props__wf. apply EInstA. apply EInstA. apply INST0. rewr. eassumption.
      eapply AInst_init_DEnv_sub'. apply INSTA2. rewr_derel. fsetdec.
      inv_Wf. constructor. constructor. eauto. eauto. eauto. apply FrA_Obj in FR. assumption. auto. crush.
      eapply DSub_unique_rewr. apply WF__dsub. rewr_dsrel. fsetdec'.
    assert (EMB__ty': DSub_app_t ty'           ([(exB, DTy2)] ++ dsub__a1' ++ dsub__a2 ++ DSub0) = emb_Ty (DT_Fun DTy1 DTy2)).
      rewrite DSub_app_t_app_distr. rewrite app_assoc. rewrite DSub_app_t_app_distr. rewrite DSub_app_t_app_symm.
      subdist. subdist in EMB2. rewrite EMB2. rewr. reflexivity. eauto.
    assert (EMB__ty1: DSub_app_t ty1           ([(exB, DTy2)] ++ dsub__a1' ++ dsub__a2 ++ DSub0) = emb_Ty         DTy1      ).
      subdist. subdist in EMB1. rewrite EMB1. rewr. reflexivity.
    assert (EMB__exB: DSub_app_t (T_ExVar exB) ([(exB, DTy2)] ++ dsub__a1' ++ dsub__a2 ++ DSub0) = emb_Ty              DTy2 ).
      rewrite DSub_app_t_app_distr. rewrite DSub_app_t_exA_notinsub. simpl. rewr. reflexivity. fsetdec.
    (**)
    assert (WFDTY__dty2:  denv :::a da1' |=dty DS_Mono DTy2).
      EInst_props__base. apply EInstA. apply INST0. rewr. eassumption. rewr in SUB__wfdty.
      inv_Wf.
      assert (denv :::a da1' |=dty DS_Mono (DT_Fun DTy1 DTy2)). eapply embed_Ty_WfDTy. eassumption. eassumption.
      rewrite <- SUB__sk. apply WfTy_props in WFTY0. jauto. eauto.
      apply WfDTy_props. apply WfDTy_props in H. destr. split. rewrite <- H. rewr. fsetdec.
      inv_LC. eauto.
    (**)
    forwards U__out: make_unification ((env2 ::a ((exB :: a2) ++ a1')) ::o ⟦⟨[]⟩ S_Mono (T_ExVar exB)⟧).
      (*sub*)
      applys DSub_app_t_Sub_app_t
              ([(exB, DTy2)] ++ dsub__a1' ++ dsub__a2 ++ DSub0)
              ty'
              (T_Fun ty1 (T_ExVar exB)).
        rewr. rewrite EMB__ty'. rewrite EMB__ty1. rewrite EMB__exB. reflexivity.
      (*inst*)
      forwards AINST__triv: AInst_trivial' a2. destruct AINST__triv as [dsub__triv [? AINST__triv]]. subst a2.
      exists. instantiate (2 := denv :::a da1' :::o ⟦⟨[]⟩ DS_Mono DTy2⟧d).
      econstructor. econstructor. eassumption. rewr. applys_eq AInst_merge.
      3:apply INSTA3. norm. rewrite app_assoc. reflexivity. instnil. reflexivity.
      applys_eq AInst_merge. 2:eassumption. rewr. reflexivity. applys_eq AInstCons.
      instnil. rewr. reflexivity. rewr. eapply WfDTy_DEnv_sub. eassumption. rewr_derel. reflexivity.
      auto. auto. rewr.
      rewrite DSub_app_t_app_distr. rewrite DSub_app_t_exA_notinsub. simpl. rewr. reflexivity.
      rewr in NI__exB. rewr. fsetdec.
    destruct U__out as [env__out [U__out [dsub__out INST__out]]].
    (**)
    forwards: U_SameShape. eassumption. inv_SS. rename env4 into env__out. rename a3 into a__out. rename ty2 into ty__out.
    (**)
    exists. splits.
    + applys InfApp exB. 2,3,4:rewr; eassumption. fsetdec.
    + forwards: AInst_NN_create a__in. assumption. destr.
      exists. constructor. eassumption. eassumption.
    + rewrite <- DEnv_cons_da_app_split. norm.
      reflexivity.

  (*let*)
  - introv POL IH__pol MON IH__mon INST__in SUB__denv WF__in SOO__in NN.
    (**)
    forwards IH1: IH__pol. eassumption. eassumption. eassumption. eassumption. eassumption.
      clear IH__pol. destruct IH1 as [env [sch [dsch' [denv__obj' [da' [GEN [INST [SS EQ]]]]]]]]. subst.
    (**)
    forwards WF: Gen_Wf. eassumption. eassumption. clear WF__in.
    (**)
    forwards [x NI__x]: atom_fresh (L \u free_xs_e e2 \u Env_boundvars env).
    forwards IH2: IH__mon x (denv__obj' :::x x :- dsch' :::a da') (env ::x x :- sch) a__in.
      fsetdec.
      destruct INST. inv_EInst'. forwards: DSODO_cons_DA'. apply H5. 1,2:SOO_auto. destr. clear H5. inverts H0.
      rewr*. exists. constructor. constructor. eassumption. rewr. rewr in EMB. eassumption. rewr.
      eapply AInst_init_DEnv_sub. eassumption. crush.
      eauto using DEnvComplRel__lethelper. inv_Wf. eauto. unfold Sch_or_Obj. SOO_auto. eassumption.
    clear IH__mon.
    destruct IH2 as [env__out' [a [ty [denv__obj'' [da'' [INF [[dsub__out INST__out] EQ]]]]]]].
    forwards: Inf_SameShape. eassumption. inv_SS. clear H4.
    (**)
    inv_EInst'. clear H.
    forwards: DSODO_cons_DA'. apply H4. 1,2:SOO_auto. destr. inverts H.
    clear H4.
    rewrite <- DEnv_cons_da_app_split in EQ.
    forwards: DSODO_cons_DA'. apply EQ. 1,2:SOO_auto. destr. inverts H.
    rewr*. emb_auto''.
    (**)
    exists. splits.
    + applys InfLet empty. eassumption. intros y NI__y.
      forwards: Inf_rename_binding' y. eassumption. fsetdec.
      rewrite subst_tm_e_open_e_wrt_e in H. simpl in H. if_taut.
      assert (subst_tm_e (e_Var_f y) x e2 = e2). crush. rewrite H0 in H. eassumption. eauto.
    + forwards: AInst_NN_create a__in. eassumption. destr.
      exists. constructor. econstructor. econstructor. eassumption. rewr.
      eapply AInst_init_DEnv_sub. eassumption. rewr_derel. fsetdec. auto. rewr. crush.
      instantiate (2 := da''). eassumption.
    + norm. reflexivity.

  (* Gen *)
  - introv DFR MON IH__e DGEN SUB__denv [dsub INST] WF__in SOO__in NN. rename DA5 into da__gen. rename DTy5 into dty.
    eapply DFra_DEnv_sup_rem in DFR. 2:eassumption. forwards> [DFR__disj DFR__nodup]: DFrA_props. eassumption.
    (**)
    inv_EInst.
    rename DEnv_5 into denv__obj. rename DA5 into da__in. rewr in INSTA.
    (**)
    forwards IH: IH__e (denv__obj :::a (da__gen ++ da__in)) env__in a__in.
      exists. constructor. eassumption. rewr. apply AInst_NN_extend'. eassumption. assumption.
      rewrite DEnv_cons_da_app_split. eapply DEnvComplRel__genhelper. eassumption.
      assumption. eassumption. eassumption.
    destruct IH as [env__out [a [ty [denv__obj'' [da__in' [INF [[dsub INST] EQ]]]]]]].
    (**)
    forwards WF__out: Inf_Wf. eassumption. auto. clear WF__in.
    (**)
    forwards SOO__out: SOO_Inf. eassumption. assumption. clear SOO__in.
    inv_EInst'. rewr*. clear H. emb_auto''.
    forwards: DSODO_cons_DA' H4. 1,2:SOO_auto. clear H4. destr. inverts H.
    rename DEnv_5 into denv__obj'. rename DSub4 into dsub__obj'.
    rename DA1 into da. rename DSub5 into dsub__a.
    rename DSub3 into dsub__in'.
    (**)
    forwards: SOO_cons_DA. apply INST1. eassumption. symmetry in EQ. rewrite <- DEnv_cons_da_app_split in EQ. apply EQ.
      destruct H as [da' [EQ__das ?]]. symmetry in EQ__das. subst. rewr in EQ__das.
    (**)
    assert (PROPS: DSub_WfDTy (denv__obj' :::a da) (dsub__a ++ dsub__obj') /\ Env_skvars (env__out ::a a) [<=] DEnv_dskvars (denv__obj' :::a da)).
      EInst_props__base. apply EInstA. apply INST1. rewr. eassumption. rewr in SUB__wfdty. jauto.
      destruct PROPS as [SUB__wfdty EQ__ex].
    forwards WFDTY: embed_Ty_WfDTy. apply SUB__wfdty. eassumption. rewrite <- EQ__ex.
      inv_Wf. apply WfTy_props in WFTY. destr. simpl in H. rewr in H. rewrite H. rewr_erel. fsetdec. inv_Wf. eauto.
    (**)
    assert (EMB__gen: exists dsch, DSub_app (generalize_Sch (S_Mono ty) a empty) dsub__obj' = emb_Sch dsch).
    { forwards: AInst_props__base. apply INSTA2. destr. apply DSub_fullb_emb.
      unfold DSub_full. forwards<: DSub_full_t_emb. exists. eassumption. unfold DSub_full_t in H1.
      rewrite free_exvars_Sch_generalize_Sch. rewrite H1. rewr_dsrel. fsetdec.
    } destr.
    assert (SubSump ((denv__obj' :::a da') :::a da__in) dsch (generalize_DSch (DS_Mono dty) da__gen)).
    { forwards: AInst_props__base. apply INSTA2. destr.
      forwards INST: EInstA. apply INST1. rewr. eassumption.
      forwards WF__sub: EInst_props__base3. apply INST. rewr in WF__sub.
      assert (exists da__useless da__gen', da__gen = da__useless ++ da__gen'
                                /\ DSub_WfDTy (((denv__obj' :::a da') :::a da__in) :::a da__gen') (dsub__a ++ dsub__obj')
                                /\ varl da__gen' [><] DSub_codom_dskvars dsub__obj'
                                /\ varl da__gen' [><] free_skvars_Ty ty
                                /\ varl da__useless [><] free_dskvars_DTy dty).
      { assert (SPLIT: (exists da__inrest, da__in' = da__gen ++ da__inrest) \/ (exists da__gen1 da__gen2, da__gen = da__gen1 ++ da__gen2 /\ da__in' = da__gen1)).
        { forwards: list_app_eq_share_head. apply EQ__das. destr. right. exists. crush. left. exists. crush. }
        destr.
        - rewr in EQ__das. apply app_inv_head in EQ__das. exists da__gen ([]:DA). rewr. splits.
          + auto.
          + simpl. rewrite <- DEnv_cons_da_app_split. rewrite EQ__das. eauto.
          + crush.
          + crush.
          + assert (DISJ: (varl da__gen [><] DEnv_dskvars (denv__obj' :::a da' :::a da__in))).
              rewr. rewr in DFR__disj. eassumption.
            apply WfDTy_props in WFDTY. destr.
            simpl in H1. rewrite H1. eapply disj_subset_proper. 3:apply DISJ. crush.
            rewrite <- DEnv_cons_da_app_split. rewrite EQ__das. rewr.
            rewrite (fold_right_varl (da__inrest ++ da)). rewr. fsetdec.
        - rewr in EQ__das. apply app_inv_head in EQ__das. subst.
          assert (DISJ: varl da__gen2 [><] DEnv_dskvars denv__obj').
            eapply disj_subset_proper. 3:eassumption.
            rewr. fsetdec. rewr. fsetdec.
          exists. splits.
          + reflexivity.
          + norm. norm in WF__sub. eauto.
          + rewrite (DSub_WfDTy_codom_in_DEnv denv__obj'). 2:{ forwards WF__sub': EInst_props__base3. apply INST1. rewr in WF__sub'. assumption. }
            assumption.
          + inv_Wf. apply WfTy_props in WFTY. destr. rewr in H1. rewrite H1.
            forwards: EInst_props__base2. apply INST1. rewrite H4. assumption.
          + apply WfDTy_props in WFDTY. destr. simpl in H1. rewrite H1.
            apply DFrA_app_shift in DFR. apply DFrA_props in DFR. destr.
            eapply disj_subset_proper. 3:apply H3. rewr. fsetdec. rewr.
            rewrite <- (fold_right_varl da__gen2).
            rewrite <- (fold_right_varl da__in).
            rewrite <- (fold_right_varl da'). fsetdec.
      }
      (**)
      destr. rewrite generalize_DSch_app. eapply DGen_complete'; try eassumption.
      - forwards: EInst_props__base3. apply INST1. rewr in H1. norm. eauto.
      - forwards: EInst_props__base3. apply INST. rewr in H1. eauto.
      - forwards: EInst_props__wf. apply INST. inv_Wf. constructor; eauto. auto. crush. rewr in H1. eauto.
      - eauto.
    }
    exists. splits.
    + econstructor. eassumption. reflexivity.
    + instantiate (3 := denv__obj').
      forwards: AInst_NN_create a__in. assumption. destr.
      exists. constructor. econstructor. eassumption. auto. rewr. eassumption.
      instantiate (2 := (da__in ++ da')). eassumption.
    + eassumption.
    + norm. reflexivity.
Qed.

Theorem Completeness__mono : forall (e : e) (dty : DTy),
    ▪ |=m e ▸ dty
  -> exists a ty,
      • |= e ▸ ⟨a⟩ ty =| •
    /\ FullEInst (<a>a ::o ⟦S_Mono ty⟧) <⟦DS_Mono dty⟧d>do.
Proof.
  introv MON. forwards [exA NI__exA]: atom_fresh empty.
  forwards: proj1 Inf_Gen_complete. unfold Inf_complete__def in H.
  forwards IH: H ▪ ▪ • ([exA]). apply MON.
  - exists. applys_eq EInstA. 2:auto. instnil. reflexivity.
    applys_eq AInstCons. instnil. rewr. reflexivity. auto. auto.
  - unfold DEnvComplRel. split; crush.
  - auto.
  - SOO_auto.
  - unfold NonNil. destruct ([exA] == []). inverts e0. assumption.
  - destruct IH as [env [a [ty [denv__obj [da [INF [[dsub INST] EQ]]]]]]].
    exists a ty.
    forwards: Inf_SameShape. eassumption. inverts H0. split.
    + eassumption.
    + inv_EInst'. destruct da. 2:inverts EQ. simpl in EQ. subst.
      simpl in H5. destruct DA5. 2:inverts H5. simpl in H5. inverts H5.
      destruct DA1. 2:inverts H2. simpl in H2. subst.
      exists. econstructor. applys_eq EInstA. 3:eassumption. reflexivity. auto. auto.
      rewr. rewr in EMB. eassumption.
Qed.

Theorem Completeness__poly : forall (e : e) (dsch : DSch),
    ▪ |=p e ▸ dsch
  -> exists sch dsch',
      • |= e ▸ sch =| •
    /\ FullEInst (<⟦sch⟧>o) <⟦dsch'⟧d>do
    /\ SubSump ▪ dsch' dsch.
Proof.
  introv DGEN. forwards [exA NI__exA]: atom_fresh empty.
  forwards: proj2 Inf_Gen_complete. unfold Gen_complete__def in H.
  forwards IH: H ▪ ▪ • ([exA]). apply DGEN.
  - unfold DEnvComplRel. split; crush.
  - exists. applys_eq EInstA. 2:auto. instnil. reflexivity.
    applys_eq AInstCons. instnil. rewr. reflexivity. auto. auto.
  - auto.
  - SOO_auto.
  - unfold NonNil. destruct ([exA] == []). inverts e0. assumption.
  - destruct IH as [env [sch [dsch' [denv__obj [da [GEN [[dsub INST] [SS EQ]]]]]]]].
    exists sch dsch'. forwards: Gen_SameShape. eassumption. inverts H0.
    splits. 1,3:assumption.
    inv_EInst'. exists. econstructor. auto. auto. rewr.
    destruct da. 2:inverts EQ. simpl in EQ. subst.
    simpl in H5. destruct DA5. 2:inverts H5. simpl in H5. inverts H5. inverts INST.
    rewr in EMB. assumption.
Qed.


Require Export prosa.analysis.transform.swap.
Require Export prosa.analysis.transform.prefix.
Require Export prosa.util.search_arg.
Require Export prosa.util.list.

(** Throughout this file, we assume ideal uniprocessor schedules. *)
Require Export prosa.model.processor.ideal.

(** In this file we define the transformation from any ideal uniprocessor schedule
    into a work-conserving one. The procedure is to patch the idle allocations
    with future job allocations. Note that a job cannot be allocated before
    its arrival, therefore there could still exist idle instants between any two
    job allocations. *)
Section WCTransformation.

  (** Consider any type of jobs with arrival times, costs, and deadlines... *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.
  Context `{JobDeadline Job}.

  (** ...an ideal uniprocessor schedule... *)
  Let PState := ideal.processor_state Job.

  (** ...and any valid job arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arr_seq_valid : valid_arrival_sequence arr_seq.

  (** We say that a state is relevant (for the purpose of the
      transformation) if it is not idle and if the job scheduled in it
      has arrived prior to some given reference time. *)
  Definition relevant_pstate reference_time pstate :=
    match pstate with
    | None => false
    | Some j => job_arrival j <= reference_time
    end.

  (** In order to patch an idle allocation, we look in the future for another allocation
      that could be moved there. The limit of the search is the maximum deadline of
      every job arrived before the given moment. *)
  Definition max_deadline_for_jobs_arrived_before arrived_before :=
    let deadlines := map job_deadline (arrivals_up_to arr_seq arrived_before)
    in max0 deadlines.

  (** Next, we define a central element of the work-conserving transformation
      procedure: given an idle allocation at [t], find a job allocation in the future
      to swap with. *)
  Definition find_swap_candidate sched t :=
    let order _ _ := false (* always take the first result *)
    in
    let max_dl := max_deadline_for_jobs_arrived_before t
    in
    let search_result := search_arg sched (relevant_pstate t) order t max_dl
    in
    if search_result is Some t_swap
    then t_swap
    else t. (* if nothing is found, swap with yourself *)

  (** The point-wise transformation procedure: given a schedule and a
      time [t1], ensure that the schedule is work-conserving at time
      [t1]. *)
  Definition make_wc_at sched t1 :=
    match sched t1 with
    | Some j => sched (* leave working instants alone *)
    | None =>
      let
        t2 := find_swap_candidate sched t1
      in swapped sched t1 t2
    end.

  (** To transform a finite prefix of a given reference schedule, apply
      [make_wc_at] to every point up to the given finite horizon. *)
  Definition wc_transform_prefix sched horizon :=
    prefix_map sched make_wc_at horizon.

  (** Finally, a fully work-conserving schedule (i.e., one that is
      work-conserving at any time) is obtained by first computing a
      work-conserving prefix up to and including the requested time [t],
      and by then looking at the last point of the prefix. *)
  Definition wc_transform sched t :=
    let
      wc_prefix := wc_transform_prefix sched t.+1
    in wc_prefix t.

End WCTransformation.