 (*

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

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

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

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

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

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

  Authors: Vincent Rahli

*)

Require Export cnterm.
Require Export substc_more.
Require Export per_props_equality.
Require Export cequiv_cnterm.
Require Export sequents2.
Require Export lsubstc_vars.

Lemma member_nout_implies {o} :
  forall lib (t : @CTerm o),
    member lib t mkc_nout
    -> {u : CNTerm , ccequivc lib t (cnterm2cterm u)}.
Proof.
  introv mem.
  apply equality_in_nout in mem; exrepnd.
  exists (cterm2cnterm u mem1).
  autorewrite with slow; auto.
Qed.

Lemma member_nout_iff {o} :
  forall lib (t : @CTerm o),
    member lib t mkc_nout
    <=> {u : CNTerm , ccequivc lib t (cnterm2cterm u)}.
Proof.
  introv; split; intro h; try (apply member_nout_implies; auto);[].
  exrepnd.
  apply equality_in_nout.
  exists (cnterm2cterm u); dands; eauto 3 with slow.
Qed.

Lemma reduces_toc_eapply_ntseqc2ntseq {o} :
  forall lib s (t u : @CTerm o),
    reduces_toc lib t u
    -> reduces_toc
         lib
         (mkc_eapply (ntseqc2ntseq s) t)
         (mkc_eapply (ntseqc2ntseq s) u).
Proof.
  introv r.
  destruct_cterms.
  allunfold @reduces_toc; allsimpl.
  apply implies_eapply_red_aux; eauto 3 with slow.
Qed.

Lemma get_cterm_cnterm2cterm_is_ntseqc2seq {o} :
  forall (f : @ntseqc o) k,
    get_cterm (cnterm2cterm (f k)) = ntseqc2seq f k.
Proof.
  introv.
  unfold cnterm2cterm, ntseqc2seq; simpl.
  remember (f k) as t; destruct t; simpl; auto.
Qed.

Lemma reduces_toc_ntseqc2ntseq_step {o} :
  forall lib (f : @ntseqc o) k,
    reduces_toc lib (mkc_eapply (ntseqc2ntseq f) (mkc_nat k)) (cnterm2cterm (f k)).
Proof.
  introv.
  unfold reduces_toc; simpl.
  apply reduces_to_if_step.
  csunf; simpl.
  dcwf h; simpl; boolvar; try omega.
  rewrite Znat.Nat2Z.id.
  rewrite get_cterm_cnterm2cterm_is_ntseqc2seq; auto.
Qed.

Lemma implies_approx_eapply {p} :
  forall lib f g a b,
    approx lib f g
    -> @approx p lib a b
    -> approx lib (mk_eapply f a) (mk_eapply g b).
Proof.
  introv H1p H2p.
  applydup @approx_relates_only_progs in H1p.
  applydup @approx_relates_only_progs in H2p.
  repnd.
  repeat (prove_approx);sp.
Qed.

Lemma implies_cequivc_eapply {o} :
  forall lib (f g a b : @CTerm o),
    cequivc lib f g
    -> cequivc lib a b
    -> cequivc lib (mkc_eapply f a) (mkc_eapply g b).
Proof.
  unfold cequivc.
  introv H1c H2c.
  destruct_cterms.
  allsimpl.
  apply isprogram_eq in i0.
  allrw @isprog_eq.
  repnud H1c.
  repnud H2c.
  repnd.
  split; apply implies_approx_eapply; auto.
Qed.

(*

   forall m : nat, squash (exists n : NUBase, P(m,n))

   implies

   squash (exists f : nat -> NUBase, forall m : nat, squash (P (m, f m)))

 *)
Lemma axiom_of_choice_0NUB {o} :
  forall lib f m n (P : @CTerm o),
    n <> m
    -> f <> m
    -> (forall a b,
          member lib a mkc_tnat
          -> member lib b mkc_nout
          -> type lib (mkc_apply2 P a b))
    -> inhabited_type
         lib
         (mkc_forall
            mkc_tnat
            m
            (mkcv_squash
               [m]
               (mkcv_exists
                  [m]
                  (mkcv_nout [m])
                  n
                  (mkcv_apply2 [n,m]
                               (mk_cv [n,m] P)
                               (mk_cv_app_l [n] [m] (mkc_var m))
                               (mk_cv_app_r [m] [n] (mkc_var n))))))
    -> inhabited_type
         lib
         (mkc_exists
            nat2nout
            f
            (mkcv_forall
               [f]
               (mk_cv [f] mkc_tnat)
               m
               (mkcv_squash
                  [m,f]
                  (mkcv_apply2 [m,f]
                               (mk_cv [m,f] P)
                               (mk_cv_app_r [f] [m] (mkc_var m))
                               (mkcv_apply [m,f]
                                           (mk_cv_app_l [m] [f] (mkc_var f))
                                           (mk_cv_app_r [f] [m] (mkc_var m))))))).
Proof.
  introv d1 d2 impp inh.

  unfold mkc_forall in inh.
  apply inhabited_function in inh.
  repnd.
  clear inh0 inh1.
  exrepnd.

  assert (forall k : CTerm,
            member lib k mkc_tnat
            -> inhabited_type
                 lib
                 (mkc_exists
                    mkc_nout
                    n
                    (mkcv_apply2
                       [n]
                       (mk_cv [n] P)
                       (mk_cv [n] k)
                       (mkc_var n)))) as q.
  { introv mem.
    pose proof (inh0 k k) as h.
    autodimp h hyp.
    allrw @substc_mkcv_squash.
    rw @equality_in_mkc_squash in h.
    repnd.
    rw @mkcv_exists_substc in h; auto.
    allrw @mkcv_nout_substc.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv_app_l.
    rw @substc2_mk_cv_app_r in h; auto.
    allrw @substc2_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear inh0.

  assert (forall k : CTerm,
            member lib k mkc_tnat
            -> {j : CTerm
                , member lib j mkc_nout
                # inhabited_type lib (mkc_apply2 P k j)}) as h.
  { introv mem.
    apply q in mem; clear q.
    apply inhabited_exists in mem; repnd.
    clear mem0 mem1.
    exrepnd.
    exists a; dands; auto.
    allrw @mkcv_apply2_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear q.

  (* First use FunctionalChoice_on to get an existential (a Coq function from terms to terms) *)

  pose proof (FunctionalChoice_on
                {k : CTerm & member lib k mkc_tnat}
                (@CTerm o)
                (fun k j =>
                   member lib j mkc_nout
                   # inhabited_type lib (mkc_apply2 P (projT1 k) j)))
    as fc.
  simphyps.
  autodimp fc hyp; tcsp;[].
  exrepnd.
  clear h.
  rename fc0 into fc.

  pose proof (FunctionalChoice_on
                {k : CTerm & member lib k mkc_nout}
                (@CNTerm o)
                (fun k j => ((projT1 k) ~=~(lib) (cnterm2cterm j))))
    as fcn.
  simphyps.
  autodimp fcn hyp; tcsp;[sp; simpl; apply member_nout_implies; auto; fail|].
  exrepnd.
  rename fcn0 into fcn.

  assert {c : ntseqc
          & forall a : CTerm,
              member lib a mkc_tnat
              -> (member lib (mkc_eapply (ntseqc2ntseq c) a) mkc_nout
                  # inhabited_type lib (mkc_apply2 P a (mkc_eapply (ntseqc2ntseq c) a)))} as fs.
  { exists (fun n =>
              f2 (existT
                    _
                    (f1 (existT _ (mkc_nat n) (nat_in_nat lib n)))
                    (fst (fc (existT _ (mkc_nat n) (nat_in_nat lib n)))))).
    introv mem.
    dands.

    - apply member_tnat_iff in mem; exrepnd.
      allrw @computes_to_valc_iff_reduces_toc; repnd.
      eapply member_respects_reduces_toc;[apply reduces_toc_eapply_ntseqc2ntseq;exact mem1|].

      eapply member_respects_reduces_toc;
        [apply reduces_toc_ntseqc2ntseq_step|].

      simpl.
      apply member_nout_iff.
      eexists; spcast; apply cequivc_refl.

    - apply member_tnat_iff in mem; exrepnd.
      pose proof (nat_in_nat lib k) as mk.

      eapply inhabited_type_cequivc;
        [apply implies_cequivc_apply2;
          [apply cequivc_refl
          |apply cequivc_sym;apply computes_to_valc_implies_cequivc;eauto
          |apply implies_cequivc_eapply;
            [apply cequivc_refl
            |apply cequivc_sym;apply computes_to_valc_implies_cequivc;eauto
            ]
          ]
        |].

      eapply inhabited_type_cequivc;
        [apply implies_cequivc_apply2;
          [apply cequivc_refl
          |apply cequivc_refl
          |apply cequivc_sym;
            apply reduces_toc_implies_cequivc;
            apply reduces_toc_ntseqc2ntseq_step
          ]
        |].
      simpl.
      remember (fc exI(mkc_nat k, nat_in_nat lib k)) as fck.
      exrepnd.
      allsimpl.

      pose proof (fcn exI(f1 exI(mkc_nat k, nat_in_nat lib k), fck0)) as xx.
      simpl in xx; spcast.
      eapply inhabited_type_cequivc;
        [apply implies_cequivc_apply2;
          [apply cequivc_refl
          |apply cequivc_refl
          |eauto]
        |].
      auto.
  }
  clear f1 fc f2 fcn.
  exrepnd.

  (* then "convert" the Coq function into a Nuprl function *)

  apply inhabited_product.

  dands; eauto 3 with slow.

  { introv eqf.
    unfold mkcv_forall.
    repeat (rw @substc_mkcv_function; auto).
    allrw @csubst_mk_cv.
    apply tequality_function.
    dands; eauto 3 with slow.
    { apply tnat_type. }

    introv eqn.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc_mkcv_squash.
    allrw @mkcv_apply2_substc.
    allrw @substc2_mk_cv.
    allrw @csubst_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @substc2_apply.
    repeat (rw @substc2_mk_cv_app_l; auto).
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @csubst_mk_cv.

    apply tequality_mkc_squash.
    apply type_respects_cequivc_left.

    { apply implies_cequivc_apply2; auto.
      { apply equality_int_nat_implies_cequivc; auto.
        apply equality_sym; auto. }
      { eapply equality_nat2nout_apply in eqf;[|exact eqn].
        apply cequiv_stable.
        apply equality_in_nout in eqf; exrepnd; spcast.
        eapply cequivc_trans; eauto.
        apply cequivc_sym; auto. }
    }

    { apply impp; eauto 3 with slow.
      { apply equality_sym in eqn; apply equality_refl in eqn; auto. }
      { eapply equality_nat2nout_apply in eqf;[|exact eqn].
        apply equality_sym in eqf; apply equality_refl in eqf; auto. }
    }
  }

  { exists (ntseqc2ntseq c).
    unfold mkcv_forall.
    repeat (rw @substc_mkcv_function; auto).
    allrw @csubst_mk_cv.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @substc2_apply.
    repeat (rw @substc2_mk_cv_app_l; auto).
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @mkc_var_substc.

    dands.

    { apply member_ntseqc2ntseq_nat2nout. }

    { apply inhabited_function; dands; eauto 3 with slow.

      - introv eqn.
        allrw @substc_mkcv_squash.
        allrw @mkcv_apply2_substc.
        allrw @mkcv_apply_substc.
        allrw @csubst_mk_cv.
        allrw @mkc_var_substc.

        apply tequality_mkc_squash.
        apply type_respects_cequivc_left.

        { apply implies_cequivc_apply2; auto.
          { apply equality_int_nat_implies_cequivc; auto.
            apply equality_sym; auto. }
          { apply implies_cequivc_apply; auto.
            apply equality_int_nat_implies_cequivc; auto.
            apply equality_sym; auto. }
        }

        { apply impp; eauto 3 with slow.
          { apply equality_sym in eqn; apply equality_refl in eqn; auto. }
          { pose proof (member_ntseqc2ntseq_nat2nout lib c) as eqf.
            eapply equality_nat2nout_apply in eqf;[|exact eqn].
            apply equality_sym in eqf; apply equality_refl in eqf; auto. }
        }

      - exists (@mkc_lam o nvarx (mkcv_axiom nvarx)).
        introv eqn.
        allrw @substc_mkcv_squash.
        allrw @mkcv_apply2_substc.
        allrw @mkcv_apply_substc.
        allrw @csubst_mk_cv.
        allrw @mkc_var_substc.

        applydup @equality_int_nat_implies_cequivc in eqn.
        apply equality_refl in eqn.
        eapply equality_respects_cequivc_right;
          [apply implies_cequivc_apply;
            [apply cequivc_refl
            |exact eqn0]
          |].
        rw @member_eq.

        eapply member_respects_cequivc;
          [apply cequivc_sym;
            apply cequivc_beta
          |].
        rw @substc_mkcv_axiom.

        apply equality_in_mkc_squash; dands; spcast;
        try (apply computes_to_valc_refl; eauto 3 with slow).

        pose proof (fs0 a eqn) as q; repnd.

        eapply inhabited_type_cequivc;[|exact q].
        apply implies_cequivc_apply2; auto.
        apply cequivc_sym.
        apply reduces_toc_implies_cequivc.
        destruct_cterms.
        unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl; auto.
    }
  }
Qed.

Definition rule_AC0NUB {o}
           (P e : @NTerm o)
           (f m n : NVar)
           (H : barehypotheses)
           (i : nat) :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_squash (mk_exists (mk_nat2nout) f (mk_forall mk_tnat n (mk_squash (mk_apply2 P (mk_var n) (mk_apply (mk_var f) (mk_var n)))))))))
      [ mk_baresequent H (mk_concl (mk_forall mk_tnat n (mk_squash (mk_exists mk_nout m (mk_apply2 P (mk_var n) (mk_var m))))) e),
        mk_baresequent H (mk_conclax (mk_member P (mk_fun mk_tnat (mk_fun mk_nout (mk_uni i))))) ]
      [].

Lemma rule_AC0NUB_true3 {p} :
  forall lib
         (P e : NTerm)
         (f m n : NVar)
         (H : @barehypotheses p)
         (i : nat)
         (d1 : n <> m)
         (d2 : f <> n)
         (d3 : !LIn f (free_vars P))
         (d4 : !LIn m (free_vars P))
         (d5 : !LIn n (free_vars P)),
    rule_true3 lib (rule_AC0NUB P e f m n H i).
Proof.
  unfold rule_AC0NUB, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  destruct hyp1 as [wc1 hyp1].
  rename Hyp0 into hyp2.
  destruct hyp2 as [wc2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H)
                         ||- (mk_conclax
                                (mk_squash
                                   (mk_exists
                                      mk_nat2nout
                                      f
                                      (mk_forall
                                         mk_tnat
                                         n
                                         (mk_squash
                                            (mk_apply2
                                               P
                                               (mk_var n)
                                               (mk_apply
                                                  (mk_var f)
                                                  (mk_var n)))))))))) as wfc.
  { clear hyp1 hyp2.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hh; exrepnd; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as qq; exrepnd; clear hyp2.

  allunfold @mk_forall.
  allunfold @mk_exists.
  allunfold @mk_nat2nout.

  lsubst_tac.
  allapply @member_if_inhabited.
  apply tequality_mkc_member_implies_sp in qq0; auto;[].
  allrw @tequality_mkc_member; repnd.

  lsubst_tac.
  allrw @lsubstc_mkc_tnat.
  allrw @lsubstc_mk_nout.

  pose proof (axiom_of_choice_0NUB lib f n m (lsubstc P wt s1 ct1)) as ac.
  repeat (autodimp ac hyp).

  - (* from qq1 *)
    introv m1 m2.
    apply equality_in_fun in qq1; repnd.
    pose proof (qq1 a a) as h.
    autodimp h hyp.
    lsubst_tac.
    allrw @lsubstc_mkc_tnat.
    allrw @lsubstc_mk_nout.
    apply equality_in_fun in h; repnd.
    pose proof (h b b) as q.
    autodimp q hyp.
    apply equality_in_uni in q; auto.
    allrw <- @mkc_apply2_eq; auto.

  - (* from hh1 *)
    apply equality_refl in hh1.
    exists (lsubstc e wfce0 s1 pt0).

    repeat lsubstc_vars_as_mkcv.
    allrw @lsubstc_mk_nout.
    auto.

  - repeat lsubstc_vars_as_mkcv.
    allrw @lsubstc_mk_nout.

    dands;
      [|apply equality_in_mkc_squash; dands; spcast;
        try (apply computes_to_valc_refl; eauto 3 with slow);
        allunfold @mkc_exists; allunfold @mkcv_forall;
        eapply inhabited_type_respects_alphaeqc;[|exact ac];
        apply alphaeqc_mkc_product1;
        apply alphaeqc_sym;
        fold (@mk_nat2nout p);
        rewrite lsubstc_mk_nat2nout;
        eauto 3 with slow];[].

    apply tequality_mkc_squash.

    eapply tequality_respects_alphaeqc_left;
      [apply alphaeqc_mkc_product1;
        apply alphaeqc_sym;
        fold (@mk_nat2nout p);
        rewrite lsubstc_mk_nat2nout;
        eauto 3 with slow
      |].
    eapply tequality_respects_alphaeqc_right;
      [apply alphaeqc_mkc_product1;
        apply alphaeqc_sym;
        fold (@mk_nat2nout p);
        rewrite lsubstc_mk_nat2nout;
        eauto 3 with slow
      |].
    apply tequality_product; dands.
    { apply type_nat2nout. }

    introv eqf.
    repeat (rw @substc_mkcv_function; auto;[]).
    allrw @mkcv_tnat_substc.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc2_apply.
    allrw @substc2_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto;[]).
    repeat (rw @substc2_mk_cv_app_l; auto;[]).
    allrw @mkc_var_substc.

    apply tequality_function; dands.
    { apply tnat_type. }

    introv eqn.
    allrw @substc_mkcv_squash.
    allrw @mkcv_apply2_substc.
    allrw @mkcv_apply_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.

    apply tequality_mkc_squash.
    apply equality_in_fun in qq0; repnd.
    applydup qq0 in eqn.
    lsubst_tac.
    apply equality_in_fun in eqn0; repnd.
    pose proof (eqn0 (mkc_apply a a0) (mkc_apply a' a'0)) as q.
    allrw @lsubstc_mkc_tnat.
    allrw @lsubstc_mk_nout.
    autodimp q hyp.
    { apply equality_nat2nout_apply; auto. }
    allrw <- @mkc_apply2_eq.
    apply equality_in_uni in q; auto.
Qed.


From iris.proofmode Require Import tactics.
From mwp.mwp_modalities Require Import mwp_step_fupd.
From mwp.mwp_modalities.ni_logrel Require Import mwp_left mwp_right ni_logrel_lemmas
     mwp_logrel_fupd ni_logrel_fupd_lemmas.
From logrel_ifc.lambda_sec Require Export lattice fundamental_binary notation.

(* This is an implicit variation of [refs.v] where we leak (temporarily)
   information through an implicit flow but fix it before returning. *)
Definition prog : expr:=
  (if: !$1 = 42 then $0 <- 1 else $0 <- 0);; $0 <- 0.

Local Instance tpSecurityLatticeH : SecurityLattice tplabel := { ζ := L }.
Notation H := (LLabel H).
Notation L := (LLabel L).

Section related.
  Context `{!secG Σ}.

  Lemma prog_related :
    [TRef (TNat @ L) @ L; TRef (TNat @ H) @ L] ⊨ prog ≤ₗ prog : TUnit @ L.
  Proof.
    iIntros (θ ρ vvs Hpers) "[#Hcoh Henv]".
    iDestruct (interp_env_length with "Henv") as %H.
    do 2 (destruct vvs; [done|]); clear H.
    iDestruct (interp_env_cons with "Henv") as "[Hlow Henv']".
    iDestruct (interp_env_cons with "Henv'") as "[Hhigh _]".
    rewrite !interp_sec_def !bool_decide_eq_true_2 // !interp_ref_def.
    iDestruct "Hlow" as ([l1 l2]) "[-> #Hlow] /=".
    iDestruct "Hhigh" as ([h1 h2]) "[-> #Hhigh] /=".
    rewrite /interp_expr /=.
    iApply (mwp_left_strong_bind _ _ (fill [BinOpLCtx _ _; IfCtx _ _; SeqCtx _])
                                (fill [BinOpLCtx _ _; IfCtx _ _; SeqCtx _])); simpl.
    iApply (mwp_double_atomic_lr _ _ StronglyAtomic).
    iInv (nroot.@(h1,h2)) as "Hh" "Hclose !>".
    iDestruct "Hh" as (v1 v2) "(>Hh1 & >Hh2 & #Hv) /=".
    rewrite !loc_to_val.
    iApply (@mwp_step_fupd_load _ secG_un_left); [done|].
    iFrame. iIntros "!> Hh1".
    iApply (@mwp_fupd_load _ secG_un_right); [done|].
    iFrame. iIntros "Hh2 /=".
    iMod ("Hclose" with "[-]") as "_".
    { iExists _,_. iFrame. iFrame "#". }
    iModIntro.
    iDestruct (secbin_subsumes_secun with "[$Hcoh $Hv]") as "[#Hv1 #Hv2] /=".
    rewrite ![⌊ TNat @ _ ⌋ₛ _ _]interp_un_sec_def !interp_un_nat_def.
    iDestruct "Hv1" as (n1) "->". iDestruct "Hv2" as (n2) "->".
    iApply (mwp_left_strong_bind _ _ (fill [IfCtx _ _; SeqCtx _])
                                (fill [IfCtx _ _; SeqCtx _])); simpl.
    rewrite !nat_to_val.
    iApply mwp_left_pure_step; [done|].
    iApply mwp_left_pure_step_index; [done|]. simpl.
    iApply (mwp_value mwp_binary); umods.
    iApply (mwp_value (mwpd_right SI_right)); umods.
    do 2 iModIntro.
    iApply ni_logrel_fupd_ni_logrel. iSplit.
    { iLeft. iIntros (σ) "Hσ".
      iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
      iModIntro. iPureIntro.
      eapply (fill_reducible [SeqCtx _]).
      apply head_prim_reducible.
      case_bool_decide; eexists [],_,_,[]; by econstructor. }
    iInv (nroot.@(l1,l2)) as "Hl" "HcloseI".
    iDestruct "Hl" as (w1 w2) "(Hl1 & Hl2 & _) /=".
    do 2 iModIntro.
    iApply mwp_un_bi_fupd_lr.
    iApply (mwp_fupd_bind _ (fill [SeqCtx _])).
    case_bool_decide.
    - (* left then branch *)
      iApply mwp_fupd_pure_step; [done|].
      rewrite !loc_to_val !nat_to_val.
      iApply ((@mwp_fupd_store _ secG_un_left)); [done|].
      iFrame. iIntros "Hl1".
      iApply mwp_fupd_pure_step; [done|].
      iApply ((@mwp_fupd_store _ secG_un_left)); [done|].
      iFrame. iIntros "Hl1".
      case_bool_decide.
      + (* right then branch *)
        iApply (mwp_fupd_bind _ (fill [SeqCtx _])).
        iApply (mwp_fupd_pure_step); [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iApply mwp_fupd_pure_step; [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iMod ("HcloseI" with "[-]") as "_".
        { iExists _,_. iModIntro. iFrame. unats.
          rewrite [bool_decide (⌊ L ⌋ₗ ρ ⊑ ζ)]bool_decide_eq_true_2 //=; auto. }
        iIntros "!> /=".
        rewrite [⟦ () @ L ⟧ₛ _ _ _]interp_sec_def interp_unit_def
                bool_decide_eq_true_2 //.
      + (* right else branch *)
        iApply (mwp_fupd_bind _ (fill [SeqCtx _])).
        iApply (mwp_fupd_pure_step); [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iApply mwp_fupd_pure_step; [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iMod ("HcloseI" with "[-]") as "_".
        { iExists _,_. iModIntro. iFrame. unats.
          rewrite [bool_decide (⌊ L ⌋ₗ ρ ⊑ ζ)]bool_decide_eq_true_2 //=; auto. }
        iIntros "!> /=".
        rewrite [⟦ () @ L ⟧ₛ _ _ _]interp_sec_def interp_unit_def
                bool_decide_eq_true_2 //.
    - (* left else branch - identical to above *)
      iApply mwp_fupd_pure_step; [done|].
      rewrite !loc_to_val !nat_to_val.
      iApply ((@mwp_fupd_store _ secG_un_left)); [done|].
      iFrame. iIntros "Hl1".
      iApply mwp_fupd_pure_step; [done|].
      iApply ((@mwp_fupd_store _ secG_un_left)); [done|].
      iFrame. iIntros "Hl1".
      case_bool_decide.
      + (* right then branch *)
        iApply (mwp_fupd_bind _ (fill [SeqCtx _])).
        iApply (mwp_fupd_pure_step); [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iApply mwp_fupd_pure_step; [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iMod ("HcloseI" with "[-]") as "_".
        { iExists _,_. iModIntro. iFrame. unats.
          rewrite [bool_decide (⌊ L ⌋ₗ ρ ⊑ ζ)]bool_decide_eq_true_2 //=; auto. }
        iIntros "!> /=".
        rewrite [⟦ () @ L ⟧ₛ _ _ _]interp_sec_def interp_unit_def
                bool_decide_eq_true_2 //.
      + (* right else branch *)
        iApply (mwp_fupd_bind _ (fill [SeqCtx _])).
        iApply (mwp_fupd_pure_step); [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iApply mwp_fupd_pure_step; [done|].
        iApply ((@mwp_fupd_store _ secG_un_right)); [done|].
        iFrame. iIntros "Hl2".
        iMod ("HcloseI" with "[-]") as "_".
        { iExists _,_. iModIntro. iFrame. unats.
          rewrite [bool_decide (⌊ L ⌋ₗ ρ ⊑ ζ)]bool_decide_eq_true_2 //=; auto. }
        iIntros "!> /=".
        rewrite [⟦ () @ L ⟧ₛ _ _ _]interp_sec_def interp_unit_def
                bool_decide_eq_true_2 //.
  Qed.

End related.


(*! Regression test for signed shifts !*)
Require Import Koika.Frontend.

Inductive idx := r3 | r4 | r5 | r6 | r7 | r8 | r9 | r10 | r11 | r12 | r13 | r14 | r15 | r16.
Inductive reg_t := cond | r_l (_: idx) | r_r (_: idx) | r_out (_: idx).

Inductive rule_name_t := rl.

Definition R (reg: reg_t) : type :=
  match reg with
  | cond => bits_t 1
  | _ => bits_t 32
  end.

Definition r (reg: reg_t) : R reg :=
  match reg with
  | cond => Ob~1
  | r_l r3 => Ob~1~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0
  | r_r r3 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
  | r_l r4 => Ob~1~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0
  | r_r r4 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1
  | r_l r5 => Ob~1~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0
  | r_r r5 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~0
  | r_l r6 => Ob~1~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
  | r_r r6 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1
  | r_l r7 => Ob~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1
  | r_r r7 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0
  | r_l r8 => Ob~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1
  | r_r r8 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
  | r_l r9 => Ob~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1
  | r_r r9 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1
  | r_l r10 => Ob~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1
  | r_r r10 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~0
  | r_l r11 => Ob~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1
  | r_r r11 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1
  | r_l r12 => Ob~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1
  | r_r r12 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0
  | r_l r13 => Ob~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1
  | r_r r13 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
  | r_l r14 => Ob~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1
  | r_r r14 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1
  | r_l r15 => Ob~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1
  | r_r r15 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~0
  | r_l r16 => Ob~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1
  | r_r r16 => Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1
  | r_out _ => Bits.zero
  end.

Definition urules (rl: rule_name_t) : uaction reg_t empty_ext_fn_t :=
  {{
      write0(r_out r3, if read0(cond)
                       then (read0(r_l r3) >>> read0(r_r r3)) >>> read0(r_r r3)
                       else (read0(r_l r3) >> read0(r_r r3)) >> read0(r_r r3));
      (* Ob~1~1~1~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0 *)

      write0(r_out r4, if read0(cond)
                       then (read0(r_l r4) >>> read0(r_r r4)) >>> read0(r_r r4)
                       else (read0(r_l r4) >> read0(r_r r4)) >> read0(r_r r4));
      (* Ob~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0 *)

      write0(r_out r5, if read0(cond)
                       then (read0(r_l r5) >>> read0(r_r r5)) >>> read0(r_r r5)
                       else (read0(r_l r5) >> read0(r_r r5)) >> read0(r_r r5));
      (* Ob~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~0~0 *)

      write0(r_out r6, if read0(cond)
                       then (read0(r_l r6) >>> read0(r_r r6)) >>> read0(r_r r6)
                       else (read0(r_l r6) >> read0(r_r r6)) >> read0(r_r r6));
      (* Ob~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 *)

      write0(r_out r7, if read0(cond)
                       then (read0(r_l r7) >>> read0(r_r r7)) >>> read0(r_r r7)
                       else (read0(r_l r7) >> read0(r_r r7)) >> read0(r_r r7));
      (* Ob~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 *)

      write0(r_out r8, if read0(cond)
                       then (read0(r_l r8) >>> read0(r_r r8)) >>> read0(r_r r8)
                       else (read0(r_l r8) >> read0(r_r r8)) >> read0(r_r r8));
      (* Ob~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 *)

      write0(r_out r9, if read0(cond)
                       then (read0(r_l r9) >>> read0(r_r r9)) >>> read0(r_r r9)
                       else (read0(r_l r9) >> read0(r_r r9)) >> read0(r_r r9));
      (* Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 *)

      write0(r_out r10, if read0(cond)
                        then (read0(r_l r10) >>> read0(r_r r10)) >>> read0(r_r r10)
                        else (read0(r_l r10) >> read0(r_r r10)) >> read0(r_r r10));
      (* Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1 *)

      write0(r_out r11, if read0(cond)
                        then (read0(r_l r11) >>> read0(r_r r11)) >>> read0(r_r r11)
                        else (read0(r_l r11) >> read0(r_r r11)) >> read0(r_r r11));
      (* Ob~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0 *)

      write0(r_out r12, if read0(cond)
                        then (read0(r_l r12) >>> read0(r_r r12)) >>> read0(r_r r12)
                        else (read0(r_l r12) >> read0(r_r r12)) >> read0(r_r r12));
      (* Ob~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1 *)

      write0(r_out r13, if read0(cond)
                        then (read0(r_l r13) >>> read0(r_r r13)) >>> read0(r_r r13)
                        else (read0(r_l r13) >> read0(r_r r13)) >> read0(r_r r13));
      (* Ob~1~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0 *)

      write0(r_out r14, if read0(cond)
                        then (read0(r_l r14) >>> read0(r_r r14)) >>> read0(r_r r14)
                        else (read0(r_l r14) >> read0(r_r r14)) >> read0(r_r r14));
      (* Ob~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~0~0~0~0~0~1~1~0~0~0~0~0~0~1~1~0 *)

      write0(r_out r15, if read0(cond)
                        then (read0(r_l r15) >>> read0(r_r r15)) >>> read0(r_r r15)
                        else (read0(r_l r15) >> read0(r_r r15)) >> read0(r_r r15));
      (* Ob~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~0~0 *)

      write0(r_out r16, if read0(cond)
                        then (read0(r_l r16) >>> read0(r_r r16)) >>> read0(r_r r16)
                        else (read0(r_l r16) >> read0(r_r r16)) >> read0(r_r r16));
      (* Ob~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 *)

      write0(cond, !read0(cond))
  }}.

Definition rules :=
  tc_rules R empty_Sigma urules.

Definition sched : scheduler :=
  rl |> done.

Definition sched_result :=
  tc_compute (interp_scheduler (ContextEnv.(create) r) empty_sigma rules sched).

Definition external (r: rule_name_t) := false.

Definition sched_circuits :=
  compile_scheduler rules external sched.

Definition sched_circuits_result :=
  tc_compute (interp_circuits empty_sigma sched_circuits (lower_r (ContextEnv.(create) r))).

Definition package :=
  {| ip_koika := {| koika_reg_types := R;
                   koika_reg_init := r;
                   koika_ext_fn_types := empty_Sigma;
                   koika_rules := rules;
                   koika_rule_external := external;
                   koika_scheduler := sched;
                   koika_module_name := "shifts" |};

     ip_sim := {| sp_ext_fn_specs := empty_ext_fn_props;
                 sp_prelude := None |};

     ip_verilog := {| vp_ext_fn_specs := empty_ext_fn_props |} |}.

Definition prog := Interop.Backends.register package.
Extraction "shifts.ml" prog.


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

From PromisingLib Require Import Basic.
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 FulfillStep.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import SimThread.
Require Import Compatibility.

Require Import SplitAcq.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Definition local_acqrel (lc:Local.t) :=
  (Local.mk (TView.write_fence_tview
               (TView.read_fence_tview (Local.tview lc) Ordering.acqrel)
               TimeMap.bot
               Ordering.acqrel)
            (Local.promises lc)).

Lemma sim_local_promise_acqrel
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to msg kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to msg lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acqrel lc1_tgt))
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to msg lc2_src mem2_src kind>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acqrel lc2_tgt)>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit SimPromises.promise_bot; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  i. des.
  exploit Memory.promise_future; try apply PROMISE_SRC; try apply WF1_SRC; eauto.
  { destruct msg; ss. inv CLOSED. econs.
    eapply sim_memory_closed_opt_view; eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    destruct msg; ss. inv CLOSED. econs.
    eapply sim_memory_closed_opt_view; eauto.
  - econs; eauto.
Qed.

Lemma sim_local_fulfill_acqrel
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.acqrel)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le (TView.cur (Local.tview lc1_src))
                          (View.join (TView.cur (Local.tview lc1_tgt)) (View.unwrap releasedm_tgt)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src released ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acqrel lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)
     (TView.write_released (Local.tview lc1_tgt) sc2_tgt loc to releasedm_tgt ord_tgt)).
  { unfold TView.write_released, TView.write_tview. ss. viewtac.
    repeat (condtac; aggrtac;
            try match goal with
                | [|- View.opt_le _ _] => econs
                end);
      try apply WF1_TGT.
    - etrans; eauto. aggrtac.
    - etrans; [apply WF1_SRC|]. etrans; eauto. aggrtac.
    - etrans; [apply LOCAL1|]. aggrtac.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove_bot; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  { econs. ss. }
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  { apply WF1_TGT. }
  i. des. esplits.
  - econs; eauto.
    inv WRITABLE. econs.
    eapply TimeFacts.le_lt_lt; [apply ACQUIRED1|]. viewtac.
    eapply TimeFacts.le_lt_lt; eauto.
  - econs; eauto. s.
    unfold TView.write_tview, TView.write_fence_tview, TView.read_fence_tview. ss.
    econs; ss; repeat (condtac; aggrtac).
    all: try by destruct ord_src, ord_tgt.
    all: try by apply WF1_TGT.
    + etrans; [apply LOCAL1|]. repeat (try condtac; aggrtac).
    + etrans; [apply LOCAL1|]. aggrtac.
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. repeat (try condtac; aggrtac).
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. ss. condtac; aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
  - ss.
Qed.

Lemma sim_local_write_acqrel
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.acqrel)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le (TView.cur (Local.tview lc1_src))
                          (View.join (TView.cur (Local.tview lc1_tgt)) (View.unwrap releasedm_tgt)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src released_src ord_src lc2_src sc2_src mem2_src kind>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acqrel lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_promise_acquired; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  hexploit sim_local_fulfill_acqrel; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  { inv STEP_SRC. inv STEP1. ss. }
  i. des.
  exploit promise_fulfill_write_sim_memory; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. hexploit ORD0; eauto.
    i. des. splits; auto. eapply sim_local_nonsynch_loc; eauto.
  }
  i. des. esplits; eauto. etrans; eauto.
Qed.

Inductive split_acqrel: forall (i1 i2:Instr.t), Prop :=
| split_acqrel_load
    r l:
    split_acqrel (Instr.load r l Ordering.acqrel) (Instr.load r l Ordering.relaxed)
| split_acqrel_update
    r l rmw ow
    (OW: Ordering.le ow Ordering.acqrel):
    split_acqrel (Instr.update r l rmw Ordering.acqrel ow) (Instr.update r l rmw Ordering.relaxed ow)
.

Inductive sim_acqrel: forall (st_src:(Language.state lang)) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                        (st_tgt:(Language.state lang)) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_acqrel_intro
    rs
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    (LOCAL: sim_local SimPromises.bot lc1_src (local_acqrel lc1_tgt))
    (SC: TimeMap.le sc1_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt):
    sim_acqrel
      (State.mk rs []) lc1_src sc1_src mem1_src
      (State.mk rs [Stmt.instr (Instr.fence Ordering.acqrel Ordering.acqrel)]) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_acqrel_mon
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      sc2_tgt mem2_tgt
      (SIM1: sim_acqrel st_src lc_src sc1_src mem1_src
                          st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future_weak mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future_weak mem1_tgt mem2_tgt)
      (SC1: TimeMap.le sc2_src sc2_tgt)
      (MEM1: sim_memory mem2_src mem2_tgt)
      (WF_SRC: Local.wf lc_src mem2_src)
      (WF_TGT: Local.wf lc_tgt mem2_tgt)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt)
      (MEM_SRC: Memory.closed mem2_src)
      (MEM_TGT: Memory.closed mem2_tgt):
  sim_acqrel st_src lc_src sc2_src mem2_src
               st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  inv SIM1. econs; eauto.
Qed.

Lemma sim_acqrel_step
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      (SIM: sim_acqrel st1_src lc1_src sc1_src mem1_src
                         st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  _sim_thread_step lang lang ((sim_thread (sim_terminal eq)) \8/ sim_acqrel)
                   st1_src lc1_src sc1_src mem1_src
                   st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  inv SIM. ii.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    right.
    exploit Local.promise_step_future; eauto. i. des.
    exploit sim_local_promise_acqrel; try exact LOCAL; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs. econs; eauto.
    + eauto.
    + right. econs; eauto.
  - (* fence *)
    right.
    exploit Local.fence_step_future; eauto. i. des.
    inv STATE. inv INSTR. inv LOCAL1. ss.
    esplits; (try by econs 1); eauto; ss.
    left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
Qed.

Lemma sim_acqrel_sim_thread:
  sim_acqrel <8= (sim_thread (sim_terminal eq)).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - inv TERMINAL_TGT. inv PR; ss.
  - right. esplits; eauto.
    inv PR. eapply sim_local_memory_bot; eauto.
  - exploit sim_acqrel_mon; eauto. i. des.
    exploit sim_acqrel_step; eauto. i. des; eauto.
    + right. esplits; eauto.
      left. eapply paco9_mon; eauto. ss.
    + right. esplits; eauto.
Qed.

Lemma split_acqrel_sim_stmts
      i_src i_tgt
      (SPLIT: split_acqrel i_src i_tgt):
  sim_stmts eq
            [Stmt.instr i_src]
            [Stmt.instr i_tgt; Stmt.instr (Instr.fence Ordering.acqrel Ordering.acqrel)]
            eq.
Proof.
  pcofix CIH. ii. subst. pfold. ii. splits; ii.
  { inv TERMINAL_TGT. }
  { right. esplits; eauto.
    inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
  }
  right.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    exploit sim_local_promise; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    econs 2. econs 1; eauto. econs; eauto. eauto.
  - (* load *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs. econs.
    + auto.
    + left. eapply paco9_mon; [apply sim_acqrel_sim_thread|]; ss.
      econs; ss. inv LOCAL2. econs; ss.
      etrans; eauto. apply TViewFacts.write_fence_tview_incr.
      eapply TViewFacts.read_fence_future; apply WF2.
  - (* update-load *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs. econs. eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_acqrel_sim_thread|]; ss.
      econs; ss. inv LOCAL2. econs; ss.
      etrans; eauto. apply TViewFacts.write_fence_tview_incr.
      eapply TViewFacts.read_fence_future; apply WF2.
  - (* update *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit Local.write_step_future; eauto. i. des.
    hexploit sim_local_write_acqrel; try exact LOCAL2; try exact SC; eauto; try refl.
    { inv LOCAL1. inv MEM_TGT. exploit CLOSED; eauto. i. des.
      inv MSG_TS. ss. }
    { inv STEP_SRC. inv LOCAL1. ss. repeat (condtac; aggrtac).
      - rewrite <- ? View.join_l. apply LOCAL.
      - apply WF_TGT.
      - unfold TimeMap.join. rewrite <- Time.join_l. rewrite <- Time.join_l. rewrite <- Time.join_r.
        unfold View.singleton_ur_if. condtac; ss. unfold TimeMap.singleton, LocFun.add.
        condtac; ss. refl.
    }
    i. des.
    exploit Local.write_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 4; eauto.
      * econs. econs. eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_acqrel_sim_thread|]; ss.
Qed.


(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Converted imports: *)

Require Coq.Numbers.BinNums.
Require Data.Bits.
Require Data.Foldable.
Require Data.IntSet.Internal.
Require GHC.Base.
Require GHC.Num.
Import Data.Bits.Notations.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* No type declarations to convert. *)

(* Converted value declarations: *)

Definition validTipPrefix : Data.IntSet.Internal.Prefix -> bool :=
  fun p => (#63 Data.Bits..&.(**) p) GHC.Base.== #0.

Definition tipsValid : Data.IntSet.Internal.IntSet -> bool :=
  fix tipsValid t
        := match t with
           | Data.IntSet.Internal.Nil => true
           | (Data.IntSet.Internal.Tip p b as tip) => validTipPrefix p
           | Data.IntSet.Internal.Bin _ _ l r => andb (tipsValid l) (tipsValid r)
           end.

Definition nilNeverChildOfBin : Data.IntSet.Internal.IntSet -> bool :=
  fun t =>
    let fix noNilInSet t'
              := match t' with
                 | Data.IntSet.Internal.Nil => false
                 | Data.IntSet.Internal.Tip _ _ => true
                 | Data.IntSet.Internal.Bin _ _ l' r' => andb (noNilInSet l') (noNilInSet r')
                 end in
    match t with
    | Data.IntSet.Internal.Nil => true
    | Data.IntSet.Internal.Tip _ _ => true
    | Data.IntSet.Internal.Bin _ _ l r => andb (noNilInSet l) (noNilInSet r)
    end.

Definition maskRespected : Data.IntSet.Internal.IntSet -> bool :=
  fix maskRespected t
        := match t with
           | Data.IntSet.Internal.Nil => true
           | Data.IntSet.Internal.Tip _ _ => true
           | Data.IntSet.Internal.Bin _ binMask l r =>
               andb (Data.Foldable.all (fun x => Data.IntSet.Internal.zero x binMask)
                     (Data.IntSet.Internal.elems l)) (andb (Data.Foldable.all (fun x =>
                                                                                negb (Data.IntSet.Internal.zero x
                                                                                binMask))
                                                            (Data.IntSet.Internal.elems r)) (andb (maskRespected l)
                                                                                (maskRespected r)))
           end.

Definition maskPowerOfTwo : Data.IntSet.Internal.IntSet -> bool :=
  fix maskPowerOfTwo t
        := match t with
           | Data.IntSet.Internal.Nil => true
           | Data.IntSet.Internal.Tip _ _ => true
           | Data.IntSet.Internal.Bin _ m l r =>
               andb (Utils.Containers.Internal.BitUtil.bitcount #0 (m) GHC.Base.== #1) (andb
                     (maskPowerOfTwo l) (maskPowerOfTwo r))
           end.

Definition commonPrefix : Data.IntSet.Internal.IntSet -> bool :=
  fix commonPrefix t
        := let sharedPrefix
            : Data.IntSet.Internal.Prefix -> Coq.Numbers.BinNums.N -> bool :=
             fun p a => p GHC.Base.== (p Data.Bits..&.(**) a) in
           match t with
           | Data.IntSet.Internal.Nil => true
           | Data.IntSet.Internal.Tip _ _ => true
           | (Data.IntSet.Internal.Bin p _ l r as b) =>
               andb (Data.Foldable.all (sharedPrefix p) (Data.IntSet.Internal.elems b)) (andb
                     (commonPrefix l) (commonPrefix r))
           end.

Definition valid : Data.IntSet.Internal.IntSet -> bool :=
  fun t =>
    andb (nilNeverChildOfBin t) (andb (maskPowerOfTwo t) (andb (commonPrefix t)
                                                               (andb (maskRespected t) (tipsValid t)))).

(* External variables:
     andb bool false negb true Coq.Numbers.BinNums.N Data.Bits.op_zizazi__
     Data.Foldable.all Data.IntSet.Internal.Bin Data.IntSet.Internal.IntSet
     Data.IntSet.Internal.Nil Data.IntSet.Internal.Prefix Data.IntSet.Internal.Tip
     Data.IntSet.Internal.elems Data.IntSet.Internal.zero GHC.Base.op_zeze__
     GHC.Num.fromInteger Utils.Containers.Internal.BitUtil.bitcount
*)


Require Import MirrorCore.Reify.Reify.
Require Import MirrorCore.Lambda.Expr.

Require Import MirrorCharge.Java.JavaFunc.
Require Import MirrorCharge.Java.JavaType.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import MirrorCharge.ModularFunc.LaterFunc.
Require Import MirrorCharge.ModularFunc.BaseFunc.
Require Import MirrorCharge.ModularFunc.ListFunc.
Require Import MirrorCharge.ModularFunc.OpenFunc.
Require Import MirrorCharge.ModularFunc.EmbedFunc.

Require Import Charge.Open.Stack.
Require Import Charge.Open.Subst.
Require Import Charge.Open.OpenILogic.

Require Import Charge.Logics.BILogic.
Require Import Charge.Logics.Later.

Require Import Java.Logic.AssertionLogic.
Require Import Java.Logic.SpecLogic.
Require Import Java.Language.Program.
Require Import Java.Language.Lang.
Require Import Java.Semantics.OperationalSemantics.

Require Import ExtLib.Structures.Applicative.

Reify Declare Patterns patterns_java_typ := typ.

Reify Declare Patterns patterns_java := (ExprCore.expr typ func).

Local Instance Applicative_Fun A : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

(*
Reify Declare Patterns const_for_cmd += ((RHasType cmd ?0) => (fun (c : id cmd) => mkCmd [c] : expr typ func)).
*)

Require Import MirrorCore.Reify.Reify.

Axiom t : Type.
Reify Declare Patterns t_pat := t.

Reify Declare Syntax t_cmd :=
{ (@Patterns.CPatterns t t_pat) }.

Reify Declare Syntax reify_imp_typ :=
  {
  	(@Patterns.CPatterns typ patterns_java_typ)
  }.

Reify Declare Typed Table term_table : BinNums.positive => reify_imp_typ.

Check term_table.

Locate exprD.

Require Import MirrorCore.ExprI.

Check @exprD.
Print Expr.
Print RType.
Let Ext x := @ExprCore.Inj typ func (inl (inl (inl (inl (inl (inl (inl (inl x)))))))).

Reify Declare Syntax reify_imp :=
  { (@Patterns.CFirst _
  		((@Patterns.CVar _ (@ExprCore.Var typ func)) ::
  	     (@Patterns.CPatterns _ patterns_java) ::
         (@Patterns.CApp _ (@ExprCore.App typ func)) ::
    	 (@Patterns.CAbs _ reify_imp_typ (@ExprCore.Abs typ func)) ::
    	 (@Patterns.CTypedTable _ _ _ term_table Ext) :: nil))
  }.

Definition stack_get (x : Lang.var) (s : stack) := s x.

Notation "'ap_eq' '[' x ',' y ']'" :=
	 (ap (T := Fun stack) (ap (T := Fun stack) (pure (T := Fun stack) (@eq val)) x) y).
Notation "'ap_pointsto' '[' x ',' f ',' e ']'" :=
	(ap (T := Fun stack) (ap (T := Fun stack) (ap (T := Fun stack)
		(pure (T := Fun stack) pointsto) (stack_get x))
			(pure (T := Fun stack) f)) e).
Notation "'ap_typeof' '[' e ',' C ']'" :=
	(ap (T := Fun stack)
	    (ap (T := Fun stack)
	        (pure (T := Fun stack) typeof)
	        (pure (T := Fun stack) C))
	    e).

Definition set_fold_fun (x f : String.string) (P : sasn) :=
	ap_pointsto [x, f, pure null] ** P.

Let _Inj := @ExprCore.Inj typ func.

Require Import Java.Examples.ListModel.
(*
Reify Seed Typed Table term_table += 1 => [ (tyArr tyVal (tyArr (tyList tyVal) tyAsn)) , List ].
Reify Seed Typed Table term_table += 2 => [ (tyArr tyVal (tyArr (tyList tyVal) tyAsn)) , NodeList ].
*)

Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
Local Notation "'#'" := RIgnore (only parsing, at level 0).

Reify Pattern patterns_java_typ += (@RImpl (?0) (?1)) => (fun (a b : function reify_imp_typ) => tyArr a b).

Reify Pattern patterns_java_typ += (!! asn)  => tyAsn.
Reify Pattern patterns_java_typ += (!! sasn) => tySasn.
Reify Pattern patterns_java_typ += (!! (@vlogic Lang.var val)) => tyPure.
Reify Pattern patterns_java_typ += (!! Prop) => tyProp.
Reify Pattern patterns_java_typ += (!! spec) => tySpec.

Reify Pattern patterns_java_typ += (!! @prod @ ?0 @ ?1) => (fun (x y : function reify_imp_typ) => tyPair x y).
Reify Pattern patterns_java_typ += (!! (@list String.string)) => tyVarList.
Reify Pattern patterns_java_typ += (!! (@list field)) => tyFields.
Reify Pattern patterns_java_typ += (!! (@list (@Open.expr (Lang.var) val))) => tyVarList.
Reify Pattern patterns_java_typ += (!! (@list (Lang.var * @Open.expr (Lang.var) val))) => tySubstList.
Reify Pattern patterns_java_typ += (!! (@substlist Lang.var val)) => tySubstList.
Reify Pattern patterns_java_typ += (!! @list @ ?0) => (fun x : function reify_imp_typ => tyList x).
Reify Pattern patterns_java_typ += (!! nat) => tyNat.
Reify Pattern patterns_java_typ += (!! val) => tyVal.
Reify Pattern patterns_java_typ += (!! bool) => tyBool.
Reify Pattern patterns_java_typ += (!! field) => tyString.
Reify Pattern patterns_java_typ += (!! class) => tyString.
Reify Pattern patterns_java_typ += (!! @Open.open Lang.var val asn) => tySasn.
Reify Pattern patterns_java_typ += (!! @Open.open Lang.var val Prop) => tyPure.
Reify Pattern patterns_java_typ += (!! Lang.var) => tyString.
Reify Pattern patterns_java_typ += (!! String.string) => tyString.
Reify Pattern patterns_java_typ += (!! Program) => tyProg.
Reify Pattern patterns_java_typ += (!! stack) => tyStack.
Reify Pattern patterns_java_typ += (!! @Stack.stack Lang.var val) => tyStack.
Reify Pattern patterns_java_typ += (!! cmd) => tyCmd.
Reify Pattern patterns_java_typ += (!! dexpr) => tyExpr.
Reify Pattern patterns_java_typ += (!! (@Open.expr Lang.var val)) => tyExpr.
Reify Pattern patterns_java_typ += (!! @Subst.subst (String.string) val) => tySubst.

Reify Pattern patterns_java_typ += (!! Fun @ ?0 @ ?1) => (fun (a b : function reify_imp_typ) => tyArr a b).

Reify Pattern patterns_java += (RHasType String.string (?0)) => (fun (s : id String.string) => mkString (func := func) (typ := typ) s).
Reify Pattern patterns_java += (RHasType field (?0)) => (fun (f : id field) => mkString (func := func) f).
Reify Pattern patterns_java += (RHasType Lang.var (?0)) => (fun (f : id Lang.var) => mkString (func := func) f).
Reify Pattern patterns_java += (RHasType val (?0)) => (fun (v : id val) => mkVal v).
Reify Pattern patterns_java += (RHasType bool (?0)) => (fun (b : id bool) => mkBool (func := func) b).
Reify Pattern patterns_java += (RHasType nat (?0)) => (fun (n : id nat) => mkNat (func := func) n).
Reify Pattern patterns_java += (RHasType cmd (?0)) => (fun (c : id cmd) => mkCmd c).
Reify Pattern patterns_java += (RHasType dexpr (?0)) => (fun (e : id dexpr) => mkDExpr e).
Reify Pattern patterns_java += (RHasType Program (?0)) => (fun (P : id Program) => mkProg P).
Reify Pattern patterns_java += (RHasType (list field) (?0)) => (fun (fs : id (list field)) => mkFields fs).
Reify Pattern patterns_java += (RHasType class (?0)) => (fun (c : id class) => mkString (func := func) c).

Reify Pattern patterns_java += (RHasType (@list dexpr) (?0)) => (fun (es : id (@list dexpr)) => mkExprList es).
Reify Pattern patterns_java += (RHasType (@list String.string) (?0)) => (fun (vs : id (@list String.string)) => mkVarList vs).
Reify Pattern patterns_java += (!! (@eq) @ ?0) => (fun (x : function reify_imp_typ) => fEq (func := expr typ func) x).

(** Intuitionistic Operators **)
Reify Pattern patterns_java += (!! @ILogic.lentails @ ?0 @ #) => (fun (x : function reify_imp_typ) => fEntails (func := expr typ func) x).
Reify Pattern patterns_java += (!! @ILogic.ltrue @ ?0 @ #) => (fun (x : function reify_imp_typ) => mkTrue (func := func) x).
Reify Pattern patterns_java += (!! @ILogic.lfalse @ ?0 @ #) => (fun (x : function reify_imp_typ) => mkFalse (func := func) x).
Reify Pattern patterns_java += (!! @ILogic.land @ ?0 @ #) => (fun (x : function reify_imp_typ) => fAnd (func := expr typ func) x).
Reify Pattern patterns_java += (!! @ILogic.lor @ ?0 @ #) => (fun (x : function reify_imp_typ) => fOr (func := expr typ func) x).
Reify Pattern patterns_java += (!! @ILogic.limpl @ ?0 @ #) => (fun (x : function reify_imp_typ) => fImpl (func := expr typ func) x).

Reify Pattern patterns_java += (!! @ILogic.lexists @ ?0 @ # @ ?1) => (fun (x y : function reify_imp_typ) => fExists (func := expr typ func) y x).

Reify Pattern patterns_java += (!! @ILogic.lforall @ ?0 @ # @ ?1) => (fun (x y : function reify_imp_typ) => fForall (func := expr typ func) y x).
(** Embedding Operators **)
Reify Pattern patterns_java += (!! @ILEmbed.embed @ ?0 @ ?1 @ #) => (fun (x y : function reify_imp_typ) => fEmbed (func := expr typ func) x y).

Reify Pattern patterns_java += (!! @pair @ ?0 @ ?1) => (fun (x y : function reify_imp_typ) => fPair (func := expr typ func) x y).

(** Special cases for Coq's primitives **)
Reify Pattern patterns_java += (!! True) => (mkTrue (func := func) tyProp).
Reify Pattern patterns_java += (!! False) => (mkFalse (func := func) tyProp).
Reify Pattern patterns_java += (!! and) => (fAnd (func := expr typ func) tyProp).

Reify Pattern patterns_java += (!! or) => (fOr (func := expr typ func) tyProp).

Reify Pattern patterns_java += (!! ex @ ?0) => (fun (x : function reify_imp_typ) => fExists (func := expr typ func) x tyProp).

Reify Pattern patterns_java += (RPi (?0) (?1)) => (fun (x : function reify_imp_typ) (y : function reify_imp) =>
                                                   ExprCore.App (fForall (func := expr typ func) x tyProp) (ExprCore.Abs x y)).

Reify Pattern patterns_java += (RImpl (?0) (?1)) => (fun (x y : function reify_imp) =>
	ExprCore.App (ExprCore.App (fImpl (func := expr typ func) tyProp) x) y).

(** Separation Logic Operators **)
Reify Pattern patterns_java += (!! @BILogic.sepSP @ ?0 @ #) => (fun (x : function reify_imp_typ) => (fStar (func := expr typ func) x)).
Reify Pattern patterns_java += (!! @BILogic.wandSP @ ?0 @ #) => (fun (x : function reify_imp_typ) => (fWand (func := expr typ func) x)).
Reify Pattern patterns_java += (!! @BILogic.empSP @ ?0 @ #) => (fun (x : function reify_imp_typ) => (mkEmp (func := func) x)).

Reify Pattern patterns_java += (!! @Later.illater @ ?0 @ #) => (fun (x : function reify_imp_typ) => (fLater (func := expr typ func) x)).

Reify Pattern patterns_java += (!! method_spec) => (fMethodSpec).

(** Program Logic **)

Reify Pattern patterns_java += (!! triple) => (fTriple).
Reify Pattern patterns_java += (!! eval @ (RHasType dexpr (?0))) => (fun e : id dexpr => evalDExpr e).
Reify Pattern patterns_java += (!! stack_get) => (fStackGet (typ := typ) (func := expr typ func)).
Reify Pattern patterns_java += (!! stack_add (val := val)) => (fStackSet (typ := typ) (func := expr typ func)).

Reify Pattern patterns_java += (!! pointsto) => (fPointsto).
Reify Pattern patterns_java += (!! prog_eq) => (fProgEq).
Reify Pattern patterns_java += (!! typeof) => (fTypeOf).

Reify Pattern patterns_java += (!! (@substl_trunc Lang.var val _)) => (fTruncSubst (func := expr typ func) (typ := typ)).
Reify Pattern patterns_java += (!! (@substl Lang.var val _)) => (fSubst (func := expr typ func) (typ := typ)).

Reify Pattern patterns_java += (!! @nil @ ?0) => (fun (x : function reify_imp_typ) => (fNil (func := expr typ func) x)).
Reify Pattern patterns_java += (!! @cons @ ?0) => (fun (x : function reify_imp_typ) => (fCons (func := expr typ func) x)).
Reify Pattern patterns_java += (!! @length @ ?0) => (fun (x : function reify_imp_typ) => (fLength (func := expr typ func) x)).
Reify Pattern patterns_java += (!! @zip @ ?0 @ ?1) => (fun (x y : function reify_imp_typ) => (fZip (func := expr typ func) x y)).
Reify Pattern patterns_java += (!! @map @ ?0 @ ?1) => (fun (x y : function reify_imp_typ) => (fMap (func := expr typ func) x y)).
Reify Pattern patterns_java += (!! @fold_right @ ?0 @ ?1) => (fun (x y : function reify_imp_typ) => (fFold (func := expr typ func) x y)).

Reify Pattern patterns_java += (!! (@apply_subst Lang.var val) @ ?0) => (fun (x : function reify_imp_typ) => fApplySubst (func := expr typ func) x).
Reify Pattern patterns_java += (!! @subst1 Lang.var val _) => (fSingleSubst (func := expr typ func)).
Reify Pattern patterns_java += (!! @field_lookup) => (fFieldLookup).
(** Applicative **)
Reify Pattern patterns_java += (!! @Applicative.ap @ !! (Fun stack) @ # @ ?0 @ ?1) => (fun (x y : function reify_imp_typ) => fAp (func := expr typ func) x y).
Reify Pattern patterns_java += (!! @Applicative.pure @ !! (Fun stack) @ # @ ?0) => (fun (x : function reify_imp_typ) => fConst (func := expr typ func) x).

Let elem_ctor : forall x : typ, typD x -> @SymEnv.function _ _ :=
  @SymEnv.F _ _.

Ltac reify_imp e :=
  let k fs e :=
      pose e in
  reify_expr reify_imp k
             [ (fun (y : @mk_dvar_map _ _ _ _ term_table elem_ctor) => True) ]
             [ e ].

Require Import ILogic.

Goal (forall (Pr : Program) (C : class) (v : val) (fields : list field), True).
  intros Pr C v fields.
  reify_imp (typeof C v).

  reify_imp (field_lookup).
  reify_imp (field_lookup Pr C fields).

  pose ((fun (_ : @Stack.stack Lang.var val) => null) : @Open.expr Lang.var val) as e2.
  pose ((fun (_ : stack) => null) : stack -> val) as e3.

  reify_imp (pure (T := Fun stack) pointsto).

  reify_imp (fun a b c => pointsto a b c).

  reify_imp e2.

  reify_imp e3.

  reify_imp (ap (T := Fun stack) (ap (T := Fun stack) (pure (@eq val)) e2) e2).

  pose (E_val (vint 3)) as d.

  reify_imp ((ap (ap (T := Fun stack) (pure (@eq val)) (eval d)) (pure (vbool true)))).

  generalize String.EmptyString. intro c.
   reify_imp (ltrue |-- {[ ltrue ]} cread c c c {[ ltrue ]}).

  reify_imp cskip.

  reify_imp (forall P, P /\ P).

  reify_imp (forall x : nat, x = x).
  reify_imp (exists x : nat, x = x).
  reify_imp (@map nat nat).
  reify_imp (@subst1 Lang.var val _).
  reify_imp (cseq cskip cskip).

  reify_imp (ILogic.lentails True True).

  reify_imp ((True -> False) -> True).
  reify_imp (forall P Q, P /\ Q).
  reify_imp (forall P : sasn, ILogic.lentails ILogic.ltrue P).
  reify_imp (forall (G : spec) (P Q : sasn), ILogic.lentails G (triple P Q cskip)).
  generalize (String.EmptyString : String.string).
  intro x.

  reify_imp stack_get.

  reify_imp (stack_get x).

  reify_imp (x = x).

  reify_imp (@ltrue sasn _).
  exact I.

Defined.

Ltac reify_aux e n :=
  let k fs e :=
      pose e as n in
  reify_expr reify_imp k
             [ (fun (y : @mk_dvar_map _ _ _ _ term_table elem_ctor) => True) ]
             [ e ].