Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.
Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.
Require Import Behavior.
Require Import Cover.
Require Import Pred.
Require Import Trace.

Require Import PromiseConsistent.
Require Import PFConsistent.
Require Import MemoryProps.
Require Import Single.

Set Implicit Arguments.

Module PF.
Section LOCALPF.
  Variable L: Loc.t -> bool.

  Definition pf_event (e: ThreadEvent.t): Prop :=
    forall loc from to val released kind
           (PROMISE: e = ThreadEvent.promise loc from to (Message.concrete val released) kind)
           (LOC: L loc),
      False.

  Definition pf_consistent lang (th: Thread.t lang): Prop :=
    exists tr_cert,
      (<<CONSISTENT: Trace.consistent th tr_cert>>) /\
      (<<PFCERT: List.Forall (compose pf_event snd) tr_cert>>).

  Definition pf_promises (prom: Memory.t): Prop :=
    forall loc to from msg
           (LOC: L loc)
           (GET: Memory.get loc to prom = Some (from, msg)),
      msg = Message.reserve.

  Definition pf_configuration (c: Configuration.t) :=
    forall tid lang st lc
           (TID: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)),
      pf_promises (Local.promises lc).

  Lemma pf_consistent_consistent lang (th: Thread.t lang)
        (CONSISTENT: pf_consistent th)
    :
      Thread.consistent th.
  Proof.
    ii. unfold pf_consistent in *. des.
    exploit CONSISTENT0; eauto. i. des.
    { eapply Trace.silent_steps_tau_steps in STEPS; eauto.
      left. unfold Thread.steps_failure. esplits; eauto. }
    { eapply Trace.silent_steps_tau_steps in STEPS; eauto. }
  Qed.

  Lemma pf_promises_promise prom0 mem0 loc from to msg prom1 mem1 kind
        (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
        (PF: L loc -> msg = Message.reserve)
        (PROMISES: pf_promises prom0)
    :
      pf_promises prom1.
  Proof.
    inv PROMISE.
    - ii. erewrite Memory.add_o in GET; eauto. des_ifs.
      + ss. des; clarify. auto.
      + eapply PROMISES; eauto.
    - ii. erewrite Memory.split_o in GET; eauto. des_ifs.
      + ss. des; clarify. auto.
      + ss. des; clarify. exploit PF; ss.
      + eapply PROMISES; eauto.
    - ii. erewrite Memory.lower_o in GET; eauto. des_ifs.
      + ss. des; clarify. auto.
      + eapply PROMISES; eauto.
    - ii. erewrite Memory.remove_o in GET; eauto. des_ifs.
      eapply PROMISES; eauto.
  Qed.

  Lemma pf_promises_write prom0 mem0 loc from to val released prom1 mem1 kind
        (WRITE: Memory.write prom0 mem0 loc from to val released prom1 mem1 kind)
        (PROMISES: pf_promises prom0)
    :
      pf_promises prom1.
  Proof.
    inv WRITE. ii. erewrite Memory.remove_o in GET; eauto. des_ifs.
    inv PROMISE.
    - ii. erewrite Memory.add_o in GET; eauto. des_ifs.
      + ss. des; clarify.
      + eapply PROMISES; eauto.
    - ii. erewrite Memory.split_o in GET; eauto. des_ifs.
      + ss. des; clarify.
      + ss. des; clarify.
        eapply Memory.split_get0 in PROMISES0. des.
        eapply PROMISES in GET0; eauto.
      + eapply PROMISES; eauto.
    - ii. erewrite Memory.lower_o in GET; eauto. des_ifs.
      + ss. des; clarify.
      + eapply PROMISES; eauto.
    - ii. erewrite Memory.remove_o in GET; eauto. des_ifs.
  Qed.

  Lemma pf_promises_step lang (th0 th1: Thread.t lang) pf e
        (STEP: Thread.step pf e th0 th1)
        (PF: pf_event e)
        (PROMISES: pf_promises (Local.promises (Thread.local th0)))
    :
      pf_promises (Local.promises (Thread.local th1)).
  Proof.
    inv STEP.
    - inv STEP0; ss. inv LOCAL.
      eapply pf_promises_promise; eauto. i.
      destruct msg; ss. exfalso. eapply PF; eauto.
    - inv STEP0. inv LOCAL; ss.
      + inv LOCAL0; ss.
      + inv LOCAL0; ss.
        eapply pf_promises_write; eauto.
      + inv LOCAL1. inv LOCAL2; ss.
        eapply pf_promises_write; eauto.
      + inv LOCAL0; ss.
      + inv LOCAL0; ss.
  Qed.

  Lemma pf_promises_opt_step lang (th0 th1: Thread.t lang) e
        (STEP: Thread.opt_step e th0 th1)
        (PF: pf_event e)
        (PROMISES: pf_promises (Local.promises (Thread.local th0)))
    :
      pf_promises (Local.promises (Thread.local th1)).
  Proof.
    inv STEP; auto.
    eapply pf_promises_step; eauto.
  Qed.

  Lemma pf_promises_reserve_steps lang (th0 th1: Thread.t lang)
        (STEPS: rtc (@Thread.reserve_step _) th0 th1)
        (PROMISES: pf_promises (Local.promises (Thread.local th0)))
    :
      pf_promises (Local.promises (Thread.local th1)).
  Proof.
    ginduction STEPS; eauto. i. eapply IHSTEPS.
    inv H. eapply pf_promises_step; eauto. ii. clarify.
  Qed.

  Lemma pf_promises_cancel_steps lang (th0 th1: Thread.t lang)
        (STEPS: rtc (@Thread.cancel_step _) th0 th1)
        (PROMISES: pf_promises (Local.promises (Thread.local th0)))
    :
      pf_promises (Local.promises (Thread.local th1)).
  Proof.
    ginduction STEPS; eauto. i. eapply IHSTEPS.
    inv H. eapply pf_promises_step; eauto. ii. clarify.
  Qed.

  Lemma configuration_init_pf syn: pf_configuration (Configuration.init syn).
  Proof.
    ii. ss. unfold Threads.init in *.
    erewrite IdentMap.Facts.map_o in TID.
    unfold option_map in *. des_ifs. dep_clarify.
    erewrite Memory.bot_get in GET. ss.
  Qed.

  Lemma pf_promises_step_event lang (th0 th1: Thread.t lang) e
        (STEP: Thread.step true e th0 th1)
        (PROMISES: pf_promises (Local.promises (Thread.local th0)))
    :
      pf_event e.
  Proof.
    ii. subst. inv STEP; inv STEP0; inv LOCAL. ss.
    inv PROMISE; ss. des. subst.
    eapply Memory.lower_get0 in PROMISES0. des.
    eapply PROMISES in GET; eauto. clarify.
  Qed.

  Lemma pf_promises_steps_trace lang (th0 th1: Thread.t lang)
        (STEPS: rtc (tau (Thread.step true)) th0 th1)
        (PROMISES: pf_promises (Local.promises (Thread.local th0)))
    :
      exists tr,
        (<<STEPS: Trace.steps tr th0 th1>>) /\
        (<<PF: List.Forall (compose pf_event snd) tr>>) /\
        (<<SILENT: List.Forall (fun lce => ThreadEvent.get_machine_event (snd lce) = MachineEvent.silent) tr>>).
  Proof.
    ginduction STEPS; eauto; i.
    { exists []. splits; eauto. }
    i. inv H. hexploit pf_promises_step_event; eauto. intros PF.
    hexploit pf_promises_step; eauto. intros PROMISES0.
    exploit IHSTEPS; eauto. i. des. esplits; eauto.
  Qed.

  Lemma pf_promises_trace_steps lang (th0 th1: Thread.t lang) tr
        (STEPS: Trace.steps tr th0 th1)
        (PF: List.Forall (compose pf_event snd) tr)
        (PROMISES: pf_promises (Local.promises (Thread.local th0)))
    :
      pf_promises (Local.promises (Thread.local th1)).
  Proof.
    ginduction STEPS; eauto. i. subst.
    inv PF. eapply IHSTEPS; eauto.
    eapply pf_promises_step; eauto.
  Qed.

  Lemma pf_promises_consistent_consistent lang (th: Thread.t lang)
        (CONSISTENT: Thread.consistent th)
        (WF: Local.wf (Thread.local th) (Thread.memory th))
        (MEM: Memory.closed (Thread.memory th))
        (PROMISES: pf_promises (Local.promises (Thread.local th)))
    :
      pf_consistent th.
  Proof.
    eapply consistent_pf_consistent in CONSISTENT; eauto.
    exploit Memory.cap_exists; eauto. i. des.
    exploit Memory.max_concrete_timemap_exists.
    { eapply Memory.cap_closed; eauto. } i. des.
    exploit CONSISTENT; eauto. i. des.
    { eapply pf_promises_steps_trace in STEPS; eauto. des.
      exists tr. splits; auto. ii.
      exploit (@Memory.cap_inj (Thread.memory th) mem2 mem1); eauto. i. subst.
      exploit (@Memory.max_concrete_timemap_inj mem1 tm sc1); eauto. i. subst.
      esplits; eauto.
    }
    { eapply pf_promises_steps_trace in STEPS; eauto. des.
      exists tr. splits; auto. ii.
      exploit (@Memory.cap_inj (Thread.memory th) mem2 mem1); eauto. i. subst.
      exploit (@Memory.max_concrete_timemap_inj mem1 tm sc1); eauto. i. subst.
      esplits; eauto.
    }
  Qed.
End LOCALPF.
End PF.

(** L-PF machine **)
Module PFConfiguration.
Section LOCALPF.
  Variable L: Loc.t -> bool.

  Inductive step:
    forall (e:ThreadEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
  | step_intro
      e tid c1 lang st1 lc1 e2 e3 st4 lc4 sc4 memory4
      (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
      (CANCELS: rtc (@Thread.cancel_step _) (Thread.mk _ st1 lc1 (Configuration.sc c1) (Configuration.memory c1)) e2)
      (STEP: Thread.opt_step e e2 e3)
      (RESERVES: rtc (@Thread.reserve_step _) e3 (Thread.mk _ st4 lc4 sc4 memory4))
      (CONSISTENT: e <> ThreadEvent.failure -> PF.pf_consistent L (Thread.mk _ st4 lc4 sc4 memory4))
      (PF: PF.pf_event L e)
    :
      step e tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st4, lc4) (Configuration.threads c1)) sc4 memory4)
  .
  Hint Constructors step.

  Inductive machine_step: forall (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
  | machine_step_intro
      e tid c1 c2
      (STEP: step e tid c1 c2)
    :
      machine_step (ThreadEvent.get_machine_event e) tid c1 c2
  .
  Hint Constructors machine_step.

  Inductive all_step (c1 c2: Configuration.t): Prop :=
  | all_step_intro
      e tid
      (STEP: step e tid c1 c2)
  .
  Hint Constructors all_step.

  Inductive opt_machine_step:
    forall (e: MachineEvent.t) (tid: Ident.t) (c1 c2: Configuration.t), Prop :=
  | opt_machine_step_none
      tid c:
      opt_machine_step MachineEvent.silent tid c c
  | opt_machine_step_some
      e tid c1 c2
      (STEP: machine_step e tid c1 c2):
      opt_machine_step e tid c1 c2
  .
  Hint Constructors opt_machine_step.

  Definition tau_machine_step := union (machine_step MachineEvent.silent).

  Inductive steps:
    forall (es: list ThreadEvent.t) (tid: Ident.t) (c1 c2:Configuration.t), Prop :=
  | steps_nil
      tid c1
    :
      steps [] tid c1 c1
  | steps_cons
      ehd etl tid c1 c2 c3
      (STEP: step ehd tid c1 c2)
      (STEPS: steps etl tid c2 c3)
    :
      steps (ehd :: etl) tid c1 c3
  .
  Hint Constructors steps.

  Lemma steps_rtc_all_step es tid c1 c2
        (STEPS: steps es tid c1 c2)
    :
      rtc all_step c1 c2.
  Proof.
    induction STEPS; eauto.
  Qed.

  Lemma steps_split es0 es1 tid c0 c2
        (STEPS: steps (es0 ++ es1) tid c0 c2)
    :
      exists c1,
        (<<STEPS0: steps es0 tid c0 c1>>) /\
        (<<STEPS1: steps es1 tid c1 c2>>).
  Proof.
    ginduction es0; eauto. i. ss. inv STEPS.
    exploit IHes0; eauto. i. des.
    esplits; eauto.
  Qed.

  Lemma silent_steps_tau_machine_steps es tid c1 c2
        (STEPS: steps es tid c1 c2)
        (SILENT: List.Forall (fun e => ThreadEvent.get_machine_event e = MachineEvent.silent) es)
    :
      rtc (machine_step MachineEvent.silent tid) c1 c2.
  Proof.
    ginduction es; i.
    { inv STEPS. eauto. }
    { inv STEPS. inv SILENT. exploit IHes; eauto.
      i. econs 2; eauto. rewrite <- H1. econs; eauto. }
  Qed.

  Lemma pf_configuration_step tid c1 c2 e
        (STEP: step e tid c1 c2)
        (PF: PF.pf_configuration L c1)
    :
      PF.pf_configuration L c2.
  Proof.
    inv STEP. unfold PF.pf_configuration in *. i. ss.
    erewrite IdentMap.gsspec in TID0. des_ifs; eauto.
    dep_clarify. eapply PF in TID.
    eapply PF.pf_promises_cancel_steps in CANCELS; eauto.
    eapply PF.pf_promises_opt_step in STEP0; eauto.
    eapply PF.pf_promises_reserve_steps in RESERVES; eauto.
  Qed.

  Lemma event_configuration_step_step c1 c2 e tid
        (STEP: SConfiguration.step e tid c1 c2)
        (WF: Configuration.wf c1)
        (PF: PF.pf_configuration L c1)
        (EVENT: PF.pf_event L e)
    :
      step e tid c1 c2.
  Proof.
    inv STEP. econs; eauto. i.
    exploit Thread.rtc_cancel_step_future; eauto; try eapply WF; eauto. ss. i. des.
    exploit Thread.opt_step_future; eauto. ss. i. des.
    exploit Thread.rtc_reserve_step_future; eauto; try eapply WF; eauto. ss. i. des.
    hexploit PF.pf_promises_cancel_steps; eauto. i. ss.
    hexploit PF.pf_promises_opt_step; eauto. i. ss.
    hexploit PF.pf_promises_reserve_steps; eauto. i. ss.
    eapply PF.pf_promises_consistent_consistent; eauto.
  Qed.

  Lemma reservation_only_step_step tid c1 c2
        (STEP: SConfiguration.reservation_only_step tid c1 c2)
        (WF: Configuration.wf c1)
        (PF: PF.pf_configuration L c1)
    :
      step ThreadEvent.silent tid c1 c2.
  Proof.
    eapply SConfiguration.reservation_only_step_step in STEP.
    eapply event_configuration_step_step; eauto. ss.
  Qed.

  Lemma step_event_configuration_step c1 c2 e tid
        (STEP: step e tid c1 c2)
        (WF: Configuration.wf c1)
    :
      (<<STEP: SConfiguration.step e tid c1 c2>>) /\
      (<<EVENT: PF.pf_event L e>>)
  .
  Proof.
    inv STEP. splits; auto. econs; eauto.
    i. eapply PF.pf_consistent_consistent; eauto.
  Qed.

  Lemma step_future
        e tid c1 c2
        (STEP: step e tid c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    exploit step_event_configuration_step; eauto. i. des.
    exploit SConfiguration.step_future; eauto. i. des.
    splits; auto. eapply pf_configuration_step; eauto.
  Qed.

  Lemma machine_step_future
        e tid c1 c2
        (STEP: machine_step e tid c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    inv STEP. eapply step_future; eauto.
  Qed.

  Lemma opt_machine_step_future
        e tid c1 c2
        (STEP: opt_machine_step e tid c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    inv STEP; eauto.
    - splits; eauto. refl.
    - eapply machine_step_future; eauto.
  Qed.

  Lemma all_step_future
        c1 c2
        (STEP: all_step c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    inv STEP. eapply step_future; eauto.
  Qed.

  Lemma tau_machine_step_future
        c1 c2
        (STEP: tau_machine_step c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    inv STEP. eapply machine_step_future; eauto.
  Qed.

  Lemma rtc_tau_machine_step_future
        c1 c2
        (STEPS: rtc tau_machine_step c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    ginduction STEPS; eauto.
    - i. splits; eauto. refl.
    - i. exploit tau_machine_step_future; eauto. i. des.
      exploit IHSTEPS; eauto. i. des. esplits; eauto. etrans; eauto.
  Qed.

  Lemma rtc_all_step_future
        c1 c2
        (STEPS: rtc all_step c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
Proof.
    ginduction STEPS; eauto.
    - i. splits; eauto. refl.
    - i. exploit all_step_future; eauto. i. des.
      exploit IHSTEPS; eauto. i. des. esplits; eauto. etrans; eauto.
  Qed.

  Lemma steps_future
        es tid c1 c2
        (STEPS: steps es tid c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    ginduction STEPS; eauto.
    - i. splits; eauto. refl.
    - i. exploit step_future; eauto. i. des.
      exploit IHSTEPS; eauto. i. des. esplits; eauto. etrans; eauto.
  Qed.

  Inductive step_trace: forall (tr: Trace.t) (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
  | step_trace_intro
      lang tr e tr' pf tid c1 st1 lc1 e2 st3 lc3 sc3 memory3
      (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
      (STEPS: Trace.steps tr' (Thread.mk _ st1 lc1 (Configuration.sc c1) (Configuration.memory c1)) e2)
      (SILENT: List.Forall (fun the => ThreadEvent.get_machine_event (snd the) = MachineEvent.silent) tr')
      (STEP: Thread.step pf e e2 (Thread.mk _ st3 lc3 sc3 memory3))
      (TR: tr = tr'++[((Thread.local e2), e)])
      (CONSISTENT: forall (EVENT: e <> ThreadEvent.failure),
          PF.pf_consistent L (Thread.mk _ st3 lc3 sc3 memory3))
      (PF: List.Forall (compose (PF.pf_event L) snd) tr)
    :
      step_trace tr (ThreadEvent.get_machine_event e) tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st3, lc3) (Configuration.threads c1)) sc3 memory3)
  .

  Lemma trace_step_step_trace c1 c2 tr e tid
        (STEP: Trace.configuration_step tr e tid c1 c2)
        (WF: Configuration.wf c1)
        (PF: PF.pf_configuration L c1)
        (TRACE: List.Forall (compose (PF.pf_event L) snd) tr)
    :
      step_trace tr e tid c1 c2.
  Proof.
    inv STEP. econs; eauto. i.
    eapply Forall_app_inv in TRACE. des. inv FORALL2.
    exploit Trace.steps_future; eauto; try eapply WF; eauto. ss. i. des.
    exploit Thread.step_future; eauto. ss. i. des.
    hexploit PF.pf_promises_trace_steps; eauto. i. ss.
    hexploit PF.pf_promises_step; eauto. i. ss.
    eapply PF.pf_promises_consistent_consistent; eauto.
  Qed.

  Lemma step_trace_trace_step c1 c2 tr e tid
        (STEP: step_trace tr e tid c1 c2)
        (WF: Configuration.wf c1)
    :
      (<<STEP: Trace.configuration_step tr e tid c1 c2>>) /\
      (<<TRACE: List.Forall (compose (PF.pf_event L) snd) tr>>).
  Proof.
    inv STEP. splits; auto. econs; eauto. i.
    eapply PF.pf_consistent_consistent; eauto.
  Qed.

  Inductive opt_step_trace: forall (tr: Trace.t) (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
  | opt_step_trace_some
      tr e tid c1 c2
      (STEP: step_trace tr e tid c1 c2)
    :
      opt_step_trace tr e tid c1 c2
  | opt_step_trace_none
      tid c1
    :
      opt_step_trace [] MachineEvent.silent tid c1 c1
  .

  Lemma step_trace_step tr e tid c1 c2
        (STEP: step_trace tr e tid c1 c2)
    :
      Configuration.step e tid c1 c2.
  Proof.
    inv STEP. destruct (classic (e0 = ThreadEvent.failure)).
    { subst. econs 1; try apply STEP0; eauto.
      eapply Trace.silent_steps_tau_steps; eauto. }
    { econs 2; try apply STEP0; eauto.
      { eapply Trace.silent_steps_tau_steps; eauto. }
      { exploit CONSISTENT; eauto. i. unfold PF.pf_consistent in *. des.
        eapply Trace.consistent_thread_consistent; eauto. }
    }
  Qed.

  Inductive steps_trace:
    forall (c0 c1: Configuration.t) (tr: Trace.t), Prop :=
  | steps_trace_nil
      c0
    :
      steps_trace c0 c0 []
  | steps_trace_cons
      c0 c1 c2 trs tr e tid
      (STEPS: steps_trace c1 c2 trs)
      (STEP: step_trace tr e tid c0 c1)
    :
      steps_trace c0 c2 (tr ++ trs)
  .

  Lemma step_trace_steps tr e tid c1 c3
        (STEP: step_trace tr e tid c1 c3)
        (WF: Configuration.wf c1)
        (PF: PF.pf_configuration L c1)
    :
      ((<<STEPS: steps (List.filter ThreadEvent.is_normal_dec (List.map snd tr)) tid c1 c3>>) /\
       (<<NIL: List.filter ThreadEvent.is_normal_dec (List.map snd tr) <> []>>)) \/
      ((<<STEP: SConfiguration.reservation_only_step tid c1 c3>>) /\
       (<<NIL: List.filter ThreadEvent.is_normal_dec (List.map snd tr) = []>>)).
  Proof.
    eapply step_trace_trace_step in STEP; eauto. des.
    eapply SConfiguration.trace_step_machine_step in STEP0; eauto. des; eauto.
    left. splits; auto. clear e.
    remember (List.filter (fun e => ThreadEvent.is_normal_dec e) (List.map snd tr)).
    assert (EVENTS: List.Forall (PF.pf_event L) l).
    { subst. clear - TRACE. induction tr; ss. inv TRACE. des_ifs; eauto. }
    clear tr Heql NIL TRACE. ginduction STEPS; eauto.
    i. inv EVENTS.
    eapply event_configuration_step_step in STEP; eauto.
    exploit step_future; eauto. i. des.
    hexploit pf_configuration_step; eauto.
  Qed.

  Lemma step_trace_future
        (tr: Trace.t) e tid c1 c2
        (STEP: step_trace tr e tid c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    eapply step_trace_steps in STEP; eauto. des.
    { eapply steps_future; eauto. }
    { eapply reservation_only_step_step in STEP0; eauto.
      eapply step_future; eauto. }
  Qed.

  Lemma opt_step_trace_future
        (tr: Trace.t) e tid c1 c2
        (STEP: opt_step_trace tr e tid c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    inv STEP.
    { eapply step_trace_future; eauto. }
    { splits; auto. refl. }
  Qed.

  Lemma steps_trace_future
        c1 c2 tr
        (STEPS: steps_trace c1 c2 tr)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    revert WF1. induction STEPS; i.
    - splits; ss; refl.
    - exploit step_trace_future; eauto. i. des.
      exploit IHSTEPS; eauto. i. des.
      splits; ss; etrans; eauto.
  Qed.

  Lemma steps_trace_n1 c0 c1 c2 tr trs e tid
        (STEPS: steps_trace c0 c1 trs)
        (STEP: step_trace tr e tid c1 c2)
    :
      steps_trace c0 c2 (trs ++ tr).
  Proof.
    ginduction STEPS.
    { i. exploit steps_trace_cons.
      { econs 1. }
      { eapply STEP. }
      { i. ss. erewrite List.app_nil_r in *. auto. }
    }
    { i. exploit IHSTEPS; eauto. i. erewrite <- List.app_assoc. econs; eauto. }
  Qed.

  Lemma steps_trace_trans c0 c1 c2 trs0 trs1
        (STEPS0: steps_trace c0 c1 trs0)
        (STEPS1: steps_trace c1 c2 trs1)
    :
      steps_trace c0 c2 (trs0 ++ trs1).
  Proof.
    ginduction STEPS0.
    { i. erewrite List.app_nil_l. eauto. }
    { i. exploit IHSTEPS0; eauto. i. erewrite <- List.app_assoc. econs; eauto. }
  Qed.

  Lemma step_trace_steps_trace tr e tid c1 c2
        (STEP: step_trace tr e tid c1 c2)
    :
      steps_trace c1 c2 tr.
  Proof.
    exploit steps_trace_cons.
    { econs 1. }
    { eauto. }
    i. rewrite List.app_nil_r in x0. auto.
  Qed.

  Lemma opt_step_trace_steps_trace tr e tid c1 c2
        (STEP: opt_step_trace tr e tid c1 c2)
    :
      steps_trace c1 c2 tr.
  Proof.
    inv STEP.
    { eapply step_trace_steps_trace; eauto. }
    { econs 1. }
  Qed.

  Inductive silent_steps_trace:
    forall (c0 c1: Configuration.t) (tr: Trace.t), Prop :=
  | silent_steps_trace_nil
      c0
    :
      silent_steps_trace c0 c0 []
  | silent_steps_trace_cons
      c0 c1 c2 trs tr tid
      (STEPS: silent_steps_trace c1 c2 trs)
      (STEP: step_trace tr MachineEvent.silent tid c0 c1)
    :
      silent_steps_trace c0 c2 (tr ++ trs)
  .

  Lemma silent_steps_trace_steps_trace
    :
      silent_steps_trace <3= steps_trace.
  Proof.
    intros. induction PR.
    { econs. }
    { econs; eauto. }
  Qed.

  Inductive steps_trace_rev: forall (c1 c2: Configuration.t) (tr: Trace.t), Prop :=
  | steps_trace_rev_nil
      c:
      steps_trace_rev c c []
  | steps_trace_rev_cons
      c1 c2 c3 tr1 tr2 e tid
      (STEPS: steps_trace_rev c1 c2 tr1)
      (STEP: step_trace tr2 e tid c2 c3):
      steps_trace_rev c1 c3 (tr1 ++ tr2)
  .
  Hint Constructors steps_trace_rev.

  Lemma steps_trace_rev_1n
        c1 c2 c3 tr1 tr2 e tid
        (STEP: step_trace tr1 e tid c1 c2)
        (STEPS: steps_trace_rev c2 c3 tr2):
    steps_trace_rev c1 c3 (tr1 ++ tr2).
  Proof.
    revert tr1 e tid c1 STEP. induction STEPS; i.
    - replace (tr1 ++ []) with ([] ++ tr1) by (rewrite List.app_nil_r; ss).
      econs 2; [econs 1|]. eauto.
    - exploit IHSTEPS; eauto. i.
      rewrite List.app_assoc.
      econs 2; eauto.
  Qed.

  Lemma steps_trace_equiv c1 c2 tr:
    steps_trace c1 c2 tr <-> steps_trace_rev c1 c2 tr.
  Proof.
    split; i.
    - induction H; eauto.
      eapply steps_trace_rev_1n; eauto.
    - induction H; [econs 1|].
      eapply steps_trace_n1; eauto.
  Qed.

  Lemma steps_trace_inv
        c1 c2 tr lc e
        (STEPS: steps_trace c1 c2 tr)
        (WF: Configuration.wf c1)
        (PF: PF.pf_configuration L c1)
        (TRACE: List.In (lc, e) tr):
    exists c tr1 tid lang st1 lc1,
      (<<STEPS: steps_trace c1 c tr1>>) /\
      (<<FIND: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st1, lc1)>>) /\
      exists tr2 pf e2 e3,
        (<<THREAD_STEPS: Trace.steps tr2 (Thread.mk _ st1 lc1 (Configuration.sc c) (Configuration.memory c)) e2>>) /\
        (<<SILENT: List.Forall (fun the => ThreadEvent.get_machine_event (snd the) = MachineEvent.silent) tr2>>) /\
        (<<PF: List.Forall (compose (PF.pf_event L) snd) tr2>>) /\
        (<<LC: (Thread.local e2) = lc>>) /\
        (<<THREAD_STEP: Thread.step pf e e2 e3>>) /\
        (<<CONS: Local.promise_consistent (Thread.local e3)>>).
  Proof.
    rewrite steps_trace_equiv in STEPS.
    induction STEPS; ss.
    apply List.in_app_or in TRACE. des; eauto.
    clear IHSTEPS. inv STEP.
    exists c2, tr1, tid, lang, st1, lc1.
    rewrite <- steps_trace_equiv in STEPS.
    splits; ss.
    apply List.in_app_or in TRACE. des; cycle 1.
    { inv TRACE; ss. inv H. esplits; eauto.
      - apply Forall_app_inv in PF0. des. ss.
      - destruct (classic (e = ThreadEvent.failure)).
        + subst. inv STEP0; inv STEP. inv LOCAL. inv LOCAL0. ss.
        + exploit CONSISTENT; eauto. i. inv x. des.
          exploit steps_trace_future; eauto. i. des.
          inv WF2. inv WF0. exploit THREADS; eauto. i.
          exploit Trace.steps_future; try exact STEPS0; eauto. s. i. des.
          exploit Thread.step_future; try exact STEP0; eauto. s. i. des.
          hexploit consistent_promise_consistent;
            try eapply Trace.consistent_thread_consistent; try exact CONSISTENT0; eauto.
    }
    exploit steps_trace_future; eauto. i. des.
    inv WF2. inv WF0. exploit THREADS; eauto. i. clear DISJOINT THREADS.
    exploit Trace.steps_inv; try exact STEPS0; eauto.
    { destruct (classic (e1 = ThreadEvent.failure)).
      - subst. inv STEP0; inv STEP. inv LOCAL. inv LOCAL0. ss.
      - exploit CONSISTENT; ss. i. inv x0. des.
        exploit Trace.steps_future; eauto. s. i. des.
        exploit Thread.step_future; eauto. s. i. des.
        eapply step_promise_consistent; eauto.
        eapply consistent_promise_consistent; eauto.
        eapply Trace.consistent_thread_consistent; eauto.
    }
    i. des. esplits; eauto; subst.
    - apply Forall_app_inv in SILENT. des. ss.
    - apply Forall_app_inv in PF0. des.
      apply Forall_app_inv in FORALL1. des. ss.
  Qed.

  Inductive multi_step (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t): Prop :=
  | multi_step_intro
      tr
      (STEP: step_trace tr e tid c1 c2)
  .

  Lemma multi_step_machine_step e tid c1 c3
        (STEP: multi_step e tid c1 c3)
        (WF: Configuration.wf c1)
        (PF: PF.pf_configuration L c1)
    :
      exists c2,
        (<<STEPS: rtc tau_machine_step c1 c2>>) /\
        (<<STEP: opt_machine_step e tid c2 c3>>).
  Proof.
    inv STEP. exploit step_trace_steps; eauto. i. des.
    { inv STEP0.
      rewrite List.map_app in *.
      rewrite list_filter_app in *. ss.
      eapply steps_split in STEPS. des. exists c0. splits.
      { eapply rtc_implies with (R1:=(machine_step MachineEvent.silent tid)).
        { clear. i. econs; eauto. }
        eapply silent_steps_tau_machine_steps; eauto.
        eapply list_filter_forall with (Q:=fun e => ThreadEvent.get_machine_event e = MachineEvent.silent); eauto.
        eapply list_map_forall; eauto.
      }
      unfold proj_sumbool in *. des_ifs.
      { inv STEPS2. inv STEPS.
        econs 2. econs; eauto. }
      { inv STEPS2.
        replace (ThreadEvent.get_machine_event e0) with MachineEvent.silent; eauto.
        apply NNPP in n.
        unfold ThreadEvent.is_reservation_event, ThreadEvent.is_reserve, ThreadEvent.is_cancel in n.
        des; des_ifs.
      }
    }
    { eapply SConfiguration.reservation_only_step_step in STEP.
      eapply event_configuration_step_step in STEP; eauto; ss.
      exists c1. esplits; eauto.
      replace e with (ThreadEvent.get_machine_event ThreadEvent.silent); eauto.
      ss. inv STEP0.
      rewrite List.map_app in NIL.
      rewrite list_filter_app in NIL.
      eapply List.app_eq_nil in NIL.
      ss. unfold proj_sumbool in NIL. des. des_ifs.
      apply NNPP in n.
      unfold ThreadEvent.is_reservation_event, ThreadEvent.is_reserve, ThreadEvent.is_cancel in n.
      des; des_ifs.
    }
  Qed.

  Lemma multi_step_future
        e tid c1 c2
        (STEP: multi_step e tid c1 c2)
        (WF1: Configuration.wf c1)
        (PF: PF.pf_configuration L c1):
    (<<WF2: Configuration.wf c2>>) /\
    (<<SC_FUTURE: TimeMap.le (Configuration.sc c1) (Configuration.sc c2)>>) /\
    (<<MEM_FUTURE: Memory.future (Configuration.memory c1) (Configuration.memory c2)>>) /\
    (<<PF: PF.pf_configuration L c2>>).
  Proof.
    inv STEP. eapply step_trace_future; eauto.
  Qed.

  Lemma silent_multi_steps_trace_behaviors c0 c1 tr
        (STEP: silent_steps_trace c0 c1 tr)
    :
      behaviors multi_step c1 <1= behaviors multi_step c0.
  Proof.
    ginduction STEP; auto.
    i. eapply IHSTEP in PR. econs 4; eauto.
    econs. esplits; eauto.
  Qed.

  Lemma multi_step_behavior c
        (WF: Configuration.wf c)
        (PF: PF.pf_configuration L c)
    :
      behaviors multi_step c <1= behaviors machine_step c.
  Proof.
    i. induction PR.
    - econs 1; eauto.
    - exploit multi_step_future; eauto. i. des.
      eapply multi_step_machine_step in STEP; eauto. des.
      eapply rtc_tau_step_behavior; eauto.
      inv STEP0; eauto. econs 2; eauto.
    - exploit multi_step_future; eauto. i. des.
      eapply multi_step_machine_step in STEP; eauto. des.
      eapply rtc_tau_step_behavior; eauto.
      inv STEP0; eauto. econs 3; eauto.
    - exploit multi_step_future; eauto. i. des.
      eapply multi_step_machine_step in STEP; eauto. des.
      eapply rtc_tau_step_behavior; eauto.
      inv STEP0; eauto. econs 4; eauto.
  Qed.

End LOCALPF.
End PFConfiguration.

(** L-PF race **)
Module PFRace.
Section LOCALPFRACE.
  Variable L: Loc.t -> bool.

  Inductive reading_event (loc: Loc.t) (ts: Time.t):
    forall (e: ThreadEvent.t), Prop :=
  | reading_event_read
      valr releasedr ordr
    :
      reading_event loc ts (ThreadEvent.read loc ts valr releasedr ordr)
  | reading_event_update
      to valr valw releasedr releasedw ordr ordw
    :
      reading_event loc ts (ThreadEvent.update loc ts to valr valw releasedr releasedw ordr ordw)
  .

  Inductive writing_event (loc: Loc.t) (ts: Time.t):
    forall (e: ThreadEvent.t), Prop :=
  | writing_event_write
      from valw releasedw ordw
      (ORD: Ordering.le ordw Ordering.relaxed)
    :
      writing_event loc ts (ThreadEvent.write loc from ts valw releasedw ordw)
  | writing_event_update
      from valr valw releasedr releasedw ordr ordw
      (ORD: Ordering.le ordw Ordering.relaxed)
    :
      writing_event loc ts (ThreadEvent.update loc from ts valr valw releasedr releasedw ordr ordw)
  .

  Definition racy_execution (c0: Configuration.t): Prop :=
    forall tid0 c1 tid1 c2 c3
           loc ts e0 e1
           (LOC: L loc)
           (TID: tid0 <> tid1)
           (CSTEP0: PFConfiguration.step L e0 tid0 c0 c1)
           (WRITE: writing_event loc ts e0)
           (STEPS: rtc (PFConfiguration.machine_step L MachineEvent.silent tid1) c1 c2)
           (CSTEP1: PFConfiguration.step L e1 tid1 c2 c3)
           (READ: reading_event loc ts e1),
      False.

  Definition racefree (c0: Configuration.t): Prop :=
    forall c1
           (CSTEPS: rtc (PFConfiguration.all_step L) c0 c1),
      racy_execution c1.

  Definition racefree_syn (syn: Threads.syntax): Prop :=
    racefree (Configuration.init syn).

  Inductive racy_state (c0: Configuration.t): Prop :=
  | race_intro
      c1 c2
      tid0 tid1 e0 e1
      lang st0 lc0 th1 th2
      tr pf loc ts
      (STEPS: rtc (PFConfiguration.machine_step L MachineEvent.silent tid0) c0 c1)
      (WRITE_STEP: PFConfiguration.step L e0 tid0 c1 c2)
      (WRITE: writing_event loc ts e0)
      (FIND: IdentMap.find tid1 (Configuration.threads c2) = Some (existT _ lang st0, lc0))
      (THREAD_STEPS: Trace.steps tr (Thread.mk _ st0 lc0 (Configuration.sc c2) (Configuration.memory c2)) th1)
      (PF: List.Forall (compose (PF.pf_event L) snd) tr)
      (CONS: Local.promise_consistent (Thread.local th1))
      (READ_STEP: Thread.step pf e1 th1 th2)
      (READ: reading_event loc ts e1)
      (LOC: L loc)
  .

  Lemma step_racefree c0 c1 e tid
        (RACEFREE: racefree c0)
        (STEP: PFConfiguration.step L e tid c0 c1)
    :
      racefree c1.
  Proof.
    unfold racefree in *. i.
    eapply RACEFREE. econs 2; eauto. econs; eauto.
  Qed.

  Lemma rtc_tau_machine_step_racefree c0 c1
        (RACEFREE: racefree c0)
        (STEP: rtc (PFConfiguration.tau_machine_step L) c0 c1)
    :
      racefree c1.
  Proof.
    ginduction STEP; eauto.
    i. eapply IHSTEP. inv H. inv USTEP.
    eapply step_racefree; eauto.
  Qed.

  Lemma steps_racefree es tid c0 c1
        (RACEFREE: racefree c0)
        (STEPS: PFConfiguration.steps L es tid c0 c1)
    :
      racefree c1.
  Proof.
    ginduction STEPS; eauto.
    i. eapply IHSTEPS.
    eapply step_racefree; eauto.
  Qed.

  Inductive multi_race (c0: Configuration.t): Prop :=
  | multi_race_intro
      c1
      tid0 tid1 e0 e1
      lang st0 lc0 th1 th2
      e trs tr pf loc ts
      (STEPS: PFConfiguration.step_trace L trs e tid0 c0 c1)
      (TRACE: final_event_trace e0 trs)
      (WRITE: writing_event loc ts e0)
      (FIND: IdentMap.find tid1 (Configuration.threads c1) = Some (existT _ lang st0, lc0))
      (THREAD_STEPS: Trace.steps tr (Thread.mk _ st0 lc0 (Configuration.sc c1) (Configuration.memory c1)) th1)
      (PF: List.Forall (compose (PF.pf_event L) snd) tr)
      (CONS: Local.promise_consistent (Thread.local th1))
      (READ_STEP: Thread.step pf e1 th1 th2)
      (READ: reading_event loc ts e1)
      (LOC: L loc)
  .

  Definition multi_racefree_imm (c0: Configuration.t): Prop :=
    forall tid0 c1 trs0 tid1 c2 trs1
           loc ts lc1 te0 te1 e0 e1
           (LOC: L loc)
           (TID: tid0 <> tid1)
           (CSTEP0: PFConfiguration.step_trace L trs0 e0 tid0 c0 c1)
           (WRITE: writing_event loc ts te0)
           (TRACE0: final_event_trace te0 trs0)
           (CSTEP1: PFConfiguration.step_trace L trs1 e1 tid1 c1 c2)
           (READ: reading_event loc ts te1)
           (TRACE1: List.In (lc1, te1) trs1),
      False.

  Definition multi_racefree (c0: Configuration.t): Prop :=
    forall c1 trs
           (CSTEPS: PFConfiguration.steps_trace L c0 c1 trs),
      multi_racefree_imm c1.

  Lemma multi_step_multi_racefree c0 c1 tr e tid
        (RACEFREE: multi_racefree c0)
        (STEP: PFConfiguration.step_trace L tr e tid c0 c1)
    :
      multi_racefree c1.
  Proof.
    unfold multi_racefree in *. i.
    eapply RACEFREE. econs 2; eauto.
  Qed.

  Lemma multi_steps_multi_racefree c0 c1 trs
        (RACEFREE: multi_racefree c0)
        (STEPS: PFConfiguration.steps_trace L c0 c1 trs)
    :
      multi_racefree c1.
  Proof.
    induction STEPS; auto. eapply IHSTEPS.
    eapply multi_step_multi_racefree; eauto.
  Qed.

  Lemma racefree_multi_racefree_imm c
        (RACEFREE: racefree c)
        (WF: Configuration.wf c)
        (PF: PF.pf_configuration L c)
    :
      multi_racefree_imm c.
  Proof.
    ii. exploit PFConfiguration.step_trace_future; try apply CSTEP0; eauto.  i. des.
    exploit final_event_trace_filter; eauto.
    { unfold ThreadEvent.is_normal, ThreadEvent.is_reservation_event.
      inv WRITE; ss; ii; des; ss. } i. des.
    eapply PFConfiguration.step_trace_steps in CSTEP0; eauto.
    rewrite FILTER in *. des; cycle 1.
    { eapply List.app_eq_nil in NIL. des; ss. }
    eapply PFConfiguration.steps_split in STEPS. des. inv STEPS1. inv STEPS.
    eapply List.in_split in TRACE1. des; subst.
    dup CSTEP1. eapply PFConfiguration.step_trace_steps in CSTEP1; eauto.
    rewrite List.map_app in *.
    rewrite list_filter_app in *. ss. unfold proj_sumbool in *.
    des_ifs; cycle 1.
    { clear - READ n. apply NNPP in n.
      unfold ThreadEvent.is_normal, ThreadEvent.is_reservation_event in *.
      inv READ; ss; ii; des; ss. }
    des; cycle 1.
    { eapply List.app_eq_nil in NIL0. des; ss. }
    eapply PFConfiguration.steps_split in STEPS. des. inv STEPS2.
    eapply RACEFREE; try eassumption.
    { eapply PFConfiguration.steps_rtc_all_step; eauto. }
    { eapply PFConfiguration.silent_steps_tau_machine_steps; eauto.
      clear - CSTEP0. inv CSTEP0.
      destruct (list_match_rev l2); des; subst.
      { eapply List.app_inj_tail in TR. des; clarify.
        eapply List.Forall_forall. ii.
        eapply List.filter_In in H. des.
        eapply List.in_map_iff in H. des; subst.
        eapply List.Forall_forall in SILENT; eauto. }
      { rewrite List.app_comm_cons in TR.
        rewrite List.app_assoc in TR.
        eapply List.app_inj_tail in TR. des; clarify.
        eapply Forall_app_inv in SILENT. des.
        eapply List.Forall_forall. ii.
        eapply List.filter_In in H. des.
        eapply List.in_map_iff in H. des; subst.
        eapply List.Forall_forall in FORALL1; eauto. }
    }
  Qed.

  Lemma racefree_multi_racefree c
        (RACEFREE: racefree c)
        (WF: Configuration.wf c)
        (PF: PF.pf_configuration L c)
    :
      multi_racefree c.
  Proof.
    unfold multi_racefree. i.
    ginduction CSTEPS; eauto.
    { i. eapply racefree_multi_racefree_imm; eauto. }
    { i. exploit PFConfiguration.step_trace_future; eauto.
      i. des. eapply IHCSTEPS; eauto.
      eapply PFConfiguration.step_trace_steps in STEP; eauto. des.
      { eapply steps_racefree; eauto. }
      { eapply PFConfiguration.reservation_only_step_step in STEP0; eauto.
        eapply step_racefree; eauto. }
    }
  Qed.

  Lemma multi_race_race c
        (RACE: multi_race c)
        (WF: Configuration.wf c)
        (PF: PF.pf_configuration L c)
    :
      racy_state c.
  Proof.
    inv RACE.
    exploit PFConfiguration.step_trace_future; try apply STEPS; eauto. i. des.
    exploit final_event_trace_filter; eauto.
    { ii. inv WRITE; eauto. } i. des.
    dup STEPS. eapply PFConfiguration.step_trace_steps in STEPS; eauto.
    rewrite FILTER in *. des; cycle 1.
    { eapply List.app_eq_nil in NIL. des; ss. }
    eapply PFConfiguration.steps_split in STEPS1. des. inv STEPS3. inv STEPS.
    econs; cycle 1; eauto.
    eapply PFConfiguration.silent_steps_tau_machine_steps; eauto.
    assert (exists trs_hd trs_tl,
               (<<TRS: trs = trs_hd ++ [trs_tl]>>) /\
               (<<SILENT: List.Forall (fun the => ThreadEvent.get_machine_event (snd the) = MachineEvent.silent) trs_hd>>)).
    { inv STEPS0. eauto. } clear STEPS0. des. subst.
    erewrite List.map_app in FILTER. erewrite list_filter_app in FILTER.
    assert (exists tl,
               tr_hd ++ tl = List.filter (fun e => ThreadEvent.is_normal_dec e) (List.map snd trs_hd)).
    { ss. des_ifs.
      - exists []. rewrite List.app_nil_r.
        eapply List.app_inj_tail in FILTER. des. auto.
      - exists [e0]. rewrite <- FILTER. rewrite List.app_nil_r. auto.
    }
    des. exploit Forall_app_inv; cycle 1.
    { i. des. eapply FORALL1. }
    { rewrite H. eapply List.Forall_forall. i.
      eapply List.filter_In in H0. des.
      eapply List.in_map_iff in H0. des. subst.
      eapply List.Forall_forall in SILENT; eauto.
    }
  Qed.

  Inductive racy_read (loc: Loc.t) (ts: Time.t):
    forall (lc: Local.t) (e: ThreadEvent.t), Prop :=
  | racy_read_read
      lc
      valr releasedr ordr
      (VIEW:
         Time.lt (if Ordering.le Ordering.relaxed ordr
                  then ((TView.cur (Local.tview lc)).(View.rlx) loc)
                  else ((TView.cur (Local.tview lc)).(View.pln) loc)) ts)
    :
      racy_read loc ts lc (ThreadEvent.read loc ts valr releasedr ordr)
  | racy_read_update
      lc
      to valr valw releasedr releasedw ordr ordw
      (VIEW:
         Time.lt (if Ordering.le Ordering.relaxed ordr
                  then ((TView.cur (Local.tview lc)).(View.rlx) loc)
                  else ((TView.cur (Local.tview lc)).(View.pln) loc)) ts)
    :
      racy_read loc ts lc (ThreadEvent.update loc ts to valr valw releasedr releasedw ordr ordw)
  .

  Definition multi_racefree_view (c0: Configuration.t): Prop :=
    forall c1 trs1 c2 trs2
      loc ts lc0 lc1 e0 e1
      (CSTEPS1: PFConfiguration.steps_trace L c0 c1 trs1)
      (LOC: L loc)
      (TRACE1: List.In (lc0, e0) trs1)
      (WRITE: writing_event loc ts e0)
      (CSTEPS2: PFConfiguration.steps_trace L c1 c2 trs2)
      (TRACE2: List.In (lc1, e1) trs2)
      (READ: racy_read loc ts lc1 e1),
      False.

  Lemma multi_step_multi_racefree_view c0 c1 tr e tid
        (RACEFREE: multi_racefree_view c0)
        (STEP: PFConfiguration.step_trace L tr e tid c0 c1)
    :
      multi_racefree_view c1.
  Proof.
    ii. eapply RACEFREE.
    { econs 2.
      { eapply CSTEPS1. }
      { eauto. }
    }
    { eauto. }
    { eapply List.in_or_app. right. eapply TRACE1. }
    { eauto. }
    { eauto. }
    { eauto. }
    { eauto. }
  Qed.

  Lemma multi_steps_multi_racefree_view c0 c1 trs
        (RACEFREE: multi_racefree_view c0)
        (STEPS: PFConfiguration.steps_trace L c0 c1 trs)
    :
      multi_racefree_view c1.
  Proof.
    induction STEPS; auto. eapply IHSTEPS.
    eapply multi_step_multi_racefree_view; eauto.
  Qed.

  Inductive racy_read_step:
    forall (loc: Loc.t) (ts: Time.t)
           (e:ThreadEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
  | racy_read_step_intro
      loc ts e tid c1 lang st1 lc1 e2 e3 st4 lc4 sc4 memory4
      (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
      (CANCELS: rtc (@Thread.cancel_step _) (Thread.mk _ st1 lc1 (Configuration.sc c1) (Configuration.memory c1)) e2)
      (STEP: Thread.opt_step e e2 e3)
      (RESERVES: rtc (@Thread.reserve_step _) e3 (Thread.mk _ st4 lc4 sc4 memory4))
      (CONSISTENT: e <> ThreadEvent.failure -> PF.pf_consistent L (Thread.mk _ st4 lc4 sc4 memory4))
      (PF: PF.pf_event L e)
      (READ: racy_read loc ts (Thread.local e2) e)
    :
      racy_read_step loc ts e tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st4, lc4) (Configuration.threads c1)) sc4 memory4)
  .
  Hint Constructors racy_read_step.

  Inductive racy_write_step:
    forall (loc: Loc.t) (ts: Time.t)
           (e:ThreadEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
  | racy_write_step_intro
      loc ts e tid c1 c2
      (STEP: PFConfiguration.step L e tid c1 c2)
      (WRITE: writing_event loc ts e)
    :
      racy_write_step loc ts e tid c1 c2
  .

  Definition racefree_view (c0: Configuration.t): Prop :=
    forall c1 c2 c3 c4 loc ts e0 e1 tid0 tid1
      (LOC: L loc)
      (CSTEPS1: rtc (PFConfiguration.all_step L) c0 c1)
      (WRITE: racy_write_step loc ts e0 tid0 c1 c2)
      (CSTEPS2: rtc (PFConfiguration.all_step L) c2 c3)
      (READ: racy_read_step loc ts e1 tid1 c3 c4),
      False.

  Definition racefree_view_syn (syn: Threads.syntax): Prop :=
    racefree_view (Configuration.init syn).

  Lemma step_racefree_view c0 c1 e tid
        (RACEFREE: racefree_view c0)
        (STEP: PFConfiguration.step L e tid c0 c1)
    :
      racefree_view c1.
  Proof.
    ii. eapply RACEFREE; cycle 2; eauto.
    econs; eauto. econs; eauto.
  Qed.

  Lemma steps_racefree_view c0 c1
        (RACEFREE: racefree_view c0)
        (STEPS: rtc (PFConfiguration.all_step L) c0 c1)
    :
      racefree_view c1.
  Proof.
    ii. eapply RACEFREE; cycle 2; eauto. etrans; eauto.
  Qed.

End LOCALPFRACE.
End PFRace.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import Types.
Require Import Dynamics.

Require Export Types.
Require Export Dynamics.

Module VoidnessPreservationBase (Import MyDynamics : DynamicsSig).

  Inductive VoidnessPreserves : DartType -> DartType -> Prop :=
  | vp_dynamic_any : ∀ dt,
    VoidnessPreserves dt_dynamic dt
  | vp_any_void : ∀ dt,
    VoidnessPreserves dt dt_void
  | vp_any_variable : ∀ dt n,
    VoidnessPreserves dt (dt_variable n)
  | vp_any_dynamic : ∀ dt,
    MyDynamics.dynamic_is_magic ->
    VoidnessPreserves dt dt_dynamic
  | vp_class : ∀ ctypes1 ctypes2,
    VoidnessClassTypesPreserve ctypes1 ctypes2 ->
    VoidnessPreserves (dt_class ctypes1) (dt_class ctypes2)
  | vp_class_dynamic : ∀ ctypes,
    VoidnessPreserves (dt_class ctypes) dt_dynamic
  | vp_function : ∀ ret1 ret2 args1 args2,
    VoidnessPreserves ret1 ret2 ->
    VoidnessPreservesPairwise args2 args1 ->
    VoidnessPreserves (dt_function ret1 args1) (dt_function ret2 args2)
  | vp_function_dynamic : ∀ ret args,
    VoidnessPreserves (dt_function ret args) dt_dynamic
  | vp_bottom_bottom :
    VoidnessPreserves dt_bottom dt_bottom

  with VoidnessPreservesPairwise : DartTypes -> DartTypes -> Prop :=
  | vpp_nil : VoidnessPreservesPairwise dts_nil dts_nil
  | vpp_cons : ∀ dt1 dt2 dts1 dts2,
    VoidnessPreserves dt1 dt2 ->
    VoidnessPreservesPairwise dts1 dts2 ->
    VoidnessPreservesPairwise (dts_cons dt1 dts1) (dts_cons dt2 dts2)

  with VoidnessClassTypesPreserve : NameDartTypes -> NameDartTypes -> Prop :=
  | vctsp_nil : ∀ ctypes,
    VoidnessClassTypesPreserve ndts_nil ctypes
  | vctsp_cons : ∀ name dt ctypes1 ctypes2,
    VoidnessClassTypePreserves name dt ctypes2 ->
    VoidnessClassTypesPreserve ctypes1 ctypes2 ->
    VoidnessClassTypesPreserve (ndts_cons name dt ctypes1) ctypes2

  with VoidnessClassTypePreserves : Name -> DartTypes -> NameDartTypes -> Prop :=
  | vctp_gone : ∀ name dt ctypes,
    VoidnessClassTypeGone name dt ctypes ->
    VoidnessClassTypePreserves name dt ctypes
  | vctp_some : ∀ name dt ctypes,
    VoidnessClassTypePreservesSome name dt ctypes ->
    VoidnessClassTypePreserves name dt ctypes

  with VoidnessClassTypeGone : Name -> DartTypes -> NameDartTypes -> Prop :=
  | vctg_nil : ∀ name dt,
    VoidnessClassTypeGone name dt ndts_nil
  | vctg_cons : ∀ name1 args1 name2 args2 ctypes,
    name1 <> name2 ->
    VoidnessClassTypeGone name1 args1 ctypes ->
    VoidnessClassTypeGone name1 args1 (ndts_cons name2 args2 ctypes)

  with VoidnessClassTypePreservesSome : Name -> DartTypes -> NameDartTypes -> Prop :=
  | vctps_first : ∀ name args1 args2 ctypes,
    VoidnessPreservesPairwise args1 args2 ->
    VoidnessClassTypePreservesSome name args1 (ndts_cons name args2 ctypes)
  | vctps_rest : ∀ name1 dt1 name2 dt2 ctypes2,
    VoidnessClassTypePreservesSome name1 dt1 ctypes2 ->
    VoidnessClassTypePreservesSome name1 dt1 (ndts_cons name2 dt2 ctypes2).

  Hint Constructors
    VoidnessPreserves VoidnessPreservesPairwise
    VoidnessClassTypesPreserve VoidnessClassTypePreserves
    VoidnessClassTypeGone VoidnessClassTypePreservesSome.

End VoidnessPreservationBase.


(*

  Copyright 2014 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export computation4.

Lemma isprog_inl_iff {p} :
  forall a : @NTerm p, isprog (mk_inl a) <=> (isprog a).
Proof.
  introv; split; intro k.
  - allrw @isprog_eq.
    destruct k as [c w].
    inversion w as [| | o lnt j e ]; subst.
    generalize (j (nobnd a)); intros i1; allsimpl.
    repeat (autodimp i1 hyp).
    unfold isprogram.
    inversion c as [pp]. allrw remove_nvars_nil_l; allrw app_nil_r.
    inversion i1; subst. sp.
  - apply isprog_inl; sp.
Qed.

Lemma isprog_inr_iff {p} :
  forall a : @NTerm p, isprog (mk_inr a) <=> (isprog a).
Proof.
  introv; split; intro k.
  - allrw @isprog_eq.
    destruct k as [c w].
    inversion w as [| | o lnt j e ]; subst.
    generalize (j (nobnd a)); intros i1; allsimpl.
    repeat (autodimp i1 hyp).
    unfold isprogram.
    inversion c as [pp]. allrw remove_nvars_nil_l; allrw app_nil_r.
    inversion i1; subst. sp.
  - apply isprog_inr; sp.
Qed.

Lemma isvalue_inl {p} :
  forall (a : @NTerm p), isprogram a ->  isvalue (mk_inl a).
Proof.
 introv ispa.
 constructor; simpl; auto.
 apply isprogram_inl; auto.
Qed.

Lemma isvalue_inr {p} :
  forall (a : @NTerm p), isprogram a ->  isvalue (mk_inr a).
Proof.
 introv ispa.
 constructor; simpl; auto.
 apply isprogram_inr; auto.
Qed.
Hint Resolve isvalue_inr isvalue_inl : slow.

Lemma compute_step_decide_ncan {o} :
  forall lib n l x y b1 b2,
    @compute_step o lib (mk_decide (oterm (NCan n) l) x b1 y b2)
    = match compute_step lib (oterm (NCan n) l) with
        | csuccess p => csuccess (mk_decide p x b1 y b2)
        | cfailure str ts => cfailure str ts
      end.
Proof. introv; csunf; simpl; sp. Qed.

Lemma hasvaluec_mkc_decide {q} :
  forall lib p x y t1 t2,
    hasvaluec lib (mkc_decide p x t1 y t2)
    -> {a : @CTerm q $
          computes_to_valc lib p (mkc_inl a)
           [+]
          computes_to_valc lib p (mkc_inr a)
       }.
Proof.
  introv hv.
  destruct_cterms.
  unfold hasvaluec in hv; allsimpl.
  rename x0 into p.
  rename x1 into t2.
  rename x2 into t1.
  unfold computes_to_valc; simpl.
  destruct hv as [t' c].
  destruct c as [rt iv].
  destruct rt as [k comp].
  revert dependent p.
  induction k; introv isp comp.

  - rw @reduces_in_atmost_k_steps_0 in comp; subst.
    inversion iv; allsimpl; tcsp.

  - rw @reduces_in_atmost_k_steps_S in comp; exrepnd.
    destruct p as [v|f|op bs].

    + inversion comp1.

    + csunf comp1; allsimpl; ginv.

    +  dopid op as [can | ncan | ex | abs] Case.

       * Case "Can".
         csunf comp1. allsimpl. apply compute_step_decide_success in comp1; exrepnd.
         subst; cpx. repndors; exrepnd; subst; fold_terms.
         { rw @isprog_inl_iff in isp. exists (mk_ct d isp). simpl. left.
           apply computes_to_value_isvalue_refl; sp. eauto 3 with slow.
         }
         { rw @isprog_inr_iff in isp. exists (mk_ct d isp). simpl. right.
           apply computes_to_value_isvalue_refl; sp. eauto 3 with slow.
         }

      * Case "NCan".
        rw @compute_step_decide_ncan in comp1.
        remember (compute_step lib (oterm (NCan ncan) bs)).
        destruct c; ginv.

        symmetry in Heqc.
        allrw @isprog_eq.
        applydup @preserve_compute_step in Heqc; auto.
        apply IHk in comp0; auto; exrepnd; try (complete (apply isprog_eq; auto)).
        exists a. repndors; [left | right];
        eapply computes_to_value_step; eauto.

      * Case "Exc".
        simpl in comp1. csunf comp1; allsimpl; ginv.
        apply reduces_atmost_exc in comp0; subst.
        inversion iv; allsimpl; tcsp.

      * Case "Abs".
        csunf comp1; simpl in comp1; unfold on_success in comp1; csunf comp1; allsimpl.
        remember (compute_step_lib lib abs bs) as csl.
        destruct csl; inversion comp1; subst; GC.
        symmetry in Heqcsl.
        rw @isprog_eq in isp.
        applydup @isprogram_compute_step_lib in Heqcsl; auto.
        rw <- @isprog_eq in Heqcsl0.
        apply IHk in comp0; auto; exrepnd.
        exists a; repndors; [ left | right ]; eapply computes_to_value_step; eauto.
Qed.

Lemma if_computes_to_exception_decide0 {o} :
  forall lib n (t : @NTerm o) x y u v e,
    isprogram t
    -> computes_to_exception lib n (mk_decide t x u y v) e
    -> computes_to_exception lib n t e
       [+] {a : NTerm
            & computes_to_value lib t (mk_inl a)
            # computes_to_exception lib n (lsubst u [(x,a)]) e}

       [+] {a : NTerm
            & computes_to_value lib t (mk_inr a)
            # computes_to_exception lib n (lsubst v [(y,a)]) e}.
Proof.
  unfold computes_to_exception, reduces_to.
  introv ispt re; exrepnd.
  revert dependent t.
  revert x y u v.
  induction k; introv ispt r.

  - apply reduces_in_atmost_k_steps_0 in r; inversion r.

  - rw @reduces_in_atmost_k_steps_S in r; exrepnd.
    csunf r1; allsimpl.
    destruct t as [z|f|op bs]; try (complete (inversion r1));[].
    dopid op as [can|ncan|exc|abs] Case; try (complete (inversion r1)).

    + Case "Can".
      apply compute_step_decide_success in r1; exrepnd; subst; ginv.
      right. repndors; [left | right]; repnd; subst; exists d; dands; eauto 3 with slow;
      allrw <- @isprogram_inl_iff; repnd;
      allrw <- @isprogram_inr_iff; repnd;
      apply computes_to_value_isvalue_refl; eauto 3 with slow.

    + Case "NCan".
      remember (compute_step lib (oterm (NCan ncan) bs)) as c;
        destruct c; allsimpl; ginv; symmetry in Heqc.

      applydup @preserve_compute_step in Heqc; auto.
      apply IHk in r0; auto.
      repndors; exrepnd.

      { left.
        exists (S k0).
        rw @reduces_in_atmost_k_steps_S.
        exists n0; auto. }

      { right. left.
        exists a; sp.
        { eapply computes_to_value_step; eauto. }
        exists k0; auto. }
      { right. right.
        exists a; sp.
        { eapply computes_to_value_step; eauto. }
        exists k0; auto. }

    + Case "Exc".
      ginv.
      left.
      exists k; auto.

    + Case "Abs".
      csunf r1; allsimpl.
      remember (compute_step_lib lib abs bs) as c;
        destruct c; allsimpl; symmetry in Heqc; ginv.

      applydup @isprogram_compute_step_lib in Heqc; auto.
      apply IHk in r0; auto.
      repndors; exrepnd.

      { left.
        exists (S k0).
        rw @reduces_in_atmost_k_steps_S.
        exists n0; auto. }

      { right. left.
        exists a; sp.
        { eapply computes_to_value_step; eauto. }
        exists k0; auto. }
      { right. right.
        exists a; sp.
        { eapply computes_to_value_step; eauto. }
        exists k0; auto. }

Qed.

(* !!MOVE *)
Lemma if_raises_exception_decide0 {o} :
  forall lib (t : @NTerm o) x y u v,
    isprogram t
    -> raises_exception lib (mk_decide t x u y v)
    -> raises_exception lib t
       [+] {a : NTerm
            & computes_to_value lib t (mk_inl a)
            # raises_exception lib (lsubst u [(x,a)]) }
       [+] {a : NTerm
            & computes_to_value lib t (mk_inr a)
            # raises_exception lib (lsubst v [(y,a)])}.
Proof.
  introv isp re.
  unfold raises_exception in re; exrepnd.
  pose proof (if_computes_to_exception_decide0 lib a t x y u v e isp re1) as h.
  repndors; exrepnd.
  - left; exists a e; auto.
  - right. left.
    exists a0; dands; auto.
    exists a e; auto.
  - right. right.
    exists a0; dands; auto.
    exists a e; auto.
Qed.

(* !!MOVE *)
Lemma if_raises_exceptionc_decide0 {o} :
  forall lib (t : @CTerm o) x y u v,
    raises_exceptionc lib (mkc_decide t x u y v)
    -> raises_exceptionc lib t
       [+] {a : CTerm
            & computes_to_valc lib t (mkc_inl a)
            # raises_exceptionc lib (substc a x u) }
       [+] {a : CTerm
            & computes_to_valc lib t (mkc_inr a)
            # raises_exceptionc lib (substc a y v) }.
Proof.
  introv re.
  destruct_cterms.
  allunfold @raises_exceptionc.
  allunfold @computes_to_valc.
  allsimpl.
  pose proof (if_raises_exception_decide0 lib x0 x y x2 x1) as h.
  repeat (autodimp h hyp); eauto 3 with slow.
  repndors; exrepnd; tcsp; right; [left | right].
  -
  applydup @preserve_program in h1; eauto 3 with slow.
  allrw <- @isprogram_inl_iff; repnd.
  exists (mk_cterm a h2); simpl.
  dands; auto.
 -applydup @preserve_program in h1; eauto 3 with slow.
  allrw <- @isprogram_inr_iff; repnd.
  exists (mk_cterm a h2); simpl.
  dands; auto.
Qed.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Local Open Scope nat_scope.

Require Import VST.msl.ageable.
Require Import VST.msl.functors.
Require Import VST.msl.predicates_hered.

Import CovariantFunctor.
Import CovariantFunctorLemmas.
Import CovariantFunctorGenerator.

Module Type TY_FUNCTOR_PROP.
  Parameter F : functor.
  Parameter other : Type.
End TY_FUNCTOR_PROP.

Module Type KNOT_HERED.
  Declare Module TF:TY_FUNCTOR_PROP.
  Import TF.

  Parameter knot:Type.
  Parameter ag_knot : ageable knot.
  #[global] Existing Instance ag_knot.
  #[global] Existing Instance ag_prod.
  Parameter ext_knot : Ext_ord knot.
  #[global] Existing Instance ext_knot.
  #[global] Existing Instance Ext_prod.

  Parameter hered : (knot * other -> Prop) -> Prop.
  Definition predicate := { p:knot * other -> Prop | hered p }.

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Parameter approx : nat -> predicate -> predicate.

  Axiom squash_unsquash : forall k:knot, squash (unsquash k) = k.
  Axiom unsquash_squash : forall (n:nat) (f:F predicate),
    unsquash (squash (n,f)) = (n, fmap F (approx n) f).

  Axiom approx_spec : forall n p k,
    proj1_sig (approx n p) k = (level k < n /\ proj1_sig p k).

  Axiom knot_level : forall k:knot, level k = fst (unsquash k).

  Axiom knot_age1 : forall k,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

End KNOT_HERED.

Module KnotHered (TF':TY_FUNCTOR_PROP) : KNOT_HERED with Module TF:=TF'.
  Module TF:=TF'.
  Import TF.

  Definition sinv_prod X := prod X (F X * other -> Prop).

  Definition guppy_sig := (fun T:Type => T * (F T * other -> Prop) -> Prop).
  Definition guppy_ty := sigT guppy_sig.

  Definition guppy_step_ty (Z:guppy_ty) : Type :=
    (sig (fun (x:sinv_prod (projT1 Z)) => projT2 Z x)).

  Definition guppy_step_prop (Z:guppy_ty) (xf:sinv_prod (guppy_step_ty Z)) :=
    forall (k:F (guppy_step_ty Z)) (o:other),
      snd xf (k,o) -> snd (proj1_sig (fst xf)) (fmap F (@fst _ _ oo @proj1_sig _ _) k,o).

  Definition guppy_step (Z:guppy_ty) : guppy_ty :=
    existT guppy_sig (guppy_step_ty Z) (guppy_step_prop Z).

  Definition guppy_base : guppy_ty :=
    existT guppy_sig unit (fun _ => True).

  Fixpoint guppy (n:nat) : guppy_ty :=
    match n with
    | 0    => guppy_base
    | S n' => guppy_step (guppy n')
    end.

  Definition sinv (n:nat) : Type := projT1 (guppy n).
  Definition sinv_prop (n:nat) : prod (sinv n) (F (sinv n) * other -> Prop) -> Prop := projT2 (guppy n).

  Fixpoint floor (m:nat) (n:nat) (p:sinv (m+n)) : sinv n :=
    match m as m' return forall (p : sinv (m'+n)), sinv n with
    | O => fun p => p
    | S m' => fun p => floor m' n (fst (proj1_sig p))
    end p.

  Definition knot := { n:nat & F (sinv n) }.

  Definition k_age1 (k:knot) : option (knot) :=
    match k with
      | (existT _ 0 f) => None
      | (existT _ (S m) f) => Some
          (existT (F oo sinv) m (fmap F (@fst _ _ oo @proj1_sig _ _) f))
    end.

  Definition k_age (k1 k2:knot) := k_age1 k1 = Some k2.

  Definition ko_age1 (x:knot * other) :=
    match k_age1 (fst x) with
    | None => None
    | Some a' => Some (a',snd x)
    end.
  Definition ko_age x y := ko_age1 x = Some y.

  Definition hered := hereditary ko_age.
  Definition predicate := { p:knot * other -> Prop | hereditary ko_age p }.

  Definition app_sinv (n:nat) (p:sinv (S n)) (x:F (sinv n) * other) :=
    snd (proj1_sig p) x.

  Lemma app_sinv_age : forall n (p:sinv (S (S n))) (f:F (sinv (S n)) * other),
    app_sinv (S n) p f ->
    app_sinv n (fst (proj1_sig p)) (fmap F (@fst _ _ oo @proj1_sig _ _) (fst f), snd f).
  Proof.
    intros.
    unfold app_sinv in *.
    destruct p; simpl in *; fold guppy in *.
    apply p; auto.
    destruct f; auto.
  Qed.

  Section stratifies.
    Variable Q:knot * other -> Prop.
    Variable HQ:hereditary ko_age Q.

    Fixpoint stratifies (n:nat) : sinv n -> Prop :=
    match n as n' return sinv n' -> Prop with
    | 0 => fun _ => True
    | S n' => fun (p:sinv (S n')) =>
          stratifies n' (fst (proj1_sig p)) /\
          forall (k:F (sinv n')) (o:other), snd (proj1_sig p) (k,o) <-> Q (existT (F oo sinv) n' k,o)
    end.

    Lemma stratifies_unique : forall n p1 p2,
      stratifies n p1 ->
      stratifies n p2 ->
      p1 = p2.
    Proof.
      induction n; simpl; intuition.
      destruct p1; destruct p2; auto.
      destruct p1; destruct p2.
      simpl in *; fold guppy in *.
      cut (x = x0).
      intros.
      revert p p0 H2 H3.
      rewrite <- H0.
      intros.
      replace p0 with p by (apply proof_irr); auto.
      destruct x; destruct x0; simpl in *.
      apply injective_projections; simpl.
      apply IHn; auto.
      extensionality; intros.
      simpl in *.
      destruct (H2 (fst x) (snd x)); destruct (H3 (fst x) (snd x)).
      apply prop_ext; destruct x; intuition.
    Qed.

    Definition stratify (n:nat) : { x:sinv n | stratifies n x }.
    Proof.
      induction n.
      exists tt; simpl; exact I.
      assert (HX:
        projT2 (guppy n)
        (proj1_sig IHn, fun v : F (sinv n) * other => Q (existT (F oo sinv) n (fst v),snd v))).
      destruct n.
      simpl; exact I.
      simpl; intros.
      destruct IHn; simpl.
      simpl in s; destruct s.
      destruct x; simpl in *; fold guppy in *.
      destruct x; simpl in *.
      hnf; simpl; intros.
      rewrite H0.
      eapply HQ.
      2: apply H1.
      simpl; reflexivity.
      exists ((exist (fun x => projT2 (guppy n) x) ( proj1_sig IHn, fun v:F (sinv n) * other => Q (existT (F oo sinv) n (fst v),snd v) ) HX)).
      simpl; split.
      destruct IHn; auto.
      unfold app_sinv; simpl; intros.
      split; trivial.
    Qed.
  End stratifies.

  Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
  Proof.
    intros x y; revert x; induction y; simpl; intros.
    right; auto with arith.
    destruct (IHy x) as [[m H]|H].
    left; exists (S m); lia.
    destruct (Peano_dec.eq_nat_dec x y).
    left; exists O; lia.
    right; lia.
  Qed.

  Definition unstratify (n:nat) (p:sinv n) : knot * other -> Prop := fun w =>
    match w with (existT _ nw w',o) =>
      match decompose_nat nw n with
        | inleft (existT _ m Hm) => snd (proj1_sig (floor m (S nw) (eq_rect  n _ p (m + S nw) Hm))) (w',o)
        | inright H => False
      end
    end.

  Lemma floor_shuffle:
    forall (m1 n : nat)
      (p1 : sinv (m1 + S n)) (H1 : (m1 + S n) = (S m1 + n)),
      floor (S m1) n (eq_rect (m1 + S n) sinv p1 (S m1 + n) H1) = fst (proj1_sig (floor m1 (S n) p1)).
  Proof.
    intros.
    remember (fst (proj1_sig (floor m1 (S n) p1))) as p.
    fold guppy in *.
    revert n p1 H1 p Heqp.
    induction m1; simpl; intros.
    replace H1 with (refl_equal (S n)) by (apply proof_irr); simpl; auto.
    assert (m1 + S n = S m1 + n) by lia.
    destruct p1 as [[p1 f'] Hp1]; simpl in *; fold guppy in *.
    generalize (IHm1 n p1 H p Heqp).
    clear.
    revert Hp1 H1; generalize H.
    revert p1 f'.
    rewrite H.
    simpl; intros.
    replace H1 with (refl_equal (S (S (m1 + n)))) by (apply proof_irr).
    simpl.
    replace H0 with (refl_equal (S (m1+n))) in H2 by (apply proof_irr).
    simpl in H2.
    trivial.
  Qed.

  Lemma unstratify_hered : forall n p,
    hereditary ko_age (unstratify n p).
  Proof.
    intros.
    hnf; intros k k'; intros.
    simpl in H.
    destruct k.
    destruct k as [x f]. destruct x.
    discriminate.
    destruct k' as [k' o'].
    assert (o = o').
    hnf in H.
    simpl in H.
    inv H. auto.
    subst o'.
    replace k' with
      (existT (F oo sinv) x (fmap F (@fst _ _ oo @proj1_sig _ _ ) f)).
    2: inversion H; auto.
    clear H.
    case_eq (decompose_nat x n); intros.
    destruct s.
    case_eq (decompose_nat (S x) n); intros.
    destruct s.
    destruct n.
    exfalso; lia.
    assert (S x1 = x0) by lia; subst x0.
    revert H0.
    unfold unstratify.
    rewrite H; rewrite H1.
    generalize e e0; revert p; rewrite e0; intros.
    rewrite floor_shuffle.
    replace e2 with (refl_equal (x1 + S (S x))) in H0;
      simpl eq_rect in H0.
    2: apply proof_irr.
    change f with (fst (f,o)).
    change o with (snd (f,o)).
    eapply app_sinv_age; apply H0.

    revert H0.
    unfold unstratify.
    rewrite H; rewrite H1.
    intuition.

    case_eq (decompose_nat (S x) n); intros.
    destruct s.
    exfalso; lia.
    revert H0.
    unfold unstratify.
    rewrite H; rewrite H1; auto.
  Qed.

  Lemma unstratify_Q : forall n (p:sinv n) Q,
    stratifies Q n p ->
    forall (k:knot) o,
      projT1 k < n ->
      (unstratify n p (k,o) <-> Q (k,o)).
  Proof.
    intros.
    unfold unstratify.
    destruct k.
    destruct (decompose_nat x n).
    destruct s.
    simpl in H0.
    2: simpl in *; exfalso; lia.
    clear H0.
    revert p H.
    generalize e.
    rewrite e.
    intros.
    replace e0 with (refl_equal (x0 + S x)) by apply proof_irr.
    simpl.
    clear e e0.
    revert p H.
    induction x0; simpl; intros.
    destruct H.
    auto.
    destruct H.
    apply IHx0.
    auto.
  Qed.

  Lemma stratifies_unstratify_more :
    forall (n m1 m2:nat) (p1:sinv (m1+n)) (p2:sinv (m2+n)),
      floor m1 n p1 = floor m2 n p2 ->
      (stratifies (unstratify (m1+n) p1) n (floor m1 n p1) ->
       stratifies (unstratify (m2+n) p2) n (floor m2 n p2)).
  Proof.
    induction n; intuition.
    split.
    assert (m2 + S n = S m2 + n) by lia.
    erewrite <- floor_shuffle.
    instantiate (1:=H1).
    replace (unstratify (m2 + S n) p2)
      with (unstratify (S m2 + n) (eq_rect (m2 + S n) sinv p2 (S m2 + n) H1)).
    assert (m1 + S n = S m1 + n) by lia.
    eapply (IHn (S m1) (S m2)
      (eq_rect (m1 + S n) sinv p1 (S m1 + n) H2)).
    rewrite floor_shuffle.
    rewrite floor_shuffle.
    rewrite H; auto.
    clear - H0.
    rewrite floor_shuffle.
    simpl in H0.
    destruct H0.
    clear H0.
    revert p1 H.
    generalize H2.
    rewrite <- H2.
    intros.
    replace H0 with (refl_equal (m1 + S n)) by apply proof_irr; auto.
    clear.
    revert p2.
    generalize H1.
    rewrite H1.
    intros.
    replace H0 with (refl_equal (S m2 + n)) by apply proof_irr; auto.

    intros.
    simpl.
    destruct (decompose_nat n (m2 + S n)).
    destruct s.
    assert (m2 = x).
    lia.
    subst x.
    replace e with (refl_equal (m2 + S n)).
    simpl; tauto.
    apply proof_irr.
    exfalso; lia.
  Qed.

  Lemma stratify_unstratify : forall n p H,
    proj1_sig (stratify (unstratify n p) H n) = p.
  Proof.
    intros.
    apply stratifies_unique with (unstratify n p).
    destruct (stratify _ H n).
    simpl; auto.
    clear H.
    revert p; induction n.
    simpl; intros; auto.
    intros.
    simpl; split.

    assert (stratifies (unstratify n (fst (proj1_sig p))) n (fst (proj1_sig p))).
    apply IHn.
    apply (stratifies_unstratify_more n 0 1 (fst (proj1_sig p)) p).
    simpl; auto.
    auto.

    intros.
    destruct (decompose_nat n (S n)).
    destruct s.
    assert (x = 0) by lia.
    subst x.
    simpl.
    simpl in e.
    replace e with (refl_equal (S n)) by apply proof_irr.
    simpl.
    split; auto.
    exfalso; lia.
  Qed.

  Definition strat (n:nat) (p:predicate) : sinv n :=
    proj1_sig (stratify (proj1_sig p) (proj2_sig p) n).

  Definition unstrat (n:nat) (p:sinv n) : predicate :=
    exist (hereditary ko_age) (unstratify n p) (unstratify_hered n p).

  Definition squash (x:nat * F predicate) : knot :=
    match x with (n,f) => existT (F oo sinv) n (fmap F (strat n) f) end.

  Definition unsquash (k:knot) : nat * F predicate :=
    match k with existT _ n f => (n, fmap F (unstrat n) f) end.

  Definition level (x:knot) : nat := fst (unsquash x).
  Program Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => level (fst w) < n /\ p w.
  Next Obligation.
    hnf; simpl; intros.
    intuition.
    unfold ko_age, ko_age1 in H.
    destruct (k_age1 (fst a)) eqn: Hage; inv H; simpl.
    assert (level k < level (fst a)); [|lia].
    unfold level, unsquash.
    destruct a as ((n', ?), ?); simpl in *.
    destruct n'; inv Hage; simpl in *; lia.
    destruct p; simpl in *.
    eapply h; eauto.
  Qed.

  Lemma strat_unstrat : forall n,
    strat n oo unstrat n = id (sinv n).
  Proof.
    intros; extensionality p.
    unfold compose, id.
    unfold strat, unstrat.
    simpl.
    rewrite stratify_unstratify.
    auto.
  Qed.

  Lemma predicate_eq : forall (p1 p2:predicate),
    proj1_sig p1 = proj1_sig p2 ->
    p1 = p2.
  Proof.
    intros; destruct p1; destruct p2; simpl in H.
    subst x0.
    replace h0 with h by apply proof_irr.
    auto.
  Qed.

  Lemma unstrat_strat : forall n,
    unstrat n oo strat n = approx n.
  Proof.
    intros.
    extensionality.
    unfold compose.
    unfold unstrat, strat.
    unfold approx.
    apply predicate_eq.
    simpl.
    extensionality k.
    apply prop_ext; intuition.
    unfold unstratify in H.
    destruct a.
    destruct (decompose_nat x0 n).
    unfold level.
    simpl.
    destruct s.
    lia.
    elim H.
    rewrite <- unstratify_Q.
    apply H.
    destruct (stratify (proj1_sig x) (proj2_sig x) n); auto.
    unfold unstratify in H.
    destruct a; simpl.
    destruct (decompose_nat x0 n).
    destruct s; lia.
    elim H.
    rewrite unstratify_Q.
    apply H1.
    destruct (stratify (proj1_sig x) (proj2_sig x) n); auto.
    unfold level in H0.
    destruct a; simpl in *.
    auto.
  Qed.

  Lemma squash_unsquash : forall k, squash (unsquash k) = k.
  Proof.
    intros.
    destruct k as [x f]; simpl.
    f_equal.
    change ((fmap F (strat x) oo fmap F (unstrat x)) f = f).
    rewrite fmap_comp.
    rewrite strat_unstrat.
    rewrite fmap_id.
    auto.
  Qed.

  Lemma unsquash_squash : forall n f,
    unsquash (squash (n,f)) = (n, fmap F (approx n) f).
  Proof.
    intros.
    unfold unsquash, squash.
    f_equal.
    change ((fmap F (unstrat n) oo fmap F (strat n)) f = fmap F (approx n) f).
    rewrite fmap_comp.
    rewrite unstrat_strat.
    auto.
  Qed.

  Lemma strat_unstrat_Sx : forall x,
    @fst _ _ oo @proj1_sig _ _ = strat x oo unstrat (S x).
  Proof.
    intros.
    extensionality k.
    change (sinv (S x)) in k.
    unfold compose.
    unfold strat, unstrat.
    simpl.
    apply stratifies_unique with (unstratify x (fst (proj1_sig k))).
    revert k; induction x; simpl; auto.
    intros.
    split.
    eapply (stratifies_unstratify_more x 0 1 ).
    simpl; reflexivity.
    simpl.
    apply IHx.
    intros.
    destruct (decompose_nat x (S x)).
    destruct s.
    assert (x0 = 0) by lia; subst x0.
    simpl in *.
    replace e with (refl_equal (S x)) by apply proof_irr; simpl.
    tauto.
    exfalso; lia.
    destruct (stratify (unstratify (S x) k)
      (unstratify_hered (S x) k) x).
    simpl; auto.
    cut (x0 = (fst (proj1_sig k))); intros.
    subst x0.
    eapply (stratifies_unstratify_more x 1 0).
    simpl; reflexivity.
    simpl; auto.
    eapply stratifies_unique.
    apply s.
    eapply (stratifies_unstratify_more x 0 1).
    simpl; reflexivity.
    simpl.
    generalize (fst (proj1_sig k) : sinv x).
    clear.
    induction x; simpl; intuition.
    eapply (stratifies_unstratify_more x 0 1).
    simpl; reflexivity.
    simpl.
    apply IHx.
    destruct (decompose_nat x (S x)).
    destruct s0.
    assert (x0 = 0) by lia; subst.
    simpl in *.
    replace e with (refl_equal (S x)); simpl; auto.
    apply proof_irr.
    lia.
    destruct (decompose_nat x (S x)).
    destruct s0.
    assert (x0 = 0) by lia; subst.
    simpl in *.
    replace e with (refl_equal (S x)) in H; simpl; auto.
    apply proof_irr.
    elim H.
  Qed.

  Lemma unsquash_inj : forall k k',
    unsquash k = unsquash k' -> k = k'.
  Proof.
    intros.
    rewrite <- (squash_unsquash k).
    rewrite <- (squash_unsquash k').
    congruence.
  Qed.

  Lemma knot_age_age1 : forall k k',
    k_age1 k = Some k' <->
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end = Some k'.
  Proof.
    split; intros.
    unfold k_age1 in H.
    unfold unsquash in H.
    destruct k as [x f].
    destruct x; auto.
    inv H.
    simpl.
    f_equal.
    f_equal.
    change (fmap F (strat x) (fmap F (unstrat (S x)) f))
      with ((fmap F (strat x) oo fmap F (unstrat (S x))) f).
    rewrite fmap_comp.
    simpl.
    f_equal.
    symmetry.
    apply (strat_unstrat_Sx x).

    simpl in H.
    destruct k.
    destruct x.
    discriminate.
    inv H.
    hnf; simpl.
    unfold k_age1.
    f_equal.
    f_equal.
    rewrite strat_unstrat_Sx.
    rewrite <- fmap_comp.
    auto.
  Qed.

  #[global] Program Instance ag_knot : ageable knot :=
  { age1 := k_age1
  ; level := level
  }.
  Next Obligation.
    econstructor.
    (* unage *)
    intros.
    destruct (unsquash x') as [n f] eqn:?H; intros.
    exists (squash (S n, f)).
    rewrite knot_age_age1.
    rewrite unsquash_squash.
    f_equal.
    apply unsquash_inj.
    rewrite unsquash_squash.
    rewrite H.
    f_equal.
    cut (f = fmap F (approx n) f).
    intros.
    rewrite fmap_app.
    pattern f at 2. rewrite H0.
    f_equal.
    extensionality p.
    apply predicate_eq.
    extensionality w.
    simpl. apply prop_ext.
    intuition.
    generalize H; intro.
    rewrite <- (squash_unsquash x') in H.
    rewrite H0 in H.
    rewrite unsquash_squash in H.
    congruence.

    (* level 0 *)
    intro x. destruct x; simpl.
    destruct x; intuition; discriminate.

    (* level S *)
    intros. destruct x; simpl in *.
    destruct x. discriminate.
    inv H. simpl. auto.
  Qed.

  #[global] Existing Instance ag_prod.

  Lemma approx_spec : forall n p (k:knot * other),
    proj1_sig (approx n p) k = (ageable.level k < n /\ proj1_sig p k).
  Proof.
    intros.
    apply prop_ext.
    unfold approx; simpl.
    intuition; simpl in *; auto.
  Qed.

  Lemma knot_level : forall k:knot, level k = fst (unsquash k).
  Proof. reflexivity. Qed.

  Lemma knot_age1 : forall k,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.
  Proof.
    intros. simpl.
    case_eq (k_age1 k). intros.
    rewrite knot_age_age1 in H.
    auto.
    destruct k; simpl. destruct x. auto.
    intros. discriminate.
  Qed.

  #[export] Program Instance ext_knot : Ext_ord knot := { ext_order := eq }.
  Next Obligation.
  Proof.
    intros ?????; subst; eauto.
  Qed.
  Next Obligation.
  Proof.
    eauto.
  Qed.

End KnotHered.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Utils Require Import utils.
From MetaCoq.Template Require Import All.
From MetaCoq.Translations Require Import translation_utils.
Import MCMonadNotation.

Local Infix "<=" := Nat.leb.

Definition default_term   := tVar "constant_not_found".
Definition debug_term msg := tVar ("debug: " ^ msg).

Fixpoint tsl_rec0 (n : nat) (o : nat) (t : term) {struct t} : term :=
  match t with
  | tRel k => if n <= k then (* global variable *) tRel (3 * (k - n) + n + o)
                        else (* local  variable *) t
  | tEvar k ts   => tEvar k (map (tsl_rec0 n o) ts)
  | tCast t c a  => tCast (tsl_rec0 n o t) c (tsl_rec0 n o a)
  | tProd na A B => tProd na (tsl_rec0 n o A) (tsl_rec0 (n+1) o B)
  | tLambda na A t  => tLambda na (tsl_rec0 n o A) (tsl_rec0 (n+1) o t)
  | tLetIn na t A u => tLetIn na (tsl_rec0 n o t) (tsl_rec0 n o A) (tsl_rec0 (n+1) o u)
  | tApp t lu       => tApp (tsl_rec0 n o t) (map (tsl_rec0 n o) lu)
  | tCase ik t u br => tCase ik (map_predicate_k id (fun k => tsl_rec0 n k) o t) (tsl_rec0 n o u)
                            (map_branches_k (fun x => tsl_rec0 n x) o br)
  | tProj p t => tProj p (tsl_rec0 n o t)
  (* | tFix : mfixpoint term -> nat -> term *)
  (* | tCoFix : mfixpoint term -> nat -> term *)
  | _ => t
  end.

Definition suffix0 (n : name) s : name :=
  match n with
  | BasicAst.nAnon     => BasicAst.nAnon
  | BasicAst.nNamed id => BasicAst.nNamed (id ^ s)
  end.

Definition nAnon := {| binder_name := BasicAst.nAnon; binder_relevance := Relevant |}.
Definition nNamed n := {| binder_name := BasicAst.nNamed n; binder_relevance := Relevant |}.

Definition suffix na n := map_binder_annot (fun na => suffix0 na n) na.

Fixpoint apply (app : list term) (t : term) :=
  match app with
  | t' :: app =>  apply app (mkApp t (t' {3 := tRel 1} {2 := tRel 0}))
  | [] => t
  end.

Fixpoint tsl_rec1_app (app : list term) (E : tsl_table) (t : term) : term :=
  let tsl_rec1 := tsl_rec1_app [] in
  let debug case symbol :=
      debug_term ("tsl_rec1: " ^ case ^ " " ^ symbol ^ " not found") in
  match t with
  | tLambda na A t =>
      let A0 := tsl_rec0 0 2 A in
      let A1 := tsl_rec1 E A in

      tLambda (suffix na "₁") A0
        (tLambda (suffix na "₂") A0
          (tLambda (tsl_name tsl_ident na)
            (subst_app (lift0 2 A1) [tRel 1; tRel 0])
            (tsl_rec1_app (map (lift 3 3) app) E t)))

  | _ => let t1 :=
  match t with
  | tSort s =>
      tLambda (nNamed "x₁") (tSort s)
        (tLambda (nNamed "x₂") (tSort s)
          (tProd nAnon (tRel 1) (tProd nAnon (tRel 1) (tSort s))))

  | tRel k => tRel (3 * k)

  | tProd na A B =>
      let A0 := tsl_rec0 0 2 A in
      let B0 := tsl_rec0 1 2 B in
      let A1 := tsl_rec1 E A in
      let B1 := tsl_rec1 E B in
      let ΠAB0 := tProd na A0 B0 in

      tLambda (nNamed "f₁") ΠAB0
        (tLambda (nNamed "f₂") ΠAB0
          (tProd (suffix na "₁") (lift0 2 A0)
            (tProd (suffix na "₂") (lift0 2 A0)
              (tProd (tsl_name tsl_ident na)
                (subst_app (lift0 4 A1) [tRel 1; tRel 0])
                (subst_app (lift 2 3 B1) [tApp (tRel 4) [tRel 2]; tApp (tRel 3) [tRel 1]])))))

  | tApp t us =>
      let us' := concat (map (fun v => [tsl_rec0 0 2 v; tsl_rec0 0 1 v; tsl_rec1 E v]) us) in
      mkApps (tsl_rec1 E t) us'

  | tCast t c A =>
      let t0 := tsl_rec0 0 2 t in
      let t1 := tsl_rec1 E t in
      let A0 := tsl_rec0 0 2 A in
      let A1 := tsl_rec1 E A in
      tCast t1 c (mkApps A1 [tCast t0 c A0])

  | tConst s univs =>
    match lookup_tsl_table E (ConstRef s) with
    | Some t => t
    | None => debug "tConst" (string_of_kername s)
    end

  | tInd i univs =>
    match lookup_tsl_table E (IndRef i) with
    | Some t => t
    | None => debug "tInd" (match i with mkInd s _ => string_of_kername s end)
    end

  | tConstruct i n univs =>
    match lookup_tsl_table E (ConstructRef i n) with
    | Some t => t
    | None => debug "tConstruct" (match i with mkInd s _ => string_of_kername s end)
    end

  | tCase ik t u brs as case =>
    case
    (* todo "case", but probably already wrong before
      let brs' := (map_branches_k (fun x => lift x 0) 1 brs) in
    let case1 := tCase ik (map_predicate_k id (fun x => lift x 0) 3 t) (tRel 2) brs' in
    let case2 := tCase ik (map_predicate_k id (fun x => lift x 0) 3 t) (tRel 1) brs' in
       match lookup_tsl_table E (IndRef ik.(ci_ind)) with
      | Some (tInd i _univ) =>
        let ci' := {| ci_ind := i; ci_npar := 3 * ci.(ci_npar); ci_relevance := ci.(ci_relevance) |} in
        tCase ci'
              (tsl_rec1_app [tsl_rec0 0 2 case1; tsl_rec0 0 1 case2] E t)
              (tsl_rec1 E u)
              (map (on_snd (tsl_rec1 E)) brs)
      | _ => debug "tCase" (match ik.(ci_ind) with mkInd s _ => string_of_kername s end)
      end*)

  | tLetIn na t A u =>
    let t0 := tsl_rec0 0 2 t in
    let A0 := tsl_rec0 0 2 A in
    let t1 := tsl_rec1 E t in
    let A1 := tsl_rec1 E A in
    let u1 := tsl_rec1 E u in
    tLetIn (suffix na "₁") t0 A0 (
      tLetIn (suffix na "₂") (lift0 1 t0) (lift0 1 A0) (
        tLetIn (tsl_name tsl_ident na) (lift0 2 t1)
          (subst_app (lift0 2 A1) [tRel 1; tRel 0]) u1))

  | tProj _ _ => todo "tsl"
  | tFix _ _ | tCoFix _ _ => todo "tsl"
  | tVar _ | tEvar _ _ => todo "tsl"
  | tLambda _ _ _ => tVar "impossible"
  | tInt _ | tFloat _ => todo "tsl"
  end
  in apply app t1
  end.

Definition tsl_rec1 := tsl_rec1_app [].

Definition tsl_mind_body (E : tsl_table) (mp : modpath) (kn : kername)
           (mind : mutual_inductive_body) : tsl_table * list mutual_inductive_body.
  refine (_, [{| ind_npars := 3 * mind.(ind_npars);
                 ind_params := _;
                 ind_bodies := _;
                 ind_universes := mind.(ind_universes);
                 ind_variance := mind.(ind_variance)|}]).  (* FIXME always ok? *)
  - refine (let kn' : kername := (mp, tsl_ident kn.2) in
            fold_left_i (fun E i ind => _ :: _ ++ E) mind.(ind_bodies) []).
    + (* ind *)
      exact (IndRef (mkInd kn i), tInd (mkInd kn' i) []).
    + (* ctors *)
      refine (fold_left_i (fun E k _ => _ :: E) ind.(ind_ctors) []).
      exact (ConstructRef (mkInd kn i) k, tConstruct (mkInd kn' i) k []).
  - exact mind.(ind_finite).
  - (* params: 2 times the same parameters? Probably wrong *)
    refine (mind.(ind_params) ++ mind.(ind_params) ++ mind.(ind_params)).
  - refine (mapi _ mind.(ind_bodies)).
    intros i ind.
    refine {| ind_name := tsl_ident ind.(ind_name);
              ind_indices := ind.(ind_indices);
              ind_sort := ind.(ind_sort);
              ind_type := _;
              ind_kelim := ind.(ind_kelim);
              ind_ctors := _;
              ind_projs := [];
              ind_relevance := ind.(ind_relevance) |}. (* UGLY HACK!!! todo *)
    + (* arity  *)
      refine (let ar := subst_app (tsl_rec1 E ind.(ind_type))
                                  [tInd (mkInd kn i) []; tInd (mkInd kn i) []] in
              ar).
    + (* constructors *)
      refine (mapi _ ind.(ind_ctors)).
      intros k [name args indices type arity].
      econstructor.
      refine (tsl_ident name).
      refine args.
      refine indices.
      refine (subst_app _ [tConstruct (mkInd kn i) k []; tConstruct (mkInd kn i) k []]).
      refine (fold_left_i (fun t0 i u => t0 {S i := u} {S i := u}) _ (tsl_rec1 E type)).
      (* [I_0; ... I_(n-1)] *)

      refine (rev (mapi (fun i _ => tInd (mkInd kn i) [])
                              mind.(ind_bodies))).
      refine (3 * arity)%nat.

Defined.

#[global]
Instance param : Translation :=
  {| tsl_id := tsl_ident ;
     tsl_tm := fun ΣE t => ret (tsl_rec1 (snd ΣE) t) ;
     (* Implement and Implement Existing cannot be used with this translation *)
     tsl_ty  := None ;
     tsl_ind := fun ΣE mp kn mind => ret (tsl_mind_body (snd ΣE) mp kn mind) |}.

(* EXAMPLES *)

MetaCoq Run (
  typ <- tmQuote (forall A, A -> A) ;;
  typ' <- tmEval all (tsl_rec1 [] typ) ;;
  tm <- tmQuote (fun A (x : A) => x) ;;
  tm' <- tmEval all (tsl_rec1 [] tm) ;;
  tmUnquote (tApp typ' [tm; tm]) >>= tmDebug ;;
  tmUnquote tm' >>= tmDebug
).

Set Warnings "-unexpected-implicit-declaration".
MetaCoq Run (
  typ <- tmQuote (forall A B, B -> (A -> B -> B) -> B) ;;
  typ' <- tmEval all (tsl_rec1 [] typ) ;;
  t   <- tmQuote (fun {A B} (x:B) (f : A -> B -> B) => x) ;;
  t'  <- tmEval all (tsl_rec1 [] t) ;;
  tmUnquote (tApp typ' [t; t]) >>= tmDebug
).

MetaCoq Run (TC <- Translate emptyTC "nat" ;;
                     tmDefinition "nat_TC" TC).

MetaCoq Run (TC <- Translate nat_TC "bool" ;;
                     tmDefinition "bool_TC" TC).

MetaCoq Run (TC <- Translate bool_TC "list" ;;
                     tmDefinition "list_TC" TC).

Module FreeTheorems.

  Definition HD := forall X, list X -> X.
  MetaCoq Run (Translate list_TC "HD").

  Definition MAP := forall X, list X -> list X.
  MetaCoq Run (Translate list_TC "MAP").

  (* taken from coq-community/paramcoq *)
  Definition graph {A B} (f : A -> B) := fun x y => f x = y.
  Definition map_rel {A B} (f : A -> B) := listᵗ A B (graph f).

  Definition map_rel_map A B (f : A -> B) :
    forall (l : list A), map_rel f l (map f l).
  induction l; constructor; compute; auto.
  Defined.

  Lemma rel_map_map A B (f : A -> B) :
    forall (l : list A) fl, map_rel f l fl -> fl = map f l.
  intros l fl H. induction H; unfold graph in *; subst; auto.
  Defined.

  Definition FREE_THEOREM (F : MAP) :=
    forall A B (f : A -> B) l,
      F B (map f l) = map f (F A l).

  Lemma param_map :
    forall F (H : MAPᵗ F F), FREE_THEOREM F.
  Proof.
    repeat intro.
    apply rel_map_map.
    apply H.
    apply map_rel_map.
  Qed.

End FreeTheorems.


Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.Adequacy.
Require Import UFO.Rel.Compatability.
Require Import UFO.Rel.Parametricity.
Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Static.
Require Import UFO.Lang.StaticFacts.
Require Import UFO.Lang.Xs.
Require Import UFO.Lang.SigFacts.
Require Import UFO.Lang.Context.
Require Import FunctionalExtensionality.

Implicit Types EV LV V L : Set.

Section section_congruence.

Hint Resolve ok_wf_lbl ok_wf_ty ok_wf_eff ok_wf_tm.
Hint Resolve XLEnv_inv_wf_XEnv.
Hint Resolve EV_map_XLEnv LV_map_XLEnv.
Hint Unfold compose.

Fixpoint
congruence_tm n EV LV V L (t₁ t₂ : tm EV LV V L)
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) (T0 : ty0)
C (OK_C : ok_ctx C Γ Π T E T0) {struct OK_C} :
n ⊨ 【 Π Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E 】 →
n ⊨ 【 LEnv_empty ∅→ ⊢ (ctx_plug C t₁) ≼ˡᵒᵍ (ctx_plug C t₂) : T0 # [] 】
with
congruence_md n EV LV V L (m₁ m₂ : md EV LV V L)
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(β : L) (σ : ms ∅ EV LV L) (T0 : ty0)
D (OK_D : ok_dtx D Γ Π β σ T0) {struct OK_D} :
n ⊨ 【 Π Γ ⊢ m₁ ≼ˡᵒᵍₘ m₂ : σ ^ (lbl_id (lid_b β)) 】 →
n ⊨ 【 LEnv_empty ∅→ ⊢ (dtx_plug D m₁) ≼ˡᵒᵍ (dtx_plug D m₂) : T0 # [] 】
.
Proof.
{
intro H.
destruct OK_C as [ | ???? D ???????? OK_D | ???? C | ???? C ?? T E | ???? C |
  ???? C t ??????? OK_t | ???? C s ??????? OK_s | ???? C s ???????? OK_s |
  ???? C t ???????? OK_t | ???? C E₁ | ???? C ℓ₁ |
  ???? C s ???????? OK_s | ???? C t ???????? OK_t | ???? C
] ; (simpl ctx_plug || simpl dtx_plug).
+ apply H ; rewrite empty_def ; try rewrite keys_def ;
    try rewrite map_nil ; simpl ; shelve.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; destruct (f β) as [|X] eqn:EQ_fβ ; [auto|].
  eapply compat_md_res ; [ eauto using LEnv_lookup_inv_binds | ].
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; crush.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ.
  iespecialize H ; ispecialize H ; [exact HΞΠ|].
  simpl L_bind_ty ; simpl L_bind_tm.
  rewrite L_bind_it_msig.
  apply compat_tm_op.
  apply H.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ.
  iespecialize H ; ispecialize H ; [exact HΞΠ|].
  simpl ; rewrite <- L_bind_eff_app.
  apply compat_tm_up ; exact H.
+ eapply congruence_tm ; try exact OK_C.
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ ; simpl.
  eapply compat_tm_down ; [intro;eauto|eauto|eauto|eauto|].
  intros X FrX.
  ispecialize H (Ξ & X ~ (L_bind_ty f T, L_bind_eff f E)).
  ispecialize H (env_ext f (lid_f X)).
  ispecialize H.
  { iintro_prop ; constructor ; eauto. }
  simpl in H.
  unshelve erewrite L_bind_map_ty, L_map_ty_id in H ; [eauto|eauto| |eauto|].
  unshelve erewrite L_bind_map_eff, L_map_eff_id in H ; [eauto|eauto| |eauto|].
  repeat erewrite L_bind_bind_tm with (g := env_ext f (lid_f X)).
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  { extensionality x ; unfold compose.
    unshelve erewrite L_bind_map_ty, L_map_ty_id ; eauto.
    intro ; erewrite L_map_lid_id ; eauto.
  }
  { intro α ; destruct α ; simpl ; [auto|].
    unshelve erewrite L_bind_map_lid, L_map_lid_id, L_bind_lid_id ; auto.
  }
  { intro α ; destruct α ; simpl ; [auto|].
    unshelve erewrite L_bind_map_lid, L_map_lid_id, L_bind_lid_id ; auto.
  }
  { intro ; erewrite L_map_lid_id ; auto. }
  { intro ; erewrite L_map_lid_id ; auto. }
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; eapply compat_tm_let ; [|exact H].
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | ].
  eapply ok_wf_tm in OK_t ; [|eauto].
  match goal with
  | [ H : wf_tm ?Ξ ?Γ ?t ?T ?E |- wf_tm ?Ξ ?Γ' ?t ?T ?E ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; crush.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; apply compat_tm_let with (S := L_bind_ty f S).
  { match goal with
    | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
      replace Γ' with Γ ; [ exact H | ]
    end.
    extensionality x ; crush.
  }
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | eauto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; eapply compat_tm_throw ; [exact H|].
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | eauto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; eapply compat_tm_throw ; [|exact H].
  apply SI_LN_parametricity_tm ; [ eauto | intro ; eauto | ].
  eapply ok_wf_tm in OK_t ; eauto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  erewrite <- EV_L_bind_ms ; [ eapply compat_tm_app_eff ; exact H | auto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  erewrite <- LV_L_bind_ms ; [ eapply compat_tm_app_lbl ; eauto | auto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  eapply compat_tm_app_tm ; [exact H|].
  eapply SI_LN_parametricity_tm ; [eauto|intro ; eauto|eauto].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  eapply compat_tm_app_tm ; [|exact H].
  eapply SI_LN_parametricity_tm ; [eauto|intro ; eauto|].
  eapply ok_wf_tm in OK_t ; eauto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  eapply compat_sub with (E := L_bind_eff f E1) ; eauto using subty_st, L_bind_se.
}
{
intro H.
destruct OK_D as [ ???? C ????? OK_C | ???? D ????? OK_D |
  ???? D ????? OK_D | ???? D ?????? OK_D ] ; (simpl ctx_plug || simpl dtx_plug).
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_tm_val.
  destruct (f β) as [α|X] eqn:EQ_fβ ; simpl in H|-* ; [destruct α|].
  apply compat_val_md ; apply H.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_md_ev.
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; auto using L_bind_EV_map_ty.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_md_lv.
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; auto using L_bind_LV_map_ty.
+ eapply congruence_md ; [exact OK_D|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  apply compat_md_tm.
  match goal with
  | [ H : ?n ⊨ ⟦ _ ?Γ ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ |- ?n ⊨ ⟦ _ ?Γ' ⊢ _ ≼ˡᵒᵍₘ _ : _ ^ _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; auto.
}
Qed.

End section_congruence.

Section section_soundness.

Hint Rewrite dom_empty union_empty_l Xs_ctx_plug.

Theorem soundness EV LV V L (t₁ t₂ : tm EV LV V L) (Closed_t₁ : Xs_tm t₁ = \{})
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) :
⊨ 【 Π Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E 】 →
【 Π Γ ⊢ t₁ ≼ᶜᵗˣ t₂ : T # E 】.
Proof.
intro Ht.
intros C T0 OK_C Closed_C.
eapply adequacy ; [ | crush ].
intro n.
eapply congruence_tm with (n := n) in Ht as HCt ; [|exact OK_C].
iespecialize HCt.
ispecialize HCt ; [ iintro_prop ; constructor | ].
erewrite L_bind_tm_id, L_bind_tm_id, L_bind_ty_id, L_bind_eff_id in HCt ;
  [|auto|auto|auto|auto].
replace (L_bind_ty ∅→ ∘ ∅→) with (∅→ : ∅ → ty0) in HCt ; [|extensionality x ; auto].
exact HCt.
Qed.

Fact unfold_log_eq_I_valid EV LV V L (t₁ t₂ : tm EV LV V L)
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) :
(⊨ 【 Π Γ ⊢ t₁ ≈ˡᵒᵍ t₂ : T # E 】) →
(⊨ 【 Π Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # E 】) ∧ (⊨ 【 Π Γ ⊢ t₂ ≼ˡᵒᵍ t₁ : T # E 】).
Proof.
intro H ; split ; intro n ; specialize (H n) ; idestruct H as H1 H2 ; assumption.
Qed.

Theorem soundness_eq EV LV V L (t₁ t₂ : tm EV LV V L)
(Closed_t₁ : Xs_tm t₁ = \{}) (Closed_t₂ : Xs_tm t₂ = \{})
(Π : LEnv EV LV L) (Γ : V → ty ∅ EV LV L)
(T : ty ∅ EV LV L) (E : eff ∅ EV LV L) :
⊨ 【 Π Γ ⊢ t₁ ≈ˡᵒᵍ t₂ : T # E 】 →
【 Π Γ ⊢ t₁ ≈ᶜᵗˣ t₂ : T # E 】.
Proof.
intro H.
apply unfold_log_eq_I_valid in H ; destruct H as [H1 H2].
split ; apply soundness ; assumption.
Qed.

End section_soundness.