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

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

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

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Require Import PromiseConsistent.
Require Import Trace.
Require Import MemoryProps.
Require Import JoinedView.

Require Import PFStep.
Require Import OrdStep.
Require Import RAStep.
Require Import Stable.
Require Import PFtoRASimThread.
Require Import PFtoRAThread.

Set Implicit Arguments.

Module PFtoRA.
  Section PFtoRA.
    Variable L: Loc.t -> bool.

    (* well-formedness *)

    Inductive wf_pf (c: Configuration.t): Prop :=
    | wf_pf_intro
        (WF: Configuration.wf c)
        (PF: PF.pf_configuration L c)
    .

    Definition wf_j := JConfiguration.wf.

    Inductive wf_ra (rels: ReleaseWrites.t) (c: Configuration.t): Prop :=
    | wf_ra_intro
        (WF: Configuration.wf c)
        (RELS: forall tid lang st lc
                 (TH: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)),
            ReleaseWrites.wf rels (Local.promises lc) (Configuration.memory c))
    .

    Lemma wf_pf_thread
          c tid lang st lc
          (WF: wf_pf c)
          (FIND: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)):
      PFtoRAThread.wf_pf (Thread.mk _ st lc (Configuration.sc c) (Configuration.memory c)).
    Proof.
      inv WF. inv WF0. inv WF.
      hexploit THREADS; eauto. i.
      econs; eauto.
    Qed.

    Lemma wf_j_thread
          views c tid lang st lc
          (WF: wf_j views c)
          (FIND: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)):
      PFtoRAThread.wf_j views (Thread.mk _ st lc (Configuration.sc c) (Configuration.memory c)).
    Proof.
      inv WF. inv WF0. inv WF.
      hexploit THREADS; eauto. i.
      hexploit REL; eauto. i.
      econs; eauto.
    Qed.

    Lemma wf_ra_thread
          rels c tid lang st lc
          (WF: wf_ra rels c)
          (FIND: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)):
      PFtoRAThread.wf_ra rels (Thread.mk _ st lc (Configuration.sc c) (Configuration.memory c)).
    Proof.
      inv WF. inv WF0. inv WF.
      hexploit THREADS; eauto. i.
      hexploit RELS; eauto. i.
      econs; eauto.
    Qed.

    Lemma step_pf_future
          e tid c1 c2
          (WF1: wf_pf c1)
          (STEP: PFConfiguration.step L e tid c1 c2):
      <<WF2: wf_pf c2>>.
    Proof.
      exploit PFConfiguration.step_future; eauto; try apply WF1. i. des. ss.
    Qed.

    Lemma step_j_future
          e tid c1 c2 views1 views2
          (WF1: wf_j views1 c1)
          (STEP: JConfiguration.single_step e tid c1 c2 views1 views2):
      <<WF2: wf_j views2 c2>>.
    Proof.
      eapply JConfiguration.single_step_future; eauto.
    Qed.

    Lemma step_ra_future
          e tid rels1 rels2 c1 c2
          (WF1: wf_ra rels1 c1)
          (STEP: RAConfiguration.step L e tid rels1 rels2 c1 c2):
      <<WF2: wf_ra rels2 c2>>.
    Proof.
      exploit RAConfiguration.step_future; try eapply WF1; eauto. i. des.
      inv STEP. ss.
      assert (STEPS': RAThread.steps L rels1 rels2
                                     (Thread.mk _ st1 lc1 (Configuration.sc c1) (Configuration.memory c1))
                                     (Thread.mk _ st4 lc4 sc4 memory4)).
      { exploit RAThread.tau_steps_steps;
          try eapply RAThread.cancel_steps_tau_steps; try exact CANCELS. i.
        exploit RAThread.opt_step_steps; try exact STEP0. i.
        exploit RAThread.tau_steps_steps;
          try eapply RAThread.reserve_steps_tau_steps; try exact RESERVES. i.
        eapply RAThread.steps_trans; [eauto|].
        eapply RAThread.steps_trans; eauto. }
      exploit wf_ra_thread; eauto. i.
      hexploit RAThread.steps_rels_wf; try exact STEPS'; try apply x1. s. i.
      econs; ss. i. Configuration.simplify; ss.
      exploit wf_ra_thread; try eapply TH; eauto. i.
      inv WF1. inv WF. inv WF0.
      exploit DISJOINT; try exact n; eauto. i.
      hexploit RAThread.steps_rels_disjoint; try exact x; eauto. apply x1.
    Qed.

    Lemma steps_pf_future
          c1 c2
          (WF1: wf_pf c1)
          (STEPS: rtc (PFConfiguration.all_step L) c1 c2):
      <<WF2: wf_pf c2>>.
    Proof.
      exploit PFConfiguration.rtc_all_step_future; try apply WF1; eauto. i. des.
      econs; ss.
    Qed.

    Lemma steps_j_future
          c1 c2 views1 views2
          (WF1: wf_j views1 c1)
          (STEPS: JConfiguration.single_steps c1 c2 views1 views2):
      <<WF2: wf_j views2 c2>>.
    Proof.
      eapply JConfiguration.single_steps_future; eauto.
    Qed.

    Lemma steps_ra_future
          rels1 rels2 c1 c2
          (WF1: wf_ra rels1 c1)
          (STEPS: RAConfiguration.steps L rels1 rels2 c1 c2):
      <<WF2: wf_ra rels2 c2>>.
    Proof.
      revert WF1. induction STEPS; i; ss.
      exploit step_ra_future; eauto.
    Qed.

    (* sim *)

    Inductive sim_thread_sl (views: Loc.t -> Time.t -> list View.t) (rels: ReleaseWrites.t)
              (sc_pf sc_j sc_ra: TimeMap.t) (mem_pf mem_j mem_ra: Memory.t):
      forall (sl_pf sl_j sl_ra: {lang: language & Language.state lang} * Local.t), Prop :=
    | sim_thread_sl_intro
        lang st_pf lc_pf st_j lc_j st_ra lc_ra
        (SIM: PFtoRAThread.sim_thread L views rels
                                      (Thread.mk lang st_pf lc_pf sc_pf mem_pf)
                                      (Thread.mk lang st_j lc_j sc_j mem_j)
                                      (Thread.mk lang st_ra lc_ra sc_ra mem_ra)):
        sim_thread_sl views rels sc_pf sc_j sc_ra mem_pf mem_j mem_ra
                      (existT _ lang st_pf, lc_pf) (existT _ lang st_j, lc_j) (existT _ lang st_ra, lc_ra)
    .

    Inductive sim_conf (views: Loc.t -> Time.t -> list View.t) (rels: ReleaseWrites.t):
      forall (c_pf c_j c_ra: Configuration.t), Prop :=
    | sim_conf_intro
        ths_pf sc_pf mem_pf
        ths_j sc_j mem_j
        ths_ra sc_ra mem_ra
        (THS: forall tid,
            option_rel3
              (sim_thread_sl views rels sc_pf sc_j sc_ra mem_pf mem_j mem_ra)
              (IdentMap.find tid ths_pf)
              (IdentMap.find tid ths_j)
              (IdentMap.find tid ths_ra)):
        sim_conf views rels
                 (Configuration.mk ths_pf sc_pf mem_pf)
                 (Configuration.mk ths_j sc_j mem_j)
                 (Configuration.mk ths_ra sc_ra mem_ra)
    .

    Lemma init_wf_pf syn:
      wf_pf (Configuration.init syn).
    Proof.
      econs; eauto using Configuration.init_wf, PF.configuration_init_pf.
    Qed.

    Lemma init_wf_j syn:
      wf_j (fun _ => fun _ => []) (Configuration.init syn).
    Proof.
      econs; eauto using Configuration.init_wf.
      - i. ss.
        unfold Threads.init in *.
        rewrite IdentMap.Facts.map_o in *.
        destruct (@UsualFMapPositive.UsualPositiveMap'.find
                    (@sigT _ (@Language.syntax ProgramEvent.t)) tid syn); inv TH.
        apply inj_pair2 in H1. subst. ss. ii.
        rewrite Memory.bot_get in *. ss.
      - ss. econs; ss. i.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0.
      - ss.
    Qed.

    Lemma init_wf_ra syn:
      wf_ra [] (Configuration.init syn).
    Proof.
      econs; eauto using Configuration.init_wf. i. ss.
    Qed.

    Lemma init_sim_conf syn:
      sim_conf (fun _ => fun _ => []) []
               (Configuration.init syn) (Configuration.init syn) (Configuration.init syn).
    Proof.
      econs; ss. i. unfold option_rel3.
      destruct (IdentMap.find tid (Threads.init syn)) as [[[lang st] lc]|] eqn:FIND; ss.
      unfold Threads.init in *.
      rewrite IdentMap.Facts.map_o in *.
      destruct (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) tid syn); inv FIND.
      apply inj_pair2 in H1. subst.
      econs. econs; ss.
      - econs; ss; try refl. econs; try refl. ii.
        rewrite Memory.bot_get. ss.
      - econs; ss.
        + econs; ss.
          * econs; ss. i. condtac; ss. refl.
          * ii. rewrite Memory.bot_get in *. ss.
        + econs; ss; i.
          * unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
            apply DOMap.singleton_find_inv in GET_SRC. des. inv GET_SRC0.
            esplits; ss. econs. condtac; ss.
          * unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
            apply DOMap.singleton_find_inv in GET_TGT. des. inv GET_TGT0.
            esplits; ss. econs. condtac; ss.
      - econs; ss. ii.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0.
      - econs; ss. ii.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET0.
      - econs; ss. ii. des; ss.
        unfold Memory.get, Memory.init, Cell.get, Cell.init in *. ss.
        apply DOMap.singleton_find_inv in GET. des. inv GET1.
    Qed.

    Lemma sim_conf_terminal
          views rrels c_pf c_j c_ra
          (SIM: sim_conf views rrels c_pf c_j c_ra)
          (TERMINAL: Configuration.is_terminal c_pf):
      Configuration.is_terminal c_ra.
    Proof.
      ii. inv SIM. specialize (THS tid).
      unfold option_rel3 in *. ss. des_ifs.
      destruct p as [[]]. destruct p0 as [[]]. inv THS.
      apply inj_pair2 in H7. apply inj_pair2 in H4. apply inj_pair2 in H1. subst.
      inv SIM. inv SIM_JOINED. inv SIM_RA. ss.
      apply inj_pair2 in H2. apply inj_pair2 in H6. subst.
      exploit TERMINAL; eauto. i. des.
      split; ss.
      inv THREAD. econs.
      inv LOCAL0. rewrite PROMISES0.
      eapply JSim.sim_local_memory_bot; eauto.
    Qed.

    (* step *)

    Lemma sim_conf_step
          views1 rels1 c1_pf c1_j c1_ra
          tid e_pf c2_pf
          (SIM1: sim_conf views1 rels1 c1_pf c1_j c1_ra)
          (WF1_PF: wf_pf c1_pf)
          (WF1_J: wf_j views1 c1_j)
          (WF1_RA: wf_ra rels1 c1_ra)
          (STEP: PFConfiguration.step L e_pf tid c1_pf c2_pf):
      (exists e_j c2_j views2 e_ra rels2 c2_ra,
          (<<STEP_J: JConfiguration.single_step e_j tid c1_j c2_j views1 views2>>) /\
          (<<STEP_RA: RAConfiguration.step L e_ra tid rels1 rels2 c1_ra c2_ra>>) /\
          (<<EVENT_J: JSim.sim_event e_j e_pf>>) /\
          (<<EVENT_RA: PFtoRASimThread.sim_event e_ra e_j>>) /\
          (<<SIM2: sim_conf views2 rels2 c2_pf c2_j c2_ra>>)) \/
      (<<RACE: RARaceW.ra_race_steps L rels1 c1_ra>>).
    Proof.
      dup SIM1. inv SIM0. inv STEP. ss.
      dup THS. specialize (THS0 tid). unfold option_rel3 in THS0. des_ifs.
      inv THS0. apply inj_pair2 in H1. subst.
      exploit wf_pf_thread; eauto. s. i.
      exploit wf_j_thread; eauto. s. i.
      exploit wf_ra_thread; eauto. s. i.
      exploit PFtoRAThread.sim_thread_cancel_steps; eauto.
      { exploit PFtoRAThread.cancel_steps_pf_future; eauto. i.
        exploit PFtoRAThread.opt_step_pf_future; eauto. i.
        exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
        destruct (classic (e_pf = ThreadEvent.failure)).
        - subst. inv STEP0. inv STEP; inv STEP0. inv LOCAL. inv LOCAL0. ss.
        - eapply opt_step_promise_consistent; eauto; try apply x3.
          eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent;
            try eapply PF.pf_consistent_consistent; eauto; try apply x5.
      }
      i. des.
      exploit PFtoRAThread.cancel_steps_pf_future; eauto. i.
      exploit PFtoRAThread.cancel_steps_j_future; eauto. i.
      exploit PFtoRAThread.cancel_steps_ra_future; eauto. i.
      exploit PFtoRAThread.sim_thread_opt_step; eauto.
      { exploit PFtoRAThread.opt_step_pf_future; eauto. i.
        exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
        destruct (classic (e_pf = ThreadEvent.failure)).
        - subst. inv STEP0. inv STEP; inv STEP0. inv LOCAL. inv LOCAL0. ss.
        - eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent;
            try eapply PF.pf_consistent_consistent; eauto; try apply x7.
      }
      i. des; cycle 1.
      { right. unfold RARaceW.ra_race_steps.
        esplits; [econs 1|..]; eauto. s.
        eapply RAThread.tau_steps_steps.
        eapply RAThread.cancel_steps_tau_steps; eauto. }
      exploit PFtoRAThread.opt_step_pf_future; eauto. i.
      exploit PFtoRAThread.opt_step_j_future; eauto. i.
      exploit PFtoRAThread.opt_step_ra_future; eauto. i.
      exploit PFtoRAThread.sim_thread_reserve_steps; eauto.
      { exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
        destruct (classic (e_pf = ThreadEvent.failure)).
        - subst. inv STEP0. inv STEP; inv STEP0. inv LOCAL. inv LOCAL0.
          eapply rtc_reserve_step_promise_consistent2; eauto. ss.
        - eapply consistent_promise_consistent;
            try eapply PF.pf_consistent_consistent; eauto; try apply x9.
      }
      i. des.
      exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
      exploit PFtoRAThread.reserve_steps_j_future; eauto. i.
      exploit PFtoRAThread.reserve_steps_ra_future; eauto. i.
      assert (STEPS': RAThread.steps L rels1 rels2 (Thread.mk _ st_ra lc_ra sc_ra mem_ra) e2_ra1).
      { exploit RAThread.tau_steps_steps;
          try eapply RAThread.cancel_steps_tau_steps; try exact STEP_RA. i.
        exploit RAThread.opt_step_steps; eauto. i.
        exploit RAThread.tau_steps_steps;
          try eapply RAThread.reserve_steps_tau_steps; try exact STEP_RA1. i.
        eapply RAThread.steps_trans; eauto.
        eapply RAThread.steps_trans; eauto. }

      destruct (classic (e_pf = ThreadEvent.failure)).
      { subst. inv EVENT_J. inv EVENT_RA.
        destruct e2_j1 as [st4_j lc4_j sc4_j mem4_j], e2_ra1 as [st4_ra lc4_ra sc4_ra mem4_ra].
        left. esplits.
        - econs; eauto. ss.
        - econs; eauto. ss.
        - ss.
        - econs.
        - econs; ss. i.
          repeat rewrite IdentMap.gsspec. condtac; ss.
          specialize (THS tid0). unfold option_rel3 in THS. des_ifs. inv THS. ss.
          inv SIM4. ss. econs. econs; s; eauto; try apply SIM3.
          * inv SIM_JOINED.
            apply inj_pair2 in H2. apply inj_pair2 in H6. subst.
            econs; s; eauto; try by (inv SIM3; inv SIM_JOINED; ss).
            exploit JThread.rtc_cancel_step_future; eauto; try apply x1. s. i. des.
            exploit JThread.opt_step_future; eauto; try apply x1. s. i. des.
            exploit JThread.rtc_reserve_step_future; eauto. s. i. des.
            eapply JSim.sim_local_le; try exact LOCAL.
            etrans; eauto. refl.
          * inv SIM_RA. ss. subst.
            econs; s; eauto; try by (inv SIM3; inv SIM_RA; ss).
            inv LOCAL. econs; ss. i.
            exploit wf_ra_thread; try exact WF1_RA; try eapply Heq4. s. i.
            eapply RAThread.steps_rels_disjoint; try exact STEPS'; ss; try apply x2; try apply x12.
            inv WF1_RA. inv WF. inv WF0. ss.
            eapply DISJOINT; [|eapply Heq1|eapply Heq4]. congr.
          * econs; try apply SIM3; try apply NORMAL_J.
          * econs; try apply SIM3; try apply NORMAL_RA.
          * econs; s; try apply SIM3; try apply STABLE_RA.
            exploit RAThread.steps_future; try exact STEPS'; try apply x2. s. i. des.
            exploit wf_ra_thread; try exact WF1_RA; try eapply Heq4. s. i.
            exploit Stable.future_stable_tview; try eapply STABLE_RA; try apply x12; eauto.
      }

      exploit PFtoRAThread.sim_thread_consistent; try eapply CONSISTENT; eauto. i. des; cycle 1.
      { right. unfold RARaceW.ra_race_steps.
        esplits; [econs 1|..]; try eapply RACE; eauto. s.
        eapply RAThread.steps_trans; eauto.
        eapply RAThread.tau_steps_steps; eauto. }
      destruct e2_j1 as [st4_j lc4_j sc4_j mem4_j], e2_ra1 as [st4_ra lc4_ra sc4_ra mem4_ra].
      left. esplits.
      - econs; eauto.
      - econs; eauto.
      - ss.
      - ss.
      - econs; ss. i.
        repeat rewrite IdentMap.gsspec. condtac; ss.
        specialize (THS tid0). unfold option_rel3 in THS. des_ifs. inv THS. ss.
        inv SIM4. ss. econs. econs; s; eauto; try apply SIM3.
        * inv SIM_JOINED.
          apply inj_pair2 in H3. apply inj_pair2 in H7. subst.
          econs; s; eauto; try by (inv SIM3; inv SIM_JOINED; ss).
          exploit JThread.rtc_cancel_step_future; eauto; try apply x1. s. i. des.
          exploit JThread.opt_step_future; eauto; try apply x1. s. i. des.
          exploit JThread.rtc_reserve_step_future; eauto. s. i. des.
          eapply JSim.sim_local_le; try exact LOCAL.
          etrans; eauto. refl.
        * inv SIM_RA. ss. subst.
          econs; s; eauto; try by (inv SIM3; inv SIM_RA; ss).
          inv LOCAL. econs; ss. i.
          exploit wf_ra_thread; try exact WF1_RA; try eapply Heq4. s. i.
          eapply RAThread.steps_rels_disjoint; try exact STEPS'; ss; try apply x2; try apply x12.
          inv WF1_RA. inv WF. inv WF0. ss.
          eapply DISJOINT; [|eapply Heq1|eapply Heq4]. congr.
        * econs; try apply SIM3; try apply NORMAL_J.
        * econs; try apply SIM3; try apply NORMAL_RA.
        * econs; s; try apply SIM3; try apply STABLE_RA.
          exploit RAThread.steps_future; try exact STEPS'; try apply x2. s. i. des.
          exploit wf_ra_thread; try exact WF1_RA; try eapply Heq4. s. i.
          exploit Stable.future_stable_tview; try eapply STABLE_RA; try apply x12; eauto.
    Qed.

    Lemma sim_conf_steps
          views1 rels1 c1_pf c1_j c1_ra
          c2_pf
          (SIM1: sim_conf views1 rels1 c1_pf c1_j c1_ra)
          (WF1_PF: wf_pf c1_pf)
          (WF1_J: wf_j views1 c1_j)
          (WF1_RA: wf_ra rels1 c1_ra)
          (STEPS: rtc (PFConfiguration.all_step L) c1_pf c2_pf):
      (exists c2_j views2 rels2 c2_ra,
          (<<STEPS_RA: RAConfiguration.steps L rels1 rels2 c1_ra c2_ra>>) /\
          (<<STEPS_J: JConfiguration.single_steps c1_j c2_j views1 views2>>) /\
          (<<SIM2: sim_conf views2 rels2 c2_pf c2_j c2_ra>>)) \/
      (<<RACE: RARaceW.ra_race_steps L rels1 c1_ra>>).
    Proof.
      revert views1 rels1 c1_j c1_ra SIM1 WF1_PF WF1_J WF1_RA.
      induction STEPS; i.
      { left. esplits; try by econs 1. ss. }
      inv H. exploit sim_conf_step; eauto. i. des; eauto.
      exploit step_pf_future; eauto. i. des.
      exploit step_j_future; eauto. i. des.
      exploit step_ra_future; eauto. i. des.
      exploit IHSTEPS; eauto. i. des.
      - left. esplits.
        + econs 2; eauto.
        + econs 2; eauto.
        + ss.
      - right. unfold RARaceW.ra_race_steps in *. des.
        esplits; [econs 2; eauto|..]; eauto.
    Qed.

    (* racefree *)

    Lemma sim_conf_racy_read
          views1 rels1 c1_pf c1_j c1_ra
          loc ts e_pf tid c2_pf
          (SIM1: sim_conf views1 rels1 c1_pf c1_j c1_ra)
          (WF1_PF: wf_pf c1_pf)
          (WF1_J: wf_j views1 c1_j)
          (WF1_RA: wf_ra rels1 c1_ra)
          (STEP: PFRace.racy_read_step L loc ts e_pf tid c1_pf c2_pf)
          (LOC: L loc)
          (RELS: ~ List.In (loc, ts) rels1):
      (<<RACE: RARaceW.ra_race_steps L rels1 c1_ra>>).
    Proof.
      inv STEP. inv SIM1. ss.
      specialize (THS tid). unfold option_rel3 in THS. des_ifs.
      inv THS. apply inj_pair2 in H1. subst.
      exploit wf_pf_thread; eauto. s. i.
      exploit wf_j_thread; eauto. s. i.
      exploit wf_ra_thread; eauto. s. i.
      exploit PFtoRAThread.sim_thread_cancel_steps; eauto.
      { destruct (classic (e_pf = ThreadEvent.failure)).
        - subst. inv STEP0; inv STEP; inv STEP0. inv LOCAL. inv LOCAL0. ss.
        - exploit PFtoRAThread.cancel_steps_pf_future; eauto. i.
          exploit PFtoRAThread.opt_step_pf_future; eauto. i.
          exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
          eapply opt_step_promise_consistent; eauto; try eapply x3.
          eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent; try eapply PF.pf_consistent_consistent;
            try eapply CONSISTENT; try eapply x5; eauto.
      }
      i. des.
      exploit PFtoRAThread.cancel_steps_pf_future; try eapply x0; eauto. i.
      exploit PFtoRAThread.cancel_steps_j_future; try eapply x1; eauto. i.
      exploit PFtoRAThread.cancel_steps_ra_future; try eapply x2; eauto. i.
      exploit PFtoRAThread.sim_thread_opt_step; eauto.
      { destruct (classic (e_pf = ThreadEvent.failure)).
        - subst. inv STEP0; inv STEP; inv STEP0. inv LOCAL. inv LOCAL0. ss.
        - exploit PFtoRAThread.opt_step_pf_future; eauto. i.
          exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
          eapply rtc_reserve_step_promise_consistent; eauto.
          eapply consistent_promise_consistent; try eapply PF.pf_consistent_consistent;
            try eapply CONSISTENT; try eapply x7; eauto.
      }
      i. unfold RARaceW.ra_race_steps. des; cycle 1.
      { esplits; [econs 1|..]; eauto. s.
        eapply RAThread.tau_steps_steps; eapply RAThread.cancel_steps_tau_steps; eauto. }
      hexploit PFtoRASimThread.sim_local_promise_consistent; try eapply SIM2.
      { inv SIM2. inv SIM_JOINED.
        apply inj_pair2 in H2. apply inj_pair2 in  H3. subst. ss.
        eapply JSim.sim_local_promise_consistent; eauto.
        exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
        destruct (classic (e_pf = ThreadEvent.failure)).
        - subst. inv STEP0; inv STEP; inv STEP0. inv LOCAL0. inv LOCAL1. ss.
        - exploit PFtoRAThread.opt_step_pf_future; eauto. i. des.
          exploit PFtoRAThread.reserve_steps_pf_future; eauto. i.
          hexploit consistent_promise_consistent; try eapply PF.pf_consistent_consistent;
            try eapply CONSISTENT; try eapply x8; eauto. s. i.
          hexploit rtc_reserve_step_promise_consistent; try exact H1; eauto. i.
          hexploit opt_step_promise_consistent; try eapply x6; eauto.
      }
      i. inv READ; inv EVENT_J; inv EVENT_RA; ss.
      - inv STEP_RA0. esplits; [econs 1|..]; eauto; ss.
        + eapply RAThread.tau_steps_steps; eapply RAThread.cancel_steps_tau_steps; eauto.
        + unfold RARaceW.ra_race. splits; eauto.
          inv SIM2. inv SIM_JOINED. inv SIM_RA.
          apply inj_pair2 in H3. apply inj_pair2 in H4. subst. ss.
          inv LOCAL0. inv TVIEW. rewrite CUR.
          eapply TimeFacts.le_lt_lt; eauto. condtac.
          * inv LOCAL. inv TVIEW. inv CUR0. apply RLX.
          * inv LOCAL. inv TVIEW. inv CUR0.
            inv NORMAL_J. inv NORMAL_TVIEW. ss. rewrite CUR0; ss.
      - inv STEP_RA0. esplits; [econs 1|..]; eauto; ss.
        + eapply RAThread.tau_steps_steps; eapply RAThread.cancel_steps_tau_steps; eauto.
        + unfold RARaceW.ra_race. splits; eauto.
          inv SIM2. inv SIM_JOINED. inv SIM_RA.
          apply inj_pair2 in H3. apply inj_pair2 in H4. subst. ss.
          inv LOCAL0. inv TVIEW. rewrite CUR.
          eapply TimeFacts.le_lt_lt; eauto. condtac.
          * inv LOCAL. inv TVIEW. inv CUR0. apply RLX.
          * inv LOCAL. inv TVIEW. inv CUR0.
            inv NORMAL_J. inv NORMAL_TVIEW. ss. rewrite CUR0; ss.
    Qed.

    Lemma sim_conf_racefree
          views rels c_pf c_j c_ra
          (SIM: sim_conf views rels c_pf c_j c_ra)
          (WF_PF: wf_pf c_pf)
          (WF_J: wf_j views c_j)
          (WF_RA: wf_ra rels c_ra)
          (RA_RACEFREE: RARaceW.racefree L rels c_ra):
      PFRace.racefree_view L c_pf.
    Proof.
      ii. exploit sim_conf_steps; eauto. i. des; cycle 1.
      { unfold RARaceW.ra_race_steps in *. des. eauto. }
      exploit steps_pf_future; eauto. i. des.
      exploit steps_j_future; eauto. i. des.
      exploit steps_ra_future; eauto. i. des.
      inv WRITE.
      exploit sim_conf_step; try exact STEP; eauto. i. des; cycle 1.
      { unfold RARaceW.ra_race_steps in *. des.
        eapply RA_RACEFREE; cycle 1; eauto.
        eapply RAConfiguration.steps_trans; eauto. }
      assert (WRITE_RA: ~ List.In (loc, ts) rels0).
      { inv WRITE0; inv EVENT_J; inv EVENT_RA; ss.
        - hexploit RAConfiguration.write_rels; try exact STEP_RA; try eapply x2; ss. i.
          inv STEP_RA. inv STEP0; ss. inv STEP1.
          unfold ReleaseWrites.append. ss. condtac; ss. condtac; ss.
          destruct ordw; ss.
        - hexploit RAConfiguration.write_rels; try exact STEP_RA; try eapply x2; ss. i.
          inv STEP_RA. inv STEP0; ss. inv STEP1.
          unfold ReleaseWrites.append. ss. condtac; ss. condtac; ss.
          destruct ordw; ss.
      }
      exploit step_pf_future; try exact STEP; eauto. i. des.
      exploit step_j_future; try exact STEP_J; eauto. i. des.
      exploit step_ra_future; try exact STEP_RA; eauto. i. des.
      exploit sim_conf_steps; try exact CSTEPS2; eauto. i. des; cycle 1.
      { unfold RARaceW.ra_race_steps in *. des.
        eapply RA_RACEFREE; cycle 1; eauto.
        eapply RAConfiguration.steps_trans; [eauto|].
        econs 2; eauto. }
      exploit steps_pf_future; try exact CSTEPS2; eauto. i. des.
      exploit steps_j_future; try exact STEPS_J0; eauto. i. des.
      exploit steps_ra_future; try exact STEPS_RA0; eauto. i. des.
      assert (READ_RA: ~ List.In (loc, ts) rels1).
      { inv WRITE0; inv EVENT_J; inv EVENT_RA; ss.
        - exploit RAConfiguration.write_get_None; try exact STEP_RA; ss; try apply x2. i. des.
          eapply RAConfiguration.steps_rels; eauto.
        - exploit RAConfiguration.write_get_None; try exact STEP_RA; ss; try apply x2. i. des.
          eapply RAConfiguration.steps_rels; eauto.
      }
      exploit sim_conf_racy_read; eauto. unfold RARaceW.ra_race_steps. i. des.
      eapply RA_RACEFREE; cycle 1; eauto.
      eapply RAConfiguration.steps_trans; eauto.
      eapply RAConfiguration.steps_trans; eauto.
      econs 2; eauto.
    Qed.

    (* behaviors *)

    Lemma sim_conf_behavior
          views rels c_pf c_j c_ra
          (SIM: sim_conf views rels c_pf c_j c_ra)
          (WF_PF: wf_pf c_pf)
          (WF_J: wf_j views c_j)
          (WF_RA: wf_ra rels c_ra)
          (RACEFREE: RARaceW.racefree L rels c_ra):
      behaviors (PFConfiguration.machine_step L) c_pf <1=
      behaviors (@OrdConfiguration.machine_step L Ordering.acqrel) c_ra.
    Proof.
      i. revert views rels c_j c_ra SIM WF_PF WF_J WF_RA RACEFREE.
      induction PR; i.
      - econs 1. eapply sim_conf_terminal; eauto.
      - inv STEP. exploit sim_conf_step; eauto. i. des.
        + exploit RARaceW.step_ord_step; eauto. i.
          inv EVENT_J; inv EVENT_RA; ss. inv H0.
          econs 2.
          { replace (MachineEvent.syscall e) with
                (ThreadEvent.get_machine_event (ThreadEvent.syscall e)) by ss.
            econs; eauto. }
          hexploit RARaceW.step_racefree; eauto. i.
          exploit step_pf_future; eauto. i. des.
          exploit step_j_future; eauto. i. des.
          exploit step_ra_future; eauto.
        + exfalso. unfold RARaceW.ra_race_steps in *. des. eauto.
      - inv STEP. exploit sim_conf_step; eauto. i. des.
        + exploit RARaceW.step_ord_step; eauto. i.
          inv EVENT_J; inv EVENT_RA; ss. inv H0.
          econs 3.
          replace MachineEvent.failure with (ThreadEvent.get_machine_event ThreadEvent.failure) by ss.
          econs; eauto.
        + exfalso. unfold RARaceW.ra_race_steps in *. des. eauto.
      - inv STEP. exploit sim_conf_step; eauto. i. des.
        + exploit RARaceW.step_ord_step; eauto. i.
          econs 4.
          { replace MachineEvent.silent with (ThreadEvent.get_machine_event e_ra); cycle 1.
            { inv EVENT_J; inv EVENT_RA; ss. }
            econs; eauto.
          }
          hexploit RARaceW.step_racefree; eauto. i.
          exploit step_pf_future; eauto. i. des.
          exploit step_j_future; eauto. i. des.
          exploit step_ra_future; eauto.
        + exfalso. unfold RARaceW.ra_race_steps in *. des. eauto.
    Qed.
  End PFtoRA.
End PFtoRA.


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.
From PromisingLib 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 Pred.
Require Import Trace.
Require Import OrderedTimes.
Require Import PFConsistentStrong.

Set Implicit Arguments.

Inductive times_configuration_step_strong (times: Loc.t -> Time.t -> Prop)
  : forall (tr tr_cert: Trace.t)
           (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
| times_configuration_step_strong_intro
    lang tr e tr' pf tid c1 st1 lc1 e2 st3 lc3 sc3 memory3 tr_cert
    (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: ThreadEvent.get_machine_event e <> MachineEvent.failure),
        pf_consistent_super_strong (Thread.mk _ st3 lc3 sc3 memory3) tr_cert times)
    (CERTBOT: ThreadEvent.get_machine_event e = MachineEvent.failure \/ (exists se, e = ThreadEvent.syscall se) -> tr_cert = [])
    (CERTBOTNIL: (Local.promises lc3) = Memory.bot -> tr_cert = [])
    (TIMES: List.Forall (fun thte => wf_time_evt times (snd thte)) tr)
  :
    times_configuration_step_strong
      times tr tr_cert
      (ThreadEvent.get_machine_event e) tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st3, lc3) (Configuration.threads c1)) sc3 memory3)
.

Inductive times_configuration_step (times: Loc.t -> Time.t -> Prop)
  : forall (tr tr_cert: Trace.t)
           (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
| times_configuration_step_intro
    lang tr e tr' pf tid c1 st1 lc1 e2 st3 lc3 sc3 memory3 tr_cert
    (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: ThreadEvent.get_machine_event e <> MachineEvent.failure),
        pf_consistent_super_strong (Thread.mk _ st3 lc3 sc3 memory3) tr_cert times)
    (CERTBOT: ThreadEvent.get_machine_event e = MachineEvent.failure \/ (exists se, e = ThreadEvent.syscall se) -> tr_cert = [])
    (TIMES: List.Forall (fun thte => wf_time_evt times (snd thte)) tr)
  :
    times_configuration_step
      times tr tr_cert
      (ThreadEvent.get_machine_event e) tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st3, lc3) (Configuration.threads c1)) sc3 memory3)
.

Lemma times_configuration_step_strong_step
  :
    times_configuration_step_strong <7= times_configuration_step.
Proof.
  i. inv PR. econs; eauto.
Qed.

Inductive times_configuration_step_strong_all (times: Loc.t -> Time.t -> Prop)
          (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t): Prop :=
| times_configuration_step_strong_all_intro
    tr tr_cert
    (STEP: @times_configuration_step_strong times tr tr_cert e tid c1 c2)
.

Lemma times_configuration_step_configuration_step times tr tr_cert e tid c1 c2
      (STEP: @times_configuration_step times tr tr_cert e tid c1 c2)
      (WF: Configuration.wf c1)
  :
    Configuration.step e tid c1 c2.
Proof.
  inv STEP. eapply Trace.silent_steps_tau_steps in STEPS; eauto.
  destruct (classic (ThreadEvent.get_machine_event e0 = MachineEvent.failure)).
  { econs; eauto. ss. }
  { inv WF. exploit Thread.rtc_tau_step_future; ss; eauto.
    { eapply WF0; eauto. } i. des.
    exploit Thread.step_future; ss; eauto. ss. i. des.
    econs; eauto. i. eapply pf_consistent_super_strong_consistent; eauto.
  }
Qed.

Lemma times_configuration_step_future
      times tr tr_cert e tid c1 c2
      (STEP: @times_configuration_step times tr tr_cert e tid c1 c2)
      (WF1: Configuration.wf 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)>>).
Proof.
  eapply times_configuration_step_configuration_step in STEP; eauto.
  eapply Configuration.step_future; eauto.
Qed.

Inductive times_configuration_opt_step (times: Loc.t -> Time.t -> Prop)
  : forall (tr tr_cert: Trace.t)
           (e:MachineEvent.t) (tid:Ident.t) (c1 c2:Configuration.t), Prop :=
| times_configuration_opt_step_some
    tr tr_cert e tid c1 c2
    (STEP: @times_configuration_step times tr tr_cert e tid c1 c2)
  :
    times_configuration_opt_step times tr tr_cert e tid c1 c2
| times_configuration_opt_step_none
    tid c
  :
    @times_configuration_opt_step times [] [] MachineEvent.silent tid c c
.

Lemma times_configuration_opt_step_future
      times tr tr_cert e tid c1 c2
      (STEP: @times_configuration_opt_step times tr tr_cert e tid c1 c2)
      (WF1: Configuration.wf 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)>>).
Proof.
  inv STEP.
  { eapply times_configuration_step_future; eauto. }
  { splits; auto. refl. }
Qed.

Lemma times_configuration_step_strong_mon times0 times1
      (LE: times0 <2= times1)
  :
    times_configuration_step_strong times0 <6= times_configuration_step_strong times1.
Proof.
  i. inv PR. econs; eauto.
  { i. hexploit CONSISTENT; eauto. i. des. esplits; eauto.
    eapply pf_consistent_super_strong_mon; eauto. }
  { eapply List.Forall_impl; eauto. i. eapply wf_time_evt_mon; eauto. }
Qed.

Lemma times_configuration_step_mon times0 times1
      (LE: times0 <2= times1)
  :
    times_configuration_step times0 <6= times_configuration_step times1.
Proof.
  i. inv PR. econs; eauto.
  { i. hexploit CONSISTENT; eauto. i. des. esplits; eauto.
    eapply pf_consistent_super_strong_mon; eauto. }
  { eapply List.Forall_impl; eauto. i. eapply wf_time_evt_mon; eauto. }
Qed.

Lemma times_configuration_step_strong_all_mon times0 times1
      (LE: times0 <2= times1)
  :
    times_configuration_step_strong_all times0 <4= times_configuration_step_strong_all times1.
Proof.
  i. inv PR. econs. eapply times_configuration_step_strong_mon; eauto.
Qed.

Lemma times_configuration_step_exists c0 c1 tid e
      (STEP: Configuration.step e tid c0 c1)
      (WF: Configuration.wf c0)
  :
    exists times tr tr_cert,
      ((<<STEP: @times_configuration_step_strong times tr tr_cert e tid c0 c1>>) \/
       exists c1',
         (<<STEP: @times_configuration_step_strong times tr tr_cert MachineEvent.failure tid c0 c1'>>))
      /\
      (<<WO: forall loc, well_ordered (times loc)>>).
Proof.
  inv STEP.
  destruct (classic (Thread.steps_failure (Thread.mk _ st1 lc1 c0.(Configuration.sc) c0.(Configuration.memory)))) as [FAILURE|NFAILURE].
  { clear STEPS STEP0 EVENT. red in FAILURE. des. destruct e3.
    eapply Trace.tau_steps_silent_steps in STEPS. des.
    hexploit (trace_times_list_exists tr). i. des.
    hexploit step_times_list_exists; eauto. i. des.
    replace MachineEvent.failure with (ThreadEvent.get_machine_event e); auto.
    eexists (fun loc ts => List.In ts (times loc ++ times0 loc)), (tr++_), []. splits.
    { right. esplits. econs; eauto; ss. eapply Forall_app.
      { eapply List.Forall_impl; eauto. i. ss. eapply wf_time_evt_mon; eauto.
        i. ss. eapply List.in_or_app; eauto. }
      { econs; ss. eapply wf_time_evt_mon; eauto.
        i. ss. eapply List.in_or_app; eauto. }
    }
    { i. eapply finite_well_ordered. }
  }
  assert (NORMAL: ThreadEvent.get_machine_event e0 <> MachineEvent.failure).
  { ii. eapply NFAILURE. red. esplits; eauto.
    replace pf with true in *; eauto. inv STEP0; inv STEP; ss.
  }
  dup STEPS. eapply Trace.tau_steps_silent_steps in STEPS. des.
  hexploit (trace_times_list_exists tr). i. des.
  hexploit step_times_list_exists; eauto. i. des.
  hexploit EVENT; ss.
  dup WF. inv WF. exploit Trace.steps_future; eauto.
  { ss. eapply WF1; eauto. } i. des. ss.
  hexploit Thread.step_future; eauto. i. des. ss.
  destruct (classic ((Local.promises lc3) = Memory.bot)) as [EQBOT|NEQBOT].
  { eexists (fun loc ts => List.In ts (times loc ++ times0 loc)), (tr++_), []. splits.
    { left. econs; eauto.
      { i. esplits. eapply promises_bot_certify_nil; eauto. }
      { eapply Forall_app.
        { eapply List.Forall_impl; eauto. i. eapply wf_time_evt_mon; try apply H0.
          i. ss. eapply List.in_or_app; eauto. }
        { econs; ss. eapply wf_time_evt_mon; try apply WFTIME0.
          i. ss. eapply List.in_or_app; eauto. }
      }
    }
    { i. eapply finite_well_ordered. }
  }
  destruct (ThreadEvent.get_machine_event e0) eqn:EQ; ss; cycle 1.
  { inv STEP0; inv STEP; ss. inv LOCAL; ss.
    inv LOCAL0; ss. exfalso. eapply NEQBOT; eauto. }
  eapply consistent_pf_consistent_super_strong in H; eauto. des.
  { red in FAILURE. des. exfalso. eapply NFAILURE. red. esplits.
    { etrans.
      { eapply STEPS0. }
      econs 2.
      { econs; [|eapply EQ]. econs; eauto. }
      { eauto. }
    }
    { eauto. }
    { eauto. }
  }
  eexists (certimes \2/ (fun loc ts => List.In ts (times loc ++ times0 loc))), (tr++_), tr0. splits.
  { left. rewrite <- EQ. econs; eauto.
    { i. esplits. eapply pf_consistent_super_strong_mon; eauto. }
    { rewrite EQ. i. des; ss; clarify. }
    { ii. ss. }
    { eapply Forall_app.
      { eapply List.Forall_impl; eauto. i. eapply wf_time_evt_mon; try apply H.
        i. ss. right. eapply List.in_or_app; eauto. }
      { econs; ss. eapply wf_time_evt_mon; try apply WFTIME0.
        i. ss. right. eapply List.in_or_app; eauto. }
    }
  }
  { i. eapply join_well_ordered; eauto. eapply finite_well_ordered. }
Qed.

Lemma times_configuration_behavior_configuration_behavior times c
      (WF: Configuration.wf c)
  :
    behaviors (times_configuration_step_strong_all times) c <2=
    behaviors (Configuration.step) c.
Proof.
  i. ginduction PR; eauto.
  { i. econs 1. eauto. }
  { i. inv STEP. eapply times_configuration_step_strong_step in STEP0.
    eapply times_configuration_step_configuration_step in STEP0; eauto.
    econs 2; eauto. eapply IHPR; eauto.
    eapply Configuration.step_future; eauto.
  }
  { i. inv STEP. eapply times_configuration_step_strong_step in STEP0.
    eapply times_configuration_step_configuration_step in STEP0; eauto.
    econs 3; eauto.
  }
  { i. inv STEP. eapply times_configuration_step_strong_step in STEP0.
    eapply times_configuration_step_configuration_step in STEP0; eauto.
    econs 4; eauto. eapply IHPR; eauto.
    eapply Configuration.step_future; eauto.
  }
  { i. econs 5; eauto. }
Qed.

Lemma times_configuration_step_same_behaviors c f beh
      (WF: Configuration.wf c)
      (BEH: behaviors Configuration.step c f beh)
  :
    exists times,
      (<<BEH: behaviors (times_configuration_step_strong_all times) c f beh>>) /\
      (<<WO: forall loc, well_ordered (times loc)>>) /\
      (<<INCR: forall nat loc, times loc (incr_time_seq nat)>>) /\
      (<<BOT: forall loc, times loc Time.bot>>)
.
Proof.
  ginduction BEH.
  { i. exists (fun loc => incr_times \1/ eq Time.bot). splits.
    { econs 1; eauto. }
    { i. eapply join_well_ordered; eauto.
      { eapply incr_times_well_ordered. }
      { eapply singleton_well_ordered. }
    }
    { i. left. eexists. eauto. }
    { auto. }
  }
  { i. exploit IHBEH.
    { eapply Configuration.step_future; eauto. } i. des.
    exploit times_configuration_step_exists; eauto. i. des.
    { exists (times \2/ times0). splits.
      { econs 2; eauto.
        { econs. eapply times_configuration_step_strong_mon; eauto. }
        { eapply le_step_behavior_improve; try apply BEH0.
          eapply times_configuration_step_strong_all_mon; auto. }
      }
      { i. eapply join_well_ordered; eauto. }
      { auto. }
      { auto. }
    }
    { exists (times \2/ times0). splits.
      { econs 3; eauto.
        { econs. eapply times_configuration_step_strong_mon; eauto. }
      }
      { i. eapply join_well_ordered; eauto. }
      { auto. }
      { auto. }
    }
  }
  { i. exploit times_configuration_step_exists; eauto. i. des.
    { exists (times \2/ (fun loc => incr_times) \2/ (fun _ => eq Time.bot)). splits; eauto.
      { econs 3; eauto. econs; eauto.
        eapply times_configuration_step_strong_mon; eauto. }
      { i. eapply join_well_ordered; eauto.
        { eapply join_well_ordered; eauto. eapply incr_times_well_ordered. }
        { eapply singleton_well_ordered. }
      }
      { i. left. right. eexists. eauto. }
    }
    { exists (times \2/ (fun loc => incr_times) \2/ (fun _ => eq Time.bot)). splits; eauto.
      { econs 3; eauto.
        { econs. eapply times_configuration_step_strong_mon; eauto. }
      }
      { i. eapply join_well_ordered; eauto.
        { eapply join_well_ordered; eauto. eapply incr_times_well_ordered. }
        { eapply singleton_well_ordered. }
      }
      { i. left. right. eexists. eauto. }
    }
  }
  { i. exploit IHBEH.
    { eapply Configuration.step_future; eauto. } i. des.
    exploit times_configuration_step_exists; eauto. i. des.
    { exists (times \2/ times0). splits.
      { econs 4; eauto.
        { econs. eapply times_configuration_step_strong_mon; eauto. }
        { eapply le_step_behavior_improve; try apply BEH0.
          eapply times_configuration_step_strong_all_mon; auto. }
      }
      { i. eapply join_well_ordered; eauto. }
      { auto. }
      { auto. }
    }
    { exists (times \2/ times0). splits.
      { econs 3; eauto.
        { econs. eapply times_configuration_step_strong_mon; eauto. }
      }
      { i. eapply join_well_ordered; eauto. }
      { auto. }
      { auto. }
    }
  }
  { i. esplits.
    { econs 5. }
    { instantiate (1:=((fun loc => incr_times) \2/ (fun _ => eq Time.bot))).
      i. eapply join_well_ordered; eauto.
      { eapply incr_times_well_ordered. }
      { eapply singleton_well_ordered. }
    }
    { i. left. eexists. eauto. }
    { i. right. auto. }
  }
Qed.


From mathcomp Require Import ssreflect ssrfun eqtype seq ssrint.
From CoqUtils Require Import word.
From extructures Require Import fmap fset.

Require Import MicroPolicies.Types.
Require Import MicroPolicies.Symbolic.
Require Import MicroPolicies.LRC.
Require Import MicroPolicies.Instance.

Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Export Extraction.Definitions.

Open Scope string_scope.

(* TL TODO: switch to Show type class, cf coqstring_of_Z *)

Axiom coqstring_of_word : forall {k}, word k -> string.
(* TL TODO: move this to Extraction.v *)
Extract Constant coqstring_of_word => "(fun _ w -> let Word x = Lazy.force w in coqstring_of_camlstring (Big.to_string x))".

Definition coqstring_of_nat (n : nat) : string := coqstring_of_word (@as_word 32 (Posz n)).

Fixpoint coqstring_of_nat_list_aux (l : list nat) : string :=
  match l with
  | nil => "]"
  | cons n nil => " " ++ coqstring_of_nat n ++ " ]"
  | cons n l' => " " ++ coqstring_of_nat n ++ ";"
  end.

Definition coqstring_of_nat_list (l : list nat) : string :=
  "[" ++ coqstring_of_nat_list_aux l.

Definition coqstring_of_value_tag (t : value_tag) : string :=
  match t with
    | Ret n => "Ret " ++ coqstring_of_nat n
    | Other => "Other"
  end.

Definition coqstring_of_ratom (a : ratom) : string :=
  "{ value: " ++ coqstring_of_word (vala a) ++ "; " ++ "tag: " ++ coqstring_of_value_tag (taga a) ++ " }".

Definition coqstring_of_regs (regs : { fmap reg mt -> ratom }) : string :=
  "regs:{
  " ++ foldl (fun s r =>
  "reg " ++ coqstring_of_word (fst r) ++ " : " ++ coqstring_of_ratom (snd r) ++ "
  " ++ s) "" regs ++ "}
  ".

Definition coqstring_of_instr (i : instr mt) : string :=
  match i with
  | Nop => "Nop"
  | Const i r => "Const r_" ++ coqstring_of_word r ++ " <- " ++ coqstring_of_word i
  | Mov r1 r2 => "Mov " ++ coqstring_of_word r1 ++ " -> " ++ coqstring_of_word r2
  | Binop o r1 r2 r3 => "Binop [TODO]"
  | Load r1 r2 => "Load [TODO]"
  | Store r1 r2 => "Store [TODO]"
  | Jump r => "Jump r_" ++ coqstring_of_word r
  | Bnz r i => "Bnz [TODO]"
  | Jal i => "Jal " ++ coqstring_of_word i
  | JumpEpc => "JumpEpc"
  | AddRule => "AddRule"
  | GetTag r1 r2 => "GetTag [TODO]"
  | PutTag r1 r2 r3 => "PutTag [TODO]"
  | Halt => "Halt"
  end.

Definition coqstring_of_entry e  :=
  match e with
  | None => ""
  | Some (p, l) => coqstring_of_nat p ++ ": " ++ coqstring_of_nat_list l
  end.

Definition coqstring_of_mem_tag (t : mem_tag) :=
  "{ vtag: " ++ coqstring_of_value_tag (vtag t) ++
  "; color: " ++ coqstring_of_nat (color t) ++
  "; entry: " ++ coqstring_of_entry (entry t) ++ "; }".

Definition coqstring_of_matom (a : matom) : string :=
  let value := match decode_instr (vala a) with
               | Some i => coqstring_of_instr i
               | None => coqstring_of_word (vala a)
               end in
"{ value: " ++ value ++ "; " ++ "
      tag: " ++ coqstring_of_mem_tag (taga a) ++ " }".

Definition coqstring_of_mem (mem : { fmap mword mt -> matom }) : string :=
  "mem:{
" ++ foldl (fun s m =>
              coqstring_of_word (fst m) ++ " : " ++ coqstring_of_matom (snd m) ++ "
" ++ s) "" mem ++ "}
".

Definition coqstring_of_pc_tag (t : pc_tag) : string :=
  match t with
  | Level n => "Level " ++ coqstring_of_nat n
  end.

Definition coqstring_of_pc (pc : atom (mword mt) pc_tag) : string :=
  "pc: " ++ coqstring_of_word (vala pc) ++ "; " ++ coqstring_of_pc_tag (taga pc) ++ "
".

Definition coqstring_of_internal (_ : unit) : string := "".

Definition coqstring_of_state (st : state) : string :=
"============================
" ++ coqstring_of_pc (Symbolic.pc st)
  ++ coqstring_of_internal (Symbolic.internal st)
  ++ coqstring_of_regs (Symbolic.regs st)
  ++ coqstring_of_mem (Symbolic.mem st) ++
"============================
".

(* Require Import CompCert.Events. *)
(* From QuickChick Require Import QuickChick. *)

(* Definition coqstring_of_Z (z : BinNums.Z) := show z. *)

(* Definition coqstring_of_event (e : event) := *)
(*   match e with *)
(*   | ECall c p r c' => "(ECall " ++ coqstring_of_nat c ++ " " *)
(*                                 ++ coqstring_of_nat p ++ " " *)
(*                                 ++ coqstring_of_Z r   ++ " " *)
(*                                 ++ coqstring_of_nat c' ++ ")" *)
(*   | ERet c r c' => "(ERet " ++ coqstring_of_nat c ++ " " *)
(*                             ++ coqstring_of_Z r   ++ " " *)
(*                             ++ coqstring_of_nat c' ++ ")" *)
(*   end. *)


(*

  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

*)

Require Export list.

Definition hidden_disjoint {T} a b := @disjoint T a b.

Ltac disj_flat_map_step :=
  match goal with
    | [ H1 : disjoint ?a (flat_map ?f ?l), H2 : LIn ?x ?l |- _ ] =>
      let k := fresh H1 in
      let h := fresh H2 in
      assert (disjoint a (flat_map f l)) as k by trivial;
        trw_h disjoint_flat_map_r k;
        assert (LIn x l) as h by trivial;
        apply k in h;
        clear k;
         fold (hidden_disjoint a (flat_map f l)) in H1
    | [ H1 : disjoint (flat_map ?f ?l) ?a, H2 : LIn ?x ?l |- _ ] =>
      let k := fresh H1 in
      let h := fresh H2 in
      assert (disjoint (flat_map f l) a) as k by trivial;
        trw_h disjoint_flat_map_l k;
        assert (LIn x l) as h by trivial;
        apply k in h;
        clear k;
         fold (hidden_disjoint (flat_map f l) a) in H1
   end.

Ltac disj_flat_map := (repeat disj_flat_map_step); allunfold (@hidden_disjoint).


(* USIG instance *)

Require Export MinBFTprops0.
Require Export MinBFTrep.
Require Export MinBFTstate.
Require Export MinBFTsubs.
Require Export MinBFTtacts2.

Section MinBFTmon.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma le_usig_counter_increment_USIG :
    forall u, usig_counter u <= usig_counter (increment_USIG u).
  Proof.
    tcsp.
  Qed.
  Hint Resolve le_usig_counter_increment_USIG : minbft.

  Lemma monotonicity_local :
    forall {eo : EventOrdering}
           (e : Event)
           (s1 s2 : USIG_state),
      is_replica e
      -> M_state_sys_before_event MinBFTsys e USIGname = Some s1
      -> M_state_sys_on_event MinBFTsys e USIGname = Some s2
      -> usig_counter s1 <= usig_counter s2.
  Proof.
    introv isr eqst1 eqst2.

    apply map_option_Some in eqst1.
    apply map_option_Some in eqst2.

    unfold is_replica in isr.
    destruct isr as [r isr].
    rewrite isr in *; simpl in *.
    exrepnd; rev_Some.

    applydup M_run_ls_on_event_ls_is_minbft in eqst2; exrepnd; subst; simpl in *.
    rewrite M_run_ls_on_event_unroll2 in eqst2.
    rewrite eqst1 in eqst2; simpl in *.
    applydup M_run_ls_before_event_ls_is_minbft in eqst1; exrepnd; subst; simpl in *.
    autorewrite with minbft in *; minbft_simp.
    clear eqst1.

    apply map_option_Some in eqst2; exrepnd; minbft_simp.
    unfold M_run_ls_on_input_ls, M_run_ls_on_input in eqst0.
    autorewrite with comp minbft in *.

    Time minbft_dest_msg Case;
      repeat (simpl in *; autorewrite with comp minbft in *; smash_minbft2).
  Qed.

  Lemma monotonicity_local2 :
    forall {eo : EventOrdering}
           (e1 e2 : Event)
           (s1 s2 : USIG_state),
      is_replica e2
      -> e1 ⊂ e2
      -> M_state_sys_on_event MinBFTsys e1 USIGname = Some s1
      -> M_state_sys_on_event MinBFTsys e2 USIGname = Some s2
      -> usig_counter s1 <= usig_counter s2.
  Proof.
    introv isr lte eqst1 eqst2.
    applydup pred_implies_local_pred in lte.
    subst.
    rewrite <- M_state_sys_before_event_as_M_state_sys_on_event_pred in eqst1; eauto 3 with eo.
    eapply monotonicity_local; eauto.
  Qed.

  Lemma monotonicity :
    forall {eo : EventOrdering}
           (e1 e2 : Event)
           (s1 s2 : USIG_state),
      is_replica e2
      -> M_state_sys_on_event MinBFTsys e1 USIGname = Some s1
      -> M_state_sys_on_event MinBFTsys e2 USIGname = Some s2
      -> e1 ⊑ e2
      -> usig_counter s1 <= usig_counter s2.
  Proof.
    intros eo e1 e2; revert e1.
    induction e2 as [e2 ind] using predHappenedBeforeInd;[]; introv isrep eqst1 eqst2 lte.

    apply localHappenedBeforeLe_implies_or2 in lte; repndors; subst; tcsp;[|].

    { rewrite eqst1 in eqst2; ginv. }

    apply local_implies_pred_or_local in lte; repndors; exrepnd.

    {
      eapply (@M_state_sys_before_event_if_on_event_direct_pred _ _ _ _ _ _ _ _ USIGname) in lte;[|eauto].
      eapply monotonicity_local; eauto.
    }

    pose proof (M_state_sys_on_event_some_between e e2 MinBFTsys USIGname s2) as q.
    repeat (autodimp q hyp); eauto 3 with eo minbft comp;[].
    exrepnd.

    pose proof (ind e lte1 e1 s1 s') as ind; repeat (autodimp ind hyp); eauto 3 with eo minbft comp.
    pose proof (monotonicity_local2 e e2 s' s2) as q; repeat (autodimp q hyp); try omega.
  Qed.

End MinBFTmon.

Hint Resolve le_usig_counter_increment_USIG : minbft.


(** Porting the OCaml version of the forcing translation plugin.

    Some notes:
    - the Yoneda embedding is removed from the translation and should be provided by
      the user, if required;
    - porting the OCaml code required to change de Bruijn indices to start from 0,
      and not from 1 as in the Coq's kernel (hopefully, fixed everywhere);
    - only the translation for the negative fragment is supported for now. *)

Require Import List Arith Nat.
Require Import String.
Require Import Template.monad_utils Template.Ast
        Template.Template Template.LiftSubst Template.Checker Template.utils
        Template.AstUtils Template.LiftSubst.
Require Import Forcing.translation_utils.
Require Import Forcing.TFUtils.

Import ListNotations MonadNotation.

Local Open Scope string_scope.

Definition list_to_string {A : Type} f (xs : list A) : string
  := (List.fold_left append (List.map (fun i => f i ++ " ") xs) "").

(** We add a composition and an identity as a part of a categorical structe that must
    be provided by a user, since the Yoneda embedding is not a part of
    the plugin anymore (instead, it could be done externally by a
    user) *)

Record category : Type :=
  mkCat { cat_obj : term;
          (** Objects. Must be of type [Type]. *)

          cat_hom : term;
          (** Morphisms. Must be of type [cat_obj -> cat_obj -> Type]. *)

          cat_id : term;
          (** Identity. Must be of the type [forall {a : cat_obj}, cat_hom a a]  *)

          cat_comp : term;
          (** Composition. Must be of the type
              [forall {a b c : cat_obj}, cat_hom b c -> cat_hom a b -> cat_hom a c] *)
        }.

Definition makeCatS (obj hom id_ comp : string) :=
  {| cat_obj := tConst obj [];
     cat_hom := tConst hom [];
     cat_id := tConst id_ [];
     cat_comp := tConst comp [];
  |}.

Quote Definition cat_def := Eval compute in category.

Definition obj_name := nNamed "R".
Definition knt_name := nNamed "k".

(** We assume that there is a hidden topmost variable [p : Obj] in the context *)

Definition pos_name := nNamed "p".
Definition hom_name := nNamed "α".

(** Optimization of cuts *)
(* TODO: for now it is just an ordinary tApp; could be changed if we need it later *)

Definition mkOptApp t args := tApp t args.
(* The original OCaml inplementation  *)
(* let mkOptApp (t, args) = *)
(*   let len = Array.length args in *)
(*   try *)
(*     let (_, t) = Term.decompose_lam_n len t in *)
(*     Vars.substl (CArray.rev_to_list args) t *)
(*   with _ -> *)
(* mkApp (t, args) *)

(** Forcing translation *)
Inductive forcing_condition :=
| fcVar : forcing_condition
| fcLift : forcing_condition.

Record forcing_context :=
  mkFCtxt { f_context : list forcing_condition;
            f_category : category;
            f_translator : tsl_table;
            (* A map associating to all source constant a forced constant *)
          }.

Definition fcond_to_string fc :=
  match fc with
  | fcVar => "fcVar"
  | fcLift => "fcLift"
  end.

(* WARNING: tRel indices start from 0 in Tempalte Coq and *not* from 1 as for mkRel in the kernel  *)

Fixpoint last_condition fc :=
  match fc with
  | [] => 0
  | fcVar :: fctx => 1 + last_condition fctx
  | fcLift :: fctx => 1
  end.

Fixpoint only_vars (fctx : list forcing_condition) : bool :=
  match fctx with
  | [] => true
  | fcVar :: tl => only_vars tl
  | fcLift :: _ => false
  end.

Definition top_condition (fctx : list forcing_condition) : nat :=
  let fld_with acc f :=
      match f with
      | fcVar => 1 + acc
      | fcLift => 2 + acc
      end in
  List.fold_left fld_with fctx 0.

(* Collects all the morphisms up to a given variable.
   Returns the resulting list along with the (optional) index
   corresponding to the domian of the last morphism in the composition.
   We return [None] if there is no morphism left in the list
   *after* the given variable *)
Fixpoint gather_morphisms_internal i n fctx : list nat * option nat :=
  if (Nat.eqb n 0) then ([], match fctx with
                             | [] => None
                             | _  =>  if (only_vars fctx) then None
                                      else Some (i + last_condition fctx)
                             end)
  else match fctx with
       | [] => ([], None)
       | fcVar :: fctx => gather_morphisms_internal (i + 1) (n - 1) fctx
       | fcLift :: fctx => let (i',b) := gather_morphisms_internal (i + 2) n fctx
                           in  (i :: i', b)
       end.

(** We return all the morphisms for the variable (represented as a de
    Bruijn index) and index of the domain of the last morphism in the
    comosition *)
Definition gather_morphisms (n : nat) (fctx : forcing_context) : list nat * option nat :=
  gather_morphisms_internal 0 (n+1) (f_context fctx).

Definition morphism_var (n : nat) (fctx : forcing_context) : term :=
  let (morphs, next_cond) := gather_morphisms n fctx in
  let last := tRel (last_condition fctx.(f_context)) in
  let cat := (f_category fctx) in
  let fold_with (accu : term) (i j : nat) :=
      tApp cat.(cat_comp) [tRel (j+1); tRel (i+1); last; accu; tRel i] in
  let init := tApp cat.(cat_id) [last] in
  let fix f_left l accu {struct l} :=
      match l with
      | [] => accu
      | i :: t =>
        match t with
        (* We have to use this to handle a special case: the top level
           condition.  There are two cases: we have traversed all the
           forcing context (i.e. next_cond=None), or we found the
           variable before we traversed the whole forcing context (and
           there are some morphism after the variable in the
           context). In first case we know that the last morphism in
           the composition is from the top-level forcing condition *)
        | [] => let top_rel :=
                    match next_cond with
                    | None => tRel (top_condition fctx.(f_context))
                    | Some i => tRel i
                    end in
                tApp cat.(cat_comp) [top_rel; tRel (i+1); last; accu; tRel i]
        | j :: t' => f_left t (fold_with accu i j)
        end
      end in
  (* tVar (list_to_string fcond_to_string fctx.(f_context)). *)
  f_left morphs init.
  (* in *)
  (* List.fold_left fold_with morphs init. *)

(* The original OCaml code *)
(* let morphism_var n fctx = *)
(*   let morphs = gather_morphisms n fctx in *)
(*   let last = mkRel (last_condition fctx) in *)
(*   let fold accu i = *)
(*     trns fctx.category dummy dummy last (mkRel i) accu *)
(*   in *)
(* List.fold_left fold (refl fctx.category last) morphs *)

(** A stub for the actual evar_map definition *)
Definition evar_map := unit.

Module Environ.
  (** Stub for global environment Environ *)

  Definition rel_declaration := unit.

  Record env := { env_globals : global_declarations }.

  Definition empty_env := {| env_globals := [] |}.

  Definition rel_context (e : env) : list rel_declaration := [].

  Definition of_global_context (c : global_context) : env :=  {| env_globals := fst c |}.

  Definition to_global_context (E : env) : global_context :=
    Typing.reconstruct_global_context E.(env_globals).
End Environ.

Definition get_var_shift n fctx :=
  let fix get n fctx :=
      if (Nat.eqb n 0 ) then 0
      else
        match fctx with
        | [] => n
        | fcVar :: fctx => 1 + get (n - 1) fctx
        | fcLift :: fctx => 2 + get n fctx
      end
  in
  get (n + 1) fctx.(f_context).

(* Some examples to play with  *)
Definition Obj := Type.
Definition Hom := (fun x y => x -> y).
Definition Id_hom := @id.
Definition Comp := @Coq.Program.Basics.compose.

Definition test_cat : category :=
  makeCatS "Obj" "Hom" "Id_hom" "Comp".

Definition test_fctx :=
  {| f_context := [fcLift; fcLift; fcVar; fcLift];
     f_category := test_cat;
     f_translator := []|}.

Eval compute in gather_morphisms 0 test_fctx.
Eval compute in get_var_shift 1 test_fctx.
Eval compute in morphism_var 1 test_fctx.

(* We convert the result of checking for relevance in a stupid way :)
   TODO: think about the error propagation *)
Definition from_rel_result (rl : rel_result) : relevance :=
  match rl with
  | RelOk r => r
  | RelNotSort _ => Relevant
  | RelTypingError _ => Relevant
  end.

(* TODO: move inference of the relevance to another place,
   since it does not change during the translation.
   Probably a good place is [translate] function that calls [otranslate]  *)

(** Produces a forcing condition along with corresponding morphism.
    We need to determine the relevance of the types of morphisms and objects in the category.
    In order to do that we use the [relevance_of_type] function, and this function requires a global context, so now
    [get_ctx_lift] also takes is as a parameter *)
Definition get_ctx_lift (cat : category) (env : Environ.env) (last_fc : nat) :=
  let g_ctx := Environ.env_globals env in
  let relevance_of_arg := from_rel_result (relevance_of_type g_ctx [] cat.(cat_obj)) in
  (* We are interested in the relevance of [hom x y] for any [x] and [y] of the appropriate type.
     So, we create a dummy context with two entries and the feed it into the [relevance_of_type] *)
  let dummy_ctx :=
      [Build_context_decl nAnon relevance_of_arg None cat.(cat_obj);
       Build_context_decl nAnon relevance_of_arg None cat.(cat_obj)] in
  let dummy_app := (tApp cat.(cat_hom) [tRel 1; tRel 0]) in
  let relevance_hom :=
      from_rel_result (relevance_of_type (Environ.env_globals env) dummy_ctx dummy_app) in
  [ vass hom_name relevance_hom (tApp cat.(cat_hom) [(tRel (1 + last_fc)); (tRel 0)]);
    vass pos_name relevance_of_arg cat.(cat_obj) ].

Definition extend_forcing_ctx (fctx : forcing_context) (f : forcing_condition):=
  {| f_context := f :: fctx.(f_context);
     f_category := fctx.(f_category);
     f_translator := fctx.(f_translator)|}.

(** Packing the extension of a context and of a forcing context together *)
Definition extend (env : Environ.env) (fctx : forcing_context) : list context_decl * forcing_context :=
  let ext := get_ctx_lift fctx.(f_category) env (last_condition fctx.(f_context)) in
  (ext, extend_forcing_ctx fctx fcLift).

Definition add_variable fctx :=
  {| f_context := fcVar :: fctx.(f_context);
     f_category := fctx.(f_category);
     f_translator := fctx.(f_translator)|}.

(** Handling of globals *)

Definition translate_var (fctx : forcing_context) (n : nat) : term :=
  let p := tRel (last_condition fctx.(f_context)) in
  let f := morphism_var n fctx in
  let m := get_var_shift n fctx in
  (* We subsrtact 1 from m because indicies start from 0 *)
  tApp (tRel (m-1)) [p; f].

Definition get_inductive (fctx : forcing_context) (ind : inductive) : inductive :=
  let gr := IndRef ind in
  let gr_ := lookup_default fctx.(f_translator) gr in
  match gr_ with
  | tInd ind_ _ => ind_
  | _ => {| inductive_mind := "inductive translation not found: " ++ ind.(inductive_mind); inductive_ind := 0 |}
  end.

Definition should_not_be_ind := tVar "Should not be an application of an inductive type constructor".

Definition apply_global (env : Environ.env) (sigma : evar_map) gr (u : universe_instance) fctx :=
  (** FIXME -- a comment from the OCaml source code *)
  (* The parameter [u] is never used in the definition *)
  let p' := lookup_default fctx.(f_translator) gr in
  (* let (sigma, c) := Evd.fresh_global env sigma p' in *)
  let last := last_condition fctx.(f_context) in
  match gr with
  | IndRef _ => (sigma, should_not_be_ind)
  | _ => (sigma, tApp p' [ tRel last ])
  end.

(** Forcing translation core *)

Definition not_supported := tVar "Not supported".

Definition is_prop (s : universe) :=
  match s with
  | [(Level.lProp, false)] => true
  | _ => false
  end.

Fixpoint sep_last' {A} (xs : list A) : option (A *list A) :=
  match xs with
    [] => None
  | hd::[] => Some (hd,[])
  | hd::tl => match (sep_last' tl) with
              | None => None
              | Some (l,tl) => Some (l,hd::tl)
              end
  end.

Fixpoint sep_last {A} (xs : list A) : option (A *list A) :=
  match xs with
    [] => None
  | hd::tl => Some (hd,tl)
  end.

Definition id_translate sigma c : unit * term :=
  (sigma, c).

Definition otranslate_type (tr : Environ.env -> forcing_context -> evar_map -> term -> unit * term)
           (env : Environ.env) (fctx : forcing_context) (sigma : evar_map) (t : term)
  : unit * term :=
  let (sigma, t_) := tr env fctx sigma t in
  let last := tRel (last_condition fctx.(f_context)) in
  let t_ := mkOptApp t_ [ last; tApp fctx.(f_category).(cat_id) [last]] in
(sigma, t_).

Definition otranslate_boxed (tr : Environ.env -> forcing_context -> evar_map -> term -> unit * term)
           (env : Environ.env) (fctx : forcing_context) (sigma : evar_map) (t : term)
  : unit * term :=
  let (ext, ufctx) := extend env fctx in
  let (sigma, t_) := tr env ufctx sigma t in
  let t_ := it_mkLambda_or_LetIn t_ ext in
  (sigma, t_).

Definition otranslate_boxed_type (tr : Environ.env -> forcing_context -> evar_map -> term -> unit * term) env fctx sigma t :=
  let (ext, ufctx) := extend env fctx in
  let (sigma, t_) := otranslate_type tr env ufctx sigma t in
  let t_ := it_mkProd_or_LetIn t_ ext in
  (sigma, t_).

Quote Recursively Definition bazz := prod.
Quote Definition bar := (fun (a b : nat) => a = b).

Definition lookup_ind Σ ind i (u : list Level.t) (* TODO Universes *) :
  option one_inductive_body :=
    match lookup_env Σ ind with
    | Some (InductiveDecl _ mib) => nth_error mib.(ind_bodies) i
    |  _ => None
    end.

Definition lookup_mind Σ ind (u : list Level.t) (* TODO Universes *) :
  option mutual_inductive_entry :=
    match lookup_env Σ ind with
    | Some (InductiveDecl _ mib) => Some (mind_body_to_entry mib)
    |  _ => None
    end.

Fixpoint list_init_rev {A} (n : nat) (f : nat -> A) : list A :=
  match n with
  | O => []
  | S n' => f n' :: list_init_rev n' f
  end.

Definition list_init {A} (n : nat) (f : nat -> A) : list A := List.rev (list_init_rev n f).

(*Ported from the OCaml implementation *)
Fixpoint mapi {A B} (i : nat) (f : nat -> A -> B) (xs : list A) : list B :=
  match xs with
  | [] => []
  | a::l => let r := f i a in r :: mapi (i + 1) f l
  end.

Definition map_local_entry (f : term -> term) (ent : local_entry) : local_entry :=
  match ent with
  | LocalDef t => LocalDef (f t)
  | LocalAssum t => LocalAssum (f t)
  end.

Definition substn_decl i n (d : context_decl) : context_decl :=
  {| decl_name := d.(decl_name);
     decl_relevance := d.(decl_relevance);
     decl_body := match d.(decl_body) with None => None | Some t => Some (subst i n t) end;
     decl_type := subst i n d.(decl_type) |}.

Definition dummy_ctx_decl : context_decl :=
  {| decl_name := nAnon;
     decl_relevance := Relevant;
     decl_body := None;
     decl_type := tVar "Inductive not declared"|}.

  Fixpoint decompose_prod_r (t : term) : (list name * list relevance * list term) * term :=
  match t with
  | tProd n r A B =>
    let (nrAs, B) := decompose_prod_r B in
    match nrAs with
    | (ns, rs, As) => (n :: ns, r :: rs, A :: As, B)
    end
  | _ => ([], [], [], t)
  end.

  Fixpoint zip3_with {A B C D : Type} (xs : list A) (ys : list B) (zs : list C)
           (f : A -> B -> C -> D)
    : list D :=
    match xs,ys,zs with
    | [],_,_ => []
    | _,[],_ => []
    | _,_,[] => []
    | x :: xs', y :: ys', z :: zs' => f x y z :: zip3_with xs' ys' zs' f
    end.

  Definition to_rel_context (ns : list name) (rs : list relevance) (tys : list term) :=
    let vars := zip3_with ns rs tys (fun a b c => (a,b,c)) in
    let fn p := match p with
                  | (nam,r,ty) => {| decl_name := nam;
                                     decl_relevance := r;
                                     decl_body := None;
                                     decl_type := ty |}
                end in
    List.map fn vars.

(** Builds a translation for the inductive type occuring in the term.
    Assumes that the type itself is prevously translated and added to
    the translation table and to the global context *)
Definition otranslate_ind
           (tr : Environ.env -> forcing_context -> evar_map -> term -> unit * term)
           (env : Environ.env) (fctx : forcing_context) (sigma :evar_map) (ind : inductive) (u : universe_instance) (args : list term) :=
  (* Looking up in the translation table *)
  let ind_ := get_inductive fctx ind in
  (* Looking up in the global environment for the actual body of the translated inductive *)
  let oib' := lookup_ind (Environ.to_global_context env)
                         ind_.(inductive_mind) ind_.(inductive_ind) [] in
  (* Translating arguments *)
  let fold sigma t := otranslate_boxed tr env fctx sigma t in
  let fix fold_map_fix a args :=
      match args with
      | [] => (a, [])
      | hd :: tl =>
        let (a_, c_) := fold sigma hd in
        let (a__, cs) := fold_map_fix a_ tl in
        (a__, c_ :: cs)
      end in
  let (sigma, args_) := fold_map_fix sigma args in
  (* Recovering a context consisting of parameters and indices of the given inductive type *)
  let ind_ctx ind := match (decompose_prod_r ind.(ind_type)) with
                     | (ns,rs,tys,_) => to_rel_context ns rs tys
                     end
  in
  let all_params :=
      match oib' with
      | Some t => ind_ctx t
      | None => [dummy_ctx_decl]
      end
  in
  (** First parameter is the toplevel forcing condition *)
  let (_, paramtyp) :=
      match oib' with
      | Some t => option_get (dummy_ctx_decl,[]) (sep_last all_params)
      | None => (dummy_ctx_decl,[dummy_ctx_decl])
      end in
  let nparams := List.length paramtyp in
  let last := last_condition fctx.(f_context) in
  let fctx := List.fold_left (fun accu _ => add_variable accu) paramtyp fctx in
  (* We extend the focring context with a new lift *)
  let (ext, fctx) := extend env fctx in
  let mk_var n :=
    let m := nparams - n - 1 in
    let (ext0, fctx) := extend env fctx in
    let ans := translate_var fctx m in
    it_mkLambda_or_LetIn ans ext0
  in
  let params := list_init nparams mk_var in
  (* Now, we apply the translation of the inductive type to a new forcing condition *)
  let app := tApp (tInd ind_ u) (tRel (last_condition fctx.(f_context)) :: params) in
  (* We have to substitute the focring condition which was the last one
     before we extended the forcing conetxt *)
  let map_p i c := substn_decl (tRel last) (nparams - i - 1) c in
  let paramtyp' := List.rev paramtyp in
  let paramtyp_subst := mapi 0 map_p paramtyp' in
  let ans := it_mkLambda_or_LetIn app (ext ++ paramtyp_subst)%list in
  (sigma, mkOptApp ans args_).

(** Adds lambda abstractions build from the context [Γ] on top if the given term [body] *)
Definition lambda_prefix Γ body := it_mkLambda_or_LetIn body Γ.

(** Adds Π's build from the context [Γ] on top if the given term [body] *)
Definition pi_prefix Γ body := it_mkProd_or_LetIn body Γ.

(** Returns a function, wrapping
    give term [t] into [λ (q : cat) (f : Hom(σₑ,q)) . t],
    where σₑ is the last forcing condition of σ.
    See Notaion 1 in DSoF paper. *)
Definition λ_q_f (env : Environ.env) (σ : forcing_context) : forcing_context * (term -> term) :=
  let ext_ctx := get_ctx_lift σ.(f_category) env (last_condition σ.(f_context)) in
  let ext_fctx := extend_forcing_ctx σ fcLift in
  (ext_fctx, lambda_prefix ext_ctx).

(** Similarly to [λ_q_f], but for [Π q f].
    See Notaion 1 in DSoF paper. *)
Definition Π_q_f (env : Environ.env) (σ : forcing_context) : forcing_context * (term -> term) :=
  let ext_ctx := get_ctx_lift σ.(f_category) env (last_condition σ.(f_context)) in
  let ext_fctx := extend_forcing_ctx σ fcLift in
  (ext_fctx, pi_prefix ext_ctx).

Fixpoint otranslate (env : Environ.env) (fctx : forcing_context)
         (sigma : evar_map) (c : term) {struct c} : evar_map * term :=
  match c with
| tRel n =>
  let ans := translate_var fctx n in
  (* let ans := tVar (list_to_string fcond_to_string fctx.(f_context) ++ " | tRel " ++ string_of_int n) in *)
    (sigma, ans)
| tSort s =>
  let (sigma, s') :=
      if is_prop s then (sigma, s)
    else
      (* TODO: Not sure how to deal with the universe variable generation *)
      (* Evd.new_sort_variable Evd.univ_flexible sigma *)
      (* Probably, use an empty list as a universe param *)
      (* For now, we just return the original universe, as it is given in the paper *)
      (sigma, s)
  in
  let (fctx_ext, λqf) := λ_q_f env fctx in
  (* TODO: universe variable generation *)
  (* let sigma := Evd.set_leq_sort env sigma s s' in *)
  let (_, Πrg) := Π_q_f env fctx_ext in
  let tpe := Πrg (tSort s') in
  (sigma, λqf tpe)
| tCast c k t =>
  let (sigma, c_) := otranslate env fctx sigma c in
  let (sigma, t_) := otranslate_type otranslate env fctx sigma t in
  let ans := tCast c_ k t_ in
  (sigma, ans)
| tProd na r t u =>
  let (ext0, fctx) := extend env fctx in
  (** Translation of t *)
  let (sigma, t_) := otranslate_boxed_type otranslate env fctx sigma t in
  (** Translation of u *)
  let ufctx := add_variable fctx in
  let (sigma, u_) := otranslate_type otranslate env ufctx sigma u in
  (** Result *)
  let ans := tProd na r t_ u_ in
  let lam := it_mkLambda_or_LetIn ans ext0 in
  (sigma, lam)
| tLambda na r t u =>
  (** Translation of t *)
  let (sigma, t_) := otranslate_boxed_type otranslate env fctx sigma t in
  (** Translation of u *)
  let ufctx := add_variable fctx in
  let (sigma, u_) := otranslate env ufctx sigma u in
  let ans := tLambda na r t_ u_ in
  (sigma, ans)
| tLetIn na r c t u =>
  let (sigma, c_) := otranslate_boxed otranslate env fctx sigma c in
  let (sigma, t_) := otranslate_boxed_type otranslate env fctx sigma t in
  let ufctx := add_variable fctx in
  let (sigma, u_) := otranslate env ufctx sigma u in
  (sigma, tLetIn na r c_ t_ u_)
| tApp (tInd t u) args  => otranslate_ind otranslate env fctx sigma t u args
| tApp t args =>
  let (sigma, t_) := otranslate env fctx sigma t in
  let fold sigma u := otranslate_boxed otranslate env fctx sigma u in
  (* implementing a specialised version of fold_map' from ftUtils as a nested fix *)
  let fix fold_map_fix a args :=
      match args with
      | [] => (a, [])
      | hd :: tl =>
        let (a_, c_) := fold sigma hd in
        let (a__, cs) := fold_map_fix a_ tl in
        (a__, c_ :: cs)
      end in
  let (sigma, args_) := fold_map_fix sigma args in
  (* the original OCaml code *)
  (* let fold sigma u = otranslate_boxed env fctx sigma u in *)
  (* let (sigma, args_) = CArray.fold_map fold sigma args in *)
  let app := tApp t_ args_ in  (sigma, app)
| tVar id => (* [VarRef] is not defined as a constuctor for [global_reference] in Template Coq *)
  (sigma, not_supported)
  (* apply_global env sigma (VarRef id) Instance.empty fctx *)
| tConst p u =>  apply_global env sigma (ConstRef p) u fctx
| tInd ind u => otranslate_ind otranslate env fctx sigma ind u []
| tConstruct c u _ => (sigma, not_supported)
  (* apply_global env sigma (ConstructRef c) u fctx *)
| tCase ci rel r c p => (sigma, not_supported)
(* Comment out this case as well, since inductive types are not yet supported by this translation *)
   (* let ind_ = get_inductive fctx ci.ci_ind in *)
   (* let ci_ = Inductiveops.make_case_info env ind_ ci.ci_pp_info.style in *)
   (* let (sigma, c_) = otranslate env fctx sigma c in *)
   (* let fix_return_clause env fctx sigma r = *)
   (*   (** The return clause structure is fun indexes self => Q *)
   (*       All indices must be boxed, but self only needs to be translated *) *)
   (*   let (args, r_) = decompose_lam_assum r in *)
   (*   let ((na, _, self), args) = match args with h :: t -> (h, t) | _ -> assert false in *)
   (*   let fold (sigma, fctx) (na, o, u) =  *)
   (*    (** For every translated index, the corresponding variable is added *)
   (*        to the forcing context *) *)
   (*     let (sigma, u_) = otranslate_boxed_type env fctx sigma u in *)
   (*     let fctx = add_variable fctx in *)
   (*     (sigma, fctx), (na, o, u_) *)
   (*   in *)
   (*   let (sigma, fctx), args = CList.fold_map fold (sigma, fctx) args in *)
   (*   let (sigma, self_) = otranslate_type env fctx sigma self in *)
   (*   let fctx_ = add_variable fctx in *)
   (*   let (sigma, r_) = otranslate_type env fctx_ sigma r_ in *)
   (*   let (ext, ufctx) = extend fctx in *)
   (*   let selfid = Id.of_string "self" in *)
   (*   let r_ = Reductionops.nf_betadeltaiota env Evd.empty r_ in  *)
   (*   let r_ = Vars.substnl [it_mkLambda_or_LetIn (mkVar selfid) ext] 1 (Vars.lift 1 r_) in *)
   (*   let r_ = Reductionops.nf_beta Evd.empty r_ in  *)
   (*   let r_ = Vars.subst_var selfid r_ in *)
   (*   let r_ = it_mkLambda_or_LetIn r_ ((na, None, self_) :: args) in  *)
   (*   (sigma, r_)        *)
   (* in *)
   (* let (sigma, r_) = fix_return_clause env fctx sigma r in *)
   (* let fold sigma u = otranslate env fctx sigma u in *)
   (* let (sigma, p_) = CArray.fold_map fold sigma p in *)
   (* (sigma, mkCase (ci_, r_, c_, p_)) *)
| tFix _ _ => (sigma, not_supported)
| tCoFix _ _ => (sigma, not_supported)
| tProj _ _ => (sigma, not_supported)
| tMeta _ => (sigma, not_supported)
| tEvar _ _ => (sigma, not_supported)
  end.

Definition empty translator cat lift env :=
  let ctx := Environ.rel_context env in
  let empty := {| f_context := []; f_category := cat; f_translator := translator; |} in
  let empty := List.fold_right (fun _ fctx => add_variable fctx) empty ctx in
  let fix flift fctx n :=
      match n with
      | O => fctx
      | S n' => flift (snd (extend env fctx)) n'
      end
  in
  flift empty (match lift with None => 0 | Some n => n end).

(** The toplevel option allows to close over the topmost forcing condition *)

Definition toplevel_term (cat : category) (c : term) : term
  := tLambda pos_name Relevant cat.(cat_obj) c.

Definition toplevel_type (cat : category) (c : term) : term
  := tProd pos_name Relevant cat.(cat_obj) c.

Definition translate (toplevel : bool) lift translator cat env sigma c :=
  let empty := empty translator cat lift env in
  let (sigma, c) := otranslate env empty sigma c in
  let ans := if toplevel then toplevel_term cat c else c in
  (sigma, ans).

Definition translate_simple (toplevel : bool) (cat : category) (c : term) : term :=
  let (_, c_) := translate toplevel None [] cat Environ.empty_env tt c in c_.

Definition translate_type (toplevel : bool) lift translator cat env sigma c :=
  let empty := empty translator cat lift env in
  let (sigma, c) := otranslate_type otranslate env empty sigma c in
  let ans := if toplevel then tProd pos_name Relevant cat.(cat_obj) c else c in
  (sigma, ans).

Definition translate_type_simple (toplevel : bool) (cat : category) (c : term) : term :=
  let (_, c_) := translate_type toplevel None [] cat Environ.empty_env tt c in c_.

Definition otranslate_context (env : Environ.env) (fctx : forcing_context)
           (sigma : evar_map) (ctx : context)
  : evar_map * context :=
  let fold (a : context_decl) (b : evar_map * forcing_context * context) :=
      match b with
       (sigma, fctx, ctx_) =>
       let (sigma, body_) := match a.(decl_body) with
                             | None => (sigma, None)
                             | Some _ => (sigma, Some (tVar ("something went wrong")))
                             end
       in
       let (ext, tfctx) := extend env fctx in
       let (sigma, t_) := otranslate_type otranslate env tfctx sigma a.(decl_type) in
       let t_ := it_mkProd_or_LetIn t_ ext in
       let decl_ := Build_context_decl a.(decl_name) a.(decl_relevance) body_ t_ in
       let fctx := add_variable fctx in
       (sigma, fctx, decl_ :: ctx_)
      end
  in
  match (List.fold_right fold (sigma, fctx, []) ctx) with
    (sigma, _, ctx_) => (sigma, ctx_)
  end.

Definition toplevel_context (cat : category) (ctx : context) : context :=
  Build_context_decl pos_name Relevant None cat.(cat_obj) :: ctx.

Definition translate_context (toplevel : bool) (lift : option nat)
           (translator : tsl_table) (cat : category)
           (env : Environ.env) (sigma : evar_map) (ctx : context)
  : evar_map * context :=
  let empty := empty translator cat lift env in
  let (sigma, ctx_) := otranslate_context env empty sigma ctx in
  let ctx__ := if toplevel then  toplevel_context cat ctx_ else ctx_ in
  (sigma, ctx__).

Definition translate_context_simple (toplevel : bool) (cat : category) (ctx : context) : context :=
  let (_, c_) := translate_context toplevel None [] cat Environ.empty_env tt ctx in c_.

(* A bridge to the monadic translation utils *)

Definition f_translate (cat : category) (tsl_ctx : tsl_context) (trm : term)
  : tsl_result term :=
  Success (snd (translate true None
                          (snd tsl_ctx)
                          cat
                          ({| Environ.env_globals := (fst (fst tsl_ctx)) |})
                          tt
                          trm)).

Definition f_translate_type (cat : category) (tsl_ctx : tsl_context) (trm : term)
  : tsl_result term :=
  Success (snd (translate_type true None
                               (snd tsl_ctx)
                               cat
                               ({| Environ.env_globals := (fst (fst tsl_ctx)) |})
                               tt
                               trm)).

Definition ForcingTranslation (cat : category) : Translation :=
  {| tsl_id := tsl_ident;
     tsl_tm := f_translate cat;
     tsl_ty := f_translate_type cat;
     tsl_ind := fun _ _ _ _ => Error TranslationNotHandeled;
     (* tsl_context -> kername -> kername -> mutual_inductive_body *)
     (*             -> tsl_result (tsl_table * list mutual_inductive_body) *)
  |}.

Definition add_translation (ctx : tsl_context) (e : global_reference * term): tsl_context :=
  let (Σ, E) := ctx in
  (Σ, e :: E).


Require Import Utils.
Require Import String.
Require Import JsNumber.
Open Scope list_scope.
Module Heap := HeapUtils.Heap.

Require Import Syntax.

(* LambdaJS values and objects *)

(* Some vocabulary:
* All of LambdaJS data is passed as value location (think of locations as
* pointers), so there is an heap mapping locations to values, and optionnally
* another one mapping names to locations.
* Moreover, objects are mutable values. To emulate mutability with Coq, we
* represent objects as pointer values, and the pointer is used to fetch
* them from the objects heap. *)

(****** Basic stuff ******)

Definition id := string.
Definition closure_id := nat.
Definition value_loc := nat.
Definition object_ptr := nat.

Definition loc_heap_type := Heap.heap id value_loc.

(****** Objects ******)

(* (The code in this section comes mostly from JSCert.) *)

(* Named data property attributes *)
Record attributes_data := attributes_data_intro {
   attributes_data_value : value_loc;
   attributes_data_writable : bool;
   attributes_data_enumerable : bool;
   attributes_data_configurable : bool }.

(* Named accessor property attributes *)
Record attributes_accessor := attributes_accessor_intro {
   attributes_accessor_get : value_loc;
   attributes_accessor_set : value_loc;
   attributes_accessor_enumerable : bool;
   attributes_accessor_configurable : bool }.

(* Property attributes *)
Inductive attributes :=
  | attributes_data_of : attributes_data -> attributes
  | attributes_accessor_of : attributes_accessor -> attributes.

Definition prop_name := string.
Definition class_name := string.
Definition object_properties := Heap.heap prop_name attributes.

Record object := object_intro {
   object_proto : value_loc;
   object_class : class_name;
   object_extensible : bool;
   object_prim_value : option value_loc;
   object_properties_ : object_properties;
   object_code : option value_loc }.

Fixpoint name_in_list (name : prop_name) (names : list prop_name) : bool :=
  match names with
  | nil => false
  | hd :: tl =>
    if (decide(name = hd)) then
      true
    else
      name_in_list name tl
  end
.

Definition get_object_property (object : object) (name : prop_name) : option attributes :=
  Heap.read_option (object_properties_ object) name
.
Definition set_object_property (obj : object) (name : prop_name) (attrs : attributes) : object :=
  match obj with (object_intro p c e p' props code) =>
    let props2 := Heap.write props name attrs in
    object_intro p c e p' props2 code
  end
.

(******* Finally, values. *******)

Inductive value : Type :=
| Null
| Undefined
| Number : Syntax.number -> value
| String : string -> value
| True
| False
| Object : object_ptr -> value
| Closure : closure_id -> loc_heap_type -> list id -> Syntax.expression -> value (* closure_id is for making closures comparable with stx= *)
.