Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Pred.
Require Import Trace.

Require Import MemoryMerge.
Require Import ReorderCancel.
Require Import MemoryProps.
Require Import OrderedTimes.
Require Import Cover.
Require Import Mapping.

Set Implicit Arguments.

Lemma promise_not_cancel_covered_increase prom0 prom1 mem0 mem1
      loc from to msg kind
      (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
      (NOTCANCEL: kind <> Memory.op_kind_cancel)
      loc0 ts0
      (COVERED: covered loc0 ts0 mem0)
  :
    covered loc0 ts0 mem1.
Proof.
  inv PROMISE.
  { erewrite (@add_covered mem1 mem0); eauto. }
  { erewrite (@split_covered mem1 mem0); eauto. }
  { erewrite (@lower_covered mem1 mem0); eauto. }
  { ss. }
Qed.

Lemma step_not_cancel_covered_increase lang (th0 th1: Thread.t lang) pf e
      (STEP: Thread.step pf e th0 th1)
      (NOTCANCEL: ~ ThreadEvent.is_cancel e)
      loc0 ts0
      (COVERED: covered loc0 ts0 (Thread.memory th0))
  :
    covered loc0 ts0 (Thread.memory th1).
Proof.
  inv STEP.
  { inv STEP0. inv LOCAL. ss.
    eapply promise_not_cancel_covered_increase; eauto. destruct kind; ss.
    des_ifs. inv PROMISE; ss.
  }
  { inv STEP0. inv LOCAL; auto.
    { inv LOCAL0. inv WRITE. eapply promise_not_cancel_covered_increase; eauto.
      destruct kind; ss. inv PROMISE; ss. }
    { inv LOCAL2. inv WRITE. eapply promise_not_cancel_covered_increase; eauto.
      destruct kind; ss. inv PROMISE; ss. }
  }
Qed.

Lemma traced_steps_not_cancel_covered_increase lang (th0 th1: Thread.t lang) tr
      (STEPS: Trace.steps tr th0 th1)
      (EVENTS: List.Forall (fun em => <<SAT: (fun e => ~ ThreadEvent.is_cancel e) (snd em)>>) tr)
      loc0 ts0
      (COVERED: covered loc0 ts0 (Thread.memory th0))
  :
    covered loc0 ts0 (Thread.memory th1).
Proof.
  ginduction STEPS; auto. i. clarify. inv EVENTS.
  eapply step_not_cancel_covered_increase in STEP; eauto.
Qed.

Section UNATTACHABLE.

  Inductive unattachable (mem: Memory.t) (loc: Loc.t) (ts: Time.t): Prop :=
  | unattachable_intro
      from to msg
      (MSG: Memory.get loc to mem = Some (from, msg))
      (FROM: Time.le from ts)
      (TO: Time.lt ts to)
  .

  Lemma lower_unattachable mem1 mem0 loc from to msg1 msg2
        (LOWER: Memory.lower mem0 loc from to msg1 msg2 mem1)
    :
      unattachable mem1 = unattachable mem0.
  Proof.
    extensionality loc0. extensionality ts0.
    exploit Memory.lower_get0; eauto. i. des.
    apply Coq.Logic.PropExtensionality.propositional_extensionality. split; i.
    { inv H. erewrite Memory.lower_o in MSG; eauto. des_ifs.
      { ss. des; clarify. econs; eauto. }
      { econs; eauto. }
    }
    { inv H. eapply Memory.lower_get1 in MSG; eauto. des. econs; eauto. }
  Qed.

  Lemma split_unattachable mem1 mem0 loc ts1 ts2 ts3 msg2 msg3
        (SPLIT: Memory.split mem0 loc ts1 ts2 ts3 msg2 msg3 mem1)
    :
      unattachable mem1 = unattachable mem0.
  Proof.
    extensionality loc0. extensionality ts0.
    exploit split_succeed_wf; eauto. i. des.
    exploit Memory.split_get0; eauto. i. des.
    apply Coq.Logic.PropExtensionality.propositional_extensionality. split; i.
    { inv H. erewrite Memory.split_o in MSG; eauto. des_ifs.
      { ss. des; clarify. econs; eauto. }
      { ss. des; clarify. econs; eauto. etrans; eauto. left. auto. }
      { econs; eauto. }
    }
    { inv H. generalize (Memory.split_o loc0 to SPLIT). intros MSG0. des_ifs.
      { ss. des; clarify. }
      { ss. des; clarify.
        destruct (Time.le_lt_dec ts2 ts0).
        { econs; try apply MSG0; eauto. }
        { econs; try apply GET1; eauto. }
      }
      { erewrite MSG in *. clarify. econs; eauto. }
    }
  Qed.

  Lemma add_unattachable mem1 mem0 loc from to msg
        (ADD: Memory.add mem0 loc from to msg mem1)
    :
      unattachable mem1 =
      (fun loc0 ts0 =>
         unattachable mem0 loc0 ts0 \/ (loc0 = loc /\ Time.le from ts0 /\ Time.lt ts0 to)).
  Proof.
    extensionality loc0. extensionality ts0.
    exploit add_succeed_wf; eauto. i.  des.
    exploit Memory.add_get0; eauto. i. des.
    apply Coq.Logic.PropExtensionality.propositional_extensionality. split; i.
    { inv H. erewrite Memory.add_o in MSG; eauto. des_ifs.
      { ss. des; clarify. right. splits; auto. }
      { left. econs; eauto. }
    }
    { des; subst.
      { inv H. econs; eauto. eapply Memory.add_get1; eauto. }
      { econs; eauto. }
    }
  Qed.

End UNATTACHABLE.

Section LIFT.

  Lemma memory_remove_le_preserve mem0 mem0' mem1 mem1' loc from to msg
        (REMOVE0: Memory.remove mem0 loc from to msg mem0')
        (REMOVE1: Memory.remove mem1 loc from to msg mem1')
        (MLE: Memory.le mem0 mem1)
  :
    Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma memory_add_le_preserve mem0 mem0' mem1 mem1' loc from to msg
        (ADD0: Memory.add mem0 loc from to msg mem0')
        (ADD1: Memory.add mem1 loc from to msg mem1')
        (MLE: Memory.le mem0 mem1)
    :
      Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.add_o; eauto.
    erewrite (@Memory.add_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma memory_split_le_preserve mem0 mem0' mem1 mem1' loc ts1 ts2 ts3 msg2 msg3
        (SPLIT0: Memory.split mem0 loc ts1 ts2 ts3 msg2 msg3 mem0')
        (SPLIT1: Memory.split mem1 loc ts1 ts2 ts3 msg2 msg3 mem1')
        (MLE: Memory.le mem0 mem1)
    :
      Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.split_o; eauto.
    erewrite (@Memory.split_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma memory_lower_le_preserve mem0 mem0' mem1 mem1' loc from to msg1 msg2
        (LOWER0: Memory.lower mem0 loc from to msg1 msg2 mem0')
        (LOWER1: Memory.lower mem1 loc from to msg1 msg2 mem1')
        (MLE: Memory.le mem0 mem1)
    :
      Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.lower_o; eauto.
    erewrite (@Memory.lower_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma step_lifting_promise prom0 prom1 mem0 mem1 cap0
        loc from to msg kind
        (spaces lefts: Loc.t -> Time.t -> Prop)
        (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
        (WRITENOTIN: forall ts (ITV: Interval.mem (from, to) ts), ~ spaces loc ts)
        (WRITENOTTO: ~ lefts loc to)
        (SOUND: Memory.le mem0 cap0)
        (SPACES:
           forall loc ts (COV: covered loc ts cap0),
             <<COV: covered loc ts mem0>> \/ <<SPACE: spaces loc ts>>)
        (LEFTS:
           forall loc ts (UNATTACHABLE: unattachable cap0 loc ts),
             <<COV: unattachable mem0 loc ts>> \/ <<LEFT: lefts loc ts>>)
        (MEM0: Memory.closed mem0)
        (PROM0: Memory.le prom0 mem0)
        (PROM1: Memory.le prom0 cap0)
        (NOTCANCEL: kind <> Memory.op_kind_cancel)
    :
      exists cap1,
        (<<STEP: Memory.promise prom0 cap0 loc from to msg prom1 cap1 kind>>) /\
        (<<SOUND: Memory.le mem1 cap1>>) /\
        (<<SPACES:
           forall loc ts (COV: covered loc ts cap1),
             <<COV: covered loc ts mem1>> \/ spaces loc ts>>) /\
        (<<LEFTS:
           forall loc ts (UNATTACHABLE: unattachable cap1 loc ts),
             <<COV: unattachable mem1 loc ts>> \/ lefts loc ts>>).
  Proof.
    inv PROMISE.
    { exploit add_succeed_wf; try apply MEM; eauto. i. des.
      exploit (@Memory.add_exists cap0 loc from to msg); eauto.
      { ii. exploit SPACES.
        { econs; eauto. }
        i. des.
        { inv COV. eapply DISJOINT; eauto. }
        { eapply WRITENOTIN; eauto. }
      }
      i. des. esplits.
      { econs; eauto. i. subst. exploit LEFTS.
        { econs; eauto.
          { refl. }
          { apply memory_get_ts_strong in GET. des; auto.
            subst. eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec. }
        }
        i. des; ss.
        { inv COV. destruct FROM.
          { eapply DISJOINT; eauto.
            { instantiate (1:=to). econs; ss. refl. }
            { econs; ss. left. eauto. }
          }
          { inv H. eapply ATTACH; eauto. }
        }
      }
      { eapply memory_add_le_preserve; eauto. }
      { i. erewrite add_covered in COV; eauto.
        erewrite (@add_covered mem1 mem0); eauto. des; eauto.
        eapply SPACES in COV. des; auto. }
      { i. erewrite add_unattachable in UNATTACHABLE; eauto.
        erewrite (@add_unattachable mem1 mem0); eauto. des; auto.
        eapply LEFTS in UNATTACHABLE. des; auto. }
    }
    { des. subst.
      exploit (@Memory.split_exists_le prom0 cap0); eauto. i. des. esplits.
      { econs; eauto. }
      { ii. erewrite Memory.split_o in LHS; eauto.
        erewrite (@Memory.split_o mem2 cap0); eauto. des_ifs.
        eapply SOUND; eauto. }
      { i. erewrite (@split_covered mem2 cap0) in COV; eauto.
        erewrite (@split_covered mem1 mem0); eauto. }
      { i. erewrite (@split_unattachable mem2 cap0) in UNATTACHABLE; eauto.
        erewrite (@split_unattachable mem1 mem0); eauto. }
    }
    { des. subst.
      exploit (@Memory.lower_exists_le prom0 cap0); eauto. i. des. esplits.
      { econs; eauto. }
      { ii. erewrite Memory.lower_o in LHS; eauto.
        erewrite (@Memory.lower_o mem2 cap0); eauto. des_ifs.
        eapply SOUND; eauto. }
      { i. erewrite (@lower_covered mem2 cap0) in COV; eauto.
        erewrite (@lower_covered mem1 mem0); eauto. }
      { i. erewrite (@lower_unattachable mem2 cap0) in UNATTACHABLE; eauto.
        erewrite (@lower_unattachable mem1 mem0); eauto. }
    }
    { ss. }
  Qed.

  Lemma step_lifting lang st0 st1 lc0 lc1 sc0 sc1 mem0 mem1 cap0 pf e
        (spaces lefts: Loc.t -> Time.t -> Prop)
        (STEP: Thread.step pf e (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk _ st1 lc1 sc1 mem1))
        (WRITENOTIN: write_not_in spaces e)
        (WRITENOTTO: write_not_to lefts e)
        (NOTCANCEL: ~ ThreadEvent.is_cancel e)
        (SOUND: Memory.le mem0 cap0)
        (SPACES:
           forall loc ts (COV: covered loc ts cap0),
             <<COV: covered loc ts mem0>> \/ <<SPACE: spaces loc ts>>)
        (LEFTS:
           forall loc ts (UNATACHABLE: unattachable cap0 loc ts),
             <<COV: unattachable mem0 loc ts>> \/ <<LEFT: lefts loc ts>>)
       (MEM0: Memory.closed mem0)
        (LOCAL0: Local.wf lc0 mem0)
        (SC0: Memory.closed_timemap sc0 mem0)
    :
      exists cap1,
        (<<STEP: Thread.step pf e (Thread.mk _ st0 lc0 sc0 cap0) (Thread.mk _ st1 lc1 sc1 cap1)>>) /\
        (<<SOUND: Memory.le mem1 cap1>>) /\
        (<<SPACES:
           forall loc ts (COV: covered loc ts cap1),
             <<COV: covered loc ts mem1>> \/ spaces loc ts>>) /\
        (<<UNATTACHABLE:
           forall loc ts (COV: unattachable cap1 loc ts),
             <<COV: unattachable mem1 loc ts>> \/ lefts loc ts>>).

  Proof.
    inv STEP.
    { inv STEP0. inv LOCAL. ss.
      destruct (Memory.op_kind_is_cancel kind) eqn:KIND; ss.
      { destruct kind; ss. des_ifs. inv PROMISE; ss. }
      exploit step_lifting_promise; eauto.
      { eapply LOCAL0. }
      { transitivity mem0; eauto. eapply LOCAL0. }
      { destruct kind; ss. }
      i. des. esplits; eauto. econs. econs.
      { econs; eauto. eapply memory_concrete_le_closed_msg; eauto. }
      { ss. destruct kind; ss. }
    }
    { inv STEP0. inv LOCAL.
      { esplits; eauto. }
      { inv LOCAL1. eapply SOUND in GET. esplits; eauto. }
      { inv LOCAL1. inv WRITE. exploit step_lifting_promise; eauto.
        { eapply LOCAL0. }
        { transitivity mem0; eauto. eapply LOCAL0. }
        { destruct kind; ss. inv PROMISE; ss. }
        i. des. esplits; eauto. econs 2; eauto.
      }
      { inv LOCAL1. eapply SOUND in GET. inv LOCAL2. inv WRITE.
        exploit step_lifting_promise; eauto.
        { eapply LOCAL0. }
        { transitivity mem0; eauto. eapply LOCAL0. }
        { destruct kind; ss. inv PROMISE; ss. }
        i. des. esplits; eauto. econs 2; eauto. econs; eauto. }
      { esplits; eauto. }
      { esplits; eauto. }
      { esplits; eauto. }
    }
  Qed.

  Lemma traced_step_lifting lang st0 st1 lc0 lc1 sc0 sc1 mem0 mem1 cap0 tr
        (spaces lefts: Loc.t -> Time.t -> Prop)
        (STEPS: Trace.steps tr (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk _ st1 lc1 sc1 mem1))
        (EVENTS: List.Forall (fun em => <<SAT: (write_not_in spaces /1\ write_not_to lefts /1\ (fun e => ~ ThreadEvent.is_cancel e)) (snd em)>>) tr)
        (SOUND: Memory.le mem0 cap0)
        (SPACES:
           forall loc ts (COV: covered loc ts cap0),
             <<COV: covered loc ts mem0>> \/ <<SPACE: spaces loc ts>>)
        (LEFTS:
           forall loc ts (UNATACHABLE: unattachable cap0 loc ts),
             <<COV: unattachable mem0 loc ts>> \/ <<LEFT: lefts loc ts>>)
        (MEM0: Memory.closed mem0)
        (LOCAL0: Local.wf lc0 mem0)
        (SC0: Memory.closed_timemap sc0 mem0)
    :
      exists cap1,
        (<<STEPS: Trace.steps tr (Thread.mk _ st0 lc0 sc0 cap0) (Thread.mk _ st1 lc1 sc1 cap1)>>) /\
        (<<SOUND: Memory.le mem1 cap1>>) /\
        (<<SPACES:
           forall loc ts (COV: covered loc ts cap1),
             <<COV: covered loc ts mem1>> \/ spaces loc ts>>) /\
        (<<LEFTS:
           forall loc ts (UNATACHABLE: unattachable cap1 loc ts),
             <<COV: unattachable mem1 loc ts>> \/ lefts loc ts>>).
  Proof.
    remember (Thread.mk lang st0 lc0 sc0 mem0).
    remember (Thread.mk lang st1 lc1 sc1 mem1). ginduction STEPS.
    { i. clarify. esplits; eauto. }
    { i. clarify. inv EVENTS. ss. des.
      exploit Thread.step_future; eauto. i. des.
      destruct th1. ss. exploit step_lifting; eauto. i. des.
      exploit IHSTEPS; eauto. i. des. exists cap2. splits; auto. econs; eauto.
    }
  Qed.

End LIFT.

Fixpoint intervals_sum (l: list (Loc.t * Interval.t)):
  Loc.t -> Time.t -> Prop :=
  match l with
  | [] => bot2
  | (loc, (from, to))::tl =>
    fun loc0 ts0 =>
      (loc0 = loc /\ Interval.mem (from, to) ts0) \/
      intervals_sum tl loc0 ts0
  end.

Fixpoint intervals_sum_left (l: list (Loc.t * Interval.t)):
  Loc.t -> Time.t -> Prop :=
  match l with
  | [] => bot2
  | (loc, (from, to))::tl =>
    fun loc0 ts0 =>
      (loc0 = loc /\ Time.le from ts0 /\ Time.lt ts0 to) \/
      intervals_sum_left tl loc0 ts0
  end.

Lemma intervals_sum_interval l
      loc ts
  :
    intervals_sum l loc ts <->
    exists from to,
      (<<IN: List.In (loc, (from, to)) l>>) /\ (<<ITV: Interval.mem (from, to) ts>>).
Proof.
  ginduction l; ss.
  { i; split; i; ss. des. ss. }
  { i; split; i; ss.
    { destruct a. destruct t0. des; clarify.
      { esplits; eauto. }
      { eapply IHl in H. des. esplits; eauto. }
    }
    { destruct a. destruct t0. des; clarify; eauto. right.
      eapply IHl. eauto. }
  }
Qed.

Lemma intervals_sum_left_interval l
      loc ts
  :
    intervals_sum_left l loc ts <->
    exists from to,
      (<<IN: List.In (loc, (from, to)) l>>) /\ (<<FROM: Time.le from ts>>) /\ (<<TO: Time.lt ts to>>).
Proof.
  ginduction l; ss.
  { i; split; i; ss. des. ss. }
  { i; split; i; ss.
    { destruct a. destruct t0. des; clarify.
      { esplits; eauto. }
      { eapply IHl in H. des. esplits; eauto. }
    }
    { destruct a. destruct t0. des; clarify; eauto. right.
      eapply IHl. eauto. }
  }
Qed.

Lemma promise_needed_spaces prom0 prom1 mem0 mem1
      loc from to msg kind
      (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
      (WF: kind <> Memory.op_kind_cancel)
  :
    ((<<ALREADY: forall ts (ITV: Interval.mem (from, to) ts), covered loc ts mem0>>) /\
     (<<COVERED: forall loc ts, covered loc ts mem1 <-> covered loc ts mem0>>))
    \/
    ((<<NEW: forall ts (ITV: Interval.mem (from, to) ts), ~ covered loc ts mem0>>) /\
     (<<COVERED: forall loc0 ts0,
         covered loc0 ts0 mem1 <-> covered loc0 ts0 mem0 \/ (loc0 = loc /\ Interval.mem (from, to) ts0)>>) /\
     (<<WF: Time.lt from to>>))
.
Proof.
  inv PROMISE.
  { right. exploit add_succeed_wf; try apply MEM. i. des. splits; auto.
    { ii. inv H. eapply DISJOINT; eauto. }
    { i. erewrite (@add_covered mem1); eauto. }
  }
  { left. exploit split_succeed_wf; try apply MEM. i. des. splits; auto.
    { ii. econs; eauto. eapply Interval.le_mem; eauto. econs; ss.
      { refl. }
      { left. auto. }
    }
    { i. eapply split_covered; eauto. }
  }
  { left. exploit lower_succeed_wf; try apply MEM. i. des. splits; auto.
    { ii. econs; eauto. }
    { i. eapply lower_covered; eauto. }
  }
  { ss. }
Qed.

Lemma step_needed_spaces lang (th0 th1: Thread.t lang) pf e
      (times: Loc.t -> Time.t -> Prop)
      (STEP: Thread.step pf e th0 th1)
      (NOTCANCEL: ~ ThreadEvent.is_cancel e)
      (WFTIME: wf_time_evt times e)
  :
    ((<<ALREADY: write_not_in (fun loc0 ts0 => ~ covered loc0 ts0 (Thread.memory th0)) e>>) /\
     (<<COVERED: forall loc ts, covered loc ts (Thread.memory th1) <-> covered loc ts (Thread.memory th0)>>))
    \/
    exists loc from to,
      (<<NEW: forall ts (ITV: Interval.mem (from, to) ts), ~ covered loc ts (Thread.memory th0)>>) /\
      (<<COVERED: forall loc0 ts0,
          covered loc0 ts0 (Thread.memory th1) <-> covered loc0 ts0 (Thread.memory th0) \/ (loc0 = loc /\ Interval.mem (from, to) ts0)>>) /\
      (<<WF: Time.lt from to>>) /\
      (<<TIMES: times loc from /\ times loc to>>) /\
      (<<EVENT: write_not_in (fun loc0 ts0 => ~ (loc0 = loc /\ Interval.mem (from, to) ts0)) e>>).
Proof.
  inv STEP.
  { inv STEP0. inv LOCAL. ss.
    destruct (Memory.op_kind_is_cancel kind) eqn:KIND.
    { destruct kind; ss. des_ifs. inv PROMISE; ss. }
    exploit promise_needed_spaces; eauto.
    { destruct kind; ss. }
    i. des.
    { left. splits; auto. }
    { right. esplits; eauto. }
  }
  { inv STEP0. inv LOCAL; try by (splits; eauto); ss.
    { ss. inv LOCAL0. inv WRITE.
      exploit promise_needed_spaces; eauto.
      { destruct kind; ss. inv PROMISE; ss. }
      i. des.
      { left. esplits; eauto. }
      { right. esplits; eauto. }
    }
    { ss. inv LOCAL2. inv WRITE.
      exploit promise_needed_spaces; eauto.
      { destruct kind; ss. inv PROMISE; ss. }
      i. des.
      { left. esplits; eauto. }
      { right. esplits; eauto. }
    }
  }
Qed.

Inductive reservations_added:
  forall (l: list (Loc.t * Interval.t)) (mem0 mem1: Memory.t), Prop :=
| reservations_added_base
    mem0
  :
    reservations_added [] mem0 mem0
| reservations_added_cons
    mem0 mem1 mem2 loc from to tl
    (ADD: Memory.add mem0 loc from to Message.reserve mem1)
    (TL: reservations_added tl mem1 mem2)
    (WF: Time.lt from to)
  :
    reservations_added ((loc, (from, to))::tl) mem0 mem2
.

Lemma reservations_added_trans l0 l1 mem0 mem1 mem2
      (ADDED0: reservations_added l0 mem0 mem1)
      (ADDED1: reservations_added l1 mem1 mem2)
  :
    reservations_added (l0 ++ l1) mem0 mem2.
Proof.
  ginduction l0; eauto.
  { i. inv ADDED0. ss. }
  { i. inv ADDED0. exploit IHl0; eauto. i. econs; eauto. }
Qed.

Lemma reservations_added_cancel
      loc from to mem0 mem1 mem2 tl
      (CANCEL: Memory.remove mem1 loc from to Message.reserve mem0)
      (TL: reservations_added tl mem1 mem2)
      (WF: Time.lt from to)
  :
    reservations_added ((loc, (from, to))::tl) mem0 mem2.
Proof.
  econs; eauto.
  exploit (@Memory.add_exists mem0 loc from to Message.reserve); eauto.
  { i. erewrite Memory.remove_o in GET2; eauto. des_ifs.
    exploit Memory.get_disjoint.
    { eapply GET2. }
    { eapply Memory.remove_get0; eauto. }
    i. ss. des; clarify. symmetry. auto.
  }
  { econs. }
  i. des. replace mem1 with mem3; auto. eapply Memory.ext.
  i. erewrite (@Memory.add_o mem3 mem0); eauto.
  erewrite (@Memory.remove_o mem0 mem1); eauto. des_ifs.
  ss. des; clarify. symmetry. eapply Memory.remove_get0; eauto.
Qed.

Inductive disjoint_intervals
  :
    forall (l: list (Loc.t * Interval.t)), Prop :=
| disjoint_base
  :
    disjoint_intervals []
| disjoint_intervals_cons
    loc from to tl
    (TL: disjoint_intervals tl)
    (NITV: forall ts (ITV: Interval.mem (from, to) ts),
        ~ intervals_sum tl loc ts)
    (TS: Time.lt from to)
  :
    disjoint_intervals ((loc, (from, to)) :: tl)
.
Hint Constructors disjoint_intervals.

Lemma traced_steps_needed_spaces lang (th0 th1: Thread.t lang) tr
      (times: Loc.t -> Time.t -> Prop)
      (STEP: Trace.steps tr th0 th1)
      (EVENTS: List.Forall (fun em => <<SAT: ((fun e => ~ ThreadEvent.is_cancel e) /1\ wf_time_evt times) (snd em)>>) tr)
  :
    exists l,
      (<<WRITENOTIN:
         List.Forall (fun em => <<SAT: write_not_in (fun loc ts => ~ (covered loc ts (Thread.memory th0) \/ intervals_sum l loc ts)) (snd em)>>) tr>>) /\
      (<<DISJOINT: disjoint_intervals l>>) /\
      (<<NITV: forall loc ts (ITV: intervals_sum l loc ts), ~ covered loc ts (Thread.memory th0)>>) /\
      (<<COVERED: forall loc ts,
          covered loc ts (Thread.memory th1) <-> covered loc ts (Thread.memory th0) \/ intervals_sum l loc ts>>) /\
      (<<TIMES: List.Forall (fun locitv =>
                               times (fst locitv) (fst (snd locitv)) /\
                               times (fst locitv) (snd (snd locitv))) l>>)
.
Proof.
  ginduction STEP; i.
  { exists []. splits; auto. i. ss. split; auto. i. des; ss. }
  { subst. inv EVENTS. des. exploit IHSTEP; eauto. i. des.
    exploit step_needed_spaces; eauto. i. des.
    { exists l. splits; auto.
      { econs; eauto.
        { eapply write_not_in_mon; eauto. i. ss.
          eapply not_or_and in PR. des. auto. }
        { eapply List.Forall_impl; eauto. i. ss.
          eapply write_not_in_mon; eauto. i. ss.
          erewrite COVERED0; eauto. }
      }
      { i. erewrite <- COVERED0; eauto. }
      { i. erewrite <- COVERED0. eauto. }
    }
    { exists ((loc, (from, to)) :: l). splits.
      { econs.
        { eapply write_not_in_mon; eauto. ss. i.
          ii. des. eapply PR. eauto. }
        { eapply List.Forall_impl; try apply WRITENOTIN; eauto. i. ss.
          eapply write_not_in_mon; eauto. i. ss.
          ii. eapply PR. des; auto. eapply COVERED0 in H3. des; auto. }
      }
      { econs; eauto. ii. eapply NITV; eauto. eapply COVERED0. auto. }
      { i. ss. des; clarify; eauto.
        eapply NITV in ITV. ii. eapply ITV. eapply COVERED0. auto. }
      { ii. erewrite COVERED. erewrite COVERED0. ss. split; i; des; auto. }
      { econs; ss. }
    }
  }
Qed.

Lemma reserve_empty_intervals times lang (th: Thread.t lang) l
      (DISJOINT: disjoint_intervals l)
      (NITV: forall loc ts (ITV: intervals_sum l loc ts),
          ~ covered loc ts (Thread.memory th))
      (MLE: Memory.le (Local.promises (Thread.local th)) (Thread.memory th))
      (TIMES: List.Forall (fun locitv =>
                             times (fst locitv) (fst (snd locitv)) /\
                             times (fst locitv) (snd (snd locitv))) l)
  :
    exists tr prom' mem',
      (<<STEPS: Trace.steps tr th (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom') (Thread.sc th) mem')>>) /\
      (<<RESERVETRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_reserve /1\ wf_time_evt times) (snd em)>>) tr>>) /\
      (<<ADDEDPROM: reservations_added l (Local.promises (Thread.local th)) prom'>>) /\
      (<<ADDEDMEM: reservations_added l (Thread.memory th) mem'>>)
.
Proof.
  ginduction l; i.
  { destruct th. destruct local. ss. exists []. esplits; eauto.
    { econs. }
    { econs. }
  }
  { inv DISJOINT. inv TIMES. ss.
    exploit (@Memory.add_exists (Thread.memory th) loc from to Message.reserve); eauto.
    { ii. eapply NITV.
      { left. eauto. }
      { econs; eauto. }
    }
    { econs. }
    intros [mem MEM].
    exploit (@Memory.add_exists_le (Local.promises (Thread.local th)) (Thread.memory th)); eauto.
    intros [prom PROM].
    assert (STEP: Thread.step false (ThreadEvent.promise loc from to Message.reserve Memory.op_kind_add) th (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom) (Thread.sc th) mem)).
    { destruct th. ss. econs. econs; ss. econs; ss. econs; ss. }
    exploit (@IHl times lang (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom) (Thread.sc th) mem)); eauto; ss.
    { i. erewrite add_covered; eauto. ii. des; subst.
      { eapply NITV; eauto. }
      { eapply NITV0; eauto. }
    }
    { hexploit step_promises_le; eauto.
      { econs; eauto. }
      i. ss.
    }
    i. des. esplits.
    { econs; eauto. }
    { econs; ss. }
    { econs; eauto. }
    { econs; eauto. }
  }
Qed.

Lemma reservations_added_get_same mem1 mem0 l
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (NIN: forall from, ~ List.In (loc, (from, ts)) l)
  :
    Memory.get loc ts mem1 = Memory.get loc ts mem0.
Proof.
  ginduction ADDED; auto. i.
  erewrite IHADDED; eauto.
  { erewrite (@Memory.add_o mem1 mem0); eauto. des_ifs. ss. des; clarify.
    exfalso. eapply NIN; eauto. }
  { ii. ss. eapply NIN; eauto. }
Qed.

Lemma reservations_added_get_none mem1 mem0 l
      (ADDED: reservations_added l mem0 mem1)
      loc from ts
      (IN: List.In (loc, (from, ts)) l)
  :
    Memory.get loc ts mem0 = None.
Proof.
  ginduction ADDED; ss. i. des; clarify.
  { eapply Memory.add_get0; eauto. }
  { eapply IHADDED in IN. erewrite Memory.add_o in IN; eauto. des_ifs. }
Qed.

Lemma reservations_added_le_le l mem0 mem1 cap1 cap0
      (ADDED0: reservations_added l mem0 mem1)
      (MLE: Memory.le mem1 cap1)
      (ADDED1: reservations_added l cap0 cap1)
  :
    Memory.le mem0 cap0.
Proof.
  ii. destruct (classic (forall from, ~ List.In (loc, (from, to)) l)).
  { erewrite <- (@reservations_added_get_same cap1 cap0); eauto.
    erewrite <- (@reservations_added_get_same mem1 mem0) in LHS; eauto. }
  { eapply not_all_not_ex in H. des.
    erewrite reservations_added_get_none in LHS; eauto. ss. }
Qed.

Lemma cancel_reservations_added times l prom lang lc
      (ADDEDPROM: reservations_added l prom (Local.promises lc))
      (TIMES: List.Forall (fun locitv =>
                             times (fst locitv) (fst (snd locitv)) /\
                             times (fst locitv) (snd (snd locitv))) l)
  :
    exists tr,
      (<<CANCELTRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_cancel /1\ wf_time_evt times) (snd em)>>) tr>>) /\
    forall
      (st: Language.state lang) sc mem
      (MLE: Memory.le (Local.promises lc) mem),
    exists mem',
      (<<STEPS: Trace.steps tr (Thread.mk _ st lc sc mem) (Thread.mk _ st (Local.mk (Local.tview lc) prom) sc mem')>>) /\
      (<<ADDEDMEM: reservations_added l mem' mem>>)
.
Proof.
  ginduction l; i.
  { exists []. splits; ss. i. destruct lc. ss. inv ADDEDPROM. esplits; eauto. econs. }
  { inv TIMES. inv ADDEDPROM.
    exploit IHl; eauto. i. des.
    eexists (tr++[(Local.mk (Local.tview lc) mem1, ThreadEvent.promise loc from to Message.reserve Memory.op_kind_cancel)]).
    splits.
    { eapply Forall_app; eauto. econs; ss. }
    i. exploit (x0 st sc mem); eauto. i. des.
    exploit (@Memory.remove_exists mem1 loc from to Message.reserve); eauto.
    { eapply Memory.add_get0; eauto. } i. des.
    exploit (@Memory.remove_exists_le mem1 mem'); eauto.
    { eapply trace_steps_promises_le in STEPS; eauto. } i. des.
    assert (mem2 = prom).
    { symmetry. eapply MemoryMerge.add_remove; eauto. } subst.
    esplits.
    { eapply Trace.steps_trans.
      { eapply STEPS. }
      { econs; eauto. econs 1; eauto. econs; eauto. }
    }
    { eapply reservations_added_cancel; eauto. }
  }
Qed.

Lemma step_finte_write_to (e: ThreadEvent.t)
      (times: Loc.t -> Time.t -> Prop)
      (EVENT: wf_time_evt times e)
  :
    exists (l: list (Loc.t * Time.t)),
      (<<EVENT: write_not_to (fun loc ts => ~ List.In (loc, ts) l) e>>) /\
      (<<TIMES: List.Forall (fun locts => times (fst locts) (snd locts)) l>>).
Proof.
  destruct e; try by (exists []; esplits; eauto); ss.
  { exists [(loc, to)]. esplits; ss.
    { des_ifs. ii. eapply H. auto. }
    { econs; ss. des. auto. }
  }
  { exists [(loc, to)]. esplits; ss.
    { ii. eapply H. auto. }
    { econs; ss. des. auto. }
  }
  { exists [(loc, tsw)]. esplits; ss.
    { ii. eapply H. auto. }
    { econs; ss. des. auto. }
  }
Qed.

Lemma write_not_to_mon P0 P1
      (LE: P0 <2= P1)
  :
    write_not_to P1 <1= write_not_to P0.
Proof.
  ii. unfold write_not_to in *. des_ifs; auto.
Qed.

Lemma traced_steps_finte_write_to (tr: Trace.t)
      (times: Loc.t -> Time.t -> Prop)
      (EVENTS: List.Forall (fun em => <<SAT: (wf_time_evt times) (snd em)>>) tr)
  :
    exists (l: list (Loc.t * Time.t)),
      (<<EVENTS: List.Forall (fun em => write_not_to (fun loc ts => ~ List.In (loc, ts) l) (snd em)) tr>>) /\
      (<<TIMES: List.Forall (fun locts => times (fst locts) (snd locts)) l>>).
Proof.
  ginduction tr.
  { i. inv EVENTS. exists []. esplits; eauto. }
  { i. inv EVENTS. exploit IHtr; eauto. i. des.
    exploit (@step_finte_write_to (snd a)); eauto. i. des.
    exists (l0 ++ l). esplits; eauto.
    { econs; eauto.
      { eapply write_not_to_mon; eauto. ii. eapply PR. eapply List.in_or_app; eauto. }
      { eapply List.Forall_impl; eauto. i. ss.
        eapply write_not_to_mon; eauto. ii. eapply PR. eapply List.in_or_app; eauto. }
    }
    { eapply Forall_app; eauto. }
  }
Qed.

Lemma reserve_write_to (times: Loc.t -> Time.t -> Prop)
      (DIVERGE: forall loc ts,
          exists ts',
            (<<TIMES: times loc ts'>>) /\
            (<<TS: Time.lt ts ts'>>))
      mem
      (MWF: memory_times_wf times mem)
      loc ts
      (TIMES: times loc ts)
  :
    (<<ALREADY: unattachable mem loc ts>>) \/
    (<<NEW: exists from mem',
        (<<TS: Time.lt ts from>>) /\
        (<<ADD: Memory.add mem loc ts from Message.reserve mem'>>) /\
        (<<TIMES: times loc from>>) /\
        (<<MWF: memory_times_wf times mem'>>)>>).
Proof.
  destruct (classic (unattachable mem loc ts)); auto. right.
  hexploit (@cell_elements_least
              (mem loc)
              (fun to => exists from msg,
                   (<<GET: Memory.get loc to mem = Some (from, msg)>>) /\
                   (<<TS: Time.lt ts from>>))).
  i. des.
  { hexploit (@Memory.add_exists mem loc ts from0 Message.reserve); ss.
    { ii. destruct (Time.le_lt_dec from2 ts).
      { eapply H. econs; eauto.
        inv LHS. inv RHS. ss. eapply TimeFacts.lt_le_lt; eauto. }
      { dup GET2. eapply LEAST in GET2.
        { exploit memory_get_to_mon.
          { eapply GET1. }
          { eapply GET0. }
          { inv LHS. inv RHS. ss. eapply TimeFacts.lt_le_lt; eauto. }
          i. timetac.
        }
        esplits; eauto.
      }
    }
    { econs. }
    i. des. esplits; eauto.
    { eapply MWF in GET0. des; auto. }
    { eapply MWF in GET0. des.
      ii. erewrite Memory.add_o in GET0; eauto. des_ifs.
      { ss. des; clarify. }
      { eapply MWF; eauto. }
    }
  }
  { hexploit (DIVERGE loc ts). i. des.
    hexploit (@Memory.add_exists mem loc ts ts' Message.reserve); ss.
    { ii. eapply EMPTY; eauto. esplits; eauto.
      destruct (Time.le_lt_dec from2 ts); auto. exfalso.
      eapply H. econs; eauto.
      inv LHS. inv RHS. ss. eapply TimeFacts.lt_le_lt; eauto. }
    { econs. }
    i. des. esplits; eauto.
    ii. erewrite Memory.add_o in GET; eauto. des_ifs.
    { ss. des; clarify. }
    { eapply MWF; eauto. }
  }
Qed.

Lemma reserve_write_tos times lang (th: Thread.t lang) tos
      (DIVERGE: forall loc ts,
          exists ts',
            (<<TIMES: times loc ts'>>) /\
            (<<TS: Time.lt ts ts'>>))
      (MWF: memory_times_wf times (Thread.memory th))
      (MLE: Memory.le (Local.promises (Thread.local th)) (Thread.memory th))
      (TIMES: List.Forall (fun locts => times (fst locts) (snd locts)) tos)
  :
    exists l tr prom' mem',
      (<<STEPS: Trace.steps tr th (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom') (Thread.sc th) mem')>>) /\
      (<<RESERVETRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_reserve /1\ wf_time_evt times) (snd em)>>) tr>>) /\
      (<<ADDEDPROM: reservations_added l (Local.promises (Thread.local th)) prom'>>) /\
      (<<ADDEDMEM: reservations_added l (Thread.memory th) mem'>>) /\
      (<<WRITETO: forall loc ts (IN: List.In (loc, ts) tos),
          unattachable mem' loc ts>>) /\
      (<<TIMES: List.Forall (fun locitv =>
                               times (fst locitv) (fst (snd locitv)) /\
                               times (fst locitv) (snd (snd locitv))) l>>)
.
Proof.
  ginduction tos; i; ss.
  { exists [], []. destruct th. destruct local. ss. esplits; eauto; ss.
    { econs. }
    { econs. }
  }
  { inv TIMES. exploit IHtos; eauto. i. des.
    exploit reserve_write_to.
    { eauto. }
    { eapply memory_times_wf_traced in STEPS; eauto.
      eapply List.Forall_impl; eauto. i. ss. des; auto. }
    { eauto. }
    i. ss. des.
    { exists l, tr. esplits; eauto. i. des; auto. clarify. }
    { exploit (@Memory.add_exists_le prom' mem'); eauto.
      { eapply trace_steps_promises_le in STEPS; eauto. }
      i. des.
      assert (PROM: Memory.promise prom' mem' (fst a) (snd a) from Message.reserve promises2 mem'0 Memory.op_kind_add).
      { econs; eauto. ss. }
      destruct th. esplits.
      { eapply Trace.steps_trans.
        { eauto. }
        { econs 2.
          { econs 1. econs; eauto. }
          { econs 1. }
          { ss. }
        }
      }
      { eapply Forall_app; eauto. econs; ss. }
      { ss. eapply reservations_added_trans.
        { eauto. }
        { econs; eauto. econs. }
      }
      { ss. eapply reservations_added_trans.
        { eauto. }
        { econs; eauto. econs. }
      }
      { i. erewrite add_unattachable; eauto. des; clarify.
        { right. splits; ss. refl. }
        { eauto. }
      }
      { eapply Forall_app; eauto. }
    }
  }
Qed.

Lemma reservations_added_non_covered l mem0 mem1
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (COVERED: covered loc ts mem0)
  :
    ~ intervals_sum l loc ts.
Proof.
  ginduction l; eauto. i. inv ADDED. ss. ii.
  des; clarify.
  { inv COVERED. eapply add_succeed_wf in ADD. des.
    eapply DISJOINT; eauto. }
  { eapply IHl; eauto. erewrite add_covered; eauto. }
Qed.

Lemma add_unattachable_disjoint mem1 mem0 loc from to msg
      (ADD: Memory.add mem0 loc from to msg mem1)
      loc0 ts0
      (UNATTACHABLE: unattachable mem0 loc0 ts0)
  :
    ~ (loc0 = loc /\ Time.le from ts0 /\ Time.lt ts0 to).
Proof.
  ii. des; subst. inv UNATTACHABLE.
  exploit add_succeed_wf; eauto. i. des.
  hexploit DISJOINT; eauto. i. eapply disjoint_equivalent2 in H. des; ss.
  { eapply TS1. eapply TimeFacts.le_lt_lt; eauto. }
  { eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
    { eapply TS0. } eapply TimeFacts.le_lt_lt.
    { instantiate (1:=ts0). unfold Time.join. des_ifs. }
    { unfold Time.meet. des_ifs. }
  }
Qed.

Lemma reservations_added_non_unattachable l mem0 mem1
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (UNATTACHABLE: unattachable mem0 loc ts)
  :
    ~ intervals_sum_left l loc ts.
Proof.
  ginduction l; eauto. i. inv ADDED. ss. ii.
  des; clarify.
  { exploit add_unattachable_disjoint; eauto. }
  { eapply IHl; eauto. erewrite add_unattachable; eauto. }
Qed.

Lemma reservations_added_unattachable l mem0 mem1
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (UNATTACHABLE: unattachable mem1 loc ts)
  :
    unattachable mem0 loc ts \/ intervals_sum_left l loc ts.
Proof.
  ginduction l; eauto. i.
  { inv ADDED. auto. }
  { i. inv ADDED. eapply IHl in TL; eauto. ss.
    erewrite add_unattachable in TL; eauto. des; auto. }
Qed.

Definition eventable (mem prom: Memory.t) (spaces: Loc.t -> Time.t -> Prop)
           (loc: Loc.t) (ts: Time.t): Prop :=
  concrete_promised mem loc ts \/
  covered loc ts prom \/
  spaces loc ts.

Definition eventable_below (mem prom: Memory.t) (spaces: Loc.t -> Time.t -> Prop)
           (loc: Loc.t) (ts: Time.t): Prop :=
  exists to, <<TIME: eventable mem prom spaces loc to>> /\ <<TS: Time.le ts to>>.

Lemma eventable_le_below mem0 prom0 mem1 prom1 spaces
      (INCR: eventable mem1 prom1 spaces <2= eventable mem0 prom0 spaces)
  :
    eventable_below mem1 prom1 spaces <2= eventable_below mem0 prom0 spaces.
Proof.
  ii. unfold eventable_below in *. des. esplits; eauto.
Qed.

Lemma event_in_concrete_or_writes_promise (spaces: Loc.t -> Time.t -> Prop)
      prom0 mem0 loc from to msg prom1 mem1 kind
      (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
      (NOTIN: if Memory.op_kind_is_cancel kind
              then True
              else (forall ts (ITV: Interval.mem (from, to) ts),
                       spaces loc ts \/ covered loc ts mem0))
      (CLOSED: Memory.closed mem0)
  :
    (<<INCR: eventable mem1 prom1 spaces <2= eventable mem0 prom0 spaces>>) /\
    (<<FROM: eventable_below mem0 prom0 spaces loc from>>) /\
    (<<TO: eventable_below mem0 prom0 spaces loc to>>).
Proof.
  unfold eventable. inv PROMISE.
  { exploit add_succeed_wf; try apply MEM; eauto. i. des.
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.add_o in GET; eauto. des_ifs.
        { ss. des; clarify. right. exploit NOTIN; eauto.
          { econs; eauto. refl. }
          i. des; auto. inv x. exfalso. eapply DISJOINT; eauto.
          econs; ss. refl.
        }
        { left. econs; eauto. }
      }
      { erewrite add_covered in PR; eauto. des; auto. subst.
        right. right. exploit NOTIN; eauto. i. des; auto.
        inv x. exfalso. eapply DISJOINT; eauto. }
    }
    { exists to. esplits; eauto.
      { right. right. exploit NOTIN; eauto.
        { econs; eauto. refl. }
        i. des; auto. inv x. exfalso. eapply DISJOINT; eauto.
        econs; ss. refl.
      }
      { left. auto. }
    }
    { exists to. esplits; eauto.
      { right. right. exploit NOTIN; eauto.
        { econs; eauto. refl. }
        i. des; auto. inv x. exfalso. eapply DISJOINT; eauto.
        econs; ss. refl.
      }
      { refl. }
    }
  }
  { exploit split_succeed_wf; try apply PROMISES; eauto. i. des.
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.split_o in GET; eauto. des_ifs.
        { ss. des; clarify. right. left. econs; eauto.
          econs; eauto. ss. left. auto. }
        { ss. des; clarify. right. left. econs; eauto.
          econs; eauto. ss. refl. }
        { left. econs; eauto. }
      }
      { erewrite split_covered in PR; eauto. }
    }
    { exists ts3. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. etrans; eauto. }
    }
    { exists ts3. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. auto. }
    }
  }
  { exploit lower_succeed_wf; try apply PROMISES; eauto. i. des.
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.lower_o in GET0; eauto. des_ifs.
        { ss. des; clarify. right. left. econs; eauto.
          econs; eauto. ss. refl. }
        { left. econs; eauto. }
      }
      { erewrite lower_covered in PR; eauto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. eauto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { refl. }
    }
  }
  { exploit Memory.remove_get0; try apply PROMISES; eauto. i. des.
    assert (TS: Time.lt from to).
    { exploit Memory.remove_get0; try apply MEM; eauto. i. des.
      inv CLOSED. apply memory_get_ts_strong in GET. des; auto.
      subst. erewrite INHABITED in GET1. ss. }
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.remove_o in GET1; eauto. des_ifs.
        left. econs; eauto. }
      { erewrite remove_covered in PR; eauto. des; auto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. eauto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { refl. }
    }
  }
Qed.

Lemma event_in_concrete_or_writes_write (spaces: Loc.t -> Time.t -> Prop)
      prom0 mem0 loc from to prom1 mem1 val released kind
      (PROMISE: Memory.write prom0 mem0 loc from to val released prom1 mem1 kind)
      (NOTIN: if Memory.op_kind_is_cancel kind
              then True
              else (forall ts (ITV: Interval.mem (from, to) ts),
                       spaces loc ts \/ covered loc ts mem0))
      (CLOSED: Memory.closed mem0)
  :
    (<<INCR: eventable mem1 prom1 spaces <2= eventable mem0 prom0 spaces>>) /\
    (<<FROM: eventable_below mem0 prom0 spaces loc from>>) /\
    (<<TO: eventable_below mem0 prom0 spaces loc to>>).
Proof.
  inv PROMISE.
  exploit event_in_concrete_or_writes_promise; eauto. i. des. esplits; eauto.
  i. eapply INCR. unfold eventable in *. des; auto.
  erewrite remove_covered in PR; eauto. des; auto.
Qed.

Lemma step_eventable_time lang (th0 th1: Thread.t lang) pf e
      (spaces: Loc.t -> Time.t -> Prop)
      (STEP: Thread.step pf e th0 th1)
      (WRITENOTIN: write_not_in (fun loc ts => ~ (spaces loc ts \/ covered loc ts (Thread.memory th0))) e)
      (CLOSED: Memory.closed (Thread.memory th0))
  :
    (<<INCR: eventable (Thread.memory th1) (Local.promises (Thread.local th1)) spaces <2= eventable (Thread.memory th0) (Local.promises (Thread.local th0)) spaces>>) /\
    (<<TIMES: tevent_map_weak
                (fun loc ts fts => ts = fts /\
                                   eventable_below (Thread.memory th0) (Local.promises (Thread.local th0)) spaces loc ts) e e>>).
Proof.
  inv STEP.
  { inv STEP0; ss. inv LOCAL.
    eapply event_in_concrete_or_writes_promise in PROMISE; ss.
    { des. splits; eauto. econs; eauto. }
    { des_ifs. ii. apply NNPP. eapply WRITENOTIN; eauto. }
  }
  { inv STEP0; ss. inv LOCAL; ss; eauto.
    { splits; auto. econs. }
    { inv LOCAL0. ss. splits; auto. econs; eauto. split; auto.
      exists ts. splits; ss.
      { left. econs; eauto. }
      { refl. }
    }
    { inv LOCAL0. eapply event_in_concrete_or_writes_write in WRITE; eauto.
      { des. splits; eauto. econs; eauto. }
      { des_ifs. ii. eapply NNPP. eauto. }
    }
    { inv LOCAL1. inv LOCAL2. eapply event_in_concrete_or_writes_write in WRITE; eauto.
      { des. splits; eauto. econs; eauto. }
      { des_ifs. ii. eapply NNPP. eauto. }
    }
    { inv LOCAL0. ss. splits; auto. econs; eauto. }
    { inv LOCAL0. ss. splits; auto. econs; eauto. }
    { inv LOCAL0. ss. splits; auto. econs; eauto. }
 }
Qed.

Lemma tevent_map_weak_mon (f0 f1: Loc.t -> Time.t -> Time.t -> Prop)
      (LE: f0 <3= f1)
  :
    tevent_map_weak f0 <2= tevent_map_weak f1.
Proof.
  i. inv PR; econs; eauto.
Qed.

Lemma traced_steps_eventable_time_normal lang (th0 th1: Thread.t lang) tr
      (spaces: Loc.t -> Time.t -> Prop)
      (STEPS: Trace.steps tr th0 th1)
      (WRITENOTIN: List.Forall (fun em => (write_not_in (fun loc ts => ~ (spaces loc ts \/ covered loc ts (Thread.memory th0))) /1\ (fun e => ~ ThreadEvent.is_cancel e)) (snd em)) tr)
      (MEM: Memory.closed (Thread.memory th0))
      (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
      (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
  :
    (<<INCR: eventable (Thread.memory th1) (Local.promises (Thread.local th1)) spaces <2= eventable (Thread.memory th0) (Local.promises (Thread.local th0)) spaces>>) /\
    (<<TIMES: List.Forall2
                (fun em fem =>
                   tevent_map_weak (fun loc ts fts => ts = fts /\ eventable_below (Thread.memory th0) (Local.promises (Thread.local th0)) spaces loc ts)
                                   (snd fem) (snd em)) tr tr>>).
Proof.
  ginduction STEPS.
  { i. splits; ss. }
  { i. subst. inv WRITENOTIN.
    exploit Thread.step_future; eauto. i. des.
    exploit IHSTEPS; eauto.
    { eapply List.Forall_impl; eauto.
      i. ss. des. splits; auto. eapply write_not_in_mon; eauto. i. ss.
      ii. eapply PR. des; eauto. right.
      eapply step_not_cancel_covered_increase; eauto. }
    i. des.
    hexploit step_eventable_time; eauto.
    i. des. esplits; eauto. econs; ss; eauto.
    eapply list_Forall2_impl; eauto.
    i. ss. eapply tevent_map_weak_mon; eauto.
    i. ss. des. subst. splits; auto.
    eapply eventable_le_below; eauto.
  }
Qed.

Lemma traced_steps_eventable_time_cancel lang (th0 th1: Thread.t lang) tr
      (spaces: Loc.t -> Time.t -> Prop)
      (STEPS: Trace.steps tr th0 th1)
      (WRITENOTIN: List.Forall (fun em => ThreadEvent.is_cancel (snd em)) tr)
      (MEM: Memory.closed (Thread.memory th0))
      (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
      (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
  :
    (<<INCR: eventable (Thread.memory th1) (Local.promises (Thread.local th1)) spaces <2= eventable (Thread.memory th0) (Local.promises (Thread.local th0)) spaces>>) /\
    (<<TIMES: List.Forall2
                (fun em fem =>
                   tevent_map_weak (fun loc ts fts => ts = fts /\ eventable_below (Thread.memory th0) (Local.promises (Thread.local th0)) spaces loc ts)
                                   (snd fem) (snd em)) tr tr>>).
Proof.
  ginduction STEPS.
  { i. splits; ss. }
  { i. subst. inv WRITENOTIN.
    exploit Thread.step_future; eauto. i. des.
    hexploit step_eventable_time; eauto.
    { instantiate (1:=spaces). destruct e; ss. des_ifs. }
    exploit IHSTEPS; eauto. i. des.
    splits; eauto. econs; eauto.
    eapply list_Forall2_impl; eauto.
    i. ss. eapply tevent_map_weak_mon; eauto.
    i. ss. des. subst. splits; auto.
    eapply eventable_le_below; eauto.
  }
Qed.

Lemma reservations_added_covered mem0 mem1 l
      (ADDED: reservations_added l mem0 mem1)
      loc ts
  :
    covered loc ts mem1 <-> (covered loc ts mem0 \/ intervals_sum l loc ts).
Proof.
  ginduction l; ss.
  { i. inv ADDED. split; i; des; ss; auto. }
  { i. inv ADDED. rewrite IHl; eauto.
    rewrite (@add_covered mem3 mem0); eauto. split; i; des; auto. }
Qed.

Lemma reservations_added_covered_rev mem0 mem1 l
      (ADDED: reservations_added l mem0 mem1)
      loc ts
  :
    covered loc ts mem0 <-> (covered loc ts mem1 /\ ~ intervals_sum l loc ts).
Proof.
  split; i.
  { split.
    { eapply reservations_added_covered; eauto. }
    { eapply reservations_added_non_covered; eauto. }
  }
  { des. eapply reservations_added_covered in H; eauto. des; ss. }
Qed.

Lemma can_reserve_all_needed times
      (DIVERGE: forall loc ts,
          exists ts',
            (<<TIMES: times loc ts'>>) /\
            (<<TS: Time.lt ts ts'>>))
      lang
      st0 st1 lc0 lc1 sc0 sc1 mem0 mem1 tr
      (MWF: memory_times_wf times mem0)
      (STEPS: Trace.steps tr (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk lang st1 lc1 sc1 mem1))
      (EVENTS: List.Forall (fun em => <<SAT: ((fun e => ~ ThreadEvent.is_cancel e) /1\ wf_time_evt times) (snd em)>>) tr)
      (MEM: Memory.closed mem0)
      (LOCAL: Local.wf lc0 mem0)
      (SC: Memory.closed_timemap sc0 mem0)
  :
    exists lc0' mem0' tr_reserve tr_cancel reserves,
      (<<RESERVESTEPS:
         Trace.steps tr_reserve (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk lang st0 lc0' sc0 mem0')>>) /\
      (<<RESERVETRACE:
         List.Forall (fun em => <<SAT: (ThreadEvent.is_reserve /1\ wf_time_evt times) (snd em)>>) tr_reserve>>) /\
      (<<CANCELTRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_cancel /1\ wf_time_evt times) (snd em)>>) tr_cancel>>) /\
      (<<RESERVEMEM: reservations_added reserves mem0 mem0'>>) /\
      (<<CAP:
         forall cap0'
                (MLE: Memory.le mem0' cap0'),
         exists cap0 cap1 ,
           (<<CANCELSTEPS:
              Trace.steps tr_cancel (Thread.mk lang st0 lc0' sc0 cap0') (Thread.mk lang st0 lc0 sc0 cap0)>>) /\
           (<<STEPS:
              Trace.steps tr (Thread.mk lang st0 lc0 sc0 cap0) (Thread.mk lang st1 lc1 sc1 cap1)>>) /\
           (<<RESERVEMEM: reservations_added reserves cap0 cap0'>>)>>) /\
      (<<TIMES: forall max
                       (MAX: concrete_promise_max_timemap mem0' (Local.promises lc0') max),
          List.Forall2
            (fun em fem =>
               tevent_map_weak (fun loc ts fts => ts = fts /\ Time.le ts (max loc))
                               (snd fem) (snd em)) (tr_cancel ++ tr) (tr_cancel ++ tr)>>)
.
Proof.
  exploit (@traced_steps_finte_write_to tr); eauto.
  { eapply List.Forall_impl; eauto. i. ss. des. eauto. }
  intros [tos ?]. des.
  exploit traced_steps_needed_spaces; eauto.
  i. des.
  exploit reserve_empty_intervals; eauto.
  { eapply LOCAL. }
  i. des. ss.
  assert (MLE: Memory.le prom' mem').
  { eapply trace_steps_promises_le in STEPS0; eauto. eapply LOCAL. }
  exploit reserve_write_tos.
  { eauto. }
  { eapply memory_times_wf_traced in STEPS0; eauto.
    eapply List.Forall_impl; eauto. i. ss. des. eauto.
  }
  { ss. }
  { eauto. }
  i. des. ss.
  assert (ADDEDPROMALL: reservations_added (l ++ l0) (Local.promises lc0) prom'0).
  { eapply reservations_added_trans; eauto. }
  assert (ADDEDMEMALL: reservations_added (l ++ l0) mem0 mem'0).
  { eapply reservations_added_trans; eauto. }
  hexploit cancel_reservations_added.
  { instantiate (1:=Local.mk (Local.tview lc0) prom'0). eapply ADDEDPROMALL. }
  { eapply Forall_app; eauto. }
  i. des.
  assert (CAP: forall cap0'
                      (MLE: Memory.le mem'0 cap0'),
             exists cap0 cap1,
               Trace.steps
                 tr2
                 (Thread.mk _ st0 {| Local.tview := Local.tview lc0; Local.promises := prom'0 |} sc0 cap0')
                 (Thread.mk _ st0 lc0 sc0 cap0) /\
               Trace.steps
                 tr
                 (Thread.mk _ st0 lc0 sc0 cap0)
                 (Thread.mk _ st1 lc1 sc1 cap1) /\
               (<<ADDED: reservations_added (l ++ l0) cap0 cap0'>>))
  .
  { i. ss. exploit (H0 st0 sc0 cap0').
    { etrans; eauto. eapply trace_steps_promises_le in STEPS1; eauto. }
    i. des.
    assert (MLE1: Memory.le mem0 mem'1).
    { eapply reservations_added_le_le.
      { eapply ADDEDMEMALL. }
      { eapply MLE0. }
      { eauto. }
    }
    hexploit traced_step_lifting.
    { eapply STEPS. }
    { eapply list_Forall_sum.
      { eapply list_Forall_sum.
        { eapply EVENTS. }
        { eapply EVENTS0. }
        { instantiate (1:=fun em => <<SAT: ((fun e => ~ ThreadEvent.is_cancel e) /1\ write_not_to (fun loc ts => ~ List.In (loc, ts) tos)) (snd em)>>).
          i. ss. des. splits; auto. }
      }
      { eapply WRITENOTIN. }
      i. ss. des. splits; eauto.
    }
    { eapply MLE1. }
    { i. destruct (classic (covered loc ts mem0)); auto. right.
      ii. des; ss. eapply reservations_added_non_covered in ADDEDMEM1; eauto.
      eapply ADDEDMEM1. erewrite intervals_sum_interval.
      erewrite intervals_sum_interval in H1. des. esplits; eauto.
      eapply List.in_or_app; eauto. }
    { i. destruct (classic (unattachable mem0 loc ts)); auto. right.
      ii. des; ss. eapply reservations_added_non_unattachable in ADDEDMEM1; eauto.
      eapply ADDEDMEM1. erewrite intervals_sum_left_interval.
      eapply WRITETO in H1. eapply reservations_added_unattachable in H1; eauto.
      des; ss. }
    { eauto. }
    { eauto. }
    { eauto. }
    i. des. exists mem'1, cap1.
    splits; eauto. destruct lc0. ss.
  }
  esplits.
  { eapply Trace.steps_trans.
    { eapply STEPS0. }
    { eapply STEPS1. }
  }
  { eapply Forall_app; eauto. }
  { eapply CANCELTRACE. }
  { eauto. }
  { i. exploit CAP; eauto. }
  { i. exploit (CAP mem'0).
    { refl. }
    i. des. ss.
    exploit Trace.steps_future; try apply STEPS0; eauto. i. des. ss.
    exploit Trace.steps_future; try apply STEPS1; eauto. i. des. ss.
    exploit Trace.steps_future; try apply x0; eauto. i. des. ss.
    exploit traced_steps_eventable_time_cancel; try apply x0; eauto; ss.
    { eapply List.Forall_impl; eauto. i. ss. des. splits; auto. }
    instantiate (1:=intervals_sum l). i. ss. des.
    assert (EVENTTIMES: forall loc ts
                               (EVENTABLE: eventable_below mem'0 prom'0 (intervals_sum l) loc ts),
               Time.le ts (max loc)).
    { i. unfold eventable_below in EVENTABLE. des. etrans; eauto.
      unfold eventable in TIME. des.
      { inv TIME. eapply MAX in GET. auto. }
      { inv TIME. eapply MAX in GET. inv ITV. ss. etrans; eauto. }
      { eapply reservations_added_covered in ADDEDPROM; eauto. des.
        exploit ADDEDPROM1.
        { right. eauto. }
        i. eapply reservations_added_covered in ADDEDPROM0; eauto. des.
        exploit ADDEDPROM2.
        { left. eauto. }
        i. inv x2. eapply MAX in GET. inv ITV. ss. etrans; eauto.
      }
    }
    eapply List.Forall2_app.
    { eapply list_Forall2_impl; eauto. i. ss.
      eapply tevent_map_weak_mon; eauto. i. ss. des. subst. splits; auto. }
    { exploit traced_steps_eventable_time_normal; try apply x1; eauto; ss.
      { instantiate (1:=intervals_sum l).
        eapply list_Forall_sum.
        { eapply EVENTS. }
        { eapply WRITENOTIN. }
        i. ss. des. splits; auto.
        eapply write_not_in_mon; eauto. i. ss. ii. eapply PR.
        apply or_comm in H. apply or_strengthen in H. des; auto. right.
        erewrite reservations_added_covered_rev; try apply ADDED; eauto.
        erewrite reservations_added_covered_rev in SAT; try apply ADDEDMEMALL; eauto.
      }
      { i. des. eapply list_Forall2_impl; eauto. i. ss.
        eapply tevent_map_weak_mon; eauto. i. ss. des. subst. splits; auto.
        eapply eventable_le_below in PR0; eauto. }
    }
  }
Qed.


(* Uniqueness of typing for concise syntax. *)

Require config.
Require Import config_tactics.
Require Import syntax.

Require concise_syntax.
Require Import tt.
Require ett ptt.
Require ptt2ett ett2ptt.
Require ptt_admissible.
Require ett_sanity ptt_sanity.
Require concise_inversion.
Require Import tactics config_tactics.

Section Uniqueness.

Context `{configReflection : config.Reflection}.
Context `{configSimpleProducts : config.SimpleProducts}.
Context `{configProdEta : config.ProdEta}.
Context `{configUniverses : config.Universes}.
Context `{configWithProp : config.WithProp}.
Context `{configId : config.IdentityTypes}.
Context `{configWithJ : config.WithJ}.
Context `{configEmpty : config.WithEmpty}.
Context `{configUnit : config.WithUnit}.
Context `{configBool : config.WithBool}.
Context `{configPi : config.WithPi}.

Local Existing Instance concise_syntax.Syntax.
Local Existing Instance concise_inversion.haveCtxExtendInversion.
Local Existing Instance concise_inversion.haveTyIdInversion.
Local Existing Instance concise_inversion.haveTyProdInversion.
Local Existing Instance concise_inversion.haveTySimProdInversion.

(* Auxiliary inversion lemmas. *)

Fixpoint eqctx_ctxextend_left G A D
         (H : ett.eqctx (ctxextend G A) D) {struct H} :
  { G' : context &
    { A' : type &
      (D = ctxextend G' A') * ett.eqctx G G' * ett.eqtype G A A'
    }
  }%type

with eqctx_ctxextend_right D G A
                           (H : ett.eqctx D (ctxextend G A)) {struct H} :
  { G' : context &
    { A' : type &
      (D = ctxextend G' A') * ett.eqctx G G' * ett.eqtype G A A'
    }
  }%type.
Proof.
  (**** left ****)
  - { inversion_clear H ; doConfig.

      (* CtxRefl *)
      - exists G, A. repeat split.
        + capply CtxRefl.
          eapply ptt2ett.sane_isctx.
          apply (concise_inversion.CtxExtendInversion G A).
          now eapply ett2ptt.sane_isctx.
        + capply EqTyRefl.
          eapply ptt2ett.sane_istype.
          apply (concise_inversion.CtxExtendInversion G A).
          now eapply ett2ptt.sane_isctx.

      (* CtxSym *)
      - destruct (eqctx_ctxextend_right _ _ _ X) as [G' [A' [[eq HG] HA]]].
        exists G', A'. repeat split ; assumption.

      (* CtxTrans *)
      - destruct (eqctx_ctxextend_left _ _ _ X2) as [G' [A' [[eq HG] HA]]].
        subst.
        destruct (eqctx_ctxextend_left _ _ _ X3) as [G'' [A'' [[eq' HG'] HA']]].
        exists G'', A''. repeat split.
        + assumption.
        + ceapply CtxTrans ; eassumption.
        + ceapply EqTyTrans.
          * eassumption.
          * ceapply EqTyCtxConv ; try eassumption.
            capply CtxSym ; assumption.

      (* EqCtxExtend *)
      - exists D0, B. repeat split ; assumption.

    }

  (**** right ****)
  - { inversion_clear H ; doConfig.

      (* CtxRefl *)
      - exists G, A. repeat split.
        + capply CtxRefl.
          eapply ptt2ett.sane_isctx.
          apply (concise_inversion.CtxExtendInversion G A).
          now eapply ett2ptt.sane_isctx.
        + capply EqTyRefl.
          eapply ptt2ett.sane_istype.
          apply (concise_inversion.CtxExtendInversion G A).
          now eapply ett2ptt.sane_isctx.

      (* CtxSym *)
      - destruct (eqctx_ctxextend_left _ _ _ X) as [G' [A' [[eq HG] HA]]].
        exists G', A'. repeat split ; assumption.

      (* CtxTrans *)
      - destruct (eqctx_ctxextend_right _ _ _ X3) as [G' [A' [[eq HG] HA]]].
        subst.
        destruct (eqctx_ctxextend_right _ _ _ X2) as [G'' [A'' [[eq' HG'] HA']]].
        exists G'', A''. repeat split.
        + assumption.
        + ceapply CtxTrans ; eassumption.
        + ceapply EqTyTrans.
          * eassumption.
          * ceapply EqTyCtxConv ; try eassumption.
            capply CtxSym ; assumption.

      (* EqCtxExtend *)
      - exists G0, A0. repeat split.
        + now capply CtxSym.
        + capply EqTySym.
          ceapply EqTyCtxConv ; eassumption.

    }

Defined.

Definition eqctx_ctxextend G A G' A'
         (H : ett.eqctx (ctxextend G A) (ctxextend G' A')) :
  (ett.eqctx G G' * ett.eqtype G A A')%type.
Proof.
  destruct (eqctx_ctxextend_left _ _ _ H) as [G'' [A'' [[eq HG] HA]]].
  inversion eq. subst.
  split ; assumption.
Defined.

(* It looks like we need to strengthen some inference
   rules, as follows: *)

Lemma substCtxConv' :
  forall G G' D sbs (E : ett.eqctx G' G),
    ett.issubst sbs G D -> ett.issubst sbs G' D.
Proof.
  intros G G' D sbs E H.
  ceapply SubstCtxConv.
  - eassumption.
  - now capply CtxSym.
  - capply CtxRefl.
    now apply (ett_sanity.sane_issubst sbs G D).
Defined.

(* Injectivity results *)

Axiom admit : forall {A}, A.
Tactic Notation "admit" := (exact admit).

Fixpoint injProd_left G A B T
         (H : ett.eqtype G (Prod A B) T) {struct H} :
  { A' : type &
    { B' : type &
      (T = Prod A' B') * ett.eqtype G A A' * ett.eqtype (ctxextend G A) B B'
    }
  }%type

with injProd_right G T A' B'
                   (H : ett.eqtype G T (Prod A' B')) {struct H} :
  { A : type &
    { B : type &
      (T = Prod A B) * ett.eqtype G A A' * ett.eqtype (ctxextend G A) B B'
    }
  }%type.
Proof.
  (** left **)
  - { inversion_clear H ; doConfig.

      - destruct (injProd_left _ _ _ _ X) as [A' [B' [[hT hA] hB]]].
        exists A', B'. repeat split.
        + assumption.
        + ceapply EqTyCtxConv ; ehyp.
        + ceapply EqTyCtxConv.
          * ehyp.
          * capply EqCtxExtend.
            -- assumption.
            -- ceapply EqTyTrans.
               ++ eassumption.
               ++ ceapply EqTySym. assumption.

      - exists A, B. repeat split.
        + capply EqTyRefl.
          eapply ptt2ett.sane_istype.
          apply (concise_inversion.TyProdInversion G A B). hyp.
        + capply EqTyRefl.
          eapply ptt2ett.sane_istype.
          apply (concise_inversion.TyProdInversion G A B). hyp.

      - destruct (injProd_right G T A B X) as [A' [B' [[hT hA] hB]]].
        exists A', B'. repeat split.
        + assumption.
        + capply EqTySym. assumption.
        + capply EqTySym. ceapply EqTyCtxConv.
          * ehyp.
          * capply EqCtxExtend.
            -- capply CtxRefl. tt_sane.
            -- hyp.

      - destruct (injProd_left _ _ _ _ X) as [A' [B' [[hT hA] hB]]]. subst.
        destruct (injProd_left _ _ _ _ X0) as [A'' [B'' [[hT' hA'] hB']]].
        subst.
        exists A', B'. repeat split.
        + admit.
        + admit.
        + admit.

      - admit.

      - admit.

      - admit.

      - admit.

      - admit.
    }

  - admit.

Defined.

Fixpoint injProd G A A' B B' (H : ett.eqtype G (Prod A B) (Prod A' B')) {struct H} :
  ett.eqtype G A A' * ett.eqtype (ctxextend G A) B B'.
Proof.
  destruct (injProd_left _ _ _ _ H) as [A'' [B'' [[eq hA] hB]]].
  inversion eq. subst.
  split ; assumption.
Defined.

(* Tactics for dealing with the conversion cases. *)

Ltac doTyConv unique_term' :=
  ceapply EqTyTrans ;
  [ eapply unique_term' ;
    [ ehyp
    | hyp ]
  | ceapply EqTyCtxConv ;
    [ ehyp
    | hyp ] ].

Ltac doCtxConv D' unique_term' :=
  eapply unique_term' ;
  [ ehyp
  | (config apply @CtxTrans with (D := D')) ; hyp ].

Ltac doSubstConv unique_subst' :=
  ceapply CtxTrans ; [
    eapply unique_subst' ; [
      ehyp
    | ceapply CtxTrans ; [
        ehyp
      | capply CtxSym ; hyp
      ]
    ]
  | hyp
  ].

(* The version of the theorem that allows variation of the context. *)

Fixpoint unique_term_ctx G u A (H1 : ptt.isterm G u A) {struct H1}:
  forall B D,
    ptt.isterm D u B ->
    ptt.eqctx D G ->
    ett.eqtype G A B

with unique_subst G D1 sbs (H1 : ptt.issubst sbs G D1) {struct H1}:
  forall G' D2 (H2 : ptt.issubst sbs G' D2) (H3 : ptt.eqctx G G'),
    ett.eqctx D1 D2.

Proof.
  (* unique_term *)
  { destruct H1 ; doConfig ;
    simple refine (fix unique_term'' B' D' H2' H3' {struct H2'} := _) ;
    pose (
      unique_term' B' D' H1 H2 :=
        unique_term'' B' D'
                      H1
                      (ett2ptt.sane_eqctx D' _ H2)
    ) ;
    pose (
      unique_term_ctx' G u A H1 B D H2 H3 :=
        unique_term_ctx G u A
                        H1
                        B D
                        (ett2ptt.sane_isterm D u B H2)
                        (ett2ptt.sane_eqctx D G H3)
    ) ;
    pose (
      unique_subst' G D1 sbs H1 G' D2 H2 H3 :=
        unique_subst G D1 sbs
                     H1
                     G' D2
                     (ett2ptt.sane_issubst sbs G' D2 H2)
                     (ett2ptt.sane_eqctx G G' H3)
    ).

    (* H1: TermTyConv *)
    - {
        config apply @EqTyTrans with (B := A).
        + capply EqTySym. hyp.
        + eapply (unique_term_ctx G u A) ; eassumption.
      }

    (* TermCtxConv *)
    - {
        ceapply EqTyCtxConv.
        - eapply unique_term_ctx'.
          + ehyp.
          + ehyp.
          + config apply @CtxTrans with (D := D).
            * hyp.
            * capply CtxSym. hyp.
        - hyp.
      }

    (* TermSubst *)
    - { inversion_clear H2' ; doConfig.
        - doTyConv unique_term'.
        - doCtxConv D' unique_term'.

        - ceapply CongTySubst.
          + ceapply SubstRefl. ehyp.
          + eapply (unique_term_ctx' _ u).
            * hyp.
            * ehyp.
            * { capply CtxSym.
                apply (@unique_subst' G _ sbs) with (G' := G).
                - hyp.
                - eapply substCtxConv'.
                  + ceapply CtxSym.
                    ehyp.
                  + hyp.
                - capply CtxRefl. hyp.
              }
      }

    (* TermVarZero *)
    - { inversion H2' ; doConfig.
        - doTyConv unique_term'.
        - doCtxConv D' unique_term'.

        - { assert (L : ett.eqctx (ctxextend G0 A0) (ctxextend G A)).
            - rewrite H. hyp.
            - destruct (eqctx_ctxextend _ _ _ _  L) as [E M].
              ceapply CongTySubst.
              + ceapply CongSubstWeak.
                capply EqTySym.
                ceapply EqTyCtxConv ; ehyp.
              + capply EqTySym.
                ceapply EqTyCtxConv ; ehyp.
          }
      }

    (* TermVarSucc *)
      - { inversion H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { assert (L : ett.eqctx (ctxextend G0 B0) (ctxextend G B)).
              - rewrite H. hyp.
              - destruct (eqctx_ctxextend _ _ _ _  L) as [E M].
                ceapply CongTySubst.
                + ceapply CongSubstWeak.
                  capply EqTySym.
                  ceapply EqTyCtxConv ; ehyp.
                + eapply (unique_term_ctx' _ (var k)).
                  * hyp.
                  * ehyp.
                  * hyp.
            }
        }

      (* TermAbs *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - capply CongProd.
            + capply EqTyRefl. hyp.
            + eapply (unique_term_ctx' _ u).
              * hyp.
              * ehyp.
              * capply EqCtxExtend.
                -- hyp.
                -- capply EqTyRefl. hyp.
        }

      (* TermApp *)
      - { inversion_clear H2'.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { ceapply CongTySubst.
              - ceapply CongSubstZero.
                + eapply (unique_term_ctx' _ v) ; ehyp.
                + ceapply EqRefl. hyp.
              - admit.
            }
        }

      (* TermRefl *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - config apply EqTyRefl, TyId.
            + hyp.
            + hyp.
        }

      (* TermJ *)
      - { inversion_clear H2'.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { ceapply CongTySubst.
              - ceapply CongSubstZero.
                + ceapply EqTyRefl.
                  capply TyId ; hyp.
                + ceapply EqRefl. hyp.
              - ceapply CongTySubst.
                + { ceapply EqSubstCtxConv.
                    - ceapply CongSubstShift.
                      + ceapply CongSubstZero.
                        * ceapply EqTyRefl. ehyp.
                        * ceapply EqRefl. hyp.
                      + ceapply CongId.
                        * { ceapply CongTySubst.
                            - ceapply CongSubstWeak.
                              ceapply EqTyRefl. hyp.
                            - ceapply EqTyRefl. hyp.
                          }
                        * { ceapply CongTermSubst.
                            - ceapply CongSubstWeak.
                              ceapply EqTyRefl. hyp.
                            - ceapply EqRefl. hyp.
                          }
                        * ceapply EqRefl. ceapply TermVarZero. hyp.
                    - ceapply EqCtxExtend.
                      + hyp.
                      + { ceapply EqTyTrans.
                          - ceapply EqTySubstId.
                            + ceapply SubstZero. hyp.
                            + ceapply TermSubst.
                              * ceapply SubstWeak. hyp.
                              * hyp.
                            + ceapply TermVarZero. hyp.
                          - ceapply CongId.
                            + ceapply EqTySym.
                              eapply ptt2ett.sane_eqtype.
                              eapply ptt_admissible.EqTyWeakZero ; hyp.
                            + eapply ptt2ett.sane_eqterm.
                              { eapply ptt_admissible.EqSubstWeakZero ; try hyp.
                                - eapply ett2ptt.sane_istype.
                                  ceapply TySubst.
                                  + ceapply SubstZero. hyp.
                                  + ceapply TySubst.
                                    * ceapply SubstWeak. hyp.
                                    * hyp.
                                - eapply ett2ptt.sane_isterm.
                                  ceapply TermTyConv.
                                  + ehyp.
                                  + eapply ptt2ett.sane_eqtype.
                                    eapply ptt_admissible.EqTyWeakZero ; hyp.
                              }
                            + { ceapply EqTyConv.
                                - ceapply EqSubstZeroZero. hyp.
                                - eapply ptt2ett.sane_eqtype.
                                  eapply ptt_admissible.EqTyWeakZero ; hyp.
                              }
                        }
                    - ceapply CtxRefl.
                      capply CtxExtend.
                      capply TyId.
                      + ceapply TermSubst.
                        * ceapply SubstWeak. hyp.
                        * hyp.
                      + ceapply TermVarZero. hyp.
                  }
                + ceapply EqTyRefl. hyp.
            }
        }

      (* TermExfalso *)
      - { inversion_clear H2'.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              ceapply TyCtxConv.
              + ehyp.
              + hyp.
            }
        }

      (* TermUnit *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - (config apply EqTyRefl, TyUnit) ; hyp.
        }

      (* TermTrue *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - (config apply EqTyRefl, TyBool) ; hyp.
        }

      (* TermFalse *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - (config apply EqTyRefl, TyBool) ; hyp.
        }

      (* TermCond *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { ceapply CongTySubst.
              - ceapply CongSubstZero.
                + ceapply EqTyRefl. capply TyBool. hyp.
                + ceapply EqRefl. hyp.
              - ceapply EqTyRefl. hyp.
            }
        }

      (* TermPair *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TySimProd.
              - hyp.
              - hyp.
            }
        }

      (* TermProjOne *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              ceapply TyCtxConv.
              - ehyp.
              - hyp.
            }
        }

      (* TermProjTwo *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              ceapply TyCtxConv.
              - ehyp.
              - hyp.
            }
        }

      (* TermUniProd *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniProdProp *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniId *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniEmpty *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniUnit *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniBool *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniSimProd *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniSimProdProp *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniUni *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }

      (* TermUniProp *)
      - { inversion_clear H2' ; doConfig.
          - doTyConv unique_term'.
          - doCtxConv D' unique_term'.

          - { capply EqTyRefl.
              capply TyUni.
              hyp.
            }
        }
  }

 (* unique_subst *)
 { destruct H1 ;
   simple refine (fix unique_subst'' G' D2' H2' H3' {struct H2'} := _) ;
   pose (
     unique_subst' G' D2' H2' H3' :=
       unique_subst'' G' D2' H2'
                      (ett2ptt.sane_eqctx _ G' H3')
   ).

   (* H1: SubstZero *)
   - { inversion_clear H2'.
       - capply EqCtxExtend.
         + hyp.
         + capply EqTyRefl. hyp.
       - doSubstConv unique_subst'.
     }

   (* H1: SubstWeak *)
   - { inversion H2'; doConfig.
       - rewrite <- H1 in H3'.
         destruct (eqctx_ctxextend G A G0 A).
         + hyp.
         + subst. hyp.
       - doSubstConv unique_subst'.
     }

   (* H1: SubstShift *)
   - { inversion H2'; doConfig.
       - rewrite <- H3 in H3'.
         destruct (eqctx_ctxextend G (Subst A sbs) G0 (Subst A sbs)).
         + hyp.
         + capply EqCtxExtend.
           * apply (@unique_subst G _ sbs) with (G'0 := G).
             -- hyp.
             -- pex. ceapply SubstCtxConv.
                ++ ehyp.
                ++ ceapply CtxSym. hyp.
                ++ capply CtxRefl. hyp.
             -- pex. capply CtxRefl. hyp.
           * capply EqTyRefl. hyp.
       - doSubstConv unique_subst'.
     }

   (* H1: SubstId *)
   - { inversion H2'; doConfig.
       - rewrite <- H1. hyp.
       - doSubstConv unique_subst'.
     }

   (* H1: SubstComp *)
   - { inversion_clear H2'.
       - eapply (unique_subst _ _ _ H1_0).
         + ehyp.
         + eapply ett2ptt.sane_eqctx.
           eapply (unique_subst _ _ _ H1_).
           * ehyp.
           * hyp.
       - doSubstConv unique_subst'.
     }

   (* H1: SubstCtxConv *)
   - config eapply @CtxTrans with (D := D1).
     + ceapply CtxSym. hyp.
     + eapply unique_subst.
       * ehyp.
       * ehyp.
       * capply ett2ptt.sane_eqctx.
         (config eapply @CtxTrans with (D := G2)) ; hyp.

 }

Defined.

(* The main theorem as it will probably be used. *)
Corollary unique_term {G A B u} :
  ptt.isterm G u A ->
  ptt.isterm G u B ->
  ett.eqtype G A B.

Proof.
  intros H1 H2.
  eapply unique_term_ctx.
  - eassumption.
  - eassumption.
  - apply CtxRefl. hyps.
Defined.

End Uniqueness.


(* Some issues with polymorphic inductive types *)

(* 1- upper constraints with respect to non polymorphic inductive types *)

Unset Elimination Schemes.
Definition Ty := Type (* Top.1 *).

Inductive Q (A:Type (* Top.2 *)) : Prop := q : A -> Q A.
Inductive T (B:Type (* Top.3 *)) := t : B -> Q (T B) -> T B.
(* ajoute Top.4 <= Top.2 inutilement:
   4 est l'univers utilisé dans le calcul du type polymorphe de T *)
Definition C := T Ty.
(* ajoute Top.1 < Top.3 :
   Top.3 jour le rôle de pivot pour propager les contraintes supérieures qu'on
   a sur l'argument B de T: Top.3 sera réutilisé plus tard comme majorant
   des arguments effectifs de T, propageant à cette occasion les contraintes
   supérieures sur Top.3 *)

(* We need either that Q is polymorphic on A (though it is in Type) or
   that the constraint Top.1 < Top.2 is set (and it is not set!) *)

(* 2- upper constraints with respect to unfoldable constants *)

Definition f (A:Type (* Top.1 *)) := True.
Inductive R := r : f R -> R.
(* ajoute Top.3 <= Top.1 inutilement:
   Top.3 est l'univers utilisé dans le calcul du type polymorphe de R *)

(* mais il manque la contrainte que l'univers de R est plus petit que Top.1
   ce qui l'empêcherait en fait d'être vraiment polymorphe *)

(* 3- constraints with respect to global constants *)

Inductive S (A:Ty) := s : A -> S A.

(* Q est considéré polymorphique vis à vis de A alors que le type de A
   n'est pas une variable mais un univers déjà existant *)

(* Malgré tout la contrainte Ty < Ty est ajoutée (car Ty est vu comme
   un pivot pour propager les contraintes sur le type A, comme si Q était
   vraiment polymorphique, ce qu'il n'est pas parce que Ty est une
   constante). Et heureusement qu'elle est ajouté car elle évite de
   pouvoir typer "Q Ty" *)


(*********************************************************************************************************************************)
(* ProgrammingLanguageFlattening                                                                                *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import Categories_ch1_3.
Require Import InitialTerminal_ch2_2.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import ProductCategories_ch1_6_1.
Require Import OppositeCategories_ch1_6_2.
Require Import Enrichment_ch2_8.
Require Import Subcategories_ch7_1.
Require Import NaturalTransformations_ch7_4.
Require Import NaturalIsomorphisms_ch7_5.
Require Import BinoidalCategories.
Require Import PreMonoidalCategories.
Require Import MonoidalCategories_ch7_8.
Require Import Coherence_ch7_8.
Require Import Enrichment_ch2_8.
Require Import RepresentableStructure_ch7_2.
Require Import FunctorCategories_ch7_7.

Require Import Reification.
Require Import NaturalDeduction.
Require Import NaturalDeductionCategory.
Require Import GeneralizedArrow.
Require Import ProgrammingLanguage.
Require Import ProgrammingLanguageReification.
Require Import SectionRetract_ch2_4.
Require Import GeneralizedArrowFromReification.
Require Import Enrichments.
Require Import ReificationsAndGeneralizedArrows.

Section Flattening.

  Context `(Guest:ProgrammingLanguage) `(Host :ProgrammingLanguage).
  Context (GuestHost:TwoLevelLanguage Guest Host).

  Definition FlatObject (x:TypesL Host) :=
    forall y1 y2, not ((reification_r_obj GuestHost y1 y2)=x).

  Instance FlatSubCategory : FullSubcategory (TypesL Host) FlatObject.

    Context  (F:RetractionOfCategories (TypesL Host) (FullSubCategoriesAreCategories FlatSubCategory)).

    Definition FlatteningOfReification HostMonic HostMonoidal :=
      (ga_functor
        (@garrow_from_reification
          (TypesEnrichedInJudgments Guest)
          (TypesEnrichedInJudgments Host)
          HostMonic HostMonoidal GuestHost))
        >>>> F.

    Lemma FlatteningIsNotDestructive HostMonic HostMonoidal :
      FlatteningOfReification HostMonic HostMonoidal >>>> retraction_retraction F >>>> HomFunctor _ []
      ≃ (reification_rstar GuestHost).
      apply if_inv.
      set (@roundtrip_reification_to_reification (TypesEnrichedInJudgments Guest) (TypesEnrichedInJudgments Host)
        HostMonic HostMonoidal GuestHost) as q.
      unfold mf_F in *; simpl in *.
      eapply if_comp.
      apply q.
      clear q.
      unfold mf_F; simpl.
      unfold pmon_I.
      apply (if_respects
        (garrow_functor (TypesEnrichedInJudgments Guest) HostMonic HostMonoidal GuestHost)
        (FlatteningOfReification HostMonic HostMonoidal >>>> retraction_retraction F)
        (HomFunctor (TypesL Host) [])
        (HomFunctor (TypesL Host) [])); [ idtac | apply (if_id _) ].
      unfold FlatteningOfReification.
      unfold mf_F; simpl.
      apply if_inv.
      eapply if_comp.
      apply (if_associativity (garrow_functor (TypesEnrichedInJudgments Guest) HostMonic HostMonoidal GuestHost) F
               (retraction_retraction F)).
      eapply if_comp; [ idtac | apply if_right_identity ].
      apply (if_respects
        (garrow_functor (TypesEnrichedInJudgments Guest) HostMonic HostMonoidal GuestHost)
        (garrow_functor (TypesEnrichedInJudgments Guest) HostMonic HostMonoidal GuestHost)
        (F >>>> retraction_retraction F)
        (functor_id _)).
      apply (if_id _).
      apply retraction_composes.
      Qed.

End Flattening.


From Equations Require Import Equations.
Require Import Equations.Prop.Subterm.

Require Import Psatz.

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Export SystemFR.TOpenTClose.
Require Export SystemFR.OpenTOpen.
Require Export SystemFR.StrictPositivity.
Require Export SystemFR.NoTypeFVarLemmas.
Require Export SystemFR.ReducibilityUnused.

Opaque makeFresh.
Opaque PeanoNat.Nat.eq_dec.
Opaque reducible_values.
Opaque strictly_positive.

Definition non_empty ρ A := exists v, [ ρ ⊨ v : A ]v.

Lemma instantiate_non_empty:
  forall ρ A,
    non_empty ρ A ->
    exists a, [ ρ ⊨ a : A ]v.
Proof.
  unfold non_empty; steps; eauto.
Qed.

Ltac instantiate_non_empty :=
  match goal with
  | H: non_empty ?ρ ?A |- _ =>
    poseNew (Mark (ρ,A) "instantiate_non_empty");
    pose proof (instantiate_non_empty _ _ H)
  end.

Lemma non_empty_extend:
  forall ρ A x RC,
    non_empty ρ A ->
    reducibility_candidate RC ->
    valid_interpretation ρ ->
    ~(x ∈ pfv A type_var) ->
    non_empty ((x, RC) :: ρ) A.
Proof.
  unfold non_empty; repeat step || exists v || apply reducible_unused2.
Qed.

Lemma strictly_positive_open_aux:
  forall n T vars rep k,
    type_nodes T < n ->
    is_erased_type T ->
    is_erased_term rep ->
    strictly_positive T vars ->
    strictly_positive (open k T rep) vars.
Proof.
  induction n; destruct T; repeat step || simp_spos || apply no_type_fvar_open || apply IHn ;
    try lia;
    try solve [ left; repeat step || apply no_type_fvar_open ];
    try solve [ right; eexists; eauto; repeat step || apply no_type_fvar_open ].

  right. exists X; repeat step || fv_open || list_utils || rewrite is_erased_term_tfv in * by steps.
  rewrite <- open_topen;
    repeat step || apply IHn || autorewrite with bsize in * || apply is_erased_type_topen;
    eauto with twf wf lia.
Qed.

Lemma strictly_positive_open:
  forall T vars rep k,
    is_erased_type T ->
    is_erased_term rep ->
    strictly_positive T vars ->
    strictly_positive (open k T rep) vars.
Proof.
  eauto using strictly_positive_open_aux.
Qed.

Lemma push_all_cons:
  forall X (RC: tree -> Prop) ρ (P: tree -> Prop),
    (X, fun v => forall a, P a -> RC v) :: push_all P ρ = push_all P ((X, fun a => RC) :: ρ).
Proof.
  steps.
Qed.

Lemma push_is_candidate:
  forall (ρ : interpretation) (A a : tree) (RC : tree -> Prop),
    reducibility_candidate RC ->
    [ ρ ⊨ a : A ]v ->
    reducibility_candidate (fun v : tree => [ ρ ⊨ a : A ]v -> RC v).
Proof.
  repeat step || unfold non_empty in * || unfold reducibility_candidate in * || instantiate_any;
    eauto with fv wf.
Qed.

Lemma push_all_is_candidate:
  forall (ρ : interpretation) (A : tree) (RC : tree -> Prop),
    reducibility_candidate RC ->
    non_empty ρ A ->
    reducibility_candidate (fun v : tree => forall a, [ ρ ⊨ a : A ]v -> RC v).
Proof.
  repeat step || unfold non_empty in * || unfold reducibility_candidate in * || instantiate_any;
    eauto with fv wf.
Qed.

Ltac find_exists2 :=
  match goal with
  | H1: [ ?ρ ⊨ ?a : ?T1 ]v,
    H2: [ ?ρ ⊨ ?v : open 0 ?T2 ?a ]v
    |- _ =>
    exists a
  end.

Lemma no_type_fvar_strictly_positive:
  forall T vars,
    is_erased_type T ->
    no_type_fvar T vars ->
    strictly_positive T vars.
Proof.
  induction T; repeat step || simp_spos || destruct_tag || unfold no_type_fvar in * || apply_any || left;
    try solve [ eapply_any; eauto; repeat step || list_utils ].
Qed.

Ltac t_red_is_val :=
  eapply red_is_val; eauto;
    repeat step || apply valid_interpretation_append || eapply valid_interpretation_one ||
    eauto with b_valid_interp; steps;
    eauto with apply_any.

#[export]
Hint Extern 50 => solve [ t_red_is_val ]: b_red_is_val.

Lemma strictly_positive_rename_aux:
  forall n T T' vars vars' rel,
    type_nodes T < n ->
    strictly_positive T vars ->
    equal_with_relation type_var rel T T' ->
    similar_sets rel vars vars' ->
    strictly_positive T' vars'.
Proof.
  induction n;
    try solve [ intros; lia ];
    destruct T; inversion 3;
    repeat match goal with
           | _ => step || simp_spos || destruct_tag
           | H1: equal_with_relation _ ?rel ?T ?T',
             H2: strictly_positive ?T ?vars |-
               strictly_positive ?T' ?vars' =>
             apply IHn with T vars rel
            end;
    eauto using no_type_fvar_rename;
    try lia.

  right.
  exists (makeFresh ((X :: nil) :: pfv Ts' type_var :: nil));
    repeat step; try finisher.

  match goal with
  | H1: equal_with_relation _ ?rel _ _,
    H2: strictly_positive ?T (?X :: nil) |-
      strictly_positive (topen 0 ?T' (fvar ?M type_var)) ?vars' =>
    apply IHn with T (X :: nil) ((X,M) :: rel)
  end;
    repeat unfold similar_sets || step || autorewrite with bsize in * || apply equal_with_relation_topen;
      try lia;
      try finisher.
Qed.

Lemma strictly_positive_rename:
  forall T T' vars vars' rel,
    strictly_positive T vars ->
    equal_with_relation type_var rel T T' ->
    similar_sets rel vars vars' ->
    strictly_positive T' vars'.
Proof.
  eauto using strictly_positive_rename_aux.
Qed.

Lemma no_type_fvar_swap:
  forall T vars i j,
    no_type_fvar T vars ->
    no_type_fvar (swap_type_holes T i j) vars.
Proof.
  unfold no_type_fvar; repeat step || rewrite pfv_swap_type_holes in *; eauto.
Qed.

Lemma strictly_positive_swap_aux:
  forall n T vars i j,
    type_nodes T < n ->
    strictly_positive T vars ->
    strictly_positive (swap_type_holes T i j) vars.
Proof.
  induction n; destruct T; repeat step || simp_spos || apply_any;
    try lia;
    eauto using no_type_fvar_swap.
  right; exists X; repeat step || rewrite pfv_swap_type_holes in *.
  rewrite topen_swap2; steps.
  apply IHn; repeat step || autorewrite with bsize in *; try lia.
Qed.

Lemma strictly_positive_swap:
  forall T vars i j,
    strictly_positive T vars ->
    strictly_positive (swap_type_holes T i j) vars.
Proof.
  eauto using strictly_positive_swap_aux.
Qed.

Lemma strictly_positive_topen_aux:
  forall n T vars k X,
    type_nodes T < n ->
    strictly_positive T vars ->
    ~(X ∈ vars) ->
    strictly_positive (topen k T (fvar X type_var)) vars.
Proof.
  induction n; destruct T; repeat step || simp_spos || apply IHn;
    eauto using no_type_fvar_in_topen;
    try lia.
  right; exists (makeFresh ((X0 :: nil) :: (X :: nil) :: pfv T3 type_var :: pfv (topen (S k) T3 (fvar X type_var)) type_var :: nil)); steps; try finisher.

  rewrite open_swap; repeat step.
  apply IHn; repeat step || autorewrite with bsize in *;
    try lia;
    try finisher.
  rewrite topen_swap; steps.
  apply strictly_positive_swap.
  match goal with
  | H2: strictly_positive (topen 0 ?T (fvar ?X type_var)) (?X :: nil) |-
      strictly_positive (topen 0 ?T (fvar ?M type_var)) (?M :: nil) =>
    apply strictly_positive_rename with (topen 0 T (fvar X type_var)) (X :: nil) ((X,M) :: idrel (pfv T type_var))
  end;
    unfold similar_sets;
    repeat step || apply equal_with_relation_topen;
    try finisher;
    eauto using equal_with_relation_refl2;
    eauto using equal_with_idrel.
Qed.

Lemma support_push_one:
  forall ρ a,
    support (push_one a ρ) = support ρ.
Proof.
  unfold push_one; repeat step || rewrite support_map_values.
Qed.

Lemma support_push_all:
  forall ρ P,
    support (push_all P ρ) = support ρ.
Proof.
  unfold push_all; repeat step || rewrite support_map_values.
Qed.

Lemma strictly_positive_topen:
  forall T vars k X,
    strictly_positive T vars ->
    ~(X ∈ vars) ->
    strictly_positive (topen k T (fvar X type_var)) vars.
Proof.
  eauto using strictly_positive_topen_aux.
Qed.

Definition pre_interpretation := list (nat * (tree -> tree -> Prop)).

Fixpoint forall_implies (P: tree -> Prop) (pre_ρ: pre_interpretation) (ρ: interpretation) :=
  match pre_ρ, ρ with
  | nil, nil => True
  | (X,pre_rc) :: pre_ρ', (Y,rc) :: ρ' =>
      X = Y /\
      forall_implies P pre_ρ' ρ' /\
      forall (v: tree), (forall a, P a -> pre_rc a v) -> rc v
  | _, _ => False
  end.

Lemma forall_implies_apply:
  forall P pre_ρ ρ X pre_rc rc v,
    forall_implies P pre_ρ ρ ->
    lookup PeanoNat.Nat.eq_dec pre_ρ X = Some pre_rc ->
    lookup PeanoNat.Nat.eq_dec ρ X = Some rc ->
    (forall a, P a -> pre_rc a v) ->
    rc v.
Proof.
  induction pre_ρ; destruct ρ; repeat step || eapply_any.
Qed.

Ltac t_forall_implies_apply :=
  match goal with
  | H1: forall_implies ?P ?pre_ρ ?ρ,
    H2: lookup _ ?pre_ρ ?X = Some ?prc,
    H3: lookup _ ?ρ ?X = Some ?rc |- ?rc ?v =>
    apply (forall_implies_apply _ _ _ _ _ _ _ H1 H2 H3)
  end.

Lemma forall_implies_support:
  forall P pre_ρ ρ,
    forall_implies P pre_ρ ρ ->
    support pre_ρ = support ρ.
Proof.
  induction pre_ρ; destruct ρ; repeat step || f_equal.
Qed.

Ltac t_forall_implies_support :=
  match goal with
  | H: forall_implies ?P ?pre_ρ ?ρ |- _ =>
    poseNew (Mark (pre_ρ,ρ) "forall_implies_suppoft");
    pose proof (forall_implies_support _ _ _ H)
  end.

Lemma forall_implies_equiv:
  forall P1 P2 pre_ρ ρ,
    forall_implies P1 pre_ρ ρ ->
    (forall x, P1 x <-> P2 x) ->
    forall_implies P2 pre_ρ ρ.
Proof.
  induction pre_ρ; destruct ρ; steps; eauto with eapply_any.
Qed.

Ltac t_forall_implies_equiv :=
  match goal with
  | H1: forall_implies ?P1 ?pre_ρ ?ρ |- forall_implies _ ?pre_ρ ?ρ =>
      apply forall_implies_equiv with P1
  end.

Lemma strictly_positive_append_aux:
  forall n T vars1 vars2,
    type_nodes T < n ->
    strictly_positive T vars1 ->
    strictly_positive T vars2 ->
    strictly_positive T (vars1 ++ vars2).
Proof.
  induction n; destruct T;
    repeat lia || step || destruct_tag || simp_spos || apply_any;
      eauto using no_type_fvar_append.
Qed.

Lemma strictly_positive_append:
  forall T vars1 vars2,
    strictly_positive T vars1 ->
    strictly_positive T vars2 ->
    strictly_positive T (vars1 ++ vars2).
Proof.
  eauto using strictly_positive_append_aux.
Qed.

Lemma strictly_positive_cons:
  forall T X vars,
    strictly_positive T (X :: nil) ->
    strictly_positive T vars ->
    strictly_positive T (X :: vars).
Proof.
  intros.
  change (X :: vars) with ((X :: nil) ++ vars);
    eauto using strictly_positive_append.
Qed.

Lemma strictly_positive_topen2:
  forall T k X vars,
    ~(X ∈ vars) ->
    strictly_positive T vars ->
    strictly_positive (topen k T (fvar X type_var)) (X :: nil) ->
    strictly_positive (topen k T (fvar X type_var)) (X :: vars).
Proof.
  intros; apply strictly_positive_cons;
    repeat step || apply strictly_positive_topen.
Qed.

Lemma strictly_positive_rename_one:
  forall T X Y vars,
    strictly_positive (topen 0 T (fvar X type_var)) (X :: vars) ->
    ~(X ∈ pfv T type_var) ->
    ~(Y ∈ pfv T type_var) ->
    strictly_positive (topen 0 T (fvar Y type_var)) (Y :: vars).
Proof.
  intros.
  apply strictly_positive_rename with (topen 0 T (fvar X type_var)) (X :: vars) ((X,Y) :: idrel (pfv T type_var));
    repeat step || apply equal_with_relation_topen || unfold similar_sets || rewrite swap_idrel in * || t_idrel_lookup2;
    eauto using equal_with_idrel.
Qed.

Lemma strictly_positive_no_fv:
  forall T vars,
    is_erased_type T ->
    (forall X, X ∈ pfv T type_var -> False) ->
    strictly_positive T vars.
Proof.
  intros.
  apply no_type_fvar_strictly_positive; repeat step || unfold no_type_fvar; eauto.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export substitution.

Lemma cover_vars_upto_cequiv {o} :
  forall vs (a b : @NTerm o) sub,
    cover_vars_upto (mk_cequiv a b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b sub vs.
Proof.
  intros; unfold cover_vars_upto; simpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw subvars_app_l; sp.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../close/")
*** End:
*)