Require Import MirrorCore.Reify.Reify.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Subst.FMapSubst.

Require Import Java.Func.JavaFunc.
Require Import Java.Func.JavaType.

Require Import Charge.ModularFunc.ILogicFunc.
Require Import Charge.ModularFunc.BILogicFunc.
Require Import Charge.ModularFunc.LaterFunc.
Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.OpenFunc.
Require Import Charge.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.
Require Import ExtLib.Tactics.

Require Import Coq.PArith.BinPos.

Section Tactics.
  Context {fs : Environment}.

Definition exprD_Prop (uvar_env var_env : env) (e : expr typ func) :=
  match exprD uvar_env var_env e tyProp with
    | Some e' => e'
    | None => True
  end.

Definition goalD_Prop (uvar_env var_env : env) goal :=
  let (tus, us) := split_env uvar_env in
  let (tvs, vs) := split_env var_env in
  match goalD tus tvs goal with
    | Some e => e us vs
    | None => False
  end.

Definition goalD_aux tus tvs goal (us : HList.hlist typD tus) (vs : HList.hlist typD tvs) :=
  match goalD tus tvs goal with
    | Some e => Some (e us vs)
    | None => None
  end.

Definition run_tac tac goal :=
  runOnGoals tac nil nil 0 0 (CTop nil nil)
    (ctx_empty (typ := typ) (expr := expr typ func)) goal.

Lemma run_rtac_More tac s goal e
  (Hsound : rtac_sound tac)
  (Hres : run_tac tac (GGoal e) = More_ s goal) :
  goalD_Prop nil nil goal -> exprD_Prop nil nil e.
Proof.
  intros He'.
  apply runOnGoals_sound_ind with (g := GGoal e) (ctx := CTop nil nil)
  	(s0 := TopSubst (expr typ func) nil nil) in Hsound.
  unfold rtac_spec in Hsound. simpl in Hsound.
  unfold run_tac in Hres. simpl in Hres.
  rewrite Hres in Hsound.
  assert (WellFormed_Goal nil nil (GGoal (typ := typ) e)) as H1 by constructor.
  assert (WellFormed_ctx_subst (TopSubst (expr typ func) nil (@nil typ))) as H2 by constructor.
  specialize (Hsound H1 H2).
  destruct Hsound as [Hwfs [Hwfg Hsound]].
  unfold Ctx.propD, exprD'_typ0 in Hsound.
  simpl in Hsound. unfold exprD_Prop, exprD; simpl.
  forward; inv_all; subst.

  destruct Hsound.
  inversion Hwfs; subst.
  simpl in H0; inv_all; subst.
  unfold pctxD in H0; inv_all; subst.
  apply H5.
  unfold goalD_Prop in He'. simpl in He'. forward; inv_all; subst.
Qed.

Lemma run_rtac_Solved tac s e
  (Hsound : rtac_sound tac)
  (Hres : run_tac tac (GGoal e) = Solved s) :
  exprD_Prop nil nil e.
Proof.
  unfold run_tac in Hres.
  unfold rtac_sound in Hsound.
  assert (WellFormed_Goal nil nil (GGoal (typ := typ) e)) as H1 by constructor.
  assert (WellFormed_ctx_subst (TopSubst (expr typ func) nil (@nil typ))) as H2 by constructor.
  specialize (Hsound _ _ _ _ Hres H1 H2).
  destruct Hsound as [Hwfs Hsound].
  simpl in Hsound.
  unfold Ctx.propD, exprD'_typ0 in Hsound.
  unfold exprD_Prop.

  simpl in Hsound. unfold exprD. simpl. forward.
  destruct Hsound.
  SearchAbout pctxD.
  inversion Hwfs; subst. simpl in H8. inv_all; subst.
  admit.
Qed.

End Tactics.

Ltac cbv_denote :=
          cbv [
          goalD_aux

		  (* ExprD' *)
          exprD' funcAs  typeof_sym typeof_expr type_cast type_cast_typ
          exprD'_simul func_simul
          ExprD.Expr_expr
          ExprDsimul.ExprDenote.exprD'
          (* RSym *)

          SymSum.RSym_sum Rcast Relim Rsym eq_sym symD(* RSym_env*)
          Rcast_val eq_rect_r eq_rect Datatypes.id

          (* Monad *)

          Monad.bind Monad.ret

          OptionMonad.Monad_option

          (* HList *)

          HList.hlist_hd HList.hlist_tl

          (* TypesI *)

          TypesI.typD
          typ2_match typ2 typ2_cast
          typ0_match typ0 typ0_cast SubstTypeD_typ
          (* ExprI *)

          MirrorCore.VariablesI.Var ExprVariables.ExprVar_expr
          MirrorCore.VariablesI.UVar
          MirrorCore.Lambda.ExprVariables.ExprUVar_expr
          ExprI.exprT_Inj ExprI.exprT_UseV ExprI.exprT_UseU
          exprT_App ExprI.exprT OpenT
          nth_error_get_hlist_nth

          exprT_GetVAs exprT_GetUAs

          (* Denotation *)

          Charge.ModularFunc.Denotation.fun_to_typ
          Charge.ModularFunc.Denotation.fun_to_typ2
          Charge.ModularFunc.Denotation.fun_to_typ3
          Charge.ModularFunc.Denotation.fun_to_typ4

          Charge.ModularFunc.Denotation.typ_to_fun
          Charge.ModularFunc.Denotation.typ_to_fun2
          Charge.ModularFunc.Denotation.typ_to_fun3

          (* ILogicFunc*)

          ILogicFunc.mkEntails ILogicFunc.mkTrue ILogicFunc.mkFalse
          ILogicFunc.mkAnd ILogicFunc.mkOr ILogicFunc.mkImpl
          ILogicFunc.mkExists ILogicFunc.mkForall

          ILogicFunc.fEntails ILogicFunc.fTrue ILogicFunc.fFalse ILogicFunc.fAnd
          ILogicFunc.fOr ILogicFunc.fImpl ILogicFunc.fExists ILogicFunc.fForall
          ILogicFuncSumL ILogicFuncSumR ILogicFuncExpr
          ILogicFunc.RSym_ilfunc
          Charge.ModularFunc.ILogicFunc.ILogicFuncInst

          ILogicFunc.funcD ILogicFunc.typ2_cast_quant
		  Charge.ModularFunc.ILogicFunc.trueD
		  Charge.ModularFunc.ILogicFunc.falseD
		  Charge.ModularFunc.ILogicFunc.andD
		  Charge.ModularFunc.ILogicFunc.orD
		  Charge.ModularFunc.ILogicFunc.implD

          (* BILogicFunc *)

          BILogicFunc.mkEmp BILogicFunc.mkStar BILogicFunc.mkWand

          BILogicFunc.fEmp BILogicFunc.fStar BILogicFunc.fWand

          BILogicFuncSumL BILogicFuncSumR BILogicFuncExpr
          BILogicFunc.RSym_bilfunc BILogicFunc.BILogicFuncInst

		  Charge.ModularFunc.BILogicFunc.empD
		  Charge.ModularFunc.BILogicFunc.starD
		  Charge.ModularFunc.BILogicFunc.wandD

          BILogicFunc.typeof_bilfunc

          (* LaterFunc *)

          LaterFunc.mkLater

          LaterFunc.fLater

          LaterFunc.LaterFuncSumL LaterFunc.LaterFuncSumR LaterFunc.LaterFuncExpr
          LaterFunc.RSym_later_func LaterFunc.LaterFuncInst

          LaterFunc.funcD LaterFunc.typ2_cast'

          LaterFunc.typeof_later_func

          (* EmbedFunc *)

          EmbedFunc.mkEmbed

          EmbedFunc.fEmbed

          EmbedFunc.EmbedFuncSumL EmbedFunc.EmbedFuncSumR EmbedFuncExpr
          EmbedFunc.RSym_embed_func EmbedFunc.EmbedFuncInst

          EmbedFunc.funcD

		  Charge.ModularFunc.EmbedFunc.embedD

          EmbedFunc.typeof_embed_func

          (* BaseFunc *)

          BaseFunc.BaseFuncSumL BaseFunc.BaseFuncSumR BaseFunc.BaseFuncExpr

          BaseFunc.BaseFuncInst
          BaseFunc.mkNat BaseFunc.mkString BaseFunc.mkBool
          BaseFunc.mkEq BaseFunc.mkPair

          BaseFunc.fConst
          BaseFunc.fEq BaseFunc.fPair

          BaseFunc.RSym_BaseFunc

          BaseFunc.typeof_base_func BaseFunc.base_func_eq BaseFunc.base_func_symD

          (* ListFunc *)

          ListFunc.ListFuncSumL ListFunc.ListFuncSumR ListFunc.ListFuncExpr

          ListFunc.ListFuncInst
          ListFunc.mkNil ListFunc.mkCons ListFunc.mkLength
          ListFunc.mkZip ListFunc.mkMap ListFunc.mkFold

          ListFunc.fNil ListFunc.fCons ListFunc.fLength
          ListFunc.fZip ListFunc.fMap ListFunc.fFold

          ListFunc.typeof_list_func ListFunc.list_func_eq ListFunc.list_func_symD
          ListFunc.RelDec_list_func

          ListFunc.nilD ListFunc.consD ListFunc.mapD ListFunc.zipD ListFunc.NoDupD ListFunc.foldD
          ListFunc.listD ListFunc.listD_sym

		  (* OpenFunc *)

		  OpenFunc.mkConst OpenFunc.mkAp OpenFunc.mkNull OpenFunc.mkStackGet
		  OpenFunc.mkStackSet OpenFunc.mkApplySubst OpenFunc.mkSingleSubst OpenFunc.mkSubst
		  OpenFunc.mkTruncSubst

		  OpenFunc.fConst OpenFunc.fAp OpenFunc.fNull OpenFunc.fStackGet
		  OpenFunc.fApplySubst OpenFunc.fSingleSubst OpenFunc.fSubst OpenFunc.fTruncSubst

		  OpenFunc.OpenFuncSumL OpenFunc.OpenFuncSumR OpenFunc.OpenFuncExpr
		  OpenFunc.OpenFuncInst OpenFunc.open_func_symD

		  OpenFunc.typeof_open_func OpenFunc.RSym_OpenFunc
		  OpenFunc.RelDec_open_func

		  Charge.ModularFunc.OpenFunc.constD
		  Charge.ModularFunc.OpenFunc.apD
		  Charge.ModularFunc.OpenFunc.stack_getD
		  Charge.ModularFunc.OpenFunc.stack_setD
		  Charge.ModularFunc.OpenFunc.applySubstD
		  Charge.ModularFunc.OpenFunc.singleSubstD

          (* BaseType *)

          BaseType.tyPair BaseType.tyNat BaseType.tyString BaseType.tyBool
          BaseType.btPair BaseType.btNat BaseType.btBool BaseType.btString

          BaseType.natD BaseType.boolD BaseType.stringD BaseType.pairD
          BaseType.natD_sym BaseType.boolD_sym BaseType.stringD_sym BaseType.pairD_sym

          (* ListType *)

          ListType.tyList ListType.btList

          (* SubstType *)

          SubstType.tyVal SubstType.tySubst
          SubstType.stSubst

          (* JavaType *)

          Typ2_Fun Typ0_Prop RType_typ typD
          should_not_be_necessary should_also_not_be_necessary

          JavaType.BaseType_typ JavaType.BaseTypeD_typ JavaType.ListType_typ
          JavaType.ListTypeD_typ JavaType.bilops JavaType.ilops
          JavaType.eops JavaType.lops

       (*   JavaType.typD *)
		 (* JavaFunc *)

          ilops is_pure func RSym_JavaFunc typeof_java_func java_func_eq
          java_func_symD RelDec_java_func typeof_ilfunc

          RSym_ilfunc RSym_open_func RSym_OpenFunc RSym_ListFunc
          JavaFunc.RSym_bilfunc JavaFunc.RSym_embed_func JavaFunc.RSym_later_func
          JavaFunc.RSym_ilfunc
          JavaFunc.Expr_expr
          mkPointstoVar
          JavaFunc.RSym_func JavaFunc.java_env
          JavaFunc.mkVal JavaFunc.mkFields
          JavaFunc.mkProg JavaFunc.mkCmd JavaFunc.mkDExpr JavaFunc.mkFields
          JavaFunc.fMethodSpec JavaFunc.fProgEq JavaFunc.fTriple JavaFunc.fTypeOf
          JavaFunc.fFieldLookup JavaFunc.fPointsto JavaFunc.mkNull
          JavaFunc.fPlus JavaFunc.fMinus JavaFunc.fTimes JavaFunc.fAnd
          JavaFunc.fOr JavaFunc.fNot JavaFunc.fLt JavaFunc.fValEq
          JavaFunc.mkTriple JavaFunc.mkFieldLookup JavaFunc.mkTypeOf
          JavaFunc.mkProgEq JavaFunc.mkExprList JavaFunc.evalDExpr

(* OTHER *)

          SubstType_typ

          goalD Ctx.propD propD exprD'_typ0 exprD split_env

          amap_substD
          substD
          SUBST.raw_substD
          UVarMap.MAP.fold
          FMapPositive.PositiveMap.fold
          FMapPositive.PositiveMap.xfoldi
          FMapPositive.append
          UVarMap.MAP.from_key
          pred
          plus
          Pos.to_nat
          Pos.iter_op
          app
          HList.hlist_app
          Quant._foralls
          Quant._exists
          goalD_Prop
          ].

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

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

Ltac run_rtac reify term_table tac_sound :=
  match type of tac_sound with
    | rtac_sound ?tac =>
	  let name := fresh "e" in
	  match goal with
	    | |- ?P =>
	      reify_aux reify term_table P name;
	      let t := eval vm_compute in (typeof_expr nil nil name) in
	      let goal := eval unfold name in name in
	      match t with
	        | Some ?t =>
	          let goal_result := constr:(run_tac tac (GGoal name)) in
	          let result := eval vm_compute in goal_result in
	          match result with
	            | More_ ?s ?g =>
	              cut (goalD_Prop nil nil g); [
	                let goal_resultV := g in
	               (* change (goalD_Prop nil nil goal_resultV -> exprD_Prop nil nil name);*)
	                exact_no_check (@run_rtac_More _ tac _ _ _ tac_sound
	                	(@eq_refl (Result (CTop nil nil)) (More_ s goal_resultV) <:
	                	   run_tac tac (GGoal goal) = (More_ s goal_resultV)))
	                | cbv_denote
	              ]
	            | Solved ?s =>
	              exact_no_check (@run_rtac_Solved _ tac s name tac_sound
	                (@eq_refl (Result (CTop nil nil)) (Solved s) <: run_tac tac (GGoal goal) = Solved s))
	            | Fail => idtac "Tactic" tac "failed."
	            | _ => idtac "Error: run_rtac could not resolve the result from the tactic :" tac
	          end
	        | None => idtac "expression " goal "is ill typed" t
	      end
	  end
	| _ => idtac tac_sound "is not a soudness theorem."
  end.

Ltac run_rtac_debug reify term_table tac_sound :=
  match type of tac_sound with
    | rtac_sound ?tac =>
	  let name := fresh "e" in
	  match goal with
	    | |- ?P =>
	      reify_aux reify term_table P name;
	      let t := eval vm_compute in (typeof_expr nil nil name) in
	      let goal := eval unfold name in name in
	      match t with
	        | Some ?t =>
	          let goal_result := constr:(run_tac tac (GGoal name)) in
	          let result := eval vm_compute in goal_result in
	          idtac result;
	          match result with
	            | More_ ?s ?g =>
	              cut (goalD_Prop nil nil g); [
	                let goal_resultV := g in
	               (* change (goalD_Prop nil nil goal_resultV -> exprD_Prop nil nil name);*)
	                exact_no_check (@run_rtac_More _ tac _ _ _ tac_sound
	                	(@eq_refl (Result (CTop nil nil)) (More_ s goal_resultV) <:
	                	   run_tac tac (GGoal goal) = (More_ s goal_resultV)))
	                | cbv_denote
	              ]
	            | Solved ?s =>
	              exact_no_check (@run_rtac_Solved _ tac s name tac_sound
	                (@eq_refl (Result (CTop nil nil)) (Solved s) <: run_tac tac (GGoal goal) = Solved s))
	            | Fail => idtac "Tactic" tac "failed."
	            | _ => idtac "Error: run_rtac could not resolve the result from the tactic :" tac
	          end
	        | None => idtac "expression " goal "is ill typed" t
	      end
	  end
	| _ => idtac tac_sound "is not a soudness theorem."
  end.


Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.Named.MapCast.
Require Import Crypto.Compilers.Named.InterpretToPHOAS.
Require Import Crypto.Compilers.Named.Compile.
Require Import Crypto.Compilers.Named.PositiveContext.
Require Import Crypto.Compilers.Named.PositiveContext.Defaults.
Require Import Crypto.Compilers.Syntax.

(** N.B. This procedure only works when there are no nested lets,
    i.e., nothing like [let x := let y := z in w] in the PHOAS syntax
    tree.  This is a limitation of [compile]. *)

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (base_type_code_beq : base_type_code -> base_type_code -> bool)
          (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y)
          (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t))
          {interp_base_type_bounds : base_type_code -> Type}
          (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst)
          (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code).
  Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v).
  Context (cast_op : forall t tR (opc : op t tR) args_bs,
              op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))).

  Local Notation PContext var := (PositiveContext _ var _ base_type_code_bl_transparent).

  Section MapCast.
    Context {t} (e : Expr base_type_code op t)
            (input_bounds : interp_flat_type interp_base_type_bounds (domain t)).

    Definition MapCastCompile
      := compile (e _) (DefaultNamesFor e).
    Definition MapCastDoCast (e' : option (Named.expr base_type_code op BinNums.positive t))
      := option_map
           (fun e'' => map_cast
                         interp_op_bounds pick_typeb cast_op
                         (BoundsContext:=PContext _)
                         empty
                         e''
                         input_bounds)
           e'.
    Definition MapCastDoInterp
               (e' : option
                       (option
                          { output_bounds : interp_flat_type interp_base_type_bounds (codomain t) &
                                           Named.expr _ _ _ (Arrow (pick_type input_bounds) (pick_type output_bounds)) }))
      : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t)
                                 & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }
      := match e' with
         | Some (Some (existT output_bounds e''))
           => Some (existT _ output_bounds (InterpToPHOAS (Context:=fun var => PContext var) failb e''))
         | Some None | None => None
         end.
    Definition MapCast
      : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t)
                                 & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }
      := MapCastDoInterp (MapCastDoCast MapCastCompile).
  End MapCast.
End language.


Require Import VST.msl.log_normalize.
Require Import VST.msl.ghost.
Require Import VST.msl.ghost_seplog.
Require Export VST.veric.base.
Require Import VST.veric.rmaps.
Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.res_predicates.

Import RML. Import R.
Local Open Scope pred.

Notation ghost_approx m := (ghost_fmap (approx (level m)) (approx (level m))).

(* Ownership construction based on "Iris from the ground up", Jung et al. *)
Program Definition ghost_is g: pred rmap :=
  fun m => ghost_of m = ghost_approx m g.
Next Obligation.
  intros ???? Hg.
  rewrite (age1_ghost_of _ _ H), Hg.
  pose proof (age_level _ _ H).
  rewrite ghost_fmap_fmap, approx_oo_approx', approx'_oo_approx by omega; eauto.
Qed.

Definition Own g: pred rmap := allp noat && ghost_is g.

Lemma Own_op: forall a b c, join a b c -> Own c = Own a * Own b.
Proof.
  intros; apply pred_ext.
  - intros w (Hno & Hg).
    destruct (make_rmap (resource_at w) (ghost_approx w a) (level w))
      as (wa & Hla & Hra & Hga).
    { extensionality; apply resource_at_approx. }
    { rewrite ghost_fmap_fmap, approx_oo_approx; auto. }
    destruct (make_rmap (resource_at w) (ghost_approx w b) (level w))
      as (wb & Hlb & Hrb & Hgb).
    { extensionality; apply resource_at_approx. }
    { rewrite ghost_fmap_fmap, approx_oo_approx; auto. }
    exists wa, wb; split.
    + apply resource_at_join2; auto.
      * intro; rewrite Hra, Hrb.
        apply identity_unit', Hno.
      * rewrite Hg, Hga, Hgb.
        apply ghost_fmap_join; auto.
    + simpl; rewrite Hla, Hlb, Hra, Hrb, Hga, Hgb; simpl; eauto 6.
  - intros w (w1 & w2 & J & (Hnoa & Hga) & (Hnob & Hgb)).
    split.
    + intro l; apply (resource_at_join _ _ _ l) in J.
      simpl in *; rewrite <- (Hnoa _ _ _ J); auto.
    + destruct (join_level _ _ _ J) as [Hl1 Hl2].
      apply ghost_of_join in J.
      rewrite Hga, Hgb in J.
      eapply join_eq; eauto.
      rewrite Hl1, Hl2; apply ghost_fmap_join; auto.
Qed.

Fixpoint make_join (a c : ghost) : ghost :=
  match a, c with
  | nil, _ => c
  | _, nil => nil
  | None :: a', x :: c' => x :: make_join a' c'
  | _ :: a', None :: c' => None :: make_join a' c'
  | Some (ga, pa) :: a', Some (gc, _) :: c' => Some (gc, pa) :: make_join a' c'
  end.

Lemma make_join_nil : forall a, make_join a nil = nil.
Proof.
  destruct a; auto.
  destruct o as [[]|]; auto.
Qed.

Lemma make_join_nil_cons : forall o a c, make_join (o :: a) (None :: c) = None :: make_join a c.
Proof.
  destruct o as [[]|]; auto.
Qed.

Lemma ghost_joins_approx: forall n a c,
  joins (ghost_fmap (approx n) (approx n) a) (ghost_fmap (approx n) (approx n) c) ->
  let c' := make_join a c in
  joins (ghost_fmap (approx (S n)) (approx (S n)) a) (ghost_fmap (approx (S n)) (approx (S n)) c') /\
    forall b, joins b (ghost_fmap (approx (S n)) (approx (S n)) c') ->
      joins (ghost_fmap (approx n) (approx n) b) (ghost_fmap (approx n) (approx n) c).
Proof.
  intros ???; revert a; induction c; intros; subst c'; simpl.
  - rewrite make_join_nil; split.
    + eexists; constructor.
    + eexists; constructor.
  - destruct H; inv H.
    + destruct a0; inv H1.
      split.
      { eexists; constructor. }
      intros ? []; eexists.
      apply ghost_fmap_join with (f := approx n)(g := approx n) in H.
      rewrite ghost_fmap_fmap, approx_oo_approx', approx'_oo_approx in H by auto; eauto.
    + destruct a0; inv H0.
      destruct (IHc a0) as (H & Hc'); eauto.
      inv H3.
      * destruct o; inv H1.
        split.
        { destruct H; eexists; constructor; eauto; constructor. }
        intros ? [? J]; inv J; [eexists; constructor|].
        destruct (Hc' m1); eauto.
        eexists; constructor; eauto.
        instantiate (1 := option_map (fun '(a, b) => (a, preds_fmap (approx n) (approx n) b)) a3).
        inv H3.
        -- destruct a as [[]|]; [simpl | constructor].
           rewrite preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor; auto.
        -- destruct a; inv H4; constructor.
        -- destruct a as [[]|]; inv H1; constructor.
           destruct a2, a5; inv H4; constructor; auto; simpl in *.
           inv H2.
           rewrite preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor; auto.
      * destruct a; inv H2.
        rewrite make_join_nil_cons.
        split.
        { destruct H; eexists; constructor; eauto; constructor. }
        intros ? [? J]; inv J; [eexists; constructor|].
        destruct (Hc' m1); eauto.
        eexists; constructor; eauto; constructor.
      * destruct o as [[]|], a as [[]|]; inv H0; inv H1.
        split.
        { destruct H.
          destruct a4; inv H2; simpl in *.
          inv H1.
          eexists (Some (_, _) :: _); constructor; eauto; constructor.
          constructor; simpl; eauto; constructor; eauto. }
        intros ? [? J]; inv J; [eexists; constructor|].
        destruct (Hc' m1); eauto.
        eexists; constructor; eauto.
        instantiate (1 := option_map (fun '(a, b) => (a, preds_fmap (approx n) (approx n) b)) a3).
        inv H4.
        -- destruct a4; inv H2; simpl in *.
           inv H3.
           rewrite <- H2, preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor.
        -- constructor.
           destruct a2, a4, a6; inv H2; inv H6; constructor; auto; simpl in *.
           inv H3; inv H4.
           rewrite <- H6, preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor; auto.
Qed.

Program Definition bupd (P: pred rmap): pred rmap :=
  fun m => forall c, joins (ghost_of m) (ghost_approx m c) ->
    exists b, joins b (ghost_approx m c) /\
    exists m', level m' = level m /\ resource_at m' = resource_at m /\ ghost_of m' = b /\ P m'.
Next Obligation.
Proof.
  repeat intro.
  rewrite (age1_ghost_of _ _ H) in H1.
  rewrite <- ghost_of_approx in H0.
  destruct (ghost_joins_approx _ _ _ H1) as (J0 & Hc0).
  rewrite <- (age_level _ _ H) in *.
  specialize (H0 _ J0); destruct H0 as (b & J & Hrb).
  pose proof (age_level _ _ H).
  exists (ghost_approx a' b); split; auto.
  destruct Hrb as (m' & Hl' & Hr' & Hg' & HP).
  destruct (levelS_age m' (level a')) as (m'' & Hage' & Hl'').
  { congruence. }
  exists m''; repeat split; auto.
  + extensionality l.
    erewrite (age1_resource_at _ _ H l) by (symmetry; apply resource_at_approx).
    erewrite (age1_resource_at _ _ Hage' l) by (symmetry; apply resource_at_approx).
    congruence.
  + rewrite (age1_ghost_of _ _ Hage').
    rewrite Hg', <- Hl''; auto.
  + eapply (proj2_sig P); eauto.
Qed.

Lemma bupd_intro: forall P, P |-- bupd P.
Proof.
  repeat intro; eauto 7.
Qed.

Lemma bupd_mono: forall P Q, P |-- Q -> bupd P |-- bupd Q.
Proof.
  repeat intro.
  simpl in *.
  destruct (H0 _ H1) as (b & ? & m' & ? & ? & ? & ?).
  exists b; split; auto.
  exists m'; repeat split; auto.
Qed.

Lemma bupd_frame_r: forall P Q, bupd P * Q |-- bupd (P * Q).
Proof.
  repeat intro.
  destruct H as (w1 & w2 & J & HP & HQ).
  destruct (join_level _ _ _ J) as [Hl1 Hl2].
  pose proof (ghost_of_join _ _ _ J) as Jg.
  destruct H0 as [? J'].
  destruct (join_assoc Jg J') as (c' & J1 & J2).
  erewrite <- (ghost_same_level_gen (level a) (ghost_of w2) c c') in J2, J1
    by (rewrite <- Hl2 at 1 2; rewrite ghost_of_approx; auto).
  destruct (HP c') as (? & [? J1'] & w1' & ? & Hr' & ? & HP'); subst.
  { rewrite Hl1; eauto. }
  rewrite Hl1 in J1'; destruct (join_assoc (join_comm J1) (join_comm J1')) as (w' & ? & ?).
  exists w'; split; [eexists; apply join_comm; eauto|].
  destruct (make_rmap (resource_at a) w' (level a)) as (m' & ? & Hr'' & ?); subst.
  { extensionality l; apply resource_at_approx. }
  { eapply ghost_same_level_gen.
    rewrite <- (ghost_of_approx w2), <- (ghost_of_approx w1'), H, Hl1, Hl2 in H0.
    apply join_comm; eauto. }
  exists m'; repeat split; auto.
  exists w1', w2; repeat split; auto.
  apply resource_at_join2; auto; try omega.
  intro; rewrite Hr', Hr''.
  apply resource_at_join; auto.
Qed.

Lemma bupd_frame_l: forall P Q, P * bupd Q |-- bupd (P * Q).
Proof.
  intros; rewrite sepcon_comm, (sepcon_comm P Q); apply bupd_frame_r.
Qed.

Lemma bupd_trans: forall P, bupd (bupd P) |-- bupd P.
Proof.
  repeat intro.
  destruct (H _ H0) as (b & J & a' & Hl & Hr & ? & Ha'); subst.
  rewrite <- Hl in J; destruct (Ha' _ J) as (b' & ? & Hm').
  rewrite <- Hl, <- Hr; eauto.
Qed.

Lemma bupd_prop : forall P, bupd (!! P) = !! P.
Proof.
  intros ?; apply pred_ext.
  - intros ??; simpl in *.
    destruct (H (core (ghost_of a))) as (? & ? & ? & ? & ? & ? & ?); auto.
    eexists.
    rewrite ghost_core; simpl; erewrite <- ghost_core.
    apply join_comm, core_unit.
  - intros ??.
    do 2 eexists; eauto.
Qed.

Lemma subp_bupd: forall (G : pred nat) (P P' : pred rmap), G |-- P >=> P' ->
    G |-- (bupd P >=> bupd P')%pred.
Proof.
  repeat intro.
  specialize (H3 _ H4) as (? & ? & ? & ? & ? & ? & HP).
  do 2 eexists; eauto; do 2 eexists; eauto; repeat (split; auto).
  pose proof (necR_level _ _ H2).
  apply (H _ H0 x0 ltac:(omega) _ (necR_refl _)); auto.
Qed.

Lemma eqp_bupd: forall (G : pred nat) (P P' : pred rmap), G |-- P <=> P' ->
    G |-- (bupd P <=> bupd P').
Proof.
  intros.
  rewrite fash_and in *.
  apply andp_right; apply subp_bupd; eapply derives_trans; try apply H;
    [apply andp_left1 | apply andp_left2]; apply derives_refl.
Qed.

Definition ghost_fp_update_ND a B :=
  forall n c, joins (ghost_fmap (approx n) (approx n) a) c ->
    exists b, B b /\ joins (ghost_fmap (approx n) (approx n) b) c.

Lemma Own_update_ND: forall a B, ghost_fp_update_ND a B ->
  Own a |-- bupd (EX b : _, !!(B b) && Own b).
Proof.
  repeat intro.
  destruct H0 as (Hno & Hg).
  rewrite Hg in H1.
  destruct H1 as [? J].
  destruct (H (level a0) (ghost_approx a0 c)) as (g' & ? & J').
  { eexists; eauto. }
  exists (ghost_fmap (approx (level a0)) (approx (level a0)) g'); split; auto.
  destruct (make_rmap (resource_at a0)
    (ghost_fmap (approx (level a0)) (approx (level a0)) g') (level a0))
    as (m' & Hl & Hr & Hg').
  { extensionality; apply resource_at_approx. }
  { rewrite ghost_fmap_fmap, approx_oo_approx; auto. }
  exists m'; repeat split; auto.
  exists g'; repeat split; auto.
  - simpl in *; intro; rewrite Hr; auto.
  - simpl; rewrite Hg', Hl; simpl; eauto.
Qed.

Definition ghost_fp_update (a b : ghost) :=
  forall n c, joins (ghost_fmap (approx n) (approx n) a) c ->
               joins (ghost_fmap (approx n) (approx n) b) c.

Instance ghost_fp_update_preorder: RelationClasses.PreOrder ghost_fp_update.
Proof.
  split; repeat intro; auto.
Qed.

Lemma ghost_fp_update_approx: forall a b n, ghost_fp_update a b ->
  ghost_fp_update (ghost_fmap (approx n) (approx n) a) (ghost_fmap (approx n) (approx n) b).
Proof.
  intros; intros m c J.
  rewrite ghost_fmap_fmap in *.
  replace (approx m oo approx n) with (approx (min m n)) in *.
  replace (approx n oo approx m) with (approx (min m n)) in *.
  auto.
  { destruct (Min.min_spec m n) as [[? ->] | [? ->]];
      [rewrite approx'_oo_approx | rewrite approx_oo_approx']; auto; omega. }
  { destruct (Min.min_spec m n) as [[? ->] | [? ->]];
      [rewrite approx_oo_approx' | rewrite approx'_oo_approx]; auto; omega. }
Qed.

Lemma Own_update: forall a b, ghost_fp_update a b ->
  Own a |-- bupd (Own b).
Proof.
  intros; eapply derives_trans.
  - eapply (Own_update_ND _ (eq _)).
    repeat intro.
    eexists; split; [constructor|].
    apply H; eauto.
  - apply bupd_mono.
    repeat (apply exp_left; intro).
    apply prop_andp_left; intro X; inv X; auto.
Qed.

Lemma Own_unit: emp |-- EX a : _, !!(identity a) && Own a.
Proof.
  intros w ?; simpl in *.
  exists (ghost_of w); split; [|split].
  - apply ghost_of_identity; auto.
  - intro; apply resource_at_identity; auto.
  - rewrite ghost_of_approx; auto.
Qed.

Lemma Own_dealloc: forall a, Own a |-- bupd emp.
Proof.
  intros ? w [] ??.
  exists (core ((ghost_approx w) c)); split; [eexists; apply core_unit|].
  destruct (make_rmap (resource_at w) (core (ghost_approx w c)) (level w)) as (w' & ? & Hr & Hg).
  { extensionality; apply resource_at_approx. }
  { rewrite ghost_core; auto. }
  exists w'; repeat split; auto.
  apply all_resource_at_identity.
  - rewrite Hr; auto.
  - rewrite Hg; apply core_identity.
Qed.

Definition singleton {A} k (x : A) : list (option A) := repeat None k ++ Some x :: nil.

Definition gname := nat.

Definition own {RA: Ghost} (n: gname) (a: G) (pp: preds) :=
  EX v : _, Own (singleton n (existT _ RA (exist _ a v), pp)).

Definition list_set {A} (m : list (option A)) k v : list (option A) :=
  firstn k m ++ repeat None (k - length m) ++ Some v :: skipn (S k) m.

Lemma singleton_join_gen: forall k a c (m: ghost)
  (Hjoin: join (Some a) (nth k m None) (Some c)),
  join (singleton k a) m (list_set m k c).
Proof.
  induction k; intros.
  - destruct m; simpl in *; subst; inv Hjoin; constructor; constructor; auto.
  - destruct m; simpl in *.
    + inv Hjoin; constructor.
    + constructor; [constructor | apply IHk; auto].
Qed.

Lemma map_repeat : forall {A B} (f : A -> B) x n, map f (repeat x n) = repeat (f x) n.
Proof.
  induction n; auto; simpl.
  rewrite IHn; auto.
Qed.

Lemma ghost_fmap_singleton: forall f g k v, ghost_fmap f g (singleton k v) =
  singleton k (match v with (a, b) => (a, preds_fmap f g b) end).
Proof.
  intros; unfold ghost_fmap, singleton.
  rewrite map_app, map_repeat; auto.
Qed.

Lemma ghost_fmap_singleton_inv : forall f g a k v,
  ghost_fmap f g a = singleton k v ->
  exists v', a = singleton k v' /\ v = let (a, b) := v' in (a, preds_fmap f g b).
Proof.
  unfold singleton; induction a; simpl; intros.
  - destruct k; discriminate.
  - destruct a as [[]|]; simpl in *.
    + destruct k; inv H.
      destruct a0; inv H2.
      simpl; eauto.
    + destruct k; inv H.
      edestruct IHa as (? & ? & ?); eauto; subst.
      simpl; eauto.
Qed.

Lemma ghost_alloc: forall {RA: Ghost} a pp, ghost.valid a ->
  emp |-- bupd (EX g: gname, own g a pp).
Proof.
  intros.
  eapply derives_trans; [apply Own_unit|].
  apply exp_left; intro g0.
  apply prop_andp_left; intro Hg0.
  eapply derives_trans.
  - apply Own_update_ND with (B := fun b => exists g, b = singleton g (existT _ RA (exist _ _ H), pp)).
    intros ? c [? J]; exists (singleton (length c) (existT _ RA (exist _ _ H), pp)).
    split; eauto.
    rewrite (identity_core Hg0), ghost_core in J; inv J; [|eexists; constructor].
    rewrite ghost_fmap_singleton; eexists; apply singleton_join_gen.
    rewrite nth_overflow by auto; constructor.
  - apply bupd_mono, exp_left; intro g'.
    apply prop_andp_left; intros [g]; subst.
    apply exp_right with g.
    eapply exp_right; eauto.
Qed.

Lemma singleton_join: forall a b c k,
  join (singleton k a) (singleton k b) (singleton k c) <-> join a b c.
Proof.
  unfold singleton; induction k; simpl.
  - split.
    + inversion 1; subst.
      inv H3; auto.
    + intro; do 2 constructor; auto.
  - rewrite <- IHk.
    split; [inversion 1 | repeat constructor]; auto.
Qed.

Lemma singleton_join_inv: forall k a b c,
  join (singleton k a) (singleton k b) c -> exists c', join a b c' /\ c = singleton k c'.
Proof.
  unfold singleton; induction k; inversion 1; subst.
  - assert (m3 = nil) by (inv H6; auto).
    inv H5; eauto.
  - assert (a3 = None) by (inv H5; auto); subst.
    edestruct IHk as (? & ? & ?); eauto; subst; eauto.
Qed.

Lemma ghost_valid_2: forall {RA: Ghost} g a1 a2 pp,
  own g a1 pp * own g a2 pp |-- !!ghost.valid_2 a1 a2.
Proof.
  intros.
  intros w (? & ? & J%ghost_of_join & (? & ? & Hg1) & (? & ? & Hg2)).
  rewrite Hg1, Hg2, !ghost_fmap_singleton in J.
  apply singleton_join_inv in J as ([] & J & ?).
  inv J; simpl in *.
  inv H2; repeat inj_pair_tac.
  eexists; eauto.
Qed.

Lemma ghost_op: forall {RA: Ghost} g (a1 a2 a3: G) pp, join a1 a2 a3 ->
  own g a3 pp = own g a1 pp * own g a2 pp.
Proof.
  intros; apply pred_ext.
  - apply exp_left; intro.
    erewrite Own_op; [apply sepcon_derives; eapply exp_right; eauto|].
    apply singleton_join; constructor; constructor; auto.
  - eapply derives_trans; [apply andp_right, derives_refl; apply ghost_valid_2|].
    apply prop_andp_left; intros (? & J & ?).
    eapply join_eq in H; eauto; subst.
    unfold own; rewrite exp_sepcon1; apply exp_left; intro.
    rewrite exp_sepcon2; apply exp_left; intro.
    erewrite <- Own_op; [eapply exp_right; eauto|].
    apply singleton_join; constructor; constructor; auto.
  Unshelve.
  eapply join_valid; eauto.
  eapply join_valid; eauto.
  auto.
Qed.

Lemma ghost_valid: forall {RA: Ghost} g a pp,
  own g a pp |-- !!ghost.valid a.
Proof.
  intros.
  rewrite <- (normalize.andp_TT (!!_)).
  erewrite ghost_op by apply core_unit.
  eapply derives_trans; [apply andp_right, derives_refl; apply ghost_valid_2|].
  apply prop_andp_left; intros (? & J & ?); apply prop_andp_right; auto.
  apply core_identity in J; subst; auto.
Qed.

Lemma singleton_join_inv_gen: forall k a (b c: ghost),
  join (singleton k a) b c ->
  join (Some a) (nth k b None) (nth k c None) /\
    exists c', nth k c None = Some c' /\ c = list_set b k c'.
Proof.
  unfold singleton; induction k; inversion 1; subst; auto.
  - split; simpl; eauto; constructor.
  - split; auto.
    unfold list_set; simpl.
    rewrite <- (ghost_core m2) in H5.
    apply (core_identity m2) in H5; subst.
    inv H2; eauto.
  - rewrite app_nth2; rewrite repeat_length; auto.
    rewrite minus_diag; split; [constructor | simpl; eauto].
  - assert (a2 = a3) by (inv H2; auto).
    destruct (IHk _ _ _ H5) as (? & ? & ? & ?); subst; eauto.
Qed.

Lemma ghost_update_ND: forall {RA: Ghost} g (a: G) B pp,
  fp_update_ND a B -> own g a pp |-- bupd (EX b : _, !!(B b) && own g b pp).
Proof.
  intros.
  apply exp_left; intro Hva.
  eapply derives_trans.
  - apply Own_update_ND with
      (B := fun b => exists b' Hvb, B b' /\ b = singleton g (existT _ RA (exist _ b' Hvb), pp)).
    intros ?? [? J].
    rewrite ghost_fmap_singleton in J.
    destruct (singleton_join_inv_gen _ _ _ _ J) as [Jg _].
    inv Jg.
    + destruct (H (core a)) as (b & ? & Hv).
      { eexists; split; [apply join_comm, core_unit | auto]. }
      assert (ghost.valid b) as Hvb.
      { destruct Hv as (? & ? & ?); eapply join_valid; eauto. }
      exists (singleton g (existT _ RA (exist _ _ Hvb), pp)); split; eauto.
      rewrite ghost_fmap_singleton.
      eexists; apply singleton_join_gen.
      rewrite <- H2; constructor.
    + destruct a2, a3; inv H3; simpl in *.
      inv H0; inj_pair_tac.
      destruct (H b0) as (b & ? & Hv).
      { eexists; eauto. }
      destruct Hv as (? & ? & ?).
      assert (ghost.valid b) as Hvb by (eapply join_valid; eauto).
      exists (singleton g (existT _ RA (exist _ _ Hvb), pp)); split; eauto.
      rewrite ghost_fmap_singleton.
      eexists; apply singleton_join_gen.
      instantiate (1 := (_, _)).
      rewrite <- H1; constructor; constructor; [constructor|]; eauto.
  - apply bupd_mono, exp_left; intro.
    apply prop_andp_left; intros (b & ? & ? & ?); subst.
    apply exp_right with b, prop_andp_right; auto.
    eapply exp_right; auto.
  Unshelve.
  auto.
Qed.

Lemma ghost_update: forall {RA: Ghost} g (a b: G) pp,
  fp_update a b -> own g a pp |-- bupd (own g b pp).
Proof.
  intros; eapply derives_trans.
  - apply (ghost_update_ND g a (eq b)).
    intros ? J; destruct (H _ J).
    do 2 eexists; [constructor | eauto].
  - apply bupd_mono.
    apply exp_left; intro; apply prop_andp_left; intro X; inv X; auto.
Qed.

Lemma ghost_dealloc: forall {RA: Ghost} g a pp,
  own g a pp |-- bupd emp.
Proof.
  intros; unfold own.
  apply exp_left; intro; apply Own_dealloc.
Qed.

Lemma list_set_same : forall {A} n l (a : A), nth n l None = Some a ->
  list_set l n a = l.
Proof.
  unfold list_set; induction n; destruct l; simpl; try discriminate; intros; subst; auto.
  f_equal; eauto.
Qed.

(* The addition of ghost state means that there are rmaps that have only
   cores for ghost state, but are not cores themselves (since they have ghost
   state at all). An rmap of this sort is not emp, but is its own unit. *)

Definition cored: pred rmap := ALL P : pred rmap, ALL Q : pred rmap,
  P && Q --> P * Q.

Program Definition is_w w: pred rmap := fun w' => necR w w'.
Next Obligation.
Proof.
  repeat intro.
  eapply necR_trans; eauto.
  constructor; auto.
Qed.

Lemma cored_unit: forall w, cored w = join w w w.
Proof.
  intro; apply prop_ext; split; unfold cored; intro.
  - edestruct (H (is_w w) (is_w w)) as (? & ? & J & Hw1 & Hw2).
    { apply necR_refl. }
    { split; apply necR_refl. }
    simpl in *.
    destruct (join_level _ _ _ J).
    eapply necR_linear' in Hw1; try apply necR_refl; auto.
    eapply necR_linear' in Hw2; try apply necR_refl; auto.
    subst; auto.
  - intros P Q ?? [HP HQ].
    exists a', a'; repeat split; auto.
    eapply nec_join in H as (? & ? & ? & Hw1 & Hw2); eauto.
    destruct (join_level _ _ _ H).
    eapply necR_linear' in Hw1; try apply H0; [|omega].
    eapply necR_linear' in Hw2; try apply H0; [|omega].
    subst; auto.
Qed.

Lemma cored_dup: forall P, P && cored |-- (P && cored) * (P && cored).
Proof.
  intros.
  rewrite <- (andp_dup cored) at 1.
  rewrite <- andp_assoc.
  intros; unfold cored at 2.
  eapply modus_ponens.
  + apply andp_left1, derives_refl.
  + eapply andp_left2, allp_left, allp_left.
    rewrite andp_dup; apply derives_refl.
Qed.

Lemma cored_core: forall w, cored (core w).
Proof.
  intro; rewrite cored_unit.
  apply identity_unit', core_identity.
Qed.

Lemma cored_duplicable: cored = cored * cored.
Proof.
  apply pred_ext.
  - rewrite <- andp_dup at 1.
    eapply derives_trans; [apply cored_dup|].
    apply sepcon_derives; apply andp_left1; auto.
  - intros ? (? & ? & J & J1 & J2).
    rewrite cored_unit in *.
    destruct (join_assoc J1 J) as (? & J' & J1').
    eapply join_eq in J'; [|apply J]; subst.
    destruct (join_assoc J2 (join_comm J)) as (? & J' & J2').
    eapply join_eq in J'; [|apply join_comm, J]; subst.
    destruct (join_assoc (join_comm J1') (join_comm J2')) as (? & J' & ?).
    eapply join_eq in J'; [|apply J]; subst; auto.
Qed.

Lemma cored_emp: cored |-- bupd emp.
Proof.
  intro; rewrite cored_unit; intros J ??.
  exists nil; split; [eexists; constructor|].
  destruct (make_rmap (resource_at a) nil (level a)) as (m' & ? & Hr & Hg); auto.
  { intros; extensionality; apply resource_at_approx. }
  exists m'; repeat split; auto.
  apply all_resource_at_identity.
  - intro; rewrite Hr.
    apply (resource_at_join _ _ _ l) in J.
    inv J.
    + apply join_self, identity_share_bot in RJ; subst.
      apply NO_identity.
    + apply join_self, identity_share_bot in RJ; subst.
      contradiction shares.bot_unreadable.
    + apply PURE_identity.
  - rewrite Hg, <- (ghost_core nil); apply core_identity.
Qed.

Lemma join_singleton_inv: forall k a b RA c v pp,
  join a b (singleton k (existT _ RA (exist _ (core c) v), pp)) ->
  a = singleton k (existT _ RA (exist _ (core c) v), pp) \/ b = singleton k (existT _ RA (exist _ (core c) v), pp).
Proof.
  induction k; unfold singleton; intros; simpl in *.
  - inv H; auto.
    assert (m1 = nil /\ m2 = nil) as [] by (inv H5; auto); subst.
    inv H4; auto.
    destruct a0, a3; inv H2; simpl in *.
    inv H0; inv H.
    inj_pair_tac.
    pose proof (core_unit a0) as J.
    erewrite join_core, core_idem in J by eauto.
    unfold unit_for in J.
    eapply join_positivity in J; eauto; subst.
    left; repeat f_equal; apply proof_irr.
  - inv H; auto.
    edestruct IHk as [|]; eauto; [left | right]; f_equal; auto; inv H4; auto.
Qed.

Lemma own_cored: forall {RA: Ghost} g a pp, join a a a -> own g a pp |-- cored.
Proof.
  intros; intros ? (? & ? & Hg).
  rewrite cored_unit; simpl in *.
  apply resource_at_join2; auto.
  - intro; apply identity_unit'.
    eapply necR_resource_at_identity; eauto.
  - rewrite Hg, ghost_fmap_singleton.
    apply singleton_join; repeat constructor; auto.
Qed.

Require Import VST.veric.tycontext.
Require Import VST.veric.Clight_seplog.

Lemma own_super_non_expansive: forall {RA: Ghost} n g a pp,
  approx n (own g a pp) = approx n (own g a (preds_fmap (approx n) (approx n) pp)).
Proof.
  intros; unfold own.
  rewrite !approx_exp; f_equal; extensionality v.
  unfold Own.
  rewrite !approx_andp; f_equal.
  apply pred_ext; intros ? [? Hg]; split; auto; simpl in *.
  - rewrite <- ghost_of_approx, Hg.
    rewrite !ghost_fmap_singleton, !preds_fmap_fmap.
    rewrite approx_oo_approx, approx_oo_approx', approx'_oo_approx by omega; auto.
  - rewrite ghost_fmap_singleton in *.
    rewrite preds_fmap_fmap in Hg.
    rewrite approx_oo_approx', approx'_oo_approx in Hg by omega; auto.
Qed.


From iris_examples.logrel.stlc Require Export fundamental.
From iris.proofmode Require Import proofmode.
From iris.program_logic Require Import adequacy.
From iris.prelude Require Import options.

Lemma wp_soundness `{irisGS stlc_lang Σ} e τ : [] ⊢ₜ e : τ → ⊢ WP e {{ ⟦ τ ⟧ }}.
Proof.
  iIntros (?).
  replace e with e.[env_subst[]] by by asimpl.
  iApply fundamental; eauto. iApply interp_env_nil.
Qed.

Theorem soundness e τ e' thp :
  [] ⊢ₜ e : τ → rtc erased_step ([e], ()) (thp, ()) → e' ∈ thp → not_stuck e' ().
Proof.
  set (Σ := invΣ). intros.
  cut (adequate NotStuck e () (λ _ _, True));
    first by intros [_ Hsafe]; eapply Hsafe; eauto.
  eapply (wp_adequacy Σ _). iIntros (Hinv ?).
  iModIntro. iExists (λ _ _, True%I), (λ _, True%I). iSplit=>//.
  set (HΣ := IrisG _ _ Hinv (λ _ _ _ _, True)%I (λ _, True)%I).
  iApply (wp_wand with "[]"); first by iApply wp_soundness. eauto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ A E /\ (wd_ X Y /\ (wd_ X B /\ (wd_ A Y /\ (wd_ A B /\ (wd_ E Z /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A D /\ (wd_ Aprime Dprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ Eprime Aprime Bprime /\ (col_ Eprime E Z /\ (col_ A D E /\ col_ A B D))))))))))))))))))))))))))))))))) -> col_ A Y B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import PSCIAux.Spec.
Require Import RVIC2.Specs.find_lock_map_target_rec.
Require Import RVIC2.LowSpecs.find_lock_map_target_rec.
Require Import RVIC2.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       mpidr_to_rec_idx_spec
       get_rec_rec_idx_spec
       get_rec_g_rec_spec
       granule_lock_spec
       granule_map_spec
       set_target_rec_spec
       get_rec_g_rd_spec
       get_rec_g_rec_list_spec
       find_lock_rec_spec
       buffer_unmap_spec
       is_null_spec
       null_ptr_spec
    .

  Lemma find_lock_map_target_rec_spec_exists:
    forall habd habd'  labd rec target
           (Hspec: find_lock_map_target_rec_spec rec target habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', find_lock_map_target_rec_spec0 rec target labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. inv Hrel. destruct rec.
    unfold find_lock_map_target_rec_spec, find_lock_map_target_rec_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; simpl in *; srewrite; repeat grewrite; simpl; bool_rel;
        repeat (simpl_htarget; srewrite; simpl in * );
        repeat (solve_bool_range; grewrite); try solve_peq;
          try solve[eexists; split; [reflexivity|constructor;reflexivity]].
    ptr_ne 3%positive 3%positive. inversion e1. contra.
    repeat (simpl_htarget; grewrite; simpl in * ).
    eexists; split. reflexivity. constructor. reflexivity.
  Qed.

End Refine.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Relations.Relation_Definitions.
Require Import "Misc/Library".
Require Import "Misc/Tactics".
Require Import "Calculus/Sets".
Require Import "Calculus/Definitions".
Require Import "Calculus/MultiStaged/Definitions".
Require Import "Calculus/MultiStaged/DataGathering".
Require Import "Calculus/MultiStaged/Monad".

(**
  There are two kind of variables:
  - Source variables, corresponding to variables
  already existing in expression
  - Hole variables, corresponding to variables
  created to put unbox content outside expression.

  hole_var and source_var enable us to have disjoint sets
 *)
Definition hole_var (x:nat) : nat := (2*x+1)%nat.
Definition source_var (x:nat) : nat := (2*x)%nat.

Module Type Context (R:Replacement) (S:ReplacementCalculus R)
  (T:StagedCalculus) (DG:DataGathering R S) (M:Monad R S T DG).

  Import T.
  Import M.
  Import DG.

  Definition t : Type := list (expr * S.var).
  Definition t_stack : Type := list t.

  Definition empty : list t := nil.

  Fixpoint fill (dg:dg_t) (c:t) (e:expr) :=
    match c with
    | nil => e
    | (e1, x) :: c => M.bind dg e1 (fun v =>
        M.cast_eapp dg (M.cast_eabs dg (M.cast_var (hole_var x))
          (fill dg c e)) v)
    end.

  Fixpoint merge (cs1 cs2:t_stack) :=
    match cs1, cs2 with
    | nil, _ => cs2
    | _, nil => cs1
    | c1::cs1, c2::cs2 =>
       (c1 ++ c2) :: merge cs1 cs2
    end.

  Fixpoint shift (cs:t_stack) : t * t_stack :=
    match cs with
    | nil => (nil, nil)
    | a :: nil => (a, nil)
    | a :: cs => let (c, cs) := shift cs in
       (c, a :: cs)
    end.

  Fixpoint unshift (cs:t_stack) (c:t) : t_stack :=
    match cs with
    | nil => c :: nil
    | a :: cs => a :: (unshift cs c)
    end.

  Fixpoint context_hole_set (c:t) : VarSet.t :=
    match c with
    | nil => VarSet.empty
    | (e1, x) :: c => VarSet.add x (context_hole_set c)
    end.

  Fixpoint stack_hole_set (cs:t_stack) : VarSet.t :=
    match cs with
    | nil => VarSet.empty
    | c :: cs => VarSet.union (context_hole_set c) (stack_hole_set cs)
    end.

  Inductive congr_context (rel:relation expr) : relation t :=
    | CongrCtx_nil: congr_context rel nil nil
    | CongrCtx_cons: forall (k1 k2:t) (e1 e2:expr) (x:S.var),
        congr_context rel k1 k2 -> rel e1 e2 ->
        congr_context rel ((e1,x)::k1) ((e2,x)::k2).

  Inductive congr_stack (rel:relation expr) : relation t_stack :=
    | CongrStack_empty: congr_stack rel nil nil
    | CongrStack_context: forall (s1 s2:t_stack) (k1 k2:t),
       congr_stack rel s1 s2 -> congr_context rel k1 k2 ->
       congr_stack rel (k1::s1) (k2::s2).

  Fixpoint ssubst_context (n:nat) (ss:StageSet.t)
    (x:S.var) (c:t) (v:expr) : t :=
    match c with
    | nil => nil
    | (eh,h) :: c => (ssubst n ss (M.cast_var x) eh v, h) ::
        (ssubst_context n (if beq_nat x (hole_var h)
        then (StageSet.add n ss) else ss) x c v)
    end.

  Fixpoint ssubst_stack (n:nat) (ss:StageSet.t)
    (x:S.var) (cs:t_stack) (v:expr) : t_stack :=
    match cs with
    | nil => nil
    | c :: cs => (ssubst_context n ss x c v) ::
       (ssubst_stack (pred n) (StageSet.remove n ss) x cs v)
    end.

End Context.

Module ContextImpl (R:Replacement) (S:ReplacementCalculus R)
    (T:StagedCalculus) (DG:DataGathering R S) (M:Monad R S T DG) :
    Context R S T DG M.
  Include Context R S T DG M.
End ContextImpl.

(* Translation R S T <: StagedTranslation S T. *)
Module Type Translation (R:Replacement) (S:ReplacementCalculus R)
    (T:StagedCalculus) (DG:DataGathering R S)
    (DGP:DataGatheringPredicates R S DG)
    (DGR:DataGatheringRequirements R S DG DGP) (M:Monad R S T DG).

  Module Context := ContextImpl R S T DG M.
  Module DGValid := DataGatheringProperties R S DG DGP DGR.
  Import S.CRaw.
  Import DG.

  Fixpoint booker (e:S.expr) (n:nat) : nat :=
    match e with
    | EConst _ => 0
    | EVar _ => 0
    | EAbs _ e => booker e n
    | EFix _ _ e => booker e n
    | EApp e1 e2 => (booker e1 n + booker e2 n)%nat
    | ELoc _ => 0
    | ERef e => booker e n
    | EDeref e => booker e n
    | EAssign e1 e2 => (booker e1 n + booker e2 n)%nat
    | EBox e => booker e (S n)
    | EUnbox e => match n with
       | 0 => 1
       | S n => booker e n
       end
    | ERun e => booker e n
    | ELift e => booker e n
    end.

  Definition map_iter_booker (e:S.expr) (bs:list nat) (n:nat) :=
    List2.map_iter (fun b n => (b+booker e n)%nat) bs n.

  Fixpoint trans (e:S.expr) (bs:list nat) (dg:dg_t) (dgs:list dg_t) : T.expr * Context.t_stack :=
    match e with
    | EConst i => (M.ret dg (M.cast_econst dg i), Context.empty)
    | EVar y => (M.ret dg (M.cast_evar dg (M.cast_var (source_var y))), Context.empty)
    | EAbs y e =>
        let (e,cs) := trans e bs (dg_eabs dg y) dgs in
        (M.ret dg (M.cast_eabs dg (M.cast_var (source_var y)) e), cs)
    | EFix f y e =>
        let (e,cs) := trans e bs (dg_efix dg f y) dgs in
        (M.ret dg (M.cast_efix dg
            (M.cast_var (source_var f))
            (M.cast_var (source_var y)) e), cs)
    | EApp e1 e2 =>
        let bs2 := map_iter_booker e2 bs 0 in
        let (e1', cs1) := trans e1 bs2 (dg_eapp_l dg) dgs in
        let (e2', cs2) := trans e2 bs (dg_eapp_r dg) dgs in
          (if svalueb 0 e1 then
	   M.bind dg e2' (fun v2 => M.cast_eapp dg
             (phi e1 bs2 (dg_eapp_l dg) dgs) v2)
	   else M.bind dg e1' (fun v1 => M.bind dg e2'
          (fun v2 => M.cast_eapp dg v1 v2)),
          Context.merge cs1 cs2)
    | ELoc l => (M.ret dg (M.cast_eloc dg l), Context.empty)
    | ERef e =>
        let (e,cs) := trans e bs (dg_eref dg) dgs in
        (M.bind dg e (fun v => M.cast_eref dg v), cs)
    | EDeref e =>
        let (e,cs) := trans e bs (dg_ederef dg) dgs in
        (M.bind dg e (fun v => M.cast_ederef dg v), cs)
    | EAssign e1 e2 =>
	let bs2 := map_iter_booker e2 bs 0 in
        let (e1', cs1) := trans e1 bs2 (dg_eassign_l dg) dgs in
        let (e2', cs2) := trans e2 bs (dg_eassign_r dg) dgs in
          (if svalueb 0 e1 then
	   M.bind dg e2' (fun v2 => M.cast_eassign dg
             (phi e1 bs2 (dg_eassign_l dg) dgs) v2)
	   else M.bind dg e1' (fun v1 => M.bind dg e2'
          (fun v2 => M.cast_eassign dg v1 v2)),
          Context.merge cs1 cs2)
    | EBox e =>
        let (e, cs) := trans e (0 :: bs) (dg_ebox dg) (dg::dgs) in
        match cs with
        | nil => (M.ret dg (M.cast_ebox dg e), Context.empty)
        | c :: cs => (Context.fill dg c (M.ret dg (M.cast_ebox dg e)), cs)
        end
    | EUnbox e =>
        let (b, bs) := List2.hd_cons bs 0 in
        let (dg', dgs') := List2.hd_cons dgs dg_empty in
        let (e', cs) := trans e bs dg' dgs' in
           (M.cast_eunbox dg (M.cast_evar dg
	   (M.cast_var (hole_var b))), ((e', b) :: nil) :: cs)
    | ERun e =>
        let (e,cs) := trans e bs (dg_erun dg) dgs in
        (M.bind dg e (fun v => M.cast_erun dg v), cs)
    | ELift e =>
        let (e,cs) := trans e bs (dg_elift dg) dgs in
        (M.bind dg e (fun v => M.cast_elift dg v), cs)
    end

  with phi (e:S.expr) (bs:list nat) (dg:dg_t) (dgs:list dg_t) : T.expr :=
    match e with
    | EConst i => M.cast_econst dg i
    | EVar y => M.cast_evar dg (M.cast_var (source_var y))
    | EAbs y e =>
        let (e, _) := trans e bs (dg_eabs dg y) dgs in
        M.cast_eabs dg (M.cast_var (source_var y)) e
    | EFix f y e =>
        let (e, _) := trans e bs (dg_efix dg f y) dgs in
        M.cast_efix dg
            (M.cast_var (source_var f))
            (M.cast_var (source_var y)) e
    | ELoc l => M.cast_eloc dg l
    | EBox e =>
        let (e, _) := trans e (0 :: bs) (dg_ebox dg) (dg::dgs) in
        M.cast_ebox dg e
    | _ => M.cast_econst dg 0
    end.

  Definition trans_expr (e:S.expr) (bs:list nat) (dg:dg_t) (dgs:list dg_t) : T.expr :=
    let (e, _) := trans e bs dg dgs in e.

  Fixpoint trans_mem (m:S.Memory.t) (bs:list nat) (dg:dg_t) (dgs:list dg_t) : T.Memory.t :=
    match m with
    | nil => nil
    | e :: m => (phi e bs dg dgs) :: (trans_mem m bs dg dgs)
    end.

  (** ** Administrative Reduction Step *)
  Inductive admin : relation T.expr :=
    | Admin_refl : forall (e:T.expr), admin e e
    | Admin_trans : forall (e1 e2 e3:T.expr),
        admin e1 e2 -> admin e2 e3 -> admin e1 e3
    | Admin_abs : forall (x:T.var) (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_eabs dg x e1) (M.cast_eabs dg x e2)
    | Admin_fix : forall (f x:T.var) (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_efix dg f x e1) (M.cast_efix dg f x e2)
    | Admin_app : forall (e1 e2 e3 e4:T.expr) (dg:dg_t),
        admin e1 e3 -> admin e2 e4 ->
        admin (M.cast_eapp dg e1 e2) (M.cast_eapp dg e3 e4)
    | Admin_ref : forall (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_eref dg e1) (M.cast_eref dg e2)
    | Admin_deref : forall (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_ederef dg e1) (M.cast_ederef dg e2)
    | Admin_assign : forall (e1 e2 e3 e4:T.expr) (dg:dg_t),
        admin e1 e3 -> admin e2 e4 ->
        admin (M.cast_eassign dg e1 e2) (M.cast_eassign dg e3 e4)
    | Admin_box : forall (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_ebox dg e1) (M.cast_ebox dg e2)
    | Admin_unbox : forall (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_eunbox dg e1) (M.cast_eunbox dg e2)
    | Admin_run : forall (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_erun dg e1) (M.cast_erun dg e2)
    | Admin_lift : forall (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.cast_elift dg e1) (M.cast_elift dg e2)
    | Admin_ret : forall (e1 e2:T.expr) (dg:dg_t),
        admin e1 e2 -> admin (M.ret dg e1) (M.ret dg e2)
    | Admin_bind : forall (e1 e2:T.expr) (f1 f2:T.expr -> T.expr) (dg:dg_t),
        admin e1 e2 -> (forall e3:T.expr, admin (f1 e3) (f2 e3)) ->
        admin (M.bind dg e1 f1) (M.bind dg e2 f2)
   | Admin_unbox_box : forall (e:expr) (*(bs:list nat)*) (dg:dg_t) (dgs:list dg_t),
        svalue 1 e ->
        DGValid.valid_dgs 1 dg (dg_empty :: dgs) ->
        admin (M.cast_eunbox dg (M.cast_ebox dg_empty
          (trans_expr e (0::nil) dg (dg_empty :: dgs))))
          (trans_expr e (0::nil) dg (dg_empty :: dgs))
   | Admin_bind_app_phi : forall (v:expr) (e:T.expr) (bs:list nat) (dg:dg_t) (dgs:list dg_t),
       svalue 0 v ->
       let f := fun v0 => M.bind dg e (fun v1 => M.cast_eapp dg v0 v1) in
       admin (M.bind dg (M.ret (dg_eapp_l dg) (phi v bs (dg_eapp_l dg) dgs)) f) (f (phi v bs (dg_eapp_l dg) dgs))
  | Admin_bind_assign_phi : forall (v:expr) (e:T.expr) (bs:list nat) (dg:dg_t) (dgs:list dg_t),
       svalue 0 v ->
       let f := fun v0 => M.bind dg e (fun v1 => M.cast_eassign dg v0 v1) in
       admin (M.bind dg (M.ret (dg_eassign_l dg) (phi v bs (dg_eassign_l dg) dgs)) f) (f (phi v bs (dg_eassign_l dg) dgs)).

  Definition admin_context :  relation Context.t :=
    Context.congr_context admin.
  Definition admin_stack : relation Context.t_stack :=
    Context.congr_stack admin.

  (** ** Relative Abstract Reduction Step *)
  Inductive rstep : relation T.state :=
    | Rel_step : forall (s:T.state) (e1 e2:T.expr) (M:T.Memory.t),
        M.astep s (M,e1) -> admin e1 e2 -> rstep s (M,e2).

End Translation.

Module TranslationImpl (R:Replacement)
   (S:ReplacementCalculus R) (T:StagedCalculus)
   (DG:DataGathering R S) (DGP:DataGatheringPredicates R S DG)
   (DGR:DataGatheringRequirements R S DG DGP)
   (M:Monad R S T DG) <: Translation R S T DG DGP DGR M.
  Include Translation R S T DG DGP DGR M.
End TranslationImpl.